From 1ba91d5a0e1df7419a561f6dcf16a0839509a5e7 Mon Sep 17 00:00:00 2001 From: k-m_schindler Date: Wed, 27 Aug 2008 13:28:57 +0000 Subject: Reordering of the directories[1]: moving Game/Code to src git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@1302 b956fd51-792f-4845-bead-9b4dfca2ff2c --- .../lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas | 565 --------------------- 1 file changed, 565 deletions(-) delete mode 100644 Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas (limited to 'Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas') diff --git a/Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas b/Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas deleted file mode 100644 index a457c1d9..00000000 --- a/Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas +++ /dev/null @@ -1,565 +0,0 @@ -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 } -{ } -{ 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. - -- cgit v1.2.3