aboutsummaryrefslogtreecommitdiffstats
path: root/src/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas
diff options
context:
space:
mode:
Diffstat (limited to 'src/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas')
-rw-r--r--src/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas565
1 files changed, 565 insertions, 0 deletions
diff --git a/src/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas b/src/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas
new file mode 100644
index 00000000..a457c1d9
--- /dev/null
+++ b/src/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas
@@ -0,0 +1,565 @@
+unit sdltruetypefont;
+{
+ $Id: sdltruetypefont.pas,v 1.5 2005/05/26 21:22:28 savage Exp $
+
+}
+{******************************************************************************}
+{ }
+{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer }
+{ Wrapper class for SDL_ttf }
+{ }
+{ The initial developer of this Pascal code was : }
+{ Dominqiue Louis <Dominique@SavageSoftware.com.au> }
+{ }
+{ Portions created by Dominqiue Louis are }
+{ Copyright (C) 2000 - 2001 Dominqiue Louis. }
+{ }
+{ }
+{ Contributor(s) }
+{ -------------- }
+{ }
+{ }
+{ Obtained through: }
+{ Joint Endeavour of Delphi Innovators ( Project JEDI ) }
+{ }
+{ You may retrieve the latest version of this file at the Project }
+{ JEDI home page, located at http://delphi-jedi.org }
+{ }
+{ The contents of this file are used with permission, subject to }
+{ the Mozilla Public License Version 1.1 (the "License"); you may }
+{ not use this file except in compliance with the License. You may }
+{ obtain a copy of the License at }
+{ http://www.mozilla.org/MPL/MPL-1.1.html }
+{ }
+{ Software distributed under the License is distributed on an }
+{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or }
+{ implied. See the License for the specific language governing }
+{ rights and limitations under the License. }
+{ }
+{ Description }
+{ ----------- }
+{ }
+{ }
+{ }
+{ }
+{ }
+{ }
+{ }
+{ Requires }
+{ -------- }
+{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so }
+{ They are available from... }
+{ http://www.libsdl.org . }
+{ }
+{ Programming Notes }
+{ ----------------- }
+{ }
+{ }
+{ }
+{ }
+{ Revision History }
+{ ---------------- }
+{ September 23 2004 - DL : Initial Creation }
+{
+ $Log: sdltruetypefont.pas,v $
+ Revision 1.5 2005/05/26 21:22:28 savage
+ Update to Input code.
+
+ Revision 1.1 2005/05/25 23:15:42 savage
+ Latest Changes
+
+ Revision 1.4 2005/05/25 22:55:01 savage
+ Added InputRect support.
+
+ Revision 1.3 2005/05/13 14:02:49 savage
+ Made it use UniCode rendering by default.
+
+ Revision 1.2 2005/05/13 11:37:52 savage
+ Improved wordwrapping algorithm
+
+ Revision 1.1 2004/09/30 22:39:50 savage
+ Added a true type font class which contains a wrap text function.
+ Changed the sdl_ttf.pas header to reflect the future of jedi-sdl.
+
+
+}
+{******************************************************************************}
+
+interface
+
+uses
+ sdl,
+ sdl_ttf;
+
+type
+ TRenderType = ( rtLatin1, rtUTF8, rtUnicode );
+ TSDLFontStyle = ( fsBold, fsItalic, fsUnderline, fsStrikeOut );
+
+ TSDLFontStyles = set of TSDLFontStyle;
+
+ TTrueTypeFont = class( TObject )
+ private
+ FFont : PTTF_Font;
+ FSolid : Boolean;
+ FBackGroundColour : TSDL_Color;
+ FForeGroundColour : TSDL_Color;
+ FRenderType : TRenderType;
+ FStyle : TSDLFontStyles;
+ FFontFile : string;
+ FFontSize : integer;
+ procedure PrepareFont;
+
+ protected
+
+ public
+ constructor Create( aFontFile : string; aRenderStyle : TSDLFontStyles = [ ]; aFontSize : integer = 14 );
+ destructor Destroy; override;
+ function DrawText( aText : WideString ) : PSDL_Surface; overload;
+ function DrawText( aText : WideString; aWidth, aHeight : Integer ) : PSDL_Surface; overload;
+ function Input(aDestination: PSDL_Surface; aX, aY, aWidth, aHeight: integer; var aText: string; aMaxChars: integer = 10 ): PSDL_Surface;
+ property BackGroundColour : TSDL_Color read FBackGroundColour write FBackGroundColour;
+ property ForeGroundColour : TSDL_Color read FForeGroundColour write FForeGroundColour;
+ property FontFile : string read FFontFile write FFontFile;
+ property RenderType : TRenderType read FRenderType write FRenderType;
+ property Solid : Boolean read FSolid write FSolid;
+ property Style : TSDLFontStyles read FStyle write FStyle;
+ property FontSize : integer read FFontSize write FFontSize;
+ end;
+
+
+implementation
+
+uses
+ SysUtils;
+
+{ TTrueTypeFont }
+
+constructor TTrueTypeFont.Create( aFontFile : string; aRenderStyle : TSDLFontStyles; aFontSize : integer );
+begin
+ inherited Create;
+ if FileExists( aFontFile ) then
+ begin
+ FStyle := aRenderStyle;
+ FFontSize := aFontSize;
+ FSolid := false;
+ FBackGroundColour.r := 255;
+ FBackGroundColour.g := 255;
+ FBackGroundColour.b := 255;
+ FForeGroundColour.r := 0;
+ FForeGroundColour.g := 0;
+ FForeGroundColour.b := 0;
+ FRenderType := rtUnicode;
+ if ( TTF_Init >= 0 ) then
+ begin
+ FFontFile := aFontFile;
+ end
+ else
+ raise Exception.Create( 'Failed to Initialiase SDL_TTF' );
+ end
+ else
+ raise Exception.Create( 'Font File does not exist' );
+end;
+
+destructor TTrueTypeFont.Destroy;
+begin
+ if FFont <> nil then
+ TTF_CloseFont( FFont );
+ TTF_Quit;
+ inherited;
+end;
+
+function TTrueTypeFont.DrawText( aText : WideString ) : PSDL_Surface;
+begin
+ PrepareFont;
+
+ result := nil;
+
+ case FRenderType of
+ rtLatin1 :
+ begin
+ if ( FSolid ) then
+ begin
+ result := TTF_RenderText_Solid( FFont, PChar( string( aText ) ), FForeGroundColour );
+ end
+ else
+ begin
+ result := TTF_RenderText_Shaded( FFont, PChar( string( aText ) ), FForeGroundColour, FBackGroundColour );
+ end;
+ end;
+
+ rtUTF8 :
+ begin
+ if ( FSolid ) then
+ begin
+ result := TTF_RenderUTF8_Solid( FFont, PChar( string( aText ) ), FForeGroundColour );
+ end
+ else
+ begin
+ result := TTF_RenderUTF8_Shaded( FFont, PChar( string( aText ) ), FForeGroundColour, FBackGroundColour );
+ end;
+ end;
+
+ rtUnicode :
+ begin
+ if ( FSolid ) then
+ begin
+ result := TTF_RenderUNICODE_Solid( FFont, PUInt16( aText ), FForeGroundColour );
+ end
+ else
+ begin
+ result := TTF_RenderUNICODE_Shaded( FFont, PUInt16( aText ), FForeGroundColour, FBackGroundColour );
+ end;
+ end;
+ end;
+end;
+
+function TTrueTypeFont.DrawText( aText : WideString; aWidth, aHeight : Integer ) : PSDL_Surface;
+var
+ textw, texth, i, yPos : integer;
+ strChopped : WideString;
+ SurfaceList : array of PSDL_Surface;
+ strlist : array of WideString;
+ ReturnedSurface : PSDL_Surface;
+ BltRect : TSDL_Rect;
+begin
+ PrepareFont;
+
+ // Do an initial check to see if it already fits
+ case FRenderType of
+ rtLatin1 :
+ begin
+ if TTF_SizeText( FFont, PChar( string( aText ) ), textw, texth ) = 0 then
+ begin
+ if ( textw < aWidth )
+ and ( texth < aHeight ) then
+ begin
+ result := DrawText( aText );
+ exit;
+ end
+ end;
+ end;
+
+ rtUTF8 :
+ begin
+ if TTF_SizeUTF8( FFont, PChar( string( aText ) ), textw, texth ) = 0 then
+ begin
+ if ( textw < aWidth )
+ and ( texth < aHeight ) then
+ begin
+ result := DrawText( aText );
+ exit;
+ end
+ end;
+ end;
+
+ rtUnicode :
+ begin
+ if TTF_SizeUNICODE( FFont, PUInt16( aText ), textw, texth ) = 0 then
+ begin
+ if ( textw < aWidth )
+ and ( texth < aHeight ) then
+ begin
+ result := DrawText( aText );
+ exit;
+ end
+ end;
+ end;
+ end;
+
+ // Create the Surface we will be returning
+ ReturnedSurface := SDL_DisplayFormat( SDL_CreateRGBSurface( SDL_SRCCOLORKEY or SDL_RLEACCEL or SDL_HWACCEL, aWidth, aHeight, 16, 0, 0, 0, 0 ) );
+
+ // If we are still here there is some serious parsing to do
+ case FRenderType of
+ rtLatin1 :
+ begin
+ strChopped := aText;
+ i := Length( strChopped );
+ while ( i <> 0 ) do
+ begin
+ if ( string( strChopped[ i ] ) <> ' ' ) and ( Integer( string( strChopped[ i ] ) ) <> 13 ) then
+ dec( i )
+ else
+ begin
+ dec( i );
+ if TTF_SizeText( FFont, PChar( string( Copy( strChopped, 0, i ) ) ), textw, texth ) = 0 then
+ begin
+ if ( textw < aWidth )
+ and ( texth < aHeight ) then
+ begin
+ SetLength( strlist, Length( strlist ) + 1 );
+ strlist[ Length( strlist ) - 1 ] := Copy( strChopped, 0, i );
+ strChopped := Copy( strChopped, i + 2, Length( strChopped ) - ( i - 1 ) );
+ i := Length( strChopped );
+ if TTF_SizeText( FFont, PChar( string( strChopped ) ), textw, texth ) = 0 then
+ begin
+ if ( textw < aWidth )
+ and ( texth < aHeight ) then
+ begin
+ SetLength( strlist, Length( strlist ) + 1 );
+ strlist[ Length( strlist ) - 1 ] := Copy( strChopped, 0, i );
+ strChopped := Copy( strChopped, i + 2, Length( strChopped ) - ( i - 1 ) );
+ i := Length( strChopped );
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+
+ SetLength( SurfaceList, Length( strlist ) );
+ for i := Low( strlist ) to High( strlist ) do
+ begin
+ if ( FSolid ) then
+ begin
+ SurfaceList[ i ] := TTF_RenderText_Solid( FFont, PChar( string( strlist[ i ] ) ), FForeGroundColour );
+ end
+ else
+ begin
+ SurfaceList[ i ] := TTF_RenderText_Shaded( FFont, PChar( string( strlist[ i ] ) ), FForeGroundColour, FBackGroundColour );
+ end;
+ end;
+ end;
+
+ rtUTF8 :
+ begin
+ strChopped := aText;
+ i := Length( strChopped );
+ while ( i <> 0 ) do
+ begin
+ if ( string( strChopped[ i ] ) <> ' ' ) and ( Integer( string( strChopped[ i ] ) ) <> 13 ) then
+ dec( i )
+ else
+ begin
+ dec( i );
+ if TTF_SizeUTF8( FFont, PChar( string( Copy( strChopped, 0, i ) ) ), textw, texth ) = 0 then
+ begin
+ if ( textw < aWidth )
+ and ( texth < aHeight ) then
+ begin
+ SetLength( strlist, Length( strlist ) + 1 );
+ strlist[ Length( strlist ) - 1 ] := Copy( strChopped, 0, i );
+ strChopped := Copy( strChopped, i + 2, Length( strChopped ) - ( i - 1 ) );
+ i := Length( strChopped );
+ if TTF_SizeUTF8( FFont, PChar( string( strChopped ) ), textw, texth ) = 0 then
+ begin
+ if ( textw < aWidth )
+ and ( texth < aHeight ) then
+ begin
+ SetLength( strlist, Length( strlist ) + 1 );
+ strlist[ Length( strlist ) - 1 ] := Copy( strChopped, 0, i );
+ strChopped := Copy( strChopped, i + 2, Length( strChopped ) - ( i - 1 ) );
+ i := Length( strChopped );
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+
+ SetLength( SurfaceList, Length( strlist ) );
+ for i := Low( strlist ) to High( strlist ) do
+ begin
+ if ( FSolid ) then
+ begin
+ SurfaceList[ i ] := TTF_RenderUTF8_Solid( FFont, PChar( string( strlist[ i ] ) ), FForeGroundColour );
+ end
+ else
+ begin
+ SurfaceList[ i ] := TTF_RenderUTF8_Shaded( FFont, PChar( string( strlist[ i ] ) ), FForeGroundColour, FBackGroundColour );
+ end;
+ end;
+ end;
+
+ rtUnicode :
+ begin
+ strChopped := aText;
+ i := Length( strChopped );
+ while ( i <> 0 ) do
+ begin
+ if ( string( strChopped[ i ] ) <> ' ' ) and ( Integer( string( strChopped[ i ] ) ) <> 13 ) then
+ dec( i )
+ else
+ begin
+ dec( i );
+ if TTF_SizeUNICODE( FFont, PUInt16( Copy( strChopped, 0, i ) ), textw, texth ) = 0 then
+ begin
+ if ( textw < aWidth )
+ and ( texth < aHeight ) then
+ begin
+ SetLength( strlist, Length( strlist ) + 1 );
+ strlist[ Length( strlist ) - 1 ] := Copy( strChopped, 0, i );
+ strChopped := Copy( strChopped, i + 2, Length( strChopped ) - ( i - 1 ) );
+ i := Length( strChopped );
+ if TTF_SizeUNICODE( FFont, PUInt16( strChopped ), textw, texth ) = 0 then
+ begin
+ if ( textw < aWidth )
+ and ( texth < aHeight ) then
+ begin
+ SetLength( strlist, Length( strlist ) + 1 );
+ strlist[ Length( strlist ) - 1 ] := Copy( strChopped, 0, i );
+ strChopped := Copy( strChopped, i + 2, Length( strChopped ) - ( i - 1 ) );
+ i := Length( strChopped );
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+ SetLength( SurfaceList, Length( strlist ) );
+ for i := Low( strlist ) to High( strlist ) do
+ begin
+ if ( FSolid ) then
+ begin
+ SurfaceList[ i ] := TTF_RenderUNICODE_Solid( FFont, PUInt16( strlist[ i ] ), FForeGroundColour );
+ end
+ else
+ begin
+ SurfaceList[ i ] := TTF_RenderUNICODE_Shaded( FFont, PUInt16( strlist[ i ] ), FForeGroundColour, FBackGroundColour );
+ end;
+ end;
+ end;
+ end;
+
+ // Now Draw the SurfaceList onto the resulting Surface
+ yPos := 6;
+ for i := Low( SurfaceList ) to High( SurfaceList ) do
+ begin
+ BltRect.x := 6;
+ BltRect.y := yPos;
+ BltRect.w := SurfaceList[ i ].w;
+ BltRect.h := SurfaceList[ i ].h;
+ SDL_BlitSurface( SurfaceList[ i ], nil, ReturnedSurface, @BltRect );
+ yPos := yPos + TTF_FontHeight( FFont );
+ end;
+ result := ReturnedSurface;
+
+ for i := Low( SurfaceList ) to High( SurfaceList ) do
+ begin
+ SDL_FreeSurface( SurfaceList[ i ] );
+ end;
+ SetLength( SurfaceList, 0 );
+ SetLength( strlist, 0 );
+end;
+
+function TTrueTypeFont.Input(aDestination: PSDL_Surface; aX, aY, aWidth: integer; aHeight : integer; var aText : string; aMaxChars: integer): PSDL_Surface;
+var
+ event : TSDL_Event;
+ ch : integer;
+
+ BackSurface, TextSurface : PSDL_Surface;
+ rect : SDL_Rect;
+ textw, texth : integer;
+ Done : boolean;
+ PassedInText : string;
+begin
+ PassedInText := aText;
+
+ BackSurface := SDL_AllocSurface( aDestination.flags,
+ aDestination.w,
+ aDestination.h,
+ aDestination.format.BitsPerPixel,
+ aDestination.format.Rmask,
+ aDestination.format.Gmask,
+ aDestination.format.Bmask, 0 );
+
+ rect.x := aX;
+ rect.y := aY;
+ rect.w := aWidth;
+ rect.h := aHeight;
+
+ SDL_BlitSurface( aDestination, nil, BackSurface, nil );
+ SDL_FillRect( BackSurface, @rect, SDL_MapRGB( aDestination.format, 0, 0, 0 ) );
+
+ TextSurface := DrawText( aText + '|' );
+
+ // start input
+ SDL_EnableUNICODE( 1 );
+ Done := false;
+ while ( not Done ) and ( SDL_WaitEvent( @event ) > 0 ) do
+ begin
+ if event.type_ = SDL_KEYDOWN then
+ begin
+ ch := event.key.keysym.unicode;
+ case ch of
+ SDLK_RETURN :
+ begin
+ Done := true;
+ end;
+
+ SDLK_ESCAPE :
+ begin
+ aText := PassedInText;
+ Done := true;
+ end;
+
+ SDLK_BACKSPACE :
+ begin
+ if ( Length( aText ) > 0 ) then
+ begin
+ aText := Copy( aText, 0, Length( aText ) - 1 );
+ if TextSurface <> nil then
+ SDL_FreeSurface( TextSurface );
+ TextSurface := DrawText( aText + '|' );
+ end;
+ end;
+ else
+ begin
+ if Length( aText ) < aMaxChars then
+ begin
+ if ( chr( ch ) <> '' ) then
+ begin
+ aText := aText + chr( ch );
+
+ if ( aText <> '' )
+ and ( TTF_SizeUNICODE( FFont, PUInt16( aText ), textw, texth ) = 0 ) then
+ begin
+ if ( textw > aWidth ) then
+ aText := Copy( aText, 0, Length( aText ) - 1 );
+ end;
+
+ if TextSurface <> nil then
+ SDL_FreeSurface( TextSurface );
+ TextSurface := DrawText( aText + '|' );
+ end;
+ end;
+ end;
+ end;
+ end;
+ SDL_BlitSurface( BackSurface, nil, aDestination, nil );
+ SDL_BlitSurface( TextSurface, nil, aDestination, @rect );
+ SDL_Flip( aDestination );
+ end;
+
+ if TextSurface <> nil then
+ SDL_FreeSurface( TextSurface );
+ if aText <> '' then
+ TextSurface := DrawText( aText );
+ SDL_FreeSurface( BackSurface );
+ result := TextSurface;
+end;
+
+procedure TTrueTypeFont.PrepareFont;
+var
+ renderstyle : integer;
+begin
+ if FFont <> nil then
+ TTF_CloseFont( FFont );
+
+ FFont := TTF_OpenFont( PChar( FFontFile ), FFontSize );
+
+ renderstyle := TTF_STYLE_NORMAL;
+ if ( fsBold in FStyle ) then
+ renderstyle := renderstyle or TTF_STYLE_BOLD;
+
+ if ( fsItalic in FStyle ) then
+ renderstyle := renderstyle or TTF_STYLE_ITALIC;
+
+ if ( fsUnderline in FStyle ) then
+ renderstyle := renderstyle or TTF_STYLE_UNDERLINE;
+
+ TTF_SetFontStyle( FFont, renderstyle );
+end;
+
+end.
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 02:50:53 +0000