diff options
Diffstat (limited to 'src/Classes/UTexture.pas')
-rw-r--r-- | src/Classes/UTexture.pas | 525 |
1 files changed, 0 insertions, 525 deletions
diff --git a/src/Classes/UTexture.pas b/src/Classes/UTexture.pas deleted file mode 100644 index 4879760a..00000000 --- a/src/Classes/UTexture.pas +++ /dev/null @@ -1,525 +0,0 @@ -unit UTexture; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - gl, - glu, - glext, - Classes, - SysUtils, - UCommon, - SDL, - SDL_Image; - -type - PTexture = ^TTexture; - TTexture = record - TexNum: GLuint; - X: real; - Y: real; - Z: real; - W: real; - H: real; - ScaleW: real; // for dynamic scalling while leaving width constant - ScaleH: real; // for dynamic scalling while leaving height constant - Rot: real; // 0 - 2*pi - Int: real; // intensity - ColR: real; - ColG: real; - ColB: real; - TexW: real; // percentage of width to use [0..1] - TexH: real; // percentage of height to use [0..1] - TexX1: real; - TexY1: real; - TexX2: real; - TexY2: real; - Alpha: real; - Name: string; // experimental for handling cache images. maybe it's useful for dynamic skins - end; - -type - TTextureType = ( - TEXTURE_TYPE_PLAIN, // Plain (alpha = 1) - TEXTURE_TYPE_TRANSPARENT, // Alpha is used - TEXTURE_TYPE_COLORIZED // Alpha is used; Hue of the HSV color-model will be replaced by a new value - ); - -const - TextureTypeStr: array[TTextureType] of string = ( - 'Plain', - 'Transparent', - 'Colorized' - ); - -function TextureTypeToStr(TexType: TTextureType): string; -function ParseTextureType(const TypeStr: string; Default: TTextureType): TTextureType; - -procedure AdjustPixelFormat(var TexSurface: PSDL_Surface; Typ: TTextureType); - -type - PTextureEntry = ^TTextureEntry; - TTextureEntry = record - Name: string; - Typ: TTextureType; - Color: Cardinal; - - // we use normal TTexture, it's easier to implement and if needed - we copy ready data - Texture: TTexture; // Full-size texture - TextureCache: TTexture; // Thumbnail texture - end; - - TTextureDatabase = class - private - Texture: array of TTextureEntry; - public - procedure AddTexture(var Tex: TTexture; Typ: TTextureType; Color: Cardinal; Cache: boolean); - function FindTexture(const Name: string; Typ: TTextureType; Color: Cardinal): integer; - end; - - TTextureUnit = class - private - TextureDatabase: TTextureDatabase; - public - Limit: integer; - - procedure AddTexture(var Tex: TTexture; Typ: TTextureType; Cache: boolean = false); overload; - procedure AddTexture(var Tex: TTexture; Typ: TTextureType; Color: Cardinal; Cache: boolean = false); overload; - function GetTexture(const Name: string; Typ: TTextureType; FromCache: boolean = false): TTexture; overload; - function GetTexture(const Name: string; Typ: TTextureType; Col: LongWord; FromCache: boolean = false): TTexture; overload; - function LoadTexture(FromRegistry: boolean; const Identifier: string; Typ: TTextureType; Col: LongWord): TTexture; overload; - function LoadTexture(const Identifier: string; Typ: TTextureType; Col: LongWord): TTexture; overload; - function LoadTexture(const Identifier: string): TTexture; overload; - function CreateTexture(Data: PChar; const Name: string; Width, Height: word; BitsPerPixel: byte): TTexture; - procedure UnloadTexture(const Name: string; Typ: TTextureType; FromCache: boolean); overload; - procedure UnloadTexture(const Name: string; Typ: TTextureType; Col: Cardinal; FromCache: boolean); overload; - //procedure FlushTextureDatabase(); - - constructor Create; - destructor Destroy; override; - end; - -var - Texture: TTextureUnit; - -implementation - -uses - DateUtils, - StrUtils, - Math, - ULog, - UCovers, - UThemes, - UImage; - -procedure AdjustPixelFormat(var TexSurface: PSDL_Surface; Typ: TTextureType); -var - TempSurface: PSDL_Surface; - NeededPixFmt: PSDL_Pixelformat; -begin - if (Typ = TEXTURE_TYPE_PLAIN) then - NeededPixFmt := @PixelFmt_RGB - else if (Typ = TEXTURE_TYPE_TRANSPARENT) or - (Typ = TEXTURE_TYPE_COLORIZED) then - NeededPixFmt := @PixelFmt_RGBA - else - NeededPixFmt := @PixelFmt_RGB; - - if not PixelformatEquals(TexSurface^.format, NeededPixFmt) then - begin - TempSurface := TexSurface; - TexSurface := SDL_ConvertSurface(TempSurface, NeededPixFmt, SDL_SWSURFACE); - SDL_FreeSurface(TempSurface); - end; -end; - -{ TTextureDatabase } - -procedure TTextureDatabase.AddTexture(var Tex: TTexture; Typ: TTextureType; Color: Cardinal; Cache: boolean); -var - TextureIndex: integer; -begin - TextureIndex := FindTexture(Tex.Name, Typ, Color); - if (TextureIndex = -1) then - begin - TextureIndex := Length(Texture); - SetLength(Texture, TextureIndex+1); - - Texture[TextureIndex].Name := Tex.Name; - Texture[TextureIndex].Typ := Typ; - Texture[TextureIndex].Color := Color; - end; - - if (Cache) then - Texture[TextureIndex].TextureCache := Tex - else - Texture[TextureIndex].Texture := Tex; -end; - -function TTextureDatabase.FindTexture(const Name: string; Typ: TTextureType; Color: Cardinal): integer; -var - TextureIndex: integer; - CurrentTexture: PTextureEntry; -begin - Result := -1; - for TextureIndex := 0 to High(Texture) do - begin - CurrentTexture := @Texture[TextureIndex]; - if (CurrentTexture.Name = Name) and - (CurrentTexture.Typ = Typ) then - begin - // colorized textures must match in their color too - if (CurrentTexture.Typ <> TEXTURE_TYPE_COLORIZED) or - (CurrentTexture.Color = Color) then - begin - Result := TextureIndex; - Break; - end; - end; - end; -end; - - -{ TTextureUnit } - -constructor TTextureUnit.Create; -begin - inherited Create; - TextureDatabase := TTextureDatabase.Create; -end; - -destructor TTextureUnit.Destroy; -begin - TextureDatabase.Free; - inherited Destroy; -end; - - -procedure TTextureUnit.AddTexture(var Tex: TTexture; Typ: TTextureType; Cache: boolean); -begin - TextureDatabase.AddTexture(Tex, Typ, 0, Cache); -end; - -procedure TTextureUnit.AddTexture(var Tex: TTexture; Typ: TTextureType; Color: Cardinal; Cache: boolean); -begin - TextureDatabase.AddTexture(Tex, Typ, Color, Cache); -end; - -function TTextureUnit.LoadTexture(FromRegistry: boolean; const Identifier: string; Typ: TTextureType; Col: LongWord): TTexture; -begin - // FIXME: what is the FromRegistry parameter supposed to do? - Result := LoadTexture(Identifier, Typ, Col); -end; - -function TTextureUnit.LoadTexture(const Identifier: string): TTexture; -begin - Result := LoadTexture(Identifier, TEXTURE_TYPE_PLAIN, 0); -end; - -function TTextureUnit.LoadTexture(const Identifier: string; Typ: TTextureType; Col: LongWord): TTexture; -var - TexSurface: PSDL_Surface; - MipmapSurface: PSDL_Surface; - newWidth, newHeight: Cardinal; - oldWidth, oldHeight: Cardinal; - ActTex: GLuint; -begin - // zero texture data - FillChar(Result, SizeOf(Result), 0); - - // load texture data into memory - TexSurface := LoadImage(Identifier); - if not assigned(TexSurface) then - begin - Log.LogError('Could not load texture: "' + Identifier +' '+ TextureTypeToStr(Typ) +'"', - 'TTextureUnit.LoadTexture'); - Exit; - end; - - // convert pixel format as needed - AdjustPixelFormat(TexSurface, Typ); - - // adjust texture size (scale down, if necessary) - newWidth := TexSurface.W; - newHeight := TexSurface.H; - - if (newWidth > Limit) then - newWidth := Limit; - - if (newHeight > Limit) then - newHeight := Limit; - - if (TexSurface.W > newWidth) or (TexSurface.H > newHeight) then - ScaleImage(TexSurface, newWidth, newHeight); - - // now we might colorize the whole thing - if (Typ = TEXTURE_TYPE_COLORIZED) then - ColorizeImage(TexSurface, Col); - - // save actual dimensions of our texture - oldWidth := newWidth; - oldHeight := newHeight; - - // make texture dimensions be powers of 2 - newWidth := Round(Power(2, Ceil(Log2(newWidth)))); - newHeight := Round(Power(2, Ceil(Log2(newHeight)))); - if (newHeight <> oldHeight) or (newWidth <> oldWidth) then - FitImage(TexSurface, newWidth, newHeight); - - // at this point we have the image in memory... - // scaled to be at most 1024x1024 pixels large - // scaled so that dimensions are powers of 2 - // and converted to either RGB or RGBA - - // if we got a Texture of Type Plain, Transparent or Colorized, - // then we're done manipulating it - // and could now create our openGL texture from it - - // prepare OpenGL texture - glGenTextures(1, @ActTex); - - glBindTexture(GL_TEXTURE_2D, ActTex); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); - - // load data into gl texture - if (Typ = TEXTURE_TYPE_TRANSPARENT) or - (Typ = TEXTURE_TYPE_COLORIZED) then - begin - glTexImage2D(GL_TEXTURE_2D, 0, 4, newWidth, newHeight, 0, GL_RGBA, GL_UNSIGNED_BYTE, TexSurface.pixels); - end - else //if Typ = TEXTURE_TYPE_PLAIN then - begin - glTexImage2D(GL_TEXTURE_2D, 0, 3, newWidth, newHeight, 0, GL_RGB, GL_UNSIGNED_BYTE, TexSurface.pixels); - end; - - // setup texture struct - with Result do - begin - X := 0; - Y := 0; - Z := 0; - W := 0; - H := 0; - ScaleW := 1; - ScaleH := 1; - Rot := 0; - TexNum := ActTex; - TexW := oldWidth / newWidth; - TexH := oldHeight / newHeight; - - Int := 1; - ColR := 1; - ColG := 1; - ColB := 1; - Alpha := 1; - - // new test - default use whole texure, taking TexW and TexH as const and changing these - TexX1 := 0; - TexY1 := 0; - TexX2 := 1; - TexY2 := 1; - - Name := Identifier; - end; - - SDL_FreeSurface(TexSurface); -end; - -function TTextureUnit.GetTexture(const Name: string; Typ: TTextureType; FromCache: boolean): TTexture; -begin - Result := GetTexture(Name, Typ, 0, FromCache); -end; - -function TTextureUnit.GetTexture(const Name: string; Typ: TTextureType; Col: LongWord; FromCache: boolean): TTexture; -var - TextureIndex: integer; - CoverIndex: integer; -begin - if (Name = '') then - begin - // zero texture data - FillChar(Result, SizeOf(Result), 0); - Exit; - end; - - if (FromCache) then - begin - (* - // use cache texture - CoverIndex := Covers.FindCover(Name); - - if TextureDatabase.Texture[TextureIndex].TextureCache.TexNum = 0 then - begin - // load texture - Covers.PrepareData(Name); - TextureDatabase.Texture[TextureIndex].TextureCache := CreateTexture(Covers.Data, Name, Covers.Cover[CoverIndex].Width, Covers.Cover[CoverIndex].Height, 24); - end; - *) - - // use texture - TextureIndex := TextureDatabase.FindTexture(Name, Typ, Col); - if (TextureIndex > -1) then - Result := TextureDatabase.Texture[TextureIndex].TextureCache; - Exit; - end; - - // find texture entry in database - TextureIndex := TextureDatabase.FindTexture(Name, Typ, Col); - if (TextureIndex = -1) then - begin - // create texture entry in database - TextureIndex := Length(TextureDatabase.Texture); - SetLength(TextureDatabase.Texture, TextureIndex+1); - - TextureDatabase.Texture[TextureIndex].Name := Name; - TextureDatabase.Texture[TextureIndex].Typ := Typ; - TextureDatabase.Texture[TextureIndex].Color := Col; - - // inform database that no textures have been loaded into memory - TextureDatabase.Texture[TextureIndex].Texture.TexNum := 0; - TextureDatabase.Texture[TextureIndex].TextureCache.TexNum := 0; - end; - - // load full texture - if (TextureDatabase.Texture[TextureIndex].Texture.TexNum = 0) then - TextureDatabase.Texture[TextureIndex].Texture := LoadTexture(false, Name, Typ, Col); - - // use texture - Result := TextureDatabase.Texture[TextureIndex].Texture; -end; - -function TTextureUnit.CreateTexture(Data: PChar; const Name: string; Width, Height: word; BitsPerPixel: byte): TTexture; -var - Error: integer; - ActTex: GLuint; -begin - glGenTextures(1, @ActTex); // ActText = new texture number - glBindTexture(GL_TEXTURE_2D, ActTex); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); - - glTexImage2D(GL_TEXTURE_2D, 0, 3, Width, Height, 0, GL_RGB, GL_UNSIGNED_BYTE, Data); - - { - if Mipmapping then - begin - Error := gluBuild2DMipmaps(GL_TEXTURE_2D, 3, W, H, GL_RGB, GL_UNSIGNED_BYTE, @Data[0]); - if Error > 0 then - Log.LogError('gluBuild2DMipmaps() failed', 'TTextureUnit.CreateTexture'); - end; - } - - Result.X := 0; - Result.Y := 0; - Result.Z := 0; - Result.W := 0; - Result.H := 0; - Result.ScaleW := 1; - Result.ScaleH := 1; - Result.Rot := 0; - Result.TexNum := ActTex; - Result.TexW := 1; - Result.TexH := 1; - - Result.Int := 1; - Result.ColR := 1; - Result.ColG := 1; - Result.ColB := 1; - Result.Alpha := 1; - - // new test - default use whole texure, taking TexW and TexH as const and changing these - Result.TexX1 := 0; - Result.TexY1 := 0; - Result.TexX2 := 1; - Result.TexY2 := 1; - - Result.Name := Name; -end; - -procedure TTextureUnit.UnloadTexture(const Name: string; Typ: TTextureType; FromCache: boolean); -begin - UnloadTexture(Name, Typ, 0, FromCache); -end; - -procedure TTextureUnit.UnloadTexture(const Name: string; Typ: TTextureType; Col: Cardinal; FromCache: boolean); -var - T: integer; - TexNum: GLuint; -begin - T := TextureDatabase.FindTexture(Name, Typ, Col); - - if not FromCache then - begin - TexNum := TextureDatabase.Texture[T].Texture.TexNum; - if TexNum > 0 then - begin - glDeleteTextures(1, PGLuint(@TexNum)); - TextureDatabase.Texture[T].Texture.TexNum := 0; - //Log.LogError('Unload texture no '+IntToStr(TexNum)); - end; - end - else - begin - TexNum := TextureDatabase.Texture[T].TextureCache.TexNum; - if TexNum > 0 then - begin - glDeleteTextures(1, @TexNum); - TextureDatabase.Texture[T].TextureCache.TexNum := 0; - //Log.LogError('Unload texture cache no '+IntToStr(TexNum)); - end; - end; -end; - -(* This needs some work -procedure TTextureUnit.FlushTextureDatabase(); -var - i: integer; - Tex: ^TTexture; -begin - for i := 0 to High(TextureDatabase.Texture) do - begin - // only delete non-cached entries - if (TextureDatabase.Texture[i].Texture.TexNum > 0) then - begin - Tex := @TextureDatabase.Texture[i].Texture; - glDeleteTextures(1, PGLuint(Tex^.TexNum)); - Tex^.TexNum := 0; - end; - end; -end; -*) - -function TextureTypeToStr(TexType: TTextureType): string; -begin - Result := TextureTypeStr[TexType]; -end; - -function ParseTextureType(const TypeStr: string; Default: TTextureType): TTextureType; -var - TexType: TTextureType; - UpCaseStr: string; -begin - UpCaseStr := UpperCase(TypeStr); - for TexType := Low(TextureTypeStr) to High(TextureTypeStr) do - begin - if (UpCaseStr = UpperCase(TextureTypeStr[TexType])) then - begin - Result := TexType; - Exit; - end; - end; - Log.LogWarn('Unknown texture-type: "' + TypeStr + '"', 'ParseTextureType'); - Result := TEXTURE_TYPE_PLAIN; -end; - -end. |