diff options
author | tobigun <tobigun@b956fd51-792f-4845-bead-9b4dfca2ff2c> | 2008-06-08 15:33:48 +0000 |
---|---|---|
committer | tobigun <tobigun@b956fd51-792f-4845-bead-9b4dfca2ff2c> | 2008-06-08 15:33:48 +0000 |
commit | 46bb010ca7c5eb04551c030105f9999ca80e472f (patch) | |
tree | 3cb6a6bdd7e4e62623c6a83b5d22c1c0dfad73e8 /Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas | |
parent | f4425b4558b7fd86de874035f81ea290c987e96d (diff) | |
download | usdx-46bb010ca7c5eb04551c030105f9999ca80e472f.tar.gz usdx-46bb010ca7c5eb04551c030105f9999ca80e472f.tar.xz usdx-46bb010ca7c5eb04551c030105f9999ca80e472f.zip |
- set svn:eol-style to native
- removed some svn:executable properties from non-executable files
git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@1144 b956fd51-792f-4845-bead-9b4dfca2ff2c
Diffstat (limited to '')
-rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas | 1130 |
1 files changed, 565 insertions, 565 deletions
diff --git a/Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas b/Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas index a0f25e12..a457c1d9 100644 --- a/Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas +++ b/Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas @@ -1,565 +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.
-
+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. + |