From 1e473d07c13c60a49a590e46314eb653c15b15e9 Mon Sep 17 00:00:00 2001 From: tobigun Date: Sun, 27 Jan 2008 10:16:40 +0000 Subject: Bugfix: In glTextWidth() "text := pchar(Copy(text, 2, Length(text)-1))" does not work with FPC, probably because a part of text is assigned to itself. Note: Why is the string copied so many times just to get the current character? I just simplified this method to use Text[index] instead. git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@806 b956fd51-792f-4845-bead-9b4dfca2ff2c --- Game/Code/Classes/TextGL.pas | 1121 +++++++++++++++++++++--------------------- 1 file changed, 562 insertions(+), 559 deletions(-) (limited to 'Game') diff --git a/Game/Code/Classes/TextGL.pas b/Game/Code/Classes/TextGL.pas index ed897071..0bd61fa7 100644 --- a/Game/Code/Classes/TextGL.pas +++ b/Game/Code/Classes/TextGL.pas @@ -1,559 +1,562 @@ -unit TextGL; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - - -uses OpenGL12, - SDL, - UTexture, - Classes, - dialogs, - SDL_ttf, - ULog; - -procedure BuildFont; // Build Our Bitmap Font -procedure KillFont; // Delete The Font -function glTextWidth(text: pchar): real; // Returns Text Width -procedure glPrintDone(text: pchar; Done: real; ColR, ColG, ColB: real); -procedure glPrintLetter(letter: char); -procedure glPrintLetterCut(letter: char; Start, Finish: real); -procedure glPrint(text: pchar); // Custom GL "Print" Routine -procedure glPrintCut(text: pchar); -procedure SetFontPos(X, Y: real); // Sets X And Y -procedure SetFontSize(Size: real); -procedure SetFontStyle(Style: integer); // sets active font style (normal, bold, etc) -procedure SetFontItalic(Enable: boolean); // sets italic type letter (works for all fonts) -procedure SetFontAspectW(Aspect: real); - -// Start of SDL_ttf -function NextPowerOfTwo(Value: Integer): Integer; -//Checks if the ttf exists, if yes then a SDL_ttf is returned -function LoadFont(FileName: PAnsiChar; PointSize: integer):PTTF_Font; - -// Does the renderstuff, color is in $ffeecc style -function RenderText(font: PTTF_Font; Text:PAnsiChar; Color: Cardinal):PSDL_Surface; -procedure printrandomtext(); -// End of SDL_ttf - -type - TTextGL = record - X: real; - Y: real; - Text: string; - Size: real; - ColR: real; - ColG: real; - ColB: real; - end; - - TFont = record - Tex: TTexture; - Width: array[0..255] of byte; - AspectW: real; - Centered: boolean; - Done: real; - Outline: real; - Italic: boolean; - end; - - -var - base: GLuint; // Base Display List For The Font Set - Fonts: array of TFont; - ActFont: integer; - PColR: real; // temps for glPrintDone - PColG: real; - PColB: real; - -implementation - -uses UMain, - UCommon, - {$IFDEF win32} - windows, - {$ELSE} - lclintf, - lcltype, - {$ENDIF} - SysUtils, - {$IFDEF LAZARUS} - LResources, - {$ENDIF} - {$IFDEF DARWIN} - MacResources, - {$ENDIF} - UGraphic; - -procedure BuildFont; // Build Our Bitmap Font - - procedure loadfont( aID : integer; aType, aResourceName : String); - {$IFDEF LAZARUS} - var - lLazRes : TLResource; - lResData : TStringStream; - begin - try - lLazRes := LazFindResource( aResourceName, aType ); - if lLazRes <> nil then - begin - lResData := TStringStream.create( lLazRes.value ); - try - lResData.position := 0; - lResData.Read(Fonts[ aID ].Width, 256); - finally - freeandnil( lResData ); - end; - end; - - {$ELSE} - var - Rejestr: TResourceStream; - begin - try - Rejestr := TResourceStream.Create(HInstance, aResourceName , pchar( aType ) ); - try - Rejestr.Read(Fonts[ aID ].Width, 256); - finally - Rejestr.Free; - end; - {$ENDIF} - - except - Log.LogStatus( 'Could not load font : loadfont( '+ inttostr( aID ) +' , '+aType+' )' , 'ERROR'); - end; - end; - -var - font: HFONT; // Windows Font ID - h_dc: hdc; - Pet: integer; -begin - ActFont := 0; - - Log.LogStatus( '' , '---------------------------'); - - Log.LogStatus( 'Font' , '---------------------------'); - SetLength(Fonts, 5); - Fonts[0].Tex := Texture.LoadTexture(true, 'Font', 'PNG', 'Transparent', 0); - Fonts[0].Tex.H := 30; - Fonts[0].AspectW := 0.9; - Fonts[0].Done := -1; - Fonts[0].Outline := 0; - - Log.LogStatus( 'FontB' , '---------------------------'); - - Fonts[1].Tex := Texture.LoadTexture(true, 'FontB', 'PNG', 'Transparent', 0); - Fonts[1].Tex.H := 30; - Fonts[1].AspectW := 1; - Fonts[1].Done := -1; - Fonts[1].Outline := 0; - - Log.LogStatus( 'FontO' , '---------------------------'); - Fonts[2].Tex := Texture.LoadTexture(true, 'FontO', 'PNG', 'Transparent', 0); - Fonts[2].Tex.H := 30; - Fonts[2].AspectW := 0.95; - Fonts[2].Done := -1; - Fonts[2].Outline := 5; - - Log.LogStatus( 'FontO2' , '---------------------------'); - Fonts[3].Tex := Texture.LoadTexture(true, 'FontO2', 'PNG', 'Transparent', 0); - Fonts[3].Tex.H := 30; - Fonts[3].AspectW := 0.95; - Fonts[3].Done := -1; - Fonts[3].Outline := 4; - -{ Fonts[4].Tex := Texture.LoadTexture('FontO', 'BMP', 'Arrow', 0); // for score screen - Fonts[4].Tex.H := 30; - Fonts[4].AspectW := 0.95; - Fonts[4].Done := -1; - Fonts[4].Outline := 5;} - - - - loadfont( 0, 'FNT', 'Font' ); - loadfont( 1, 'FNT', 'FontB' ); - loadfont( 2, 'FNT', 'FontO' ); - loadfont( 3, 'FNT', 'FontO2' ); - -{ Rejestr := TResourceStream.Create(HInstance, 'FontO', 'FNT'); - Rejestr.Read(Fonts[4].Width, 256); - Rejestr.Free;} - - for Pet := 0 to 255 do - Fonts[1].Width[Pet] := Fonts[1].Width[Pet] div 2; - - for Pet := 0 to 255 do - Fonts[2].Width[Pet] := Fonts[2].Width[Pet] div 2 + 2; - - for Pet := 0 to 255 do - Fonts[3].Width[Pet] := Fonts[3].Width[Pet] + 1; - -{ for Pet := 0 to 255 do - Fonts[4].Width[Pet] := Fonts[4].Width[Pet] div 2 + 2;} - -end; - -procedure KillFont; // Delete The Font -begin -// glDeleteLists(base, 256); // Delete All 96 Characters -end; - -function glTextWidth(text: pchar): real; -var - Letter: char; -begin -// Log.LogStatus(Text, 'glTextWidth'); - Result := 0; - while (length(text) > 0) do begin - Letter := Text[0]; - text := pchar(Copy(text, 2, Length(text)-1)); - Result := Result + Fonts[ActFont].Width[Ord(Letter)] * Fonts[ActFont].Tex.H / 30 * Fonts[ActFont].AspectW; - end; // while -end; - -procedure glPrintDone(text: pchar; Done: real; ColR, ColG, ColB: real); -begin - Fonts[ActFont].Done := Done; - PColR := ColR; - PColG := ColG; - PColB := ColB; - glPrintCut(text); - Fonts[ActFont].Done := -1; -end; - -procedure glPrintLetter(Letter: char); -var - TexX, TexY: real; - TexR, TexB: real; - FWidth: real; - PL, PT: real; - PR, PB: real; - XItal: real; // X shift for italic type letter -begin - with Fonts[ActFont].Tex do - begin - FWidth := Fonts[ActFont].Width[Ord(Letter)]; - - W := FWidth * (H/30) * Fonts[ActFont].AspectW; - // H := 30; - - // set texture positions - TexX := (ord(Letter) mod 16) * 1/16 + 1/32 - FWidth/1024 - Fonts[ActFont].Outline/1024; - TexY := (ord(Letter) div 16) * 1/16 + 2/1024; // 2/1024 - TexR := (ord(Letter) mod 16) * 1/16 + 1/32 + FWidth/1024 + Fonts[ActFont].Outline/1024; - TexB := (1 + ord(Letter) div 16) * 1/16 - 2/1024; - - // set vector positions - PL := X - Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW /2; - PT := Y; - PR := PL + W + Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW; - PB := PT + H; - - if Fonts[ActFont].Italic = false then - XItal := 0 - else - XItal := 12; - - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, TexNum); - - glBegin(GL_QUADS); - try - glTexCoord2f(TexX, TexY); glVertex2f(PL+XItal, PT); - glTexCoord2f(TexX, TexB); glVertex2f(PL, PB); - glTexCoord2f(TexR, TexB); glVertex2f(PR, PB); - glTexCoord2f(TexR, TexY); glVertex2f(PR+XItal, PT); - finally - glEnd; - end; - - X := X + W; - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); - end; // with -end; - -procedure glPrintLetterCut(letter: char; Start, Finish: real); -var - TexX, TexY: real; - TexR, TexB: real; - TexTemp: real; - FWidth: real; - PL, PT: real; - PR, PB: real; - OutTemp: real; - XItal: real; -begin - with Fonts[ActFont].Tex do begin - FWidth := Fonts[ActFont].Width[Ord(Letter)]; - - W := FWidth * (H/30) * Fonts[ActFont].AspectW; -// H := 30; - OutTemp := Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW; - - // set texture positions - TexX := (ord(Letter) mod 16) * 1/16 + 1/32 - FWidth/1024 - Fonts[ActFont].Outline/1024; - TexY := (ord(Letter) div 16) * 1/16 + 2/1024; // 2/1024 - TexR := (ord(Letter) mod 16) * 1/16 + 1/32 + FWidth/1024 + Fonts[ActFont].Outline/1024; - TexB := (1 + ord(Letter) div 16) * 1/16 - 2/1024; - - TexTemp := TexX + Start * (TexR - TexX); - TexR := TexX + Finish * (TexR - TexX); - TexX := TexTemp; - - // set vector positions - PL := X - OutTemp / 2 + OutTemp * Start; - PT := Y; - PR := PL + (W + OutTemp) * (Finish - Start); - PB := PT + H; - if Fonts[ActFont].Italic = false then - XItal := 0 - else - XItal := 12; - - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, TexNum); - glBegin(GL_QUADS); - glTexCoord2f(TexX, TexY); glVertex2f(PL+XItal, PT); - glTexCoord2f(TexX, TexB); glVertex2f(PL, PB); - glTexCoord2f(TexR, TexB); glVertex2f(PR, PB); - glTexCoord2f(TexR, TexY); glVertex2f(PR+XItal, PT); // not tested with XItal - glEnd; - X := X + W * (Finish - Start); - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); - end; // with - -end; - -procedure glPrint(text: pchar); // Custom GL "Print" Routine -var -// Letter : char; - iPos : Integer; - -begin - if (Text = '') then // If There's No Text - Exit; // Do Nothing - -(* - while (length(text) > 0) do - begin - // cut - Letter := Text[0]; - Text := pchar(Copy(Text, 2, Length(Text)-1)); - - // print - glPrintLetter(Letter); - end; // while -*) - - // This code is better, because doing a Copy of for every - // letter in a string is a waste of CPU & Memory resources. - // Copy operations are quite memory intensive, and this simple - // code achieves the same result. - for iPos := 0 to length( text ) - 1 do - begin - glPrintLetter( Text[iPos] ); - end; - -end; - -function NextPowerOfTwo(Value: Integer): Integer; -// tyty to Asphyre -begin - Result:= 1; - asm - xor ecx, ecx - bsr ecx, Value - inc ecx - shl Result, cl - end; -end; - -function LoadFont(FileName: PAnsiChar; PointSize: integer):PTTF_Font; -begin - if (FileExists(FileName)) then - begin - Result := TTF_OpenFont( FileName, PointSize ); - end - else - begin - Log.LogStatus('ERROR Could not find font in ' + FileName , ''); - ShowMessage( 'ERROR Could not find font in ' + FileName ); - end; -end; - -function RenderText(font: PTTF_Font; Text:PAnsiChar; Color: Cardinal): PSDL_Surface; -var - clr : TSDL_color; -begin - clr.r := ((Color and $ff0000) shr 16 ) div 255; - clr.g := ((Color and $ff00 ) shr 8 ) div 255; - clr.b := ( Color and $ff ) div 255 ; - - result := TTF_RenderText_Blended( font, text, cLr); -end; - -procedure printrandomtext(); -var - stext,intermediary : PSDL_surface; - clrFg, clrBG : TSDL_color; - texture : Gluint; - font : PTTF_Font; - w,h : integer; -begin - -font := LoadFont('fonts\comicbd.ttf', 42); - -clrFg.r := 255; -clrFg.g := 255; -clrFg.b := 255; -clrFg.unused := 255; - -clrBg.r := 255; -clrbg.g := 0; -clrbg.b := 255; -clrbg.unused := 0; - - sText := RenderText(font, 'katzeeeeeee', $fe198e); -//sText := TTF_RenderText_Blended( font, 'huuuuuuuuuund', clrFG); - - // Convert the rendered text to a known format - w := nextpoweroftwo(sText.w); - h := nextpoweroftwo(sText.h); - -intermediary := SDL_CreateRGBSurface(0, w, h, 32, - $000000ff, $0000ff00, $00ff0000, $ff000000); - - SDL_SetAlpha(intermediary, 0, 255); - SDL_SetAlpha(sText, 0, 255); - SDL_BlitSurface(sText, 0, intermediary, 0); - - glGenTextures(1, @texture); - - glBindTexture(GL_TEXTURE_2D, texture); - - glTexImage2D(GL_TEXTURE_2D, 0, 4, w, h, 0, GL_RGBA, GL_UNSIGNED_BYTE, intermediary.pixels); - - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - - - - - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glBindTexture(GL_TEXTURE_2D, texture); - glColor4f(1, 0, 1, 1); - - glbegin(gl_quads); - glTexCoord2f(0,0); glVertex2f(200, 300); - glTexCoord2f(0,sText.h/h); glVertex2f(200 , 300 + sText.h); - glTexCoord2f(sText.w/w,sText.h/h); glVertex2f(200 + sText.w, 300 + sText.h); - glTexCoord2f(sText.w/w,0); glVertex2f(200 + sText.w, 300); - glEnd; - glfinish(); - glDisable(GL_BLEND); - gldisable(gl_texture_2d); - - - - -SDL_FreeSurface( sText ); -SDL_FreeSurface( intermediary ); -glDeleteTextures(1, @texture); -TTF_CloseFont( font ); - -end; - -procedure glPrintCut(text: pchar); -var - Letter: char; - PToDo: real; - PTotWidth: real; - PDoingNow: real; - S: string; -begin - if (Text = '') then // If There's No Text - Exit; // Do Nothing - - PTotWidth := glTextWidth(Text); - PToDo := Fonts[ActFont].Done; - - while (length(text) > 0) do begin - // cut - Letter := Text[0]; - Text := pchar(Copy(Text, 2, Length(Text)-1)); - - // analyze - S := Letter; - PDoingNow := glTextWidth(pchar(S)) / PTotWidth; - - // drawing - if (PToDo > 0) and (PDoingNow <= PToDo) then - glPrintLetter(Letter); - - if (PToDo > 0) and (PDoingNow > PToDo) then begin - glPrintLetterCut(Letter, 0, PToDo / PDoingNow); - glColor3f(PColR, PColG, PColB); - glPrintLetterCut(Letter, PToDo / PDoingNow, 1); - end; - - if (PToDo <= 0) then - glPrintLetter(Letter); - - PToDo := PToDo - PDoingNow; - - end; // while -end; - - -procedure SetFontPos(X, Y: real); -begin - Fonts[ActFont].Tex.X := X; - Fonts[ActFont].Tex.Y := Y; -end; - -procedure SetFontSize(Size: real); -begin - Fonts[ActFont].Tex.H := 30 * (Size/10); -end; - -procedure SetFontStyle(Style: integer); -begin - ActFont := Style; -end; - -procedure SetFontItalic(Enable: boolean); -begin - Fonts[ActFont].Italic := Enable; -end; - -procedure SetFontAspectW(Aspect: real); -begin - Fonts[ActFont].AspectW := Aspect; -end; - - -{$IFDEF LAZARUS} -{$IFDEF win32} -initialization - {$I UltraStar.lrs} -{$ENDIF} -{$ENDIF} - - -end. - - +unit TextGL; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + + +uses OpenGL12, + SDL, + UTexture, + Classes, + dialogs, + SDL_ttf, + ULog; + +procedure BuildFont; // Build Our Bitmap Font +procedure KillFont; // Delete The Font +function glTextWidth(text: pchar): real; // Returns Text Width +procedure glPrintDone(text: pchar; Done: real; ColR, ColG, ColB: real); +procedure glPrintLetter(letter: char); +procedure glPrintLetterCut(letter: char; Start, Finish: real); +procedure glPrint(text: pchar); // Custom GL "Print" Routine +procedure glPrintCut(text: pchar); +procedure SetFontPos(X, Y: real); // Sets X And Y +procedure SetFontSize(Size: real); +procedure SetFontStyle(Style: integer); // sets active font style (normal, bold, etc) +procedure SetFontItalic(Enable: boolean); // sets italic type letter (works for all fonts) +procedure SetFontAspectW(Aspect: real); + +// Start of SDL_ttf +function NextPowerOfTwo(Value: Integer): Integer; +//Checks if the ttf exists, if yes then a SDL_ttf is returned +function LoadFont(FileName: PAnsiChar; PointSize: integer):PTTF_Font; + +// Does the renderstuff, color is in $ffeecc style +function RenderText(font: PTTF_Font; Text:PAnsiChar; Color: Cardinal):PSDL_Surface; +procedure printrandomtext(); +// End of SDL_ttf + +type + TTextGL = record + X: real; + Y: real; + Text: string; + Size: real; + ColR: real; + ColG: real; + ColB: real; + end; + + TFont = record + Tex: TTexture; + Width: array[0..255] of byte; + AspectW: real; + Centered: boolean; + Done: real; + Outline: real; + Italic: boolean; + end; + + +var + base: GLuint; // Base Display List For The Font Set + Fonts: array of TFont; + ActFont: integer; + PColR: real; // temps for glPrintDone + PColG: real; + PColB: real; + +implementation + +uses UMain, + UCommon, + {$IFDEF win32} + windows, + {$ELSE} + lclintf, + lcltype, + {$ENDIF} + SysUtils, + {$IFDEF LAZARUS} + LResources, + {$ENDIF} + {$IFDEF DARWIN} + MacResources, + {$ENDIF} + UGraphic; + +procedure BuildFont; // Build Our Bitmap Font + + procedure loadfont( aID : integer; aType, aResourceName : String); + {$IFDEF LAZARUS} + var + lLazRes : TLResource; + lResData : TStringStream; + begin + try + lLazRes := LazFindResource( aResourceName, aType ); + if lLazRes <> nil then + begin + lResData := TStringStream.create( lLazRes.value ); + try + lResData.position := 0; + lResData.Read(Fonts[ aID ].Width, 256); + finally + freeandnil( lResData ); + end; + end; + + {$ELSE} + var + Rejestr: TResourceStream; + begin + try + Rejestr := TResourceStream.Create(HInstance, aResourceName , pchar( aType ) ); + try + Rejestr.Read(Fonts[ aID ].Width, 256); + finally + Rejestr.Free; + end; + {$ENDIF} + + except + Log.LogStatus( 'Could not load font : loadfont( '+ inttostr( aID ) +' , '+aType+' )' , 'ERROR'); + end; + end; + +var + font: HFONT; // Windows Font ID + h_dc: hdc; + Pet: integer; +begin + ActFont := 0; + + Log.LogStatus( '' , '---------------------------'); + + Log.LogStatus( 'Font' , '---------------------------'); + SetLength(Fonts, 5); + Fonts[0].Tex := Texture.LoadTexture(true, 'Font', 'PNG', 'Transparent', 0); + Fonts[0].Tex.H := 30; + Fonts[0].AspectW := 0.9; + Fonts[0].Done := -1; + Fonts[0].Outline := 0; + + Log.LogStatus( 'FontB' , '---------------------------'); + + Fonts[1].Tex := Texture.LoadTexture(true, 'FontB', 'PNG', 'Transparent', 0); + Fonts[1].Tex.H := 30; + Fonts[1].AspectW := 1; + Fonts[1].Done := -1; + Fonts[1].Outline := 0; + + Log.LogStatus( 'FontO' , '---------------------------'); + Fonts[2].Tex := Texture.LoadTexture(true, 'FontO', 'PNG', 'Transparent', 0); + Fonts[2].Tex.H := 30; + Fonts[2].AspectW := 0.95; + Fonts[2].Done := -1; + Fonts[2].Outline := 5; + + Log.LogStatus( 'FontO2' , '---------------------------'); + Fonts[3].Tex := Texture.LoadTexture(true, 'FontO2', 'PNG', 'Transparent', 0); + Fonts[3].Tex.H := 30; + Fonts[3].AspectW := 0.95; + Fonts[3].Done := -1; + Fonts[3].Outline := 4; + +{ Fonts[4].Tex := Texture.LoadTexture('FontO', 'BMP', 'Arrow', 0); // for score screen + Fonts[4].Tex.H := 30; + Fonts[4].AspectW := 0.95; + Fonts[4].Done := -1; + Fonts[4].Outline := 5;} + + + + loadfont( 0, 'FNT', 'Font' ); + loadfont( 1, 'FNT', 'FontB' ); + loadfont( 2, 'FNT', 'FontO' ); + loadfont( 3, 'FNT', 'FontO2' ); + +{ Rejestr := TResourceStream.Create(HInstance, 'FontO', 'FNT'); + Rejestr.Read(Fonts[4].Width, 256); + Rejestr.Free;} + + for Pet := 0 to 255 do + Fonts[1].Width[Pet] := Fonts[1].Width[Pet] div 2; + + for Pet := 0 to 255 do + Fonts[2].Width[Pet] := Fonts[2].Width[Pet] div 2 + 2; + + for Pet := 0 to 255 do + Fonts[3].Width[Pet] := Fonts[3].Width[Pet] + 1; + +{ for Pet := 0 to 255 do + Fonts[4].Width[Pet] := Fonts[4].Width[Pet] div 2 + 2;} + +end; + +procedure KillFont; // Delete The Font +begin +// glDeleteLists(base, 256); // Delete All 96 Characters +end; + +function glTextWidth(text: pchar): real; +var + Letter: char; + i: integer; +begin +// Log.LogStatus(Text, 'glTextWidth'); + Result := 0; + for i := 0 to Length(text) do + begin + Letter := Text[i]; + // Bugfix: does not work with FPC, probably because a part of text is assigned to itself + //text := pchar(Copy(text, 2, Length(text)-1)); + Result := Result + Fonts[ActFont].Width[Ord(Letter)] * Fonts[ActFont].Tex.H / 30 * Fonts[ActFont].AspectW; + end; +end; + +procedure glPrintDone(text: pchar; Done: real; ColR, ColG, ColB: real); +begin + Fonts[ActFont].Done := Done; + PColR := ColR; + PColG := ColG; + PColB := ColB; + glPrintCut(text); + Fonts[ActFont].Done := -1; +end; + +procedure glPrintLetter(Letter: char); +var + TexX, TexY: real; + TexR, TexB: real; + FWidth: real; + PL, PT: real; + PR, PB: real; + XItal: real; // X shift for italic type letter +begin + with Fonts[ActFont].Tex do + begin + FWidth := Fonts[ActFont].Width[Ord(Letter)]; + + W := FWidth * (H/30) * Fonts[ActFont].AspectW; + // H := 30; + + // set texture positions + TexX := (ord(Letter) mod 16) * 1/16 + 1/32 - FWidth/1024 - Fonts[ActFont].Outline/1024; + TexY := (ord(Letter) div 16) * 1/16 + 2/1024; // 2/1024 + TexR := (ord(Letter) mod 16) * 1/16 + 1/32 + FWidth/1024 + Fonts[ActFont].Outline/1024; + TexB := (1 + ord(Letter) div 16) * 1/16 - 2/1024; + + // set vector positions + PL := X - Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW /2; + PT := Y; + PR := PL + W + Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW; + PB := PT + H; + + if Fonts[ActFont].Italic = false then + XItal := 0 + else + XItal := 12; + + glEnable(GL_TEXTURE_2D); + glEnable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + glBindTexture(GL_TEXTURE_2D, TexNum); + + glBegin(GL_QUADS); + try + glTexCoord2f(TexX, TexY); glVertex2f(PL+XItal, PT); + glTexCoord2f(TexX, TexB); glVertex2f(PL, PB); + glTexCoord2f(TexR, TexB); glVertex2f(PR, PB); + glTexCoord2f(TexR, TexY); glVertex2f(PR+XItal, PT); + finally + glEnd; + end; + + X := X + W; + glDisable(GL_BLEND); + glDisable(GL_TEXTURE_2D); + end; // with +end; + +procedure glPrintLetterCut(letter: char; Start, Finish: real); +var + TexX, TexY: real; + TexR, TexB: real; + TexTemp: real; + FWidth: real; + PL, PT: real; + PR, PB: real; + OutTemp: real; + XItal: real; +begin + with Fonts[ActFont].Tex do begin + FWidth := Fonts[ActFont].Width[Ord(Letter)]; + + W := FWidth * (H/30) * Fonts[ActFont].AspectW; +// H := 30; + OutTemp := Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW; + + // set texture positions + TexX := (ord(Letter) mod 16) * 1/16 + 1/32 - FWidth/1024 - Fonts[ActFont].Outline/1024; + TexY := (ord(Letter) div 16) * 1/16 + 2/1024; // 2/1024 + TexR := (ord(Letter) mod 16) * 1/16 + 1/32 + FWidth/1024 + Fonts[ActFont].Outline/1024; + TexB := (1 + ord(Letter) div 16) * 1/16 - 2/1024; + + TexTemp := TexX + Start * (TexR - TexX); + TexR := TexX + Finish * (TexR - TexX); + TexX := TexTemp; + + // set vector positions + PL := X - OutTemp / 2 + OutTemp * Start; + PT := Y; + PR := PL + (W + OutTemp) * (Finish - Start); + PB := PT + H; + if Fonts[ActFont].Italic = false then + XItal := 0 + else + XItal := 12; + + glEnable(GL_TEXTURE_2D); + glEnable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + glBindTexture(GL_TEXTURE_2D, TexNum); + glBegin(GL_QUADS); + glTexCoord2f(TexX, TexY); glVertex2f(PL+XItal, PT); + glTexCoord2f(TexX, TexB); glVertex2f(PL, PB); + glTexCoord2f(TexR, TexB); glVertex2f(PR, PB); + glTexCoord2f(TexR, TexY); glVertex2f(PR+XItal, PT); // not tested with XItal + glEnd; + X := X + W * (Finish - Start); + glDisable(GL_BLEND); + glDisable(GL_TEXTURE_2D); + end; // with + +end; + +procedure glPrint(text: pchar); // Custom GL "Print" Routine +var +// Letter : char; + iPos : Integer; + +begin + if (Text = '') then // If There's No Text + Exit; // Do Nothing + +(* + while (length(text) > 0) do + begin + // cut + Letter := Text[0]; + Text := pchar(Copy(Text, 2, Length(Text)-1)); + + // print + glPrintLetter(Letter); + end; // while +*) + + // This code is better, because doing a Copy of for every + // letter in a string is a waste of CPU & Memory resources. + // Copy operations are quite memory intensive, and this simple + // code achieves the same result. + for iPos := 0 to length( text ) - 1 do + begin + glPrintLetter( Text[iPos] ); + end; + +end; + +function NextPowerOfTwo(Value: Integer): Integer; +// tyty to Asphyre +begin + Result:= 1; + asm + xor ecx, ecx + bsr ecx, Value + inc ecx + shl Result, cl + end; +end; + +function LoadFont(FileName: PAnsiChar; PointSize: integer):PTTF_Font; +begin + if (FileExists(FileName)) then + begin + Result := TTF_OpenFont( FileName, PointSize ); + end + else + begin + Log.LogStatus('ERROR Could not find font in ' + FileName , ''); + ShowMessage( 'ERROR Could not find font in ' + FileName ); + end; +end; + +function RenderText(font: PTTF_Font; Text:PAnsiChar; Color: Cardinal): PSDL_Surface; +var + clr : TSDL_color; +begin + clr.r := ((Color and $ff0000) shr 16 ) div 255; + clr.g := ((Color and $ff00 ) shr 8 ) div 255; + clr.b := ( Color and $ff ) div 255 ; + + result := TTF_RenderText_Blended( font, text, cLr); +end; + +procedure printrandomtext(); +var + stext,intermediary : PSDL_surface; + clrFg, clrBG : TSDL_color; + texture : Gluint; + font : PTTF_Font; + w,h : integer; +begin + +font := LoadFont('fonts\comicbd.ttf', 42); + +clrFg.r := 255; +clrFg.g := 255; +clrFg.b := 255; +clrFg.unused := 255; + +clrBg.r := 255; +clrbg.g := 0; +clrbg.b := 255; +clrbg.unused := 0; + + sText := RenderText(font, 'katzeeeeeee', $fe198e); +//sText := TTF_RenderText_Blended( font, 'huuuuuuuuuund', clrFG); + + // Convert the rendered text to a known format + w := nextpoweroftwo(sText.w); + h := nextpoweroftwo(sText.h); + +intermediary := SDL_CreateRGBSurface(0, w, h, 32, + $000000ff, $0000ff00, $00ff0000, $ff000000); + + SDL_SetAlpha(intermediary, 0, 255); + SDL_SetAlpha(sText, 0, 255); + SDL_BlitSurface(sText, 0, intermediary, 0); + + glGenTextures(1, @texture); + + glBindTexture(GL_TEXTURE_2D, texture); + + glTexImage2D(GL_TEXTURE_2D, 0, 4, w, h, 0, GL_RGBA, GL_UNSIGNED_BYTE, intermediary.pixels); + + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); + + + + + glEnable(GL_TEXTURE_2D); + glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA); + glEnable(GL_BLEND); + glBindTexture(GL_TEXTURE_2D, texture); + glColor4f(1, 0, 1, 1); + + glbegin(gl_quads); + glTexCoord2f(0,0); glVertex2f(200, 300); + glTexCoord2f(0,sText.h/h); glVertex2f(200 , 300 + sText.h); + glTexCoord2f(sText.w/w,sText.h/h); glVertex2f(200 + sText.w, 300 + sText.h); + glTexCoord2f(sText.w/w,0); glVertex2f(200 + sText.w, 300); + glEnd; + glfinish(); + glDisable(GL_BLEND); + gldisable(gl_texture_2d); + + + + +SDL_FreeSurface( sText ); +SDL_FreeSurface( intermediary ); +glDeleteTextures(1, @texture); +TTF_CloseFont( font ); + +end; + +procedure glPrintCut(text: pchar); +var + Letter: char; + PToDo: real; + PTotWidth: real; + PDoingNow: real; + S: string; +begin + if (Text = '') then // If There's No Text + Exit; // Do Nothing + + PTotWidth := glTextWidth(Text); + PToDo := Fonts[ActFont].Done; + + while (length(text) > 0) do begin + // cut + Letter := Text[0]; + Text := pchar(Copy(Text, 2, Length(Text)-1)); + + // analyze + S := Letter; + PDoingNow := glTextWidth(pchar(S)) / PTotWidth; + + // drawing + if (PToDo > 0) and (PDoingNow <= PToDo) then + glPrintLetter(Letter); + + if (PToDo > 0) and (PDoingNow > PToDo) then begin + glPrintLetterCut(Letter, 0, PToDo / PDoingNow); + glColor3f(PColR, PColG, PColB); + glPrintLetterCut(Letter, PToDo / PDoingNow, 1); + end; + + if (PToDo <= 0) then + glPrintLetter(Letter); + + PToDo := PToDo - PDoingNow; + + end; // while +end; + + +procedure SetFontPos(X, Y: real); +begin + Fonts[ActFont].Tex.X := X; + Fonts[ActFont].Tex.Y := Y; +end; + +procedure SetFontSize(Size: real); +begin + Fonts[ActFont].Tex.H := 30 * (Size/10); +end; + +procedure SetFontStyle(Style: integer); +begin + ActFont := Style; +end; + +procedure SetFontItalic(Enable: boolean); +begin + Fonts[ActFont].Italic := Enable; +end; + +procedure SetFontAspectW(Aspect: real); +begin + Fonts[ActFont].AspectW := Aspect; +end; + + +{$IFDEF LAZARUS} +{$IFDEF win32} +initialization + {$I UltraStar.lrs} +{$ENDIF} +{$ENDIF} + + +end. + + -- cgit v1.2.3