path: root/Game/Code/lib/JEDI-SDL/SDL_ttf/Pas/sdltruetypefont.pas

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.