{ TextSuite (C) Steffen Xonna (aka Lossy eX) http://www.opengl24.de/ ----------------------------------------------------------------------- For copyright informations see file copyright.txt. } {$WARNINGS OFF} {$HINTS OFF} {$I TextSuiteOptions.inc} unit TextSuiteClasses; interface uses Classes, TextSuite, TextSuiteWideUtils, TextSuiteImports; { intern types for Renderer } const TS_BLOCK_FONT = $1; TS_BLOCK_COLOR = $2; TS_BLOCK_WORD = $3; TS_BLOCK_SPACE = $4; TS_BLOCK_LINEBREAK = $5; TS_BLOCK_TAB = $6; type TtsFontStyle = (tsStyleBold, tsStyleItalic, tsStyleUnderline, tsStyleStrikeout); TtsFontStyles = set of TtsFontStyle; TtsAntiAliasing = (tsAANone, tsAANormal); TtsFormat = (tsFormatEmpty, tsFormatRGBA8); TtsImageMode = (tsModeRed, tsModeGreen, tsModeBlue, tsModeAlpha, tsModeLuminance); TtsImageModes = array [TtsImageMode] of tsEnum; tsQuad = array[0..3] of tsPoint; tsPointFloat = packed record X: Single; Y: Single; end; tsQuadFloat = array[0..3] of tsPointFloat; const cModesReplace : TtsImageModes = (TS_MODE_REPLACE, TS_MODE_REPLACE, TS_MODE_REPLACE, TS_MODE_REPLACE, TS_MODE_REPLACE); cModesNormal : TtsImageModes = (TS_MODE_REPLACE, TS_MODE_REPLACE, TS_MODE_REPLACE, TS_MODE_MODULATE, TS_MODE_REPLACE); type PtsHashEntry = ^TtsHashEntry; TtsHashEntry = record Name: Integer; Value: Pointer; Next: PtsHashEntry; end; TtsHash = class(TObject) private fHashArray: array of PtsHashEntry; fHashEntrys: Integer; fCount: Integer; function IntToPos(Name: Integer): Integer; public property Count: Integer read fCount; constructor Create(HashEntrys: Integer); destructor Destroy; override; procedure Add(Name: Integer; Value: Pointer); procedure Delete(Name: Integer); procedure Clear; function Get(Name: Integer): Pointer; procedure GetNames(const NameList: TList); procedure GetValues(const ValueList: TList); end; PtsStringHashEntry = ^TtsStringHashEntry; TtsStringHashEntry = record pString: pWideChar; Next: PtsStringHashEntry; end; TtsStringHash = class(TObject) private fHashArray: array of PtsStringHashEntry; fHashEntrys: Cardinal; public constructor Create(HashEntrys: Integer); destructor Destroy; override; procedure Add(pString: pWideChar); function Delete(pString: pWideChar): Boolean; end; TtsKernel1DItem = packed record Offset: Integer; Value: Single; DataOffset: Integer; end; TtsKernel1D = class public Size: Integer; ValueSum: Double; Items: array of TtsKernel1DItem; ItemCount: Integer; constructor Create(Radius, Strength: Single); procedure UpdateDataOffset(DataSize: Integer); end; TtsKernel2DItem = packed record OffsetX: Integer; OffsetY: Integer; Value: Single; DataOffset: Integer; end; TtsKernel2D = class public SizeX: Integer; SizeY: Integer; MidSizeX: Integer; MidSizeY: Integer; ValueSum: Double; Items: array of TtsKernel2DItem; ItemCount: Integer; constructor Create(Radius, Strength: Single); procedure UpdateDataOffset(DataSizeX, DataSizeY: Integer); end; TtsImage = class; TtsRenderer = class; TtsRendererImageReference = class; TtsContext = class; TtsChar = class; TtsImageFunc = procedure(Image: TtsImage; X, Y: Integer; var Pixel: tsColor; Data: Pointer); TtsImage = class private fWidth: Integer; fHeight: Integer; fFormat: TtsFormat; fData: Pointer; fScanLinesValid: Boolean; fScanLines: array of Pointer; procedure SetDataPtr(aData: Pointer; aFormat: TtsFormat = tsFormatEmpty; aWidth: Integer = 0; aHeight: Integer = 0); function GetFormatSize(Format: TtsFormat): Integer; procedure UpdateScanLines; function GetScanLine(Index: Integer): pointer; function GetEmpty: Boolean; public procedure BeforeDestruction; override; procedure AssignFrom(Image: TtsImage); procedure CreateEmpty(Format: TtsFormat; aWidth, aHeight: Integer); procedure LoadFromFile(FileName: PAnsiChar); procedure Resize(NewWidth, NewHeight, X, Y: Integer); procedure FindMinMax(var MinMaxInfo: tsRect); procedure AddFunc(Func: TtsImageFunc; Data: Pointer); procedure FillColor(Red, Green, Blue, Alpha: Single; ChannelMask: tsBitmask; Modes: TtsImageModes); procedure FillPattern(Pattern: TtsImage; X, Y: Integer; ChannelMask: tsBitmask; Modes: TtsImageModes); procedure BlendImage(Image: TtsImage; X, Y: Integer; AutoExpand: Boolean = True); procedure Blur(HorzKernel, VertKernel: TtsKernel1D; ChannelMask: tsBitmask); procedure AddResizingBorder(tsChar: TtsChar); property Empty: Boolean read GetEmpty; property Data: Pointer read fData; property Width: Integer read fWidth; property Height: Integer read fHeight; property Format: TtsFormat read fFormat; property ScanLine[Index: Integer]: pointer read GetScanline; end; TtsChar = class protected // CharCode fCharCode: WideChar; public // Position of char GlyphOriginX: Smallint; GlyphOriginY: Smallint; Advance: SmallInt; GlyphRect: tsRect; HasResizingBorder: Boolean; // Kerning // KerningValuesLeft: array of WORD; // KerningValuesRight: array of WORD; // Renderer data for Imagehandling RendererImageReference: TtsRendererImageReference; constructor Create(CharCode: WideChar); destructor Destroy; override; procedure ExpandRect(Left, Top, Right, Bottom: Integer); // Kerning // procedure CalculateKerningData(CharImage: TtsImage); // function CalculateKerningValue(LastChar: TtsChar): Smallint; // CharCode property CharCode: WideChar read fCharCode; end; PtsFontCharArray = ^TtsFontCharArray; TtsFontCharArray = packed record Chars: array [Byte] of TtsChar; CharCount: Byte; end; TtsTextMetric = record Ascent: Integer; Descent: Integer; LineSkip: Integer; LineSkip_with_LineSpace: Integer; end; TtsFont = class private // Strings fCopyright: AnsiString; fFaceName: AnsiString; fStyleName: AnsiString; fFullName: AnsiString; // font styles fSize: Integer; fStyle: TtsFontStyles; fFormat: TtsFormat; fAntiAliasing: TtsAntiAliasing; // font settings fAscent: Integer; fDescent: Integer; fExternalLeading: Integer; fBaselineOffset: Integer; fDefaultChar: WideChar; fFontFileStyle: Integer; fFixedWidth: Boolean; fCharSpacing: Integer; fLineSpacing: Integer; fUnderlinePosition: Integer; fUnderlineSize: Integer; fStrikeoutPosition: Integer; fStrikeoutSize: Integer; // chars fChars: array [Byte] of PtsFontCharArray; protected fRenderer: TtsRenderer; function Validate(CharCode: WideChar): Boolean; virtual; procedure AddChar(CharCode: WideChar; Char: TtsChar); function GetChar(CharCode: WideChar): TtsChar; public // chars property Char[CharCode: WideChar]: TtsChar read GetChar; // strings property Copyright: AnsiString read fCopyright write fCopyright; property FaceName: AnsiString read fFaceName write fFaceName; property StyleName: AnsiString read fStyleName write fStyleName; property FullName: AnsiString read fFullName write fFullName; property Size: Integer read fSize write fSize; property Style: TtsFontStyles read fStyle write fStyle; property Format: TtsFormat read fFormat write fFormat; property AntiAliasing: TtsAntiAliasing read fAntiAliasing write fAntiAliasing; // Font propertys property Ascent: Integer read fAscent write fAscent; property Descent: Integer read fDescent write fDescent; property ExternalLeading: Integer read fExternalLeading write fExternalLeading; property BaselineOffset: Integer read fBaselineOffset write fBaselineOffset; property DefaultChar: WideChar read fDefaultChar write fDefaultChar; property FontFileStyle: Integer read fFontFileStyle write fFontFileStyle; property FixedWidth: Boolean read fFixedWidth write fFixedWidth; property CharSpacing: Integer read fCharSpacing write fCharSpacing; property LineSpacing: Integer read fLineSpacing write fLineSpacing; property UnderlinePosition: Integer read fUnderlinePosition write fUnderlinePosition; property UnderlineSize: Integer read fUnderlineSize write fUnderlineSize; property StrikeoutPosition: Integer read fStrikeoutPosition write fStrikeoutPosition; property StrikeoutSize: Integer read fStrikeoutSize write fStrikeoutSize; constructor Create(Renderer: TtsRenderer; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); destructor Destroy; override; procedure ClearChars; procedure DeleteChar(CharCode: WideChar); procedure GetTextMetric(var Metric: TtsTextMetric); end; PtsPostProcessStepRange = ^TtsPostProcessStepRange; TtsPostProcessStepRange = record StartChar: WideChar; EndChar: WideChar; end; TtsFontProcessStepUsage = (tsUInclude, tsUExclude); TtsPostProcessStep = class protected fIncludeCharRange: TList; fExcludeCharRange: TList; procedure ClearList(List: TList); procedure PostProcess(const CharImage: TtsImage; const Char: TtsChar); virtual; abstract; public constructor Create; destructor Destroy; override; function IsInRange(CharCode: WideChar): Boolean; procedure AddUsageRange(Usage: TtsFontProcessStepUsage; StartChar, EndChar: WideChar); procedure AddUsageChars(Usage: TtsFontProcessStepUsage; Chars: pWideChar); procedure ClearIncludeRange; procedure ClearExcludeRange; end; TtsFontCreator = class(TtsFont) private fPostProcessSteps: TList; function GetPostProcessStepCount: Integer; function GetPostProcessStep(Index: Integer): TtsPostProcessStep; protected fCreateChars: Boolean; fAddResizingBorder: Boolean; function Validate(CharCode: WideChar): Boolean; override; function GetGlyphMetrics(CharCode: WideChar; var GlyphOriginX, GlyphOriginY, GlyphWidth, GlyphHeight, Advance: Integer): Boolean; virtual; abstract; procedure GetCharImage(CharCode: WideChar; const CharImage: TtsImage); virtual; abstract; procedure DrawLine(Char: TtsChar; CharImage: TtsImage; LinePosition, LineSize: Integer); procedure DoPostProcess(var CharImage: TtsImage; const tsChar: TtsChar); public property CreateChars: Boolean read fCreateChars write fCreateChars; property AddResizingBorder: Boolean read fAddResizingBorder write fAddResizingBorder; constructor Create(Renderer: TtsRenderer; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); destructor Destroy; override; procedure AddChar(CharCode: WideChar); overload; function AddPostProcessStep(PostProcessStep: TtsPostProcessStep): TtsPostProcessStep; procedure DeletePostProcessStep(Index: Integer); procedure ClearPostProcessSteps; property PostProcessStepCount: Integer read GetPostProcessStepCount; property PostProcessStep[Index: Integer]: TtsPostProcessStep read GetPostProcessStep; end; TtsFontCreatorSDL = class(TtsFontCreator) protected fSDLFont: PTTF_Font; function GetGlyphMetrics(CharCode: WideChar; var GlyphOriginX, GlyphOriginY, GlyphWidth, GlyphHeight, Advance: Integer): Boolean; override; procedure GetCharImage(CharCode: WideChar; const CharImage: TtsImage); override; public constructor Create(Renderer: TtsRenderer; const Filename: AnsiString; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); destructor Destroy; override; end; TtsFontCreatorGDIFontFace = class(TtsFontCreator) protected fFontHandle: THandle; fMat2: TMat2; fFontname: AnsiString; function GetGlyphIndex(CharCode: WideChar): Integer; function GetGlyphMetrics(CharCode: WideChar; var GlyphOriginX, GlyphOriginY, GlyphWidth, GlyphHeight, Advance: Integer): Boolean; override; procedure GetCharImageAntialiased(DC: HDC; CharCode: WideChar; const CharImage: TtsImage); procedure GetCharImageNone(DC: HDC; CharCode: WideChar; const CharImage: TtsImage); procedure GetCharImage(CharCode: WideChar; const CharImage: TtsImage); override; public constructor Create(Renderer: TtsRenderer; const Fontname: AnsiString; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); destructor Destroy; override; end; TtsFontCreatorGDIFile = class(TtsFontCreatorGDIFontFace) protected fFilename: pAnsiChar; fFontRegistred: Boolean; function RegisterFont(Filename: pAnsiChar; RegisterPublic: Boolean): boolean; function UnRegisterFont(Filename: pAnsiChar; RegisterPublic: Boolean): boolean; function GetFaceName(Filename: pAnsiChar; var Face: AnsiString): boolean; public constructor Create(Renderer: TtsRenderer; const Filename: AnsiString; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); destructor Destroy; override; end; TtsFontCreatorGDIStream = class(TtsFontCreatorGDIFontFace) protected fFontRegistred: Boolean; fHandle: THandle; function RegisterFont(Data: TStream): boolean; function UnRegisterFont(): boolean; function GetFaceName(Stream: TStream; var Face: AnsiString): boolean; public constructor Create(Renderer: TtsRenderer; const Source: TStream; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); destructor Destroy; override; end; PtsLineItem = ^TtsLineItem; TtsLineItem = record NextItem: PtsLineItem; PrevItem: PtsLineItem; ItemType: Integer; case Integer of TS_BLOCK_FONT: ( Font: TtsFont; FontID: tsFontID; ); TS_BLOCK_COLOR: ( Red: Single; Green: Single; Blue: Single; Alpha: Single; ); TS_BLOCK_WORD, TS_BLOCK_SPACE: ( Word: PWideChar; WordLength: Integer; ); end; PtsLinesItem = ^TtsLinesItem; TtsLinesItem = record NextLine: PtsLinesItem; LineItemFirst: PtsLineItem; LineItemLast: PtsLineItem; LineLength: Integer; LineAutoBreak: Boolean; end; TtsTempLines = record Lines: PtsLinesItem; Empty: Boolean; end; { *** *** } TtsRendererImageReference = class end; TtsRenderer = class private fContext: TtsContext; fSaveImages: Boolean; fisBlock: Boolean; fBlockLeft: Integer; fBlockTop: Integer; fBlockWidth: Integer; fBlockHeight: Integer; fFlags: Integer; fWordWrap: Boolean; // fSingleLine: Boolean; fActiveFont: TtsFont; fActiveFontID: Cardinal; fLastActiveFont: TtsFont; fLastActiveFontID: Cardinal; fLinesFirst: PtsLinesItem; fLinesLast: PtsLinesItem; fLinesTemp: TtsTempLines; // drawings fLineTop: Integer; fTextOffsetY: Integer; fTextOffsetX: Integer; function GetActiveFont: TtsFont; function GetActiveFontID: Cardinal; function SplitText(pText: PWideChar): PtsLineItem; procedure CalculateWordLength(Font: TtsFont; pWord: PtsLineItem); procedure SplitIntoLines(pItemList: PtsLineItem); procedure DrawLine(pLine: PtsLineItem; LineLength: Integer; LineBreak: Boolean); procedure DrawLines(pLinesItem: PtsLinesItem); function CalculateLinesHeight(pLinesItem: PtsLinesItem): Integer; procedure GetLineMetric(pLine: PtsLineItem; var Metric: TtsTextMetric); procedure PushLineItem(pLine: PtsLineItem); procedure FreeLineItems(var pLine: PtsLineItem); procedure PushTempLines; procedure FreeLines(var pLinesItem: PtsLinesItem); procedure TrimSpaces(pLinesItem: PtsLinesItem); protected procedure DrawChar(Font: TtsFont; Char: TtsChar); virtual; abstract; procedure DrawSetPosition(X, Y: Integer); virtual; abstract; procedure DrawSetPositionRelative(X, Y: Integer); virtual; abstract; procedure DrawSetColor(Red, Green, Blue, Alpha: Single); virtual; abstract; function AddImage(Char: TtsChar; CharImage: TtsImage): TtsRendererImageReference; virtual; abstract; procedure RemoveImageReference(ImageReference: TtsRendererImageReference); virtual; abstract; public property ActiveFont: TtsFont read GetActiveFont; property ActiveFontID: Cardinal read GetActiveFontID; property SaveImages: Boolean read fSaveImages write fSaveImages; property isBlock: Boolean read FisBlock; constructor Create(Context: TtsContext); destructor Destroy; override; procedure BeginBlock(Left, Top, Width, Height: Integer; Flags: tsBitmask); virtual; procedure EndBlock; procedure FontActivate(FontID: Cardinal); procedure Color(Red, Green, Blue, Alpha: Single); procedure TextOut(pText: pWideChar); function TextGetWidth(pText: pWideChar): Integer; function TextGetDrawWidth: Integer; function TextGetDrawHeight: Integer; procedure CharOut(CharCode: WideChar); end; TtsRendererNULLImageReference = class(TtsRendererImageReference) Image: TtsImage; end; TtsRendererNULL = class(TtsRenderer) protected procedure DrawChar(Font: TtsFont; Char: TtsChar); override; procedure DrawSetPosition(X, Y: Integer); override; procedure DrawSetPositionRelative(X, Y: Integer); override; procedure DrawSetColor(Red, Green, Blue, Alpha: Single); override; function AddImage(Char: TtsChar; CharImage: TtsImage): TtsRendererImageReference; override; procedure RemoveImageReference(ImageReference: TtsRendererImageReference); override; end; TtsRendererOpenGLImageReference = class(TtsRendererImageReference) TexID: Integer; Coordinates: tsRect; TexCoords: tsQuadFloat; Vertex: tsQuadFloat; end; PtsRendererOpenGLTexture = ^TtsRendererOpenGLTexture; TtsRendererOpenGLTexture = record glTextureID: Cardinal; Width: Integer; Height: Integer; end; PtsRendererOpenGLManagedEntry = ^TtsRendererOpenGLManagedEntry; TtsRendererOpenGLManagedEntry = record Start: Word; Count: Word; NextEntry: PtsRendererOpenGLManagedEntry; end; PtsRendererOpenGLTextureEntry = ^TtsRendererOpenGLTextureEntry; TtsRendererOpenGLTextureEntry = record ID: Integer; Texture: PtsRendererOpenGLTexture; Lines: array of PtsRendererOpenGLManagedEntry; Usage: Integer; end; TtsRendererOpenGL = class(TtsRenderer) private fPos: tsPoint; fTextureSize: Integer; // Texture fTextures: TList; procedure AllocSpace(var FirstManaged: PtsRendererOpenGLManagedEntry; Start, Count: Word); procedure FreeSpace(var FirstManaged: PtsRendererOpenGLManagedEntry; Start, Count: Word); function GetTextureByID(ID: Integer): PtsRendererOpenGLTexture; function AddImageToTexture(Texture: PtsRendererOpenGLTextureEntry; Image: TtsImage; var TextureID: Integer; var Coordinates: tsRect): boolean; function CreateNewTexture: PtsRendererOpenGLTextureEntry; procedure DeleteTexture(Idx: Integer); procedure ClearTextures; protected procedure DrawChar(Font: TtsFont; Char: TtsChar); override; procedure DrawSetPosition(X, Y: Integer); override; procedure DrawSetPositionRelative(X, Y: Integer); override; procedure DrawSetColor(Red, Green, Blue, Alpha: Single); override; function AddImage(Char: TtsChar; CharImage: TtsImage): TtsRendererImageReference; override; procedure RemoveImageReference(ImageReference: TtsRendererImageReference); override; public property TextureSize: Integer read fTextureSize write fTextureSize; procedure BeginBlock(Left, Top, Width, Height: Integer; Flags: tsBitmask); override; procedure AfterConstruction; override; procedure BeforeDestruction; override; end; // context structures/types for use in unit TextSuite TtsContext = class private fContextID: Cardinal; // Fonts fFonts: TtsHash; fLastFontID: Cardinal; // Images fImages: TtsHash; fLastImageID: Cardinal; function GetIsLocked: boolean; procedure ClearFonts; procedure ClearImages; function GetActiveFont: TtsFont; public // ThreadID gBoundThreadID: Cardinal; // error Error: Cardinal; // globals settings Renderer: TtsRenderer; gCreator: tsEnum; gGlobalFormat: tsEnum; gGlobalAntiAliasing: tsEnum; gDebugDrawCharRects: Boolean; gEmptyCodePageEntry: tsEnum; gCodePage: tsEnum; gCodePagePtr: Pointer; gCodePageFunc: TtsAnsiToWideCharFunc; gSingleLine: tsEnum; gAlign: tsEnum; gVAlign: tsEnum; gClip: tsEnum; gBlockOffsetX: tsInt; gBlockOffsetY: tsInt; gImageMode: TtsImageModes; gImageLibrary: tsEnum; { Tab: tsEnum; TabWidth: tsInt; } // context specific / helper property ContextID: Cardinal read fContextID; property IsLocked: boolean read GetIsLocked; property ActiveFont: TtsFont read GetActiveFont; // helper functions function ImageAdd(Image: TtsImage): Cardinal; function ImageGet(Image: Cardinal): TtsImage; procedure ImageDelete(Image: Cardinal); function ImageCount: Cardinal; function FontAdd(Font: TtsFont): Cardinal; function FontGet(Font: Cardinal): TtsFont; procedure FontDelete(Font: Cardinal); function FontCount: Cardinal; function AnsiToWide(pText: pAnsiChar): pWideChar; constructor Create; destructor Destroy; override; end; PtsContextFontEntry = ^TtsContextFontEntry; TtsContextFontEntry = record FontID: tsFontID; Font: TtsFont; end; PtsContextImageEntry = ^TtsContextImageEntry; TtsContextImageEntry = record ImageID: tsImageID; Image: TtsImage; end; // Helper function MakeColor(Red: Byte = 0; Green: Byte = 0; Blue: Byte = 0; Alpha: Byte = 0): tsColor; implementation uses Math, SysUtils, SyncObjs, TextSuitePostProcess, TextSuiteTTFUtils; var gLastContextID: Cardinal; // Helper function MakeColor(Red, Green, Blue, Alpha: Byte): tsColor; begin Result.Red := Red; Result.Green := Green; Result.Blue := Blue; Result.Alpha := Alpha; end; procedure TranslateQuad(var Dest: tsQuadFloat; const Source: tsQuadFloat; const Translate: tsPoint); begin Dest[0].X := Source[0].X + Translate.X; Dest[0].Y := Source[0].Y + Translate.Y; Dest[1].X := Source[1].X + Translate.X; Dest[1].Y := Source[1].Y + Translate.Y; Dest[2].X := Source[2].X + Translate.X; Dest[2].Y := Source[2].Y + Translate.Y; Dest[3].X := Source[3].X + Translate.X; Dest[3].Y := Source[3].Y + Translate.Y; end; { TtsHash } procedure TtsHash.Add(Name: Integer; Value: Pointer); var Pos: Integer; Entry, HashEntry: PtsHashEntry; begin if Name <> 0 then begin Pos := IntToPos(Name); HashEntry := fHashArray[Pos]; Entry := fHashArray[Pos]; if (HashEntry = nil) then begin if (Value = nil) then Exit; New(HashEntry); HashEntry^.Name := Name; HashEntry^.Value := Value; HashEntry^.Next := nil; fHashArray[Pos] := HashEntry; Inc(fCount); Exit; end; while HashEntry <> nil do begin if Name = HashEntry^.Name then begin if Value = nil then begin if (HashEntry = fHashArray[Pos]) then fHashArray[Pos] := fHashArray[Pos]^.Next else Entry^.Next := HashEntry^.Next; Dispose(HashEntry); Dec(fCount); Exit; end; HashEntry^.Value := Value; Exit; end; if HashEntry^.Next = nil then break; Entry := HashEntry; HashEntry := HashEntry^.Next; end; if (Value = nil) then Exit; New(Entry); Entry^.Name := Name; Entry^.Value := Value; Entry^.Next := nil; Inc(fCount); HashEntry^.Next := Entry; end; end; procedure TtsHash.Clear; var Idx: Integer; TempEntry, Entry: PtsHashEntry; begin for Idx := Low(fHashArray) to High(fHashArray) do begin Entry := fHashArray[Idx]; while Entry <> nil do begin TempEntry := Entry; Entry := Entry^.Next; Dispose(TempEntry); end; fHashArray[Idx] := nil; end; fCount := 0; end; constructor TtsHash.Create(HashEntrys: Integer); begin inherited Create; fHashEntrys := Max(1, HashEntrys); SetLength(fHashArray, fHashEntrys); end; procedure TtsHash.Delete(Name: Integer); begin // Add with an empty value is enough Add(Name, nil); end; destructor TtsHash.Destroy; begin Clear; inherited; end; function TtsHash.Get(Name: Integer): Pointer; var Pos: Integer; Entry: PtsHashEntry; begin Result := nil; if Name <> 0 then begin Pos := IntToPos(Name); Entry := fHashArray[Pos]; if Entry <> nil then begin while Entry <> nil do begin if Name = Entry^.Name then begin Result := Entry^.Value; Break; end; Entry := Entry^.Next; end; end; end; end; procedure TtsHash.GetNames(const NameList: TList); var Idx: Integer; Entry: PtsHashEntry; begin Assert(NameList <> nil, 'TtsHash.GetNames - NameList is undefined'); NameList.Clear; for Idx := Low(fHashArray) to High(fHashArray) do begin Entry := fHashArray[Idx]; while Entry <> nil do begin NameList.Add({%H-}Pointer(Entry^.Name)); Entry := Entry^.Next; end; end; end; procedure TtsHash.GetValues(const ValueList: TList); var Idx: Integer; Entry: PtsHashEntry; begin Assert(ValueList <> nil, 'TtsHash.GetValues - ValuesList is undefined'); ValueList.Clear; for Idx := Low(fHashArray) to High(fHashArray) do begin Entry := fHashArray[Idx]; while Entry <> nil do begin ValueList.Add(Entry^.Value); Entry := Entry^.Next; end; end; end; function TtsHash.IntToPos(Name: Integer): Integer; begin if Name < 0 then Result := -Name else Result := Name; Result := Result mod fHashEntrys; end; { TtsStringHash } procedure TtsStringHash.Add(pString: pWideChar); var Pos: Integer; Entry, HashEntry: PtsStringHashEntry; begin if pString <> nil then begin Pos := {%H-}Cardinal(pString) mod fHashEntrys; Entry := fHashArray[Pos]; HashEntry := Entry; // is empty field if (Entry = nil) then begin New(Entry); Entry^.pString := pString; Entry^.Next := nil; fHashArray[Pos] := Entry; Exit; end; // search last while HashEntry <> nil do begin if HashEntry^.Next = nil then break; HashEntry := HashEntry^.Next; end; New(Entry); Entry^.pString := pString; Entry^.Next := nil; HashEntry^.Next := Entry; end; end; constructor TtsStringHash.Create(HashEntrys: Integer); begin inherited Create; fHashEntrys := Max(1, HashEntrys); SetLength(fHashArray, fHashEntrys); end; function TtsStringHash.Delete(pString: pWideChar) : Boolean; var Pos: Integer; Entry, HashEntry: PtsStringHashEntry; begin Result := False; if pString <> nil then begin Pos := {%H-}Cardinal(pString) mod fHashEntrys; HashEntry := fHashArray[Pos]; Entry := nil; while HashEntry <> nil do begin if pString = HashEntry^.pString then begin if (HashEntry = fHashArray[Pos]) then fHashArray[Pos] := fHashArray[Pos]^.Next else Entry^.Next := HashEntry^.Next; Dispose(HashEntry); Result := True; Exit; end; Entry := HashEntry; HashEntry := HashEntry^.Next; end; end; end; destructor TtsStringHash.Destroy; var Idx: Integer; Temp: PtsStringHashEntry; begin for Idx := Low(fHashArray) to High(fHashArray) do begin while fHashArray[Idx] <> nil do begin Temp := fHashArray[Idx]; fHashArray[Idx] := fHashArray[Idx]^.Next; tsStrDispose(Temp^.pString); Dispose(Temp); end; end; SetLength(fHashArray, 0); inherited; end; { TtsKernel1D } constructor TtsKernel1D.Create(Radius, Strength: Single); var TempRadius, SQRRadius, TempStrength, TempValue: Double; Idx: Integer; function CalcValue(Index: Integer): Single; var Temp: Double; begin Temp := Max(0, Abs(Index) - TempStrength); Temp := Sqr(Temp * TempRadius) / SQRRadius; Result := Exp(-Temp); end; begin inherited Create; // calculate new radius and strength TempStrength := Min(Radius - 1, Radius * Strength); TempRadius := Radius - TempStrength; SQRRadius := sqr(TempRadius) * sqr(TempRadius); // caluculating size of the kernel Size := Round(TempRadius); while CalcValue(Size) > 0.001 do Inc(Size); Size := Size -1; ValueSum := 0; ItemCount := Size * 2 +1; SetLength(Items, ItemCount); // calculate Value (yes thats right. there is no -1) for Idx := 0 to Size do begin TempValue := CalcValue(Idx); with Items[Size + Idx] do begin Offset := Idx; Value := TempValue; end; with Items[Size - Idx] do begin Offset := -Idx; Value := TempValue; end; // sum ValueSum := ValueSum + TempValue; if Idx > 0 then ValueSum := ValueSum + TempValue; end; end; procedure TtsKernel1D.UpdateDataOffset(DataSize: Integer); var Idx: Integer; begin for Idx := 0 to ItemCount -1 do with Items[Idx] do DataOffset := Offset * DataSize; end; { TtsKernel2D } constructor TtsKernel2D.Create(Radius, Strength: Single); var TempRadius, SQRRadius, TempStrength, TempValue: Double; X, Y, Height, Width: Integer; function CalcValue(Index: Single): Single; var Temp: Double; begin Temp := Max(0, Abs(Index) - TempStrength); Temp := Sqr(Temp * TempRadius) / SQRRadius; Result := Exp(-Temp); end; procedure QuickSort(L, R: Integer); var I, J: Integer; P, T: TtsKernel2DItem; function Compare(const Item1, Item2: TtsKernel2DItem): Integer; begin if Item1.Value = Item2.Value then Result := 0 else if Item1.Value > Item2.Value then Result := -1 else Result := 1; end; begin repeat I := L; J := R; P := Items[(L + R) shr 1]; repeat while Compare(Items[I], P) < 0 do Inc(I); while Compare(Items[J], P) > 0 do Dec(J); if I <= J then begin T := Items[I]; Items[I] := Items[J]; Items[J] := T; Inc(I); Dec(J); end; until I > J; if L < J then QuickSort(L, J); L := I; until I >= R; end; begin inherited Create; // calculate new radius and strength TempStrength := Min(Radius - 1, Radius * Strength); TempRadius := Radius - TempStrength; SQRRadius := sqr(TempRadius) * sqr(TempRadius); // caluculating X size of the kernel SizeX := 0; MidSizeX := SizeX; while CalcValue(SizeX) > 0.5 do begin Inc(SizeX); Inc(MidSizeX); end; while CalcValue(SizeX) > 0.001 do Inc(SizeX); // caluculating Y size of the kernel SizeY := 0; MidSizeY := SizeY; while CalcValue(SizeY) > 0.5 do begin Inc(SizeY); Inc(MidSizeY); end; while CalcValue(SizeY) > 0.001 do Inc(SizeY); ValueSum := 0; Width := SizeX * 2 + 1; Height := SizeY * 2 + 1; ItemCount := Height * Width; SetLength(Items, ItemCount); Width := SizeX * 2 + 1; Height := SizeY * 2 + 1; ItemCount := Height * Width; SetLength(Items, ItemCount); // calculate Value (yes thats right. there is no -1) for Y := 0 to SizeY do begin for X := 0 to SizeX do begin TempValue := CalcValue(Sqrt(Sqr(X) + Sqr(Y))); with Items[(SizeY + Y) * Width + (SizeX + X)] do begin OffsetX := X; OffsetY := Y; Value := TempValue; end; with Items[(SizeY + Y) * Width + (SizeX - X)] do begin OffsetX := -X; OffsetY := Y; Value := TempValue; end; with Items[(SizeY - Y) * Width + (SizeX + X)] do begin OffsetX := X; OffsetY := -Y; Value := TempValue; end; with Items[(SizeY - Y) * Width + (SizeX - X)] do begin OffsetX := -X; OffsetY := -Y; Value := TempValue; end; // sum ValueSum := ValueSum + TempValue; if (X > 0) and (Y > 0) then ValueSum := ValueSum + TempValue; end; end; // sort QuickSort(0, ItemCount -1); // cut small items while Items[ItemCount -1].Value < 0.001 do Dec(ItemCount); SetLength(Items, ItemCount); end; procedure TtsKernel2D.UpdateDataOffset(DataSizeX, DataSizeY: Integer); var Idx: Integer; begin for Idx := 0 to ItemCount -1 do with Items[Idx] do DataOffset := OffsetX * DataSizeX + OffsetY * DataSizeY; end; { TtsChar } (* procedure TtsChar.CalculateKerningData(CharImage: TtsImage); var Y: Integer; pLeft, pRight: PtsColor; function GetFirstPixel(pData: PtsColor; MinOpaque: Byte; IncValue, MaxSteps: Integer) : Integer; var CurStep: Integer; begin Result := MaxSteps; CurStep := 0; while CurStep < MaxSteps do begin if pData^.Alpha >= MinOpaque then begin Result := CurStep; Break; end; Inc(CurStep); Inc(pData, IncValue); end; end; begin SetLength(KerningValuesLeft, CharImage.Height); SetLength(KerningValuesRight, CharImage.Height); for Y := 0 to CharImage.Height - 1 do begin pRight := CharImage.ScanLine[Y]; Inc(pRight, CharImage.Width -1); KerningValuesRight[Y] := GetFirstPixel(pRight, $40, -1, CharImage.Width); pLeft:= CharImage.ScanLine[Y]; KerningValuesLeft[Y] := GetFirstPixel(pLeft, $40, 1, CharImage.Width); end; end; *) //function TtsChar.CalculateKerningValue(LastChar: TtsChar): Smallint; //begin // Result := 0; //var // TempHeight, TempLastHeight: Integer; // Y, YMin, YMax: Integer; // LeftYMin, LeftYMax, RightYMin, RightYMax: Integer; // // Dist, TempDist: Integer; // // function GetMinDistance(Row: Integer): Integer; // begin //// Result := //// Self.KerningValuesLeft[Self.BaseLine - Self.GlyphRect.Top + Row] + //// LastChar.KerningValuesRight[LastChar.BaseLine - LastChar.GlyphRect.Top + Row]; // end; // //begin // Result := 0; // // if Assigned(LastChar) then begin // TempLastHeight := Length(LastChar.KerningValuesRight); // TempHeight := Length(Self.KerningValuesLeft); // // if (TempLastHeight > 0) and (TempHeight > 0) then begin // LeftYMin := Self.GlyphRect.Bottom - Self.BaseLine; // LeftYMax := Self.GlyphRect.Top - Self.BaseLine; // // RightYMin := LastChar.GlyphRect.Bottom - LastChar.BaseLine; // RightYMax := LastChar.GlyphRect.Top - LastChar.BaseLine; // // YMin := Min(LeftYMin, RightYMin); // YMax := Max(LeftYMax, RightYMax); // // Dist := -1; // // for Y := YMax to YMin -1 do begin // TempDist := GetMinDistance(Y); // // if (Dist = -1) then // Dist := TempDist // else // // if TempDist < Dist then // Dist := TempDist; // end; // // // calculate advance of last char to diff // Dist := Dist + LastChar.Advance - (LastChar.GlyphRect.Right - LastChar.GlyphRect.Left); // // Result := -Dist +3; // end; // end; //end; constructor TtsChar.Create(CharCode: WideChar); begin inherited Create; fCharCode := CharCode; end; destructor TtsChar.Destroy; begin // SetLength(KerningValuesLeft, 0); // SetLength(KerningValuesRight, 0); inherited; end; procedure TtsChar.ExpandRect(Left, Top, Right, Bottom: Integer); begin Advance := Advance + Left + Right; GlyphOriginY := GlyphOriginY + Top + Bottom; GlyphRect.Right := GlyphRect.Right + Left + Right; GlyphRect.Bottom := GlyphRect.Bottom + Top + Bottom; end; { TtsImage } type TtsModeFunc = function(Source, Dest: Byte): Byte; register; function ModeFuncIgnore(Source, Dest: Byte): Byte; register; {$ifdef TS_PURE_PASCAL} begin Result := Dest; {$else} asm mov al, dl {$endif} end; function ModeFuncReplace(Source, Dest: Byte): Byte; register; {$ifdef TS_PURE_PASCAL} begin Result := Source; {$else} asm {$endif} end; function ModeFuncModulate(Source, Dest: Byte): Byte; register; {$ifdef TS_PURE_PASCAL} begin Result := (Source * Dest) div $FF {$else} asm // inc ax // inc dx mul dl shr eax, 8 {$endif} end; procedure TtsImage.AddFunc(Func: TtsImageFunc; Data: Pointer); var X, Y: Integer; pPix: PtsColor; begin for Y := 0 to Height - 1 do begin pPix := ScanLine[Y]; for X := 0 to Width - 1 do begin Func(Self, X, Y, pPix^, Data); Inc(pPix); end; end; end; procedure TtsImage.AddResizingBorder(tsChar: TtsChar); var X, Y: Integer; pPix: PtsColor; pTemp: PtsColor; SumCount: Integer; SumColor: array [0..2] of integer; begin SumColor[0] := 0; SumColor[1] := 0; SumColor[2] := 0; SumCount := 0; // settings of char tsChar.GlyphRect.Top := tsChar.GlyphRect.Top + 1; tsChar.GlyphRect.Left := tsChar.GlyphRect.Left + 1; tsChar.GlyphRect.Right := tsChar.GlyphRect.Right + 1; tsChar.GlyphRect.Bottom := tsChar.GlyphRect.Bottom + 1; // resize image Resize(Width + 4, Height + 4, 2, 2); // calculate color of invisible pixels for Y := 0 to Height -1 do begin pPix := ScanLine[Y]; for X := 0 to Width -1 do begin if pPix^.Alpha = 0 then begin // row -1 if Y > 0 then begin pTemp := pPix; Dec(pTemp, fWidth); // row -1 / col if pTemp^.Alpha > 0 then begin Inc(SumCount); Inc(SumColor[0], pTemp^.Red); Inc(SumColor[1], pTemp^.Green); Inc(SumColor[2], pTemp^.Blue); end; // row -1 / col -1 if X > 0 then begin Dec(pTemp); if pTemp^.Alpha > 0 then begin Inc(SumCount); Inc(SumColor[0], pTemp^.Red); Inc(SumColor[1], pTemp^.Green); Inc(SumColor[2], pTemp^.Blue); end; Inc(pTemp); end; // row -1 / col +1 if X < fWidth -1 then begin Inc(pTemp); if pTemp^.Alpha > 0 then begin Inc(SumCount); Inc(SumColor[0], pTemp^.Red); Inc(SumColor[1], pTemp^.Green); Inc(SumColor[2], pTemp^.Blue); end; end; end; // row +1 if Y < fHeight -1 then begin pTemp := pPix; Inc(pTemp, fWidth); // row +1 / col if pTemp^.Alpha > 0 then begin Inc(SumCount); Inc(SumColor[0], pTemp^.Red); Inc(SumColor[1], pTemp^.Green); Inc(SumColor[2], pTemp^.Blue); end; // row +1 / col -1 if X > 0 then begin Dec(pTemp); if pTemp^.Alpha > 0 then begin Inc(SumCount); Inc(SumColor[0], pTemp^.Red); Inc(SumColor[1], pTemp^.Green); Inc(SumColor[2], pTemp^.Blue); end; Inc(pTemp); end; // row +1 / col +1 if X < fWidth -1 then begin Inc(pTemp); if pTemp^.Alpha > 0 then begin Inc(SumCount); Inc(SumColor[0], pTemp^.Red); Inc(SumColor[1], pTemp^.Green); Inc(SumColor[2], pTemp^.Blue); end; end; end; // row / col -1 if X > 0 then begin pTemp := pPix; Dec(pTemp); if pTemp^.Alpha > 0 then begin Inc(SumCount); Inc(SumColor[0], pTemp^.Red); Inc(SumColor[1], pTemp^.Green); Inc(SumColor[2], pTemp^.Blue); end; end; // row / col +1 if X < fWidth -1 then begin pTemp := pPix; Inc(pTemp); if pTemp^.Alpha > 0 then begin Inc(SumCount); Inc(SumColor[0], pTemp^.Red); Inc(SumColor[1], pTemp^.Green); Inc(SumColor[2], pTemp^.Blue); end; end; // any pixel next to the transparent pixel they are opaque? if SumCount > 0 then begin // calculate resulting pixel color pPix^.Red := SumColor[0] div SumCount; pPix^.Green := SumColor[1] div SumCount; pPix^.Blue := SumColor[2] div SumCount; // clearing values SumColor[0] := 0; SumColor[1] := 0; SumColor[2] := 0; SumCount := 0; end; end; Inc(pPix); end; end; end; procedure TtsImage.AssignFrom(Image: TtsImage); var pImage: Pointer; ImageSize: Integer; begin ImageSize := Image.Width * Image.Height * GetFormatSize(Image.Format); GetMem(pImage, ImageSize); if pImage <> nil then Move(Image.Data^, pImage^, ImageSize); SetDataPtr(pImage, Image.Format, Image.Width, Image.Height); end; procedure TtsImage.BeforeDestruction; begin SetDataPtr(nil); inherited; end; procedure TtsImage.BlendImage(Image: TtsImage; X, Y: Integer; AutoExpand: Boolean); var pImage, pDest: PtsColor; X1, X2, Y1, Y2, BX1, BX2, BY1, BY2, NewWidth, NewHeight: Integer; TempX, TempY: Integer; TempLines: array of PtsColor; pSource: PtsColor; // Blending pUnder, pOver: PtsColor; ResultAlpha, FaqUnder, FaqOver: Byte; begin // Calculate new size X1 := Min(X, 0); X2 := Max(X + Image.Width, Width); Y1 := Min(Y, 0); Y2 := Max(Y + Image.Height, Height); BX1 := Max(X, 0); BX2 := Min(X + Image.Width, Width); BY1 := Max(Y, 0); BY2 := Min(Y + Image.Height, Height); NewWidth := X2 - X1; NewHeight := Y2 - Y1; // Allocate new image GetMem(pImage, NewWidth * NewHeight * GetFormatSize(Format)); try FillChar(pImage^, NewWidth * NewHeight * GetFormatSize(Format), #$00); // ScanLines SetLength(TempLines, NewHeight); for TempY := 0 to NewHeight - 1 do begin TempLines[TempY] := pImage; Inc(TempLines[TempY], NewWidth * TempY); end; // copy non overlapping data from underlaying Image for TempY := 0 to Height -1 do begin pDest := TempLines[TempY - Y1]; Inc(pDest, - X1); pSource := ScanLine[TempY]; for TempX := 0 to Width -1 do begin pDest^ := pSource^; Inc(pDest); Inc(pSource); end; end; // copy non overlapping data from overlaying Image for TempY := 0 to Image.Height -1 do begin pDest := TempLines[TempY + Y - Y1]; Inc(pDest, X - X1); pSource := Image.ScanLine[TempY]; for TempX := 0 to Image.Width -1 do begin pDest^ := pSource^; Inc(pDest); Inc(pSource); end; end; // Blend overlapped for TempY := BY1 to BY2 - 1 do begin pOver := Image.ScanLine[TempY - Min(BY1, Y)]; Inc(pOver, BX1 - X); pUnder := ScanLine[TempY - Min(BY1, 0)]; Inc(pUnder, BX1); pDest := TempLines[TempY - Min(Y, 0)]; Inc(pDest, BX1 - Min(X, 0)); for TempX := BX1 to BX2 - 1 do begin ResultAlpha := pOver^.Alpha + pUnder^.Alpha * ($FF - pOver^.Alpha) div $FF; if ResultAlpha > 0 then begin FaqUnder := (pUnder^.Alpha * ($FF - pOver^.Alpha) div $FF) * $FF div ResultAlpha; FaqOver := pOver^.Alpha * $FF div ResultAlpha; pDest^.Red := (pOver^.Red * FaqOver + pUnder^.Red * FaqUnder) div $FF; pDest^.Green := (pOver^.Green * FaqOver + pUnder^.Green * FaqUnder) div $FF; pDest^.Blue := (pOver^.Blue * FaqOver + pUnder^.Blue * FaqUnder) div $FF; end else begin pDest^.Red := 0; pDest^.Green := 0; pDest^.Blue := 0; end; pDest^.Alpha := ResultAlpha; Inc(pOver); Inc(pUnder); Inc(pDest); end; end; // Set new image SetDataPtr(pImage, Format, NewWidth, NewHeight); except FreeMem(pImage); end; end; type TtsImageBlurFuncData = packed record Kernel: TtsKernel1D; Pos, MaxPos: Integer; end; TBlurFunc = function(pSource: pByte; var Data: TtsImageBlurFuncData): Byte; register; function BlurFuncKernel(pSource: pByte; var Data: TtsImageBlurFuncData): Byte; register; var Idx: Integer; pTemp: pByte; TempSum, TempMax: Double; begin TempSum := 0; TempMax := 0; with Data do begin for Idx := 0 to Kernel.ItemCount -1 do begin with Kernel.Items[Idx] do begin if (Pos + Offset >= 0) and (Pos + Offset < MaxPos) then begin pTemp := pSource; Inc(pTemp, DataOffset); TempSum := TempSum + pTemp^ * Value; TempMax := TempMax + Value; end; end; end; end; Result := Round(TempSum / TempMax); end; function BlurFuncIgnore(pSource: pByte; var Data: TtsImageBlurFuncData): Byte; register; {$ifdef TS_PURE_PASCAL} begin Result := pSource^; {$else} asm mov al, byte ptr [eax] {$endif} end; procedure TtsImage.Blur(HorzKernel, VertKernel: TtsKernel1D; ChannelMask: tsBitmask); var X, Y: Integer; Temp: TtsImage; pSource, pDest: ptsColor; FuncData: TtsImageBlurFuncData; RedFunc, GreenFunc, BlueFunc, AlphaFunc: TBlurFunc; procedure AssignFunc(var Func: TBlurFunc; MaskBit: Cardinal); begin if MaskBit and ChannelMask > 0 then Func := BlurFuncKernel else Func := BlurFuncIgnore; end; begin // casing functions AssignFunc(RedFunc, TS_CHANNEL_RED); AssignFunc(GreenFunc, TS_CHANNEL_GREEN); AssignFunc(BlueFunc, TS_CHANNEL_BLUE); AssignFunc(AlphaFunc, TS_CHANNEL_ALPHA); Temp := TtsImage.Create; try Temp.CreateEmpty(Format, Width, Height); Temp.FillColor(1, 1, 1, 0, TS_CHANNELS_RGBA, cModesReplace); // blur horz from original to temp image HorzKernel.UpdateDataOffset(4); FuncData.Kernel := HorzKernel; FuncData.MaxPos := Temp.Width; for Y := 0 to Temp.Height - 1 do begin pSource := Self.ScanLine[Y]; pDest := Temp.ScanLine[Y]; for X := 0 to FuncData.MaxPos - 1 do begin FuncData.Pos := X; pDest^.Red := RedFunc(@(pSource^.Red), FuncData); pDest^.Green := GreenFunc(@(pSource^.Green), FuncData); pDest^.Blue := BlueFunc(@(pSource^.Blue), FuncData); pDest^.Alpha := AlphaFunc(@(pSource^.Alpha), FuncData); Inc(pDest); Inc(pSource); end; end; // blur vert from temp to original image VertKernel.UpdateDataOffset(Width * 4); FuncData.Kernel := VertKernel; FuncData.MaxPos := Temp.Height; for Y := 0 to Temp.Height - 1 do begin pSource := Temp.ScanLine[Y]; pDest := Self.ScanLine[Y]; FuncData.Pos := Y; for X := 0 to Temp.Width - 1 do begin pDest^.Red := RedFunc(@(pSource^.Red), FuncData); pDest^.Green := GreenFunc(@(pSource^.Green), FuncData); pDest^.Blue := BlueFunc(@(pSource^.Blue), FuncData); pDest^.Alpha := AlphaFunc(@(pSource^.Alpha), FuncData); Inc(pDest); Inc(pSource); end; end; finally Temp.Free; end; end; procedure TtsImage.CreateEmpty(Format: TtsFormat; aWidth, aHeight: Integer); var pImage: pByte; begin pImage := AllocMem(aWidth * aHeight * GetFormatSize(Format)); SetDataPtr(pImage, Format, aWidth, aHeight); end; procedure TtsImage.FillColor(Red, Green, Blue, Alpha: Single; ChannelMask: tsBitmask; Modes: TtsImageModes); //var // MaskColor: TtsFillcolorData; //begin // // prepare mask // FillChar(MaskColor.Mask, 4, $FF); // if ChannelMask and TS_CHANNEL_RED = TS_CHANNEL_RED then // MaskColor.Mask[0] := $00; // if ChannelMask and TS_CHANNEL_GREEN = TS_CHANNEL_GREEN then // MaskColor.Mask[1] := $00; // if ChannelMask and TS_CHANNEL_BLUE = TS_CHANNEL_BLUE then // MaskColor.Mask[2] := $00; // if ChannelMask and TS_CHANNEL_ALPHA = TS_CHANNEL_ALPHA then // MaskColor.Mask[3] := $00; // // pCardinal(@MaskColor.Mask[4])^ := pCardinal(@MaskColor.Mask[0])^; // pCardinal(@MaskColor.Mask[8])^ := pCardinal(@MaskColor.Mask[0])^; // pCardinal(@MaskColor.Mask[12])^ := pCardinal(@MaskColor.Mask[0])^; // // // prepare color // MaskColor.Color[0] := Round($FF * Red); // MaskColor.Color[1] := Round($FF * Green); // MaskColor.Color[2] := Round($FF * Blue); // MaskColor.Color[3] := Round($FF * Alpha); // pCardinal(@MaskColor.Color[4])^ := pCardinal(@MaskColor.Color[0])^; // pCardinal(@MaskColor.Color[8])^ := pCardinal(@MaskColor.Color[0])^; // pCardinal(@MaskColor.Color[12])^ := pCardinal(@MaskColor.Color[0])^; // // // image mode // FillChar(MaskColor.ModuloMask, 4, $00); // if (Modes[tsModeRed] = TS_MODE_MODULATE) and (MaskColor.Mask[0] > 0) then // MaskColor.ModuloMask[0] := $FF; // if (Modes[tsModeGreen] = TS_MODE_MODULATE) and (MaskColor.Mask[1] > 0) then // MaskColor.ModuloMask[1] := $FF; // if (Modes[tsModeBlue] = TS_MODE_MODULATE) and (MaskColor.Mask[2] > 0) then // MaskColor.ModuloMask[2] := $FF; // if (Modes[tsModeAlpha] = TS_MODE_MODULATE) and (MaskColor.Mask[3] > 0) then // MaskColor.ModuloMask[3] := $FF; // pCardinal(@MaskColor.ModuloMask[4])^ := pCardinal(@MaskColor.ModuloMask[0])^; // // // fill with color // if pCardinal(@MaskColor.ModuloMask[0])^ = 0 then // Fillcolor_RGBA8(Data, @MaskColor, Width * Height) // else // Fillcolor_RGBA8_modulo(Data, @MaskColor, Width * Height); // // {$IFNDEF TS_PURE_PASCAL} //// if supportSSE then //// Fillcolor_RGBA8_SSE(Data, @MaskColor, Width * Height) //// else // {$ENDIF} // //// Fillcolor_RGBA8(Data, @MaskColor, Width * Height); //end; var _Red, _Green, _Blue, _Alpha: Byte; RedFunc, GreenFunc, BlueFunc, AlphaFunc, LuminanceFunc: TtsModeFunc; Y, X: Integer; pPix: PtsColor; procedure AssignFunc(var Func: TtsModeFunc; Mask, Mode: tsEnum); begin if ChannelMask and Mask = Mask then begin if Mode = TS_MODE_MODULATE then Func := ModeFuncModulate else Func := ModeFuncReplace end else Func := ModeFuncIgnore end; begin _Red := Round($FF * Red); _Green := Round($FF * Green); _Blue := Round($FF * Blue); _Alpha := Round($FF * Alpha); AssignFunc(RedFunc, TS_CHANNEL_RED, Modes[tsModeRed]); AssignFunc(GreenFunc, TS_CHANNEL_GREEN, Modes[tsModeGreen]); AssignFunc(BlueFunc, TS_CHANNEL_BLUE, Modes[tsModeBlue]); AssignFunc(AlphaFunc, TS_CHANNEL_ALPHA, Modes[tsModeAlpha]); AssignFunc(LuminanceFunc, TS_CHANNEL_LUMINANCE, Modes[tsModeLuminance]); for Y := 0 to Height - 1 do begin pPix := ScanLine[Y]; for X := 0 to Width - 1 do begin pPix^.Red := RedFunc (_Red, pPix^.Red); pPix^.Green := GreenFunc(_Green, pPix^.Green); pPix^.Blue := BlueFunc (_Blue, pPix^.Blue); pPix^.Alpha := AlphaFunc(_Alpha, pPix^.Alpha); Inc(pPix); end; end; end; procedure TtsImage.FillPattern(Pattern: TtsImage; X, Y: Integer; ChannelMask: tsBitmask; Modes: TtsImageModes); var TempX, TempY, RandX, RandY, PosX: Integer; RedFunc, GreenFunc, BlueFunc, AlphaFunc, LuminanceFunc: TtsModeFunc; pSrc, pDest: PtsColor; procedure AssignFunc(var Func: TtsModeFunc; Mask, Mode: tsEnum); begin if ChannelMask and Mask = Mask then begin if Mode = TS_MODE_MODULATE then Func := ModeFuncModulate else Func := ModeFuncReplace end else Func := ModeFuncIgnore end; begin // Pattern position if X < 0 then RandX := Random(Pattern.Width) else RandX := X; if Y < 0 then RandY := Random(Pattern.Height) else RandY := Y; AssignFunc(RedFunc, TS_CHANNEL_RED, Modes[tsModeRed]); AssignFunc(GreenFunc, TS_CHANNEL_GREEN, Modes[tsModeGreen]); AssignFunc(BlueFunc, TS_CHANNEL_BLUE, Modes[tsModeBlue]); AssignFunc(AlphaFunc, TS_CHANNEL_ALPHA, Modes[tsModeAlpha]); AssignFunc(LuminanceFunc, TS_CHANNEL_LUMINANCE, Modes[tsModeLuminance]); // Copy data for TempY := 0 to Height - 1 do begin pDest := ScanLine[TempY]; pSrc := Pattern.Scanline[(TempY + RandY) mod Pattern.Height]; Inc(pSrc, RandX); PosX := RandX; for TempX := 0 to Width - 1 do begin if PosX >= Pattern.Width then begin pSrc := Pattern.Scanline[(TempY + RandY) mod Pattern.Height]; PosX := 0; end; pDest^.Red := RedFunc (pSrc^.Red, pDest^.Red); pDest^.Green := GreenFunc(pSrc^.Green, pDest^.Green); pDest^.Blue := BlueFunc (pSrc^.Blue, pDest^.Blue); pDest^.Alpha := AlphaFunc(pSrc^.Alpha, pDest^.Alpha); Inc(pDest); Inc(pSrc); Inc(PosX); end; end; end; procedure TtsImage.FindMinMax(var MinMaxInfo: tsRect); var X, Y: Integer; pPix: PtsColor; begin MinMaxInfo.Top := -1; MinMaxInfo.Left := -1; MinMaxInfo.Right := -1; MinMaxInfo.Bottom := -1; // Search for MinMax for Y := 0 to Height -1 do begin pPix := ScanLine[Y]; for X := 0 to Width -1 do begin if pPix^.Alpha > 0 then begin if (X < MinMaxInfo.Left) or (MinMaxInfo.Left = -1) then MinMaxInfo.Left := X; if (X+1 > MinMaxInfo.Right) or (MinMaxInfo.Right = -1) then MinMaxInfo.Right := X +1; if (Y < MinMaxInfo.Top) or (MinMaxInfo.Top = -1) then MinMaxInfo.Top := Y; if (Y+1 > MinMaxInfo.Bottom) or (MinMaxInfo.Bottom = -1) then MinMaxInfo.Bottom := Y +1; end; Inc(pPix); end; end; end; function TtsImage.GetEmpty: Boolean; begin Result := fData = nil; end; function TtsImage.GetFormatSize(Format: TtsFormat): Integer; begin case Format of tsFormatRGBA8: Result := 4; else Result := 0; end; end; function TtsImage.GetScanLine(Index: Integer): pointer; begin if not fScanLinesValid then UpdateScanLines; if (fScanLinesValid) and (Index >= 0) and (Index <= High(fScanLines)) then Result := fScanLines[Index] else Result := nil; end; procedure TtsImage.LoadFromFile(FileName: PAnsiChar); var Surface, ConvSurface: PSDL_Surface; Format: TSDL_PixelFormat; ImageSize: Integer; Image: pByte; begin Surface := IMG_Load(FileName); if Surface <> nil then try FillChar(Format, SizeOf(TSDL_PixelFormat), 0); Format.BitsPerPixel := 32; Format.BytesPerPixel := 4; Format.RMask := $000000FF; Format.GMask := $0000FF00; Format.BMask := $00FF0000; Format.AMask := $FF000000; Format.Rshift := 0; Format.Gshift := 8; Format.Bshift := 16; Format.Ashift := 24; ConvSurface := SDL_ConvertSurface(Surface, @Format, SDL_SWSURFACE); if ConvSurface <> nil then try // Set Image Size ImageSize := ConvSurface^.Width * ConvSurface^.Height * 4; GetMem(Image, ImageSize); try // Copy image Move(ConvSurface^.pixels^, Image^, ImageSize); // Set new Data SetDataPtr(Image, tsFormatRGBA8, ConvSurface^.Width, ConvSurface^.Height); except FreeMem(Image); end; finally SDL_FreeSurface(ConvSurface); end; finally SDL_FreeSurface(Surface); end; end; procedure TtsImage.Resize(NewWidth, NewHeight, X, Y: Integer); var pImage: PByte; PixSize, LineSize, ImageSize, OrgLineSize: Integer; pSource, pDest: PByte; YStart, YEnd, YPos, XStart, XEnd: Integer; begin if (NewHeight = 0) or (NewWidth = 0) then begin SetDataPtr(nil); end else begin PixSize := GetFormatSize(Format); LineSize := PixSize * NewWidth; ImageSize := LineSize * NewHeight; OrgLineSize := PixSize * Width; GetMem(pImage, ImageSize); try FillChar(pImage^, ImageSize, 0); // positions YStart := Max(0, Y); YEnd := Min(NewHeight, Y + Height); XStart := Max(0, X); XEnd := Min(NewWidth, X + Width); // copy data for YPos := YStart to YEnd -1 do begin pDest := pImage; Inc(pDest, LineSize * YPos + PixSize * XStart); pSource := fData; Inc(pSource, OrgLineSize * (YPos - Y) + PixSize * (XStart - X)); Move(pSource^, pDest^, (XEnd - XStart) * PixSize); end; // assign SetDataPtr(pImage, Format, NewWidth, NewHeight); except FreeMem(pImage); end; end; end; procedure TtsImage.SetDataPtr(aData: Pointer; aFormat: TtsFormat; aWidth, aHeight: Integer); begin fScanLinesValid := False; if fData <> nil then FreeMemory(fData); fData := aData; if fData <> nil then begin fWidth := aWidth; fHeight := aHeight; fFormat := aFormat; end else begin fWidth := 0; fHeight := 0; fFormat := tsFormatEmpty; end; end; procedure TtsImage.UpdateScanLines; var Idx, LineSize: Integer; Temp: pByte; begin LineSize := fWidth * GetFormatSize(fFormat); SetLength(fScanLines, fHeight); for Idx := 0 to fHeight -1 do begin Temp := fData; Inc(Temp, Idx * LineSize); fScanLines[Idx] := Temp; end; fScanLinesValid := True; end; { TtsFont } procedure TtsFont.AddChar(CharCode: WideChar; Char: TtsChar); var Idx1, Idx2: Integer; Chars: PtsFontCharArray; begin Idx1 := Hi(Ord(CharCode)); Chars := fChars[Idx1]; if Chars = nil then begin New(Chars); FillChar(Chars^, SizeOf(TtsFontCharArray), 0); fChars[Idx1] := Chars; end; if Chars <> nil then begin Idx2 := Lo(Ord(CharCode)); Chars^.Chars[Idx2] := Char; Chars^.CharCount := Chars^.CharCount + 1; end; end; procedure TtsFont.ClearChars; var Idx1, Idx2: Integer; Chars: PtsFontCharArray; Char: TtsChar; begin // iterate first step for Idx1 := Low(fChars) to High(fChars) do begin Chars := fChars[Idx1]; // iterate second step if Chars <> nil then begin for Idx2 := Low(Chars^.Chars) to High(Chars^.Chars) do begin Char := Chars^.Chars[Idx2]; // free char if Char <> nil then begin if Char.RendererImageReference <> nil then begin if fRenderer <> nil then fRenderer.RemoveImageReference(Char.RendererImageReference); Char.RendererImageReference.Free; end; Char.Free; end; end; // dispose fChars[Idx1] := nil; dispose(Chars); end; end; end; constructor TtsFont.Create(Renderer: TtsRenderer; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); begin inherited Create; fRenderer := Renderer; fSize := Size; fStyle := Style; fFormat := Format; fAntiAliasing := AntiAliasing; end; procedure TtsFont.DeleteChar(CharCode: WideChar); var Idx1, Idx2: Integer; Chars: PtsFontCharArray; Char: TtsChar; begin // first step Idx1 := Hi(Ord(CharCode)); Chars := fChars[Idx1]; if Chars <> nil then begin // second step Idx2 := Lo(Ord(CharCode)); Char := Chars^.Chars[Idx2]; if Char <> nil then begin Chars^.Chars[Idx2] := nil; Chars^.CharCount := Chars^.CharCount -1; // no chars so delete the subpage if Chars^.CharCount = 0 then begin fChars[Idx1] := nil; Dispose(Chars); end; if Char.RendererImageReference <> nil then begin if fRenderer <> nil then fRenderer.RemoveImageReference(Char.RendererImageReference); Char.RendererImageReference.Free; end; Char.Free; end; end; end; destructor TtsFont.Destroy; begin // Chars ClearChars; inherited; end; function TtsFont.GetChar(CharCode: WideChar): TtsChar; {$IFDEF TS_PURE_PASCAL} var Chars: PtsFontCharArray; begin // first step Chars := fChars[Hi(Ord(CharCode))]; // second step if Chars <> nil then Result := Chars^.Chars[Lo(Ord(CharCode))] else Result := nil; {$else} asm add eax, offset TtsFont.fChars // add offset of fChars to self movzx ecx, dh // extract high byte to ecx mov eax, dword ptr [eax + ecx * 4] // copy array element to eax test eax, eax // subarray is empty jz @@end movzx edx, dl // extract lower byte to ed x mov eax, dword ptr [eax + edx * 4] // copy array element to eax @@end: {$endif} end; procedure TtsFont.GetTextMetric(var Metric: TtsTextMetric); begin Metric.Ascent := Ascent; Metric.Descent := Descent; Metric.LineSkip := Ascent + Descent + ExternalLeading; Metric.LineSkip_with_LineSpace := Metric.LineSkip + LineSpacing; end; // May be fpc has problems because it's an virtual function function TtsFont.Validate(CharCode: WideChar): Boolean; //{$IFDEF TS_PURE_PASCAL} begin Result := GetChar(CharCode) <> nil; //{$else} //asm // // self is still in eax // // charcode is still is edx // call TtsFont.GetChar // test eax, eax // setnz al //{$endif} end; { TtsFontCreator } procedure TtsFontCreator.AddChar(CharCode: WideChar); var tsChar: TtsChar; GlyphOriginX, GlyphOriginY, GlyphWidth, GlyphHeight, Advance: Integer; CharImage: TtsImage; begin if fCreateChars and (Ord(CharCode) > 0) then begin tsChar := GetChar(CharCode); // Check if the char allready was added if tsChar = nil then begin // check if the Char exists in the font if GetGlyphMetrics(CharCode, GlyphOriginX, GlyphOriginY, GlyphWidth, GlyphHeight, Advance) then if (GlyphOriginX <> 0) or (GlyphOriginY <> 0) or (GlyphWidth <> 0) or (GlyphHeight <> 0) or (Advance <> 0) then begin // Getting Image of Char CharImage := TtsImage.Create; try if fRenderer.SaveImages then begin if (GlyphWidth > 0) and (GlyphHeight > 0) then begin // getting char image GetCharImage(CharCode, CharImage); end; end; if (tsStyleUnderline in Style) or (tsStyleStrikeout in Style) then begin if (CharImage.Width = 0) and (CharImage.Height = 0) then begin CharImage.CreateEmpty(tsFormatRGBA8, Advance, 1); GlyphOriginY := 1; end; end; // Create new Entry for Char tsChar := TtsChar.Create(CharCode); tsChar.GlyphOriginX := GlyphOriginX; tsChar.GlyphOriginY := GlyphOriginY; tsChar.Advance := Advance; tsChar.GlyphRect.Left := 0; tsChar.GlyphRect.Top := 0; tsChar.GlyphRect.Right := CharImage.Width; tsChar.GlyphRect.Bottom := CharImage.Height; AddChar(CharCode, tsChar); if fRenderer.SaveImages then begin try // apply underline style if tsStyleUnderline in Style then DrawLine(tsChar, CharImage, UnderlinePosition, UnderlineSize); // apply strikeout stlye if tsStyleStrikeout in Style then DrawLine(tsChar, CharImage, StrikeoutPosition, StrikeoutSize); except CharImage.FillColor(1, 0, 0, 0, TS_CHANNELS_RGB, cModesNormal); end; // PostProcessing DoPostProcess(CharImage, tsChar); // Add invisible border for resizing (at last before adding) if AddResizingBorder then begin tsChar.HasResizingBorder := True; CharImage.AddResizingBorder(tsChar); end; // Add Image to Renderer tsChar.RendererImageReference := fRenderer.AddImage(tsChar, CharImage); end; finally FreeAndNil(CharImage); end; end; end; end; end; function TtsFontCreator.AddPostProcessStep(PostProcessStep: TtsPostProcessStep): TtsPostProcessStep; begin Result := PostProcessStep; fPostProcessSteps.Add(PostProcessStep); end; procedure TtsFontCreator.ClearPostProcessSteps; var Idx: Integer; begin for Idx := fPostProcessSteps.Count -1 downto 0 do DeletePostProcessStep(Idx); fPostProcessSteps.Clear; end; constructor TtsFontCreator.Create(Renderer: TtsRenderer; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); begin inherited Create(Renderer, Size, Style, Format, AntiAliasing); fCreateChars := True; fPostProcessSteps := TList.Create; end; procedure TtsFontCreator.DeletePostProcessStep(Index: Integer); var Entry: TtsPostProcessStep; begin if (Index >= 0) and (Index < fPostProcessSteps.Count) then begin Entry := fPostProcessSteps[Index]; Entry.Free; fPostProcessSteps.Delete(Index); end; end; destructor TtsFontCreator.Destroy; begin if fPostProcessSteps <> nil then begin ClearPostProcessSteps; FreeAndNil(fPostProcessSteps); end; inherited; end; procedure TtsFontCreator.DoPostProcess(var CharImage: TtsImage; const tsChar: TtsChar); var Idx: Integer; Entry: TtsPostProcessStep; begin if not CharImage.Empty then begin for Idx := 0 to fPostProcessSteps.Count - 1 do begin Entry := fPostProcessSteps[Idx]; if Entry.IsInRange(tsChar.CharCode) then Entry.PostProcess(CharImage, tsChar); end; end; end; procedure TtsFontCreator.DrawLine(Char: TtsChar; CharImage: TtsImage; LinePosition, LineSize: Integer); var NewWidth, NewHeight, NewPosX, NewPosY, YOffset, Idx: Integer; procedure FillLine(pPix: ptsColor); var Idx: Integer; begin Idx := NewWidth; while Idx > 0 do begin pPix^.Red := $FF; pPix^.Green := $FF; pPix^.Blue := $FF; pPix^.Alpha := $FF; Inc(pPix); Dec(Idx); end; end; begin if LineSize <= 0 then Exit; LinePosition := LinePosition - LineSize; // calculate width and height NewWidth := CharImage.Width; NewPosX := 0; NewHeight := CharImage.Height; NewPosY := 0; // expand image to the full advance if Char.Advance > CharImage.Width then NewWidth := Char.Advance; // add glyph position to image width and set position if Char.GlyphOriginX > Char.GlyphRect.Left then begin NewWidth := NewWidth + Char.GlyphOriginX; NewPosX := Char.GlyphOriginX; end; if Char.GlyphOriginX < 0 then NewWidth := NewWidth - Char.GlyphOriginX; // line is under the image if LinePosition < (Char.GlyphOriginY - CharImage.Height) then NewHeight := NewHeight + (Char.GlyphOriginY - CharImage.Height - LinePosition); // line is above the image if LinePosition + LineSize > Char.GlyphOriginY then begin NewPosY := ((LinePosition + LineSize) - Char.GlyphOriginY); NewHeight := NewHeight + NewPosY; end; // resize CharImage.Resize(NewWidth, NewHeight, NewPosX, NewPosY); // draw lines YOffset := (Char.GlyphOriginY + NewPosY) - LinePosition; for Idx := 1 to LineSize do FillLine(CharImage.ScanLine[YOffset - Idx]); // move glyph rect Char.GlyphRect.Left := Char.GlyphRect.Left + NewPosX; Char.GlyphRect.Right := Char.GlyphRect.Right + NewPosX; Char.GlyphRect.Top := Char.GlyphRect.Top + NewPosY; Char.GlyphRect.Bottom := Char.GlyphRect.Bottom + NewPosY; end; function TtsFontCreator.GetPostProcessStep(Index: Integer): TtsPostProcessStep; begin if (Index >= 0) and (Index < fPostProcessSteps.Count) then Result := TtsPostProcessStep(fPostProcessSteps[Index]) else Result := nil; end; function TtsFontCreator.GetPostProcessStepCount: Integer; begin Result := fPostProcessSteps.Count; end; function TtsFontCreator.Validate(CharCode: WideChar): Boolean; begin Result := Inherited Validate(CharCode); // if char wasnt found then create it. if not Result then begin AddChar(CharCode); // and test for creation Result := Inherited Validate(CharCode); end; end; { TtsPostProcessStep } procedure TtsPostProcessStep.AddUsageChars(Usage: TtsFontProcessStepUsage; Chars: pWideChar); begin if Chars <> nil then while Chars^ <> #0 do begin AddUsageRange(Usage, Chars^, Chars^); Inc(Chars); end; end; procedure TtsPostProcessStep.AddUsageRange(Usage: TtsFontProcessStepUsage; StartChar, EndChar: WideChar); var pItem: PtsPostProcessStepRange; begin New(pItem); pItem^.StartChar := StartChar; pItem^.EndChar := EndChar; case Usage of tsUInclude: fIncludeCharRange.Add(pItem); tsUExclude: fExcludeCharRange.Add(pItem); end; end; procedure TtsPostProcessStep.ClearExcludeRange; begin ClearList(fExcludeCharRange); end; procedure TtsPostProcessStep.ClearIncludeRange; begin ClearList(fIncludeCharRange); end; procedure TtsPostProcessStep.ClearList(List: TList); var Idx: Integer; pItem: PtsPostProcessStepRange; begin for Idx := 0 to List.Count - 1 do begin pItem := List[Idx]; Dispose(pItem); end; List.Clear; end; constructor TtsPostProcessStep.Create; begin inherited Create; fIncludeCharRange := TList.Create; fExcludeCharRange := TList.Create; end; destructor TtsPostProcessStep.Destroy; begin ClearIncludeRange; ClearExcludeRange; fIncludeCharRange.Free; fExcludeCharRange.Free; inherited; end; function TtsPostProcessStep.IsInRange(CharCode: WideChar): Boolean; var Idx: Integer; pItem: PtsPostProcessStepRange; begin // Look in include range if fIncludeCharRange.Count <> 0 then begin Result := False; for Idx := 0 to fIncludeCharRange.Count - 1 do begin pItem := fIncludeCharRange[Idx]; if (CharCode >= pItem^.StartChar) and (CharCode <= pItem^.EndChar) then begin Result := True; Break; end; end; end else Result := True; // Look in exclude range but only if its included if Result then begin for Idx := 0 to fExcludeCharRange.Count - 1 do begin pItem := fExcludeCharRange[Idx]; if (CharCode >= pItem^.StartChar) and (CharCode <= pItem^.EndChar) then begin Result := False; Break; end; end; end; end; { TtsFontCreatorSDL } constructor TtsFontCreatorSDL.Create(Renderer: TtsRenderer; const Filename: AnsiString; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); var TempStyle: Integer; begin inherited Create(Renderer, Size, Style, Format, AntiAliasing); // Init SDL_ttf if (TTF_WasInit = 0) then if (TTF_Init < 0) then raise Exception.Create('TtsFontCreator.Create: TTF_Init error'); // Create FFT_Font fSDLFont := TTF_OpenFont(pAnsiChar(Filename), Size); // Getting style - SDL_ttf dosn't support it. so we only have normal fFontFileStyle := TS_STYLE_NORMAL; // getting props Ascent := TTF_FontAscent(fSDLFont); Descent := -TTF_FontDescent(fSDLFont); ExternalLeading := TTF_FontLineSkip(fSDLFont) - (Ascent + Descent); // SDL_ttf dosn't support it so we must calculate it by our self UnderlinePosition := - round(Ascent / 8); if UnderlinePosition > -1 then UnderlinePosition := -1; if tsStyleBold in Style then UnderlineSize := round(Ascent / 8) else UnderlineSize := round(Ascent / 13); if UnderlineSize < 1 then UnderlineSize := 1; StrikeoutPosition := round(Ascent / 3.5); if tsStyleBold in Style then StrikeoutSize := round(Ascent / 14) else StrikeoutSize := round(Ascent / 19); if StrikeoutSize < 1 then StrikeoutSize := 1; FixedWidth := TTF_FontFaceIsFixedWidth(fSDLFont) > 0; Copyright := ''; FaceName := TTF_FontFaceFamilyName(fSDLFont); StyleName := TTF_FontFaceStyleName(fSDLFont); FullName := FaceName + #32 + StyleName; // Set style TempStyle := 0; if tsStyleBold in Style then TempStyle := TempStyle or TTF_STYLE_BOLD; if tsStyleItalic in Style then TempStyle := TempStyle or TTF_STYLE_ITALIC; // if tsStyleUnderline in Style then // TempStyle := TempStyle or TTF_STYLE_UNDERLINE; TTF_SetFontStyle(fSDLFont, TempStyle); end; destructor TtsFontCreatorSDL.Destroy; begin // Destroy Font TTF_CloseFont(fSDLFont); fSDLFont := nil; inherited; end; procedure TtsFontCreatorSDL.GetCharImage(CharCode: WideChar; const CharImage: TtsImage); const WHITE: TSDL_Color = (r: $FF; g: $FF; b: $FF; unused: 0); BLACK: TSDL_Color = (r: $00; g: $00; b: $00; unused: 0); var CharSurface: PSDL_Surface; X, Y, TempWidth: Integer; pSource: pByte; pDest: PtsColor; function GetPaletteEntry(Index: Byte): Byte; begin Result := 0; with CharSurface^.format^ do begin if palette <> nil then if (palette^.ncolors > 0) and (Index < palette^.ncolors) then Result := palette^.colors[Index].r end; end; begin //CharCode: Needs to use an widestring because of #0 endchar case AntiAliasing of tsAANone: CharSurface := TTF_RenderGlyph_Solid(fSDLFont, Ord(CharCode), WHITE); tsAANormal: CharSurface := TTF_RenderGlyph_Shaded(fSDLFont, Ord(CharCode), WHITE, BLACK); end; if CharSurface <> nil then try CharImage.CreateEmpty(fFormat, CharSurface^.Width, CharSurface^.Height); try TempWidth := CharSurface^.Width; if TempWidth mod 4 > 0 then TempWidth := (TempWidth div 4 + 1) * 4; for Y := 0 to CharSurface^.Height - 1 do begin pDest := CharImage.ScanLine[Y]; pSource := CharSurface^.Pixels; Inc(pSource, Y * TempWidth); for X := 0 to CharSurface^.Width - 1 do begin pDest^.Red := $FF; pDest^.Green := $FF; pDest^.Blue := $FF; pDest^.Alpha := GetPaletteEntry(pSource^); Inc(pSource); Inc(pDest); end; end; except CharImage.Free; end; finally SDL_FreeSurface(CharSurface); end; end; function TtsFontCreatorSDL.GetGlyphMetrics(CharCode: WideChar; var GlyphOriginX, GlyphOriginY, GlyphWidth, GlyphHeight, Advance: Integer): Boolean; var MinX, MaxX, MinY, MaxY: Integer; begin if fSDLFont <> nil then begin Result := TTF_GlyphMetrics(fSDLFont, Ord(CharCode), MinX, MaxX, MinY, MaxY, Advance) = 0; GlyphWidth := MaxX - MinX; GlyphHeight := MaxY - MinY; GlyphOriginX := MinX; GlyphOriginY := GlyphHeight + MinY; end else Result := False; end; { TtsFontCreatorGDIFontFace } constructor TtsFontCreatorGDIFontFace.Create(Renderer: TtsRenderer; const Fontname: AnsiString; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); var Idx: Integer; LogFont: TLogFontA; DC: HDC; TableName: Cardinal; Buffer: Pointer; BufferSize: Cardinal; Lang: AnsiString; TextMetric: TTextMetricW; OutTextMetric: TOutlineTextmetricW; begin inherited Create (Renderer, Size, Style, Format, AntiAliasing); // setting up matrix FillChar(fMat2, SizeOf(TMat2), $00); fMat2.eM11.Value := 1; fMat2.eM22.Value := 1; fFontname := Fontname; // Creating Font FillChar(LogFont, SizeOf(LogFont), 0); // name fFontname := Fontname; for Idx := 1 to Min(Length(Fontname), Length(LogFont.lfFaceName)) do LogFont.lfFaceName[Idx -1] := Fontname[Idx]; // char set LogFont.lfCharSet := DEFAULT_CHARSET; // size // fPointSize := PointSize; LogFont.lfHeight := -Size; //-MulDiv(PointSize, GetDeviceCaps(Temp.Canvas.Handle, LOGPIXELSY), 72); // style if tsStyleBold in Style then LogFont.lfWeight := FW_BOLD else LogFont.lfWeight := FW_NORMAL; if tsStyleItalic in Style then LogFont.lfItalic := 1; if tsStyleUnderline in Style then LogFont.lfUnderline := 1; // smooth case AntiAliasing of tsAANone: LogFont.lfQuality := NONANTIALIASED_QUALITY; tsAANormal: LogFont.lfQuality := ANTIALIASED_QUALITY; // tsSmoothSmooth: // begin // if Smooth = tsSmoothSmooth then // fMat2.eM11.Value := 3; // end; end; // create font fFontHandle := CreateFontIndirectA(LogFont); // Getting informations about font DC := CreateCompatibleDC(0); try SelectObject(DC, fFontHandle); // find strings in text TableName := MakeTTTableName('n', 'a', 'm', 'e'); BufferSize := GetFontData(DC, TableName, 0, nil, 0); if BufferSize <> GDI_ERROR then begin GetMem(Buffer, BufferSize); try if GetFontData(DC, TableName, 0, Buffer, BufferSize) <> GDI_ERROR then begin SetLength(Lang, 4); GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @Lang[1], 4); GetTTString(Buffer, BufferSize, NAME_ID_COPYRIGHT, StrToInt('$' + String(Lang)), fCopyright); GetTTString(Buffer, BufferSize, NAME_ID_FACE_NAME, StrToInt('$' + String(Lang)), fFaceName); GetTTString(Buffer, BufferSize, NAME_ID_STYLE_NAME, StrToInt('$' + String(Lang)), fStyleName); GetTTString(Buffer, BufferSize, NAME_ID_FULL_NAME, StrToInt('$' + String(Lang)), fFullName); end; finally FreeMem(Buffer); end; end; // Text Metric GetTextMetricsW(DC, TextMetric); Ascent := TextMetric.tmAscent; Descent := TextMetric.tmDescent; ExternalLeading := TextMetric.tmExternalLeading; DefaultChar := TextMetric.tmDefaultChar; // inverse logic of the bit. clear then fixed pitch FixedWidth := TextMetric.tmPitchAndFamily and TMPF_FIXED_PITCH = 0; // style FontFileStyle := TS_STYLE_NORMAL; if TextMetric.tmWeight > 400 then FontFileStyle := FontFileStyle or TS_STYLE_BOLD; if TextMetric.tmItalic > 0 then FontFileStyle := FontFileStyle or TS_STYLE_ITALIC; if TextMetric.tmUnderlined > 0 then FontFileStyle := FontFileStyle or TS_STYLE_UNDERLINE; if TextMetric.tmStruckOut > 0 then FontFileStyle := FontFileStyle or TS_STYLE_STRIKEOUT; // Outline Text Metric GetOutlineTextMetricsW(DC, SizeOf(OutTextMetric), OutTextMetric); UnderlinePosition := OutTextMetric.otmsUnderscorePosition; UnderlineSize := OutTextMetric.otmsUnderscoreSize; if UnderlineSize < 1 then UnderlineSize := 1; StrikeoutPosition := OutTextMetric.otmsStrikeoutPosition; StrikeoutSize := OutTextMetric.otmsStrikeoutSize; if StrikeoutSize < 1 then StrikeoutSize := 1; finally DeleteDC(DC); end; end; destructor TtsFontCreatorGDIFontFace.Destroy; begin DeleteObject(fFontHandle); inherited; end; procedure TtsFontCreatorGDIFontFace.GetCharImage(CharCode: WideChar; const CharImage: TtsImage); var DC: HDC; begin DC := CreateCompatibleDC(0); try SelectObject(DC, fFontHandle); case AntiAliasing of tsAANone: GetCharImageNone(DC, CharCode, CharImage); tsAANormal: GetCharImageAntialiased(DC, CharCode, CharImage); end; finally DeleteDC(DC); end; end; procedure TtsFontCreatorGDIFontFace.GetCharImageAntialiased(DC: HDC; CharCode: WideChar; const CharImage: TtsImage); var Metric: TGlyphMetrics; pBuffer: Pointer; Size, OutlineResult: Cardinal; GlyphIndex: Integer; X, Y, Height, Width, Spacer: Integer; pDest: PtsColor; pSrc: pByte; procedure CopyPixel; var Idx: Integer; Temp, Count: Cardinal; begin Count := Min(X, fMat2.eM11.Value); Temp := 0; for Idx := 0 to Count -1 do begin Temp := Temp + pSrc^; Inc(pSrc); end; Dec(X, Count); pDest^.Red := $FF; pDest^.Green := $FF; pDest^.Blue := $FF; pDest^.Alpha := $FF * Temp div ($40 * Cardinal(fMat2.eM11.Value)); Inc(pDest); end; begin FillChar(Metric, SizeOf(TGlyphMetrics), $00); // Translate Glyphindex GlyphIndex := GetGlyphIndex(CharCode); // size // if GlyphIndex <> 0 then Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @fMat2); // else // Size := GetGlyphOutlineA(DC, Ord(fDefaultChar), GGO_GRAY8_BITMAP, Metric, 0, nil, fMat2); if (Size <> GDI_ERROR) and (Size <> 0) then begin GetMem(pBuffer, Size); try // glyphdata // if GlyphIndex <> 0 then OutlineResult := GetGlyphOutlineA(DC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @Metric, Size, pBuffer, @fMat2); // else // OutlineResult := GetGlyphOutlineA(DC, Ord(fDefaultChar), GGO_GRAY8_BITMAP, Metric, Size, pBuffer, fMat2); if OutlineResult <> GDI_ERROR then begin // Image size Height := Metric.gmBlackBoxY; Width := Integer(Metric.gmBlackBoxX) div fMat2.eM11.Value; if (Integer(Metric.gmBlackBoxX) mod fMat2.eM11.Value) <> 0 then Width := Width + fMat2.eM11.Value - (Integer(Metric.gmBlackBoxX) mod fMat2.eM11.Value); // spacer if (Metric.gmBlackBoxX mod 4) <> 0 then Spacer := 4 - (Metric.gmBlackBoxX mod 4) else Spacer := 0; // copy image if (Height > 0) and (Width > 0) then begin CharImage.CreateEmpty(fFormat, Width, Height); pSrc := pBuffer; for Y := 0 to Height -1 do begin pDest := CharImage.ScanLine[Y]; X := Metric.gmBlackBoxX; while X > 0 do CopyPixel; if Spacer <> 0 then Inc(pSrc, Spacer); end; end; end; finally FreeMem(pBuffer); end; end; end; procedure TtsFontCreatorGDIFontFace.GetCharImageNone(DC: HDC; CharCode: WideChar; const CharImage: TtsImage); var Metric: TGlyphMetrics; pBuffer: Pointer; Size, OutlineResult: Cardinal; GlyphIndex: Integer; X, Y, Height, Width, SourceX, SourceWidth: Integer; pDest: PtsColor; pSrc: pByte; procedure ExpandByte; var Idx, Count, SourceCount: Integer; begin SourceCount := Min(8, SourceX); Count := Min(8, X); for Idx := 1 to Count do begin pDest^.Red := $FF; pDest^.Green := $FF; pDest^.Blue := $FF; if (pSrc^ and $80) > 0 then pDest^.Alpha := $FF else pDest^.Alpha := $00; pSrc^ := (pSrc^ and not $80) shl 1; Inc(pDest); end; Dec(SourceX, SourceCount); Dec(X, Count); end; begin // fMat2.eM11.Value must be 1 Assert(fMat2.eM11.Value = 1); FillChar(Metric, SizeOf(TGlyphMetrics), $00); // Translate Glyphindex GlyphIndex := GetGlyphIndex(CharCode); // size // if GlyphIndex <> 0 then Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @fMat2); // else // Size := GetGlyphOutlineA(DC, Ord(fDefaultChar), GGO_BITMAP, Metric, 0, nil, fMat2); if (Size <> GDI_ERROR) and (Size <> 0) then begin GetMem(pBuffer, Size); try // glyphdata // if GlyphIndex <> 0 then OutlineResult := GetGlyphOutlineA(DC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @Metric, Size, pBuffer, @fMat2); // else // OutlineResult := GetGlyphOutlineA(DC, Ord(fDefaultChar), GGO_BITMAP, Metric, Size, pBuffer, fMat2); if OutlineResult <> GDI_ERROR then begin SourceWidth := (Size div Metric.gmBlackBoxY) * 8; Width := Metric.gmBlackBoxX; Height := Metric.gmBlackBoxY; // copy image if (Height > 0) and (Width > 0) then begin CharImage.CreateEmpty(tsFormatRGBA8, Width, Height); pSrc := pBuffer; for Y := 0 to Height -1 do begin pDest := CharImage.ScanLine[Y]; // copy data SourceX := SourceWidth; X := Width; while SourceX > 0 do begin ExpandByte; Inc(pSrc); end; end; end; end; finally FreeMem(pBuffer); end; end; end; function TtsFontCreatorGDIFontFace.GetGlyphIndex(CharCode: WideChar): Integer; var // ReadRawData: Boolean; DC: HDC; GCPRes: TGCPResultsW; begin Result := 0; // ReadRawData := True; DC := CreateCompatibleDC(0); try SelectObject(DC, fFontHandle); // windows nt if Addr(GetCharacterPlacementW) <> nil then begin FillChar(GCPRes, SizeOf(GCPRes), 0); GetMem(GCPRes.lpGlyphs, SizeOf(Cardinal)); try GCPRes.lStructSize := SizeOf(GCPRes); GCPRes.lpGlyphs^ := 0; GCPRes.nGlyphs := 1; if GetCharacterPlacementW(DC, @CharCode, 1, GCP_MAXEXTENT, @GCPRes, 0) <> GDI_ERROR then begin if (GCPRes.nGlyphs = 1) and (GCPRes.lpGlyphs <> nil) then begin Result := GCPRes.lpGlyphs^; // ReadRawData := False; end; end; finally FreeMem(GCPRes.lpGlyphs); end; end; // windows 9x workaround // ReadRawData := True; // if ReadRawData then begin // if GetTTUnicodeCharCount(DC) > 0 then // Result := GetTTUnicodeGlyphIndex(DC, Ord(CharCode)); // end; finally DeleteDC(DC); end; end; function TtsFontCreatorGDIFontFace.GetGlyphMetrics(CharCode: WideChar; var GlyphOriginX, GlyphOriginY, GlyphWidth, GlyphHeight, Advance: Integer): Boolean; var DC: HDC; Metric: TGlyphMetrics; Size: Cardinal; GlyphIndex: Integer; begin Result := False; // Set values to 0 GlyphOriginX := 0; GlyphOriginY := 0; GlyphWidth := 0; GlyphHeight := 0; Advance := 0; // Translate Glyphindex GlyphIndex := GetGlyphIndex(CharCode); DC := CreateCompatibleDC(0); try SelectObject(DC, fFontHandle); // get value of resulting bitmaps case AntiAliasing of tsAANone: begin // if GlyphIndex <> 0 then Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @fMat2); // else // Size := GetGlyphOutlineA(DC, Ord(fDefaultChar), GGO_BITMAP, Metric, 0, nil, fMat2); end; tsAANormal: begin // if GlyphIndex <> 0 then Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @fMat2); // else // Size := GetGlyphOutlineA(DC, Ord(fDefaultChar), GGO_GRAY8_BITMAP, Metric, 0, nil, fMat2); end; else Size := 0; end; // dosn't work so get metric value if (Size = GDI_ERROR) or (Size = 0) then begin // if GlyphIndex <> 0 then Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_METRICS or GGO_GLYPH_INDEX, @Metric, 0, nil, @fMat2); // else // Size := GetGlyphOutlineA(DC, Ord(fDefaultChar), GGO_METRICS, Metric, 0, nil, fMat2); end; // we have values? if (Size <> GDI_ERROR) and (Size > 0) then begin GlyphOriginX := Round(Metric.gmptGlyphOrigin.X / fMat2.eM11.value); GlyphOriginY := Metric.gmptGlyphOrigin.Y; GlyphWidth := Round(Metric.gmBlackBoxX / fMat2.eM11.value); GlyphHeight := Metric.gmBlackBoxY; Advance := Round(Metric.gmCellIncX / fMat2.eM11.value); Result := True; end; finally DeleteDC(DC) end; end; { TtsFontCreatorGDIFile } constructor TtsFontCreatorGDIFile.Create(Renderer: TtsRenderer; const Filename: AnsiString; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); var FaceName: AnsiString; begin // filename fFileName := StrNew(pAnsiChar(Filename)); fFontRegistred := false; FaceName := ''; if GetFaceName(fFilename, FaceName) then fFontRegistred := RegisterFont(fFilename, False); // inherited inherited Create(Renderer, FaceName, Size, Style, Format, AntiAliasing); end; destructor TtsFontCreatorGDIFile.Destroy; begin inherited; // unregister font if fFontRegistred then UnRegisterFont(fFilename, False); StrDispose(fFileName); end; function TtsFontCreatorGDIFile.GetFaceName(Filename: PAnsiChar; var Face: AnsiString): boolean; var Lang: AnsiString; begin SetLength(Lang, 4); GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @Lang[1], 4); Face := GetTTFontFullNameFromFile(Filename, StrToInt('$' + String(Lang))); Result := Face <> ''; end; function TtsFontCreatorGDIFile.RegisterFont(Filename: pAnsiChar; RegisterPublic: Boolean): boolean; var Flags: Cardinal; begin Result := False; // Flags if not RegisterPublic then Flags := FR_PRIVATE or FR_NOT_ENUM else Flags := 0; // AddFontResource if Addr(AddFontResourceExA) <> nil then Result := AddFontResourceExA(FileName, Flags, nil) > 0 else if Addr(AddFontResourceA) <> nil then Result := AddFontResourceA(FileName) > 0; end; function TtsFontCreatorGDIFile.UnRegisterFont(Filename: pAnsiChar; RegisterPublic: Boolean): boolean; var Flags: Cardinal; begin Result := False; // Flags if not RegisterPublic then Flags := FR_PRIVATE or FR_NOT_ENUM else Flags := 0; // RemoveFontResource if Addr(RemoveFontResourceExA) <> nil then Result := RemoveFontResourceExA(FileName, Flags, nil) else if Addr(RemoveFontResourceA) <> nil then Result := RemoveFontResourceA(FileName); end; { TtsFontCreatorGDIFile } constructor TtsFontCreatorGDIStream.Create(Renderer: TtsRenderer; const Source: TStream; Size: Integer; Style: TtsFontStyles; Format: TtsFormat; AntiAliasing: TtsAntiAliasing); var FaceName: AnsiString; begin fFontRegistred := false; FaceName := ''; if GetFaceName(Source, FaceName) then fFontRegistred := RegisterFont(Source); // inherited inherited Create(Renderer, FaceName, Size, Style, Format, AntiAliasing); end; destructor TtsFontCreatorGDIStream.Destroy; begin inherited; // unregister font if fFontRegistred then UnRegisterFont(); end; function TtsFontCreatorGDIStream.GetFaceName(Stream: TStream; var Face: AnsiString): boolean; var Lang: AnsiString; begin SetLength(Lang, 4); GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @Lang[1], 4); Face := GetTTFontFullNameFromStream(Stream, StrToInt('$' + String(Lang))); Result := Face <> ''; end; function TtsFontCreatorGDIStream.RegisterFont(Data: TStream): boolean; var ms: TMemoryStream; cnt: DWORD; begin Result := False; fHandle := 0; ms:= TMemoryStream.Create; try ms.CopyFrom(Data, 0); if Addr(AddFontMemResourceEx)<>nil then fHandle:= AddFontMemResourceEx(ms.Memory, ms.Size, nil, @cnt); Result:= fHandle > 0; finally ms.Free; end; end; function TtsFontCreatorGDIStream.UnRegisterFont(): boolean; begin Result := RemoveFontMemResourceEx(fHandle); end; { TtsRenderer } procedure TtsRenderer.BeginBlock(Left, Top, Width, Height: Integer; Flags: tsBitmask); begin fisBlock := True; fBlockLeft := Left; fBlockTop := Top; fBlockWidth := Width; fBlockHeight := Height; fFlags := Flags; fWordWrap := fFlags and TS_BLOCKFLAG_WORD_WRAP = TS_BLOCKFLAG_WORD_WRAP; // fSingleLine := fFlags and TS_BLOCKFLAG_SINGLE_LINE = TS_BLOCKFLAG_SINGLE_LINE; fLineTop := Top + tsGetParameteri(TS_BLOCK_OFFSET_Y); fTextOffsetY := 0; fTextOffsetX := 0; with fLinesTemp do begin New(Lines); with Lines^ do begin NextLine := nil; LineItemFirst := nil; LineItemLast := nil; LineLength := 0; LineAutoBreak := False; end; Empty := True; end; fLinesFirst := nil; fLinesLast := nil; // if font is active add to list if fActiveFont <> nil then FontActivate(fActiveFontID); end; function TtsRenderer.CalculateLinesHeight(pLinesItem: PtsLinesItem): Integer; var pLine: PtsLineItem; Metric: TtsTextMetric; begin Result := 0; while pLinesItem <> nil do begin pLine := pLinesItem^.LineItemFirst; GetLineMetric(pLine, Metric); Result := Result + Metric.LineSkip_with_LineSpace; pLinesItem := pLinesItem^.NextLine; end; // remove last linespace from the lines Result := Result - (Metric.LineSkip_with_LineSpace - Metric.LineSkip); end; procedure TtsRenderer.CalculateWordLength(Font: TtsFont; pWord: PtsLineItem); var pTempWord: PWideChar; Char: TtsChar; CharSpacing: tsInt; begin if pWord^.ItemType in [TS_BLOCK_WORD, TS_BLOCK_SPACE] then begin CharSpacing := fLastActiveFont.CharSpacing; pTempWord := pWord^.Word; pWord^.WordLength := 0; while pTempWord^ <> #0 do begin // normal char if Font.Validate(pTempWord^) then Char := Font.GetChar(pTempWord^) else // default char if Font.Validate(Font.DefaultChar) then Char := Font.GetChar(Font.DefaultChar) else Char := nil; if Char <> nil then begin pWord^.WordLength := pWord^.WordLength + Char.Advance + CharSpacing; end; Inc(pTempWord); end; end; end; procedure TtsRenderer.Color(Red, Green, Blue, Alpha: Single); var LineItem: PtsLineItem; begin if isBlock then begin New(LineItem); LineItem^.NextItem := nil; LineItem^.PrevItem := nil; LineItem^.ItemType := TS_BLOCK_COLOR; LineItem^.Red := Red; LineItem^.Green := Green; LineItem^.Blue := Blue; LineItem^.Alpha := Alpha; PushLineItem(LineItem); end else begin DrawSetColor(Red, Green, Blue, Alpha); end; end; constructor TtsRenderer.Create(Context: TtsContext); begin inherited Create; fContext := Context; fSaveImages := True; end; destructor TtsRenderer.Destroy; begin if isBlock then EndBlock; inherited; end; procedure TtsRenderer.DrawLine(pLine: PtsLineItem; LineLength: Integer; LineBreak: Boolean); var pText: PWideChar; Char: TtsChar; Metric: TtsTextMetric; TempLeft, Temp: Integer; DrawLeft, SpaceTemp: Single; DrawAscent, LineSkip: Integer; DrawText: Boolean; BlockSpaceCount: Integer; BlockSpaceWidth: Single; function CountSpaces(pLine: PtsLineItem): Integer; var pText: PWideChar; begin Result := 0; while pLine <> nil do begin case pLine^.ItemType of TS_BLOCK_SPACE: begin pText := pLine^.Word; // Enumerate Text while pText^ <> #0 do begin Inc(Result); Inc(pText); end; end; end; pLine := pLine^.NextItem; end; end; begin if fFlags and TS_BLOCKFLAG_CALC_SIZE > 0 then Exit; BlockSpaceWidth := 0; DrawLeft := 0; TempLeft := 0; GetLineMetric(pLine, Metric); // set drawposition to new baseline DrawAscent := fLineTop + fTextOffsetY + Metric.Ascent; // increment linetop with height of line LineSkip := Metric.LineSkip; fLineTop := fLineTop + LineSkip; // clipping DrawText := True; if fisBlock then begin if not (fFlags and TS_BLOCKFLAG_NO_CLIP = TS_BLOCKFLAG_NO_CLIP) then begin case tsGetParameteri(TS_CLIP) of TS_CLIP_COMPLETE: begin if (fLineTop + fTextOffsetY < fBlockTop) or ((fLineTop + fTextOffsetY - LineSkip) > (fBlockTop + fBlockHeight)) then DrawText := False; end; TS_CLIP_BORDER: begin if ((fLineTop + fTextOffsetY - LineSkip) < fBlockTop) or (fLineTop + fTextOffsetY > (fBlockTop + fBlockHeight)) then DrawText := False; end; end; end; end; // TextBlock text alignment if isBlock then begin case tsGetParameteri(TS_ALIGN) of TS_ALIGN_CENTER: begin TempLeft := (fBlockWidth div 2) - (LineLength div 2); end; TS_ALIGN_RIGHT: begin TempLeft := fBlockWidth - LineLength; end; TS_ALIGN_BLOCK: begin if LineBreak then begin BlockSpaceCount := CountSpaces(pLine); if BlockSpaceCount > 0 then BlockSpaceWidth := (fBlockWidth - LineLength) / BlockSpaceCount; end; end; end; DrawSetPosition(fBlockLeft + TempLeft, DrawAscent); end else // Normal text alignment begin case tsGetParameteri(TS_ALIGN) of TS_ALIGN_CENTER: begin TempLeft := - (LineLength div 2); end; TS_ALIGN_RIGHT: begin TempLeft := - LineLength; end; end; DrawSetPositionRelative(TempLeft, 0); end; DrawSetPositionRelative(tsGetParameteri(TS_BLOCK_OFFSET_X), 0); // Enumerate LineItems while pLine <> nil do begin case pLine^.ItemType of TS_BLOCK_FONT: begin fActiveFont := pLine^.Font; fActiveFontID := pLine^.FontID; end; TS_BLOCK_COLOR: begin DrawSetColor(pLine^.Red, pLine^.Green, pLine^.Blue, pLine^.Alpha); end; TS_BLOCK_WORD: begin if DrawText then begin if fActiveFont <> nil then begin pText := pLine^.Word; // Enumerate Text while pText^ <> #0 do begin // normal char if fActiveFont.Validate(pText^) then Char := fActiveFont.GetChar(pText^) else // default char if fActiveFont.Validate(fActiveFont.DefaultChar) then Char := fActiveFont.GetChar(fActiveFont.DefaultChar) else Char := nil; if Char <> nil then begin DrawSetPositionRelative(Char.GlyphOriginX, -fActiveFont.fBaselineOffset); DrawChar(fActiveFont, Char); DrawSetPositionRelative(Char.Advance - Char.GlyphOriginX + fActiveFont.CharSpacing, fActiveFont.fBaselineOffset); end; Inc(pText); end; end; end; end; TS_BLOCK_SPACE: begin if DrawText then begin if fActiveFont <> nil then begin pText := pLine^.Word; // Enumerate Text while pText^ <> #0 do begin // normal char if fActiveFont.Validate(pText^) then Char := fActiveFont.GetChar(pText^) else // default char if fActiveFont.Validate(fActiveFont.DefaultChar) then Char := fActiveFont.GetChar(fActiveFont.DefaultChar) else Char := nil; if Char <> nil then begin // We have lines so we must repeat the "empty" space if (tsStyleUnderline in fActiveFont.Style) or (tsStyleStrikeout in fActiveFont.Style) then begin // width we need to draw SpaceTemp := Char.Advance + fActiveFont.CharSpacing + BlockSpaceWidth; // set the position to the normal end. Following we decrease // these value by the width of the drawn chars. So we get the // difference of the last drawn space. DrawLeft := DrawLeft + Char.Advance + fActiveFont.CharSpacing + BlockSpaceWidth; Temp := Char.Advance - Char.GlyphOriginX + fActiveFont.CharSpacing; while SpaceTemp > 0 do begin // draw the char DrawSetPositionRelative(Char.GlyphOriginX, 0); DrawChar(fActiveFont, Char); // set the position inside the drawer DrawSetPositionRelative(Temp, 0); // decrease need to draw width SpaceTemp := SpaceTemp - Temp; // decrease the drawwidth with the width of the char. DrawLeft := DrawLeft - Temp; end; end else // no lines so only set the position DrawLeft := DrawLeft + Char.Advance + fActiveFont.CharSpacing + BlockSpaceWidth; end; Inc(pText); end; DrawSetPositionRelative(Round(DrawLeft), 0); DrawLeft := DrawLeft - Round(DrawLeft); end; end; end; TS_BLOCK_LINEBREAK: begin end; // TS_BLOCK_TAB: begin // case tsGetParameteri(TS_TAB) of // TS_TAB_FIXED: // begin // Temp := tsGetParameteri(TS_TAB_FIXED_WIDTH); // //// if (DrawLeft - fBlockLeft) mod Temp > 0 then // DrawLeft := (Round(DrawLeft) mod Temp) + Temp; // end; // TS_TAB_ABSOLUTE: // begin // // end; // end; // end; end; pLine := pLine^.NextItem; end; end; procedure TtsRenderer.DrawLines(pLinesItem: PtsLinesItem); begin if fFlags and TS_BLOCKFLAG_CALC_SIZE = 0 then begin while pLinesItem <> nil do begin DrawLine(pLinesItem^.LineItemFirst, pLinesItem^.LineLength, pLinesItem^.LineAutoBreak); pLinesItem := pLinesItem^.NextLine; end; end; end; procedure TtsRenderer.EndBlock; var LinesHeight: Integer; VerticalAlign: tsEnum; begin // if temp line exist then push them with fLinesTemp do begin if Lines <> nil then if Lines^.LineItemFirst <> nil then PushTempLines; FreeLines(Lines); end; // if vertical align isn't top VerticalAlign := tsGetParameteri(TS_VALIGN); if (VerticalAlign = TS_VALIGN_CENTER) or (VerticalAlign = TS_VALIGN_BOTTOM) then begin // calculating height LinesHeight := CalculateLinesHeight(fLinesFirst); // setting offset case VerticalAlign of TS_VALIGN_CENTER: fTextOffsetY := fTextOffsetY + (fBlockHeight div 2 - LinesHeight div 2); TS_VALIGN_BOTTOM: fTextOffsetY := fTextOffsetY + (fBlockHeight - LinesHeight); end; // drawing lines DrawLines(fLinesFirst); end; // Free all lines FreeLines(fLinesFirst); fLinesLast := nil; fisBlock := False; end; procedure TtsRenderer.FontActivate(FontID: Cardinal); var pLine: PtsLineItem; begin if FontID <> 0 then begin fLastActiveFont := fContext.FontGet(FontID); fLastActiveFontID := FontID; end else fLastActiveFont := nil; // if in block then add blockitem if isBlock then begin New(pLine); pLine^.NextItem := nil; pLine^.PrevItem := nil; pLine^.ItemType := TS_BLOCK_FONT; pLine^.FontID := FontID; pLine^.Font := fLastActiveFont; if pLine^.Font <> nil then PushLineItem(pLine) else Dispose(pLine); end else // activate font begin fActiveFontID := FontID; fActiveFont := fLastActiveFont; end; end; procedure TtsRenderer.FreeLines(var pLinesItem: PtsLinesItem); var pTemp: PtsLinesItem; begin while pLinesItem <> nil do begin pTemp := pLinesItem; FreeLineItems(pLinesItem^.LineItemFirst); pLinesItem^.LineItemLast := pLinesItem^.LineItemFirst; pLinesItem := pLinesItem^.NextLine; Dispose(pTemp); end; end; procedure TtsRenderer.FreeLineItems(var pLine: PtsLineItem); var pTemp: PtsLineItem; begin while pLine <> nil do begin pTemp := pLine; case pLine^.ItemType of TS_BLOCK_WORD, TS_BLOCK_SPACE: tsStrDispose(pLine^.Word); end; pLine := pLine^.NextItem; Dispose(pTemp); end; end; function TtsRenderer.GetActiveFont: TtsFont; begin if fisBlock then Result := fLastActiveFont else Result := fActiveFont; end; function TtsRenderer.GetActiveFontID: Cardinal; begin if fisBlock then Result := fLastActiveFontID else Result := fActiveFontID; end; procedure TtsRenderer.GetLineMetric(pLine: PtsLineItem; var Metric: TtsTextMetric); var Font: TtsFont; Temp: TtsTextMetric; begin // Defaults Metric.Ascent := 0; Metric.Descent := 0; Metric.LineSkip := 0; Metric.LineSkip_with_LineSpace := 0; // calculating lines Font := fActiveFont; while pLine <> nil do begin case pLine^.ItemType of TS_BLOCK_FONT: begin Font := pLine^.Font; end; TS_BLOCK_WORD, TS_BLOCK_SPACE, TS_BLOCK_LINEBREAK: begin if Font <> nil then begin Font.GetTextMetric(Temp); if Temp.Ascent > Metric.Ascent then Metric.Ascent := Temp.Ascent; if Temp.Descent > Metric.Descent then Metric.Descent := Temp.Descent; if Temp.LineSkip > Metric.LineSkip then Metric.LineSkip := Temp.LineSkip; if Temp.LineSkip_with_LineSpace > Metric.LineSkip_with_LineSpace then Metric.LineSkip_with_LineSpace := Temp.LineSkip_with_LineSpace; // font was handled so we can remove the font to skip the following words. // because the value only will change if we change the font. Font := nil; end; end; end; pLine := pLine^.NextItem; end; end; procedure TtsRenderer.PushTempLines; begin TrimSpaces(fLinesTemp.Lines); fLinesTemp.Lines^.LineLength := fLinesTemp.Lines^.LineLength - fLastActiveFont.CharSpacing; // add after last item if fLinesFirst <> nil then begin fLinesLast^.NextLine := fLinesTemp.Lines; fLinesLast := fLinesTemp.Lines; end; // set first item if fLinesFirst = nil then begin fLinesFirst := fLinesTemp.Lines; fLinesLast := fLinesTemp.Lines; end; // if vertical align is top then draw direktlly if tsGetParameteri(TS_VALIGN) = TS_VALIGN_TOP then DrawLine(fLinesLast^.LineItemFirst, fLinesLast^.LineLength, fLinesLast^.LineAutoBreak); // create new item with fLinesTemp do begin New(Lines); with Lines^ do begin NextLine := nil; LineItemFirst := nil; LineItemLast := nil; LineLength := 0; LineAutoBreak := False; end; Empty := True; end; end; procedure TtsRenderer.PushLineItem(pLine: PtsLineItem); begin with fLinesTemp do begin if Lines <> nil then begin // add after last item if Lines^.LineItemLast <> nil then begin pLine^.PrevItem := Lines^.LineItemLast; Lines^.LineItemLast^.NextItem := pLine; Lines^.LineItemLast := pLine; end; // set first item if Lines^.LineItemFirst = nil then begin Lines^.LineItemFirst := pLine; Lines^.LineItemLast := pLine; end; end; end; end; procedure TtsRenderer.SplitIntoLines(pItemList: PtsLineItem); var pExtractItem: PtsLineItem; procedure PushWord(pItem: PtsLineItem); begin if pItem <> nil then begin with fLinesTemp.Lines^ do begin // add after last item if LineItemLast <> nil then begin LineItemLast^.NextItem := pItem; pItem^.PrevItem := LineItemLast; LineItemLast := pItem; end; // set first item if LineItemFirst = nil then begin LineItemFirst := pItem; LineItemLast := pItem; end; end; end; end; begin while pItemList <> nil do begin // extract word from list pExtractItem := pItemList; pItemList := pItemList^.NextItem; pExtractItem^.NextItem := nil; pExtractItem^.PrevItem := nil; case pExtractItem^.ItemType of TS_BLOCK_WORD, TS_BLOCK_SPACE: begin // calculate size CalculateWordLength(fLastActiveFont, pExtractItem); if fWordWrap {and not fSingleLine} then begin // if line + word is larger than draw width if fLinesTemp.Lines^.LineLength + pExtractItem^.WordLength > fBlockWidth then begin fLinesTemp.Lines^.LineAutoBreak := True; // if line is empty if fLinesTemp.Lines^.LineLength = 0 then begin // ### Split word into multiple lines PushWord(pExtractItem); pExtractItem := nil; end; // else PushTempLines; end; end; // add extracted word to intern small list if pExtractItem <> nil then begin // add word PushWord(pExtractItem); // add Length fLinesTemp.Lines^.LineLength := fLinesTemp.Lines^.LineLength + pExtractItem^.WordLength; end; end; TS_BLOCK_LINEBREAK: begin // if not fSingleLine then begin PushWord(pExtractItem); PushTempLines; // end; end; TS_BLOCK_TAB: begin PushWord(pExtractItem); end; end; end; end; function TtsRenderer.SplitText(pText: PWideChar): PtsLineItem; var pLastItem: PtsLineItem; State: Integer; WordLength: Integer; pWordBegin: PWideChar; procedure ExtractWord; var pWord: PWideChar; pWordItem: PtsLineItem; procedure AddItem; begin // add item to list if Result <> nil then begin pLastItem^.NextItem := pWordItem; pWordItem^.PrevItem := pLastItem; pLastItem := pWordItem; end; if Result = nil then begin Result := pWordItem; pLastItem := pWordItem; end; end; begin if State <> 0 then begin // Create listitem New(pWordItem); pWordItem^.NextItem := nil; pWordItem^.PrevItem := nil; pWordItem^.ItemType := State; // only if space or text case State of TS_BLOCK_WORD, TS_BLOCK_SPACE: begin pWordItem^.Word := tsStrAlloc(WordLength); // copy chars WordLength := 0; pWord := pWordItem^.Word; while pWordBegin <> pText do begin pWord^ := pWordBegin^; Inc(pWord); Inc(pWordBegin); end; AddItem; end; TS_BLOCK_LINEBREAK: begin if pWordBegin <> pText then begin // Skip Linebreak while pWordBegin <> pText do Inc(pWordBegin); // if not fSingleLine then begin AddItem; // end else // begin // Dispose(pWordItem); // pWordItem := nil; // end; end else begin Dispose(pWordItem); pWordItem := nil; end; end; TS_BLOCK_TAB: begin AddItem; end; end; end; end; begin Result := nil; pLastItem := nil; WordLength := 0; State := 0; pWordBegin := pText; // look for word breaks while pText^ <> #0 do begin case pText^ of // Tabulator #$0009: begin ExtractWord; Inc(pWordBegin); State := TS_BLOCK_TAB; end; // line breaks #$000D, #$000A: begin if State <> TS_BLOCK_LINEBREAK then ExtractWord; if pWordBegin <> pText then begin ExtractWord; Inc(pWordBegin); end; State := TS_BLOCK_LINEBREAK; end; // Spaces #$0020: begin if State <> TS_BLOCK_SPACE then begin ExtractWord; State := TS_BLOCK_SPACE; end; end; else if State <> TS_BLOCK_WORD then begin ExtractWord; State := TS_BLOCK_WORD; end; end; Inc(pText); Inc(WordLength); end; // copy last word if pWordBegin <> pText then ExtractWord; end; function TtsRenderer.TextGetDrawHeight: Integer; var pLinesItem: PtsLinesItem; Metric: TtsTextMetric; begin Result := 0; // all lines pLinesItem := fLinesFirst; while pLinesItem <> nil do begin GetLineMetric(pLinesItem^.LineItemFirst, Metric); Result := Result + Metric.LineSkip_with_LineSpace; pLinesItem := pLinesItem^.NextLine; end; // last if we had an templine if fLinesTemp.Lines <> nil then begin GetLineMetric(fLinesTemp.Lines^.LineItemFirst, Metric); Result := Result + Metric.LineSkip_with_LineSpace; end; end; function TtsRenderer.TextGetDrawWidth: Integer; var pLinesItem: PtsLinesItem; Temp: Integer; {%H-}Font: TtsFont; function IntGetLineWidth(pLine: PtsLineItem): Integer; begin Result := 0; while pLine <> nil do begin case pLine^.ItemType of TS_BLOCK_FONT: begin Font := pLine^.Font; end; TS_BLOCK_WORD, TS_BLOCK_SPACE: begin Result := Result + pLine^.WordLength; end; end; pLine := pLine^.NextItem; end; end; begin Result := 0; // all lines Font := fActiveFont; pLinesItem := fLinesFirst; while pLinesItem <> nil do begin Temp := IntGetLineWidth(pLinesItem^.LineItemFirst); if Temp > Result then Result := Temp; pLinesItem := pLinesItem^.NextLine; end; // last if we had an templine if fLinesTemp.Lines <> nil then begin Temp := IntGetLineWidth(fLinesTemp.Lines^.LineItemFirst); if Temp > Result then Result := Temp; end; end; function TtsRenderer.TextGetWidth(pText: pWideChar): Integer; var pItemList: PtsLineItem; pTempItem: PtsLineItem; begin Result := 0; pItemList := SplitText(pText); pTempItem := pItemList; while pTempItem <> nil do begin CalculateWordLength(fActiveFont, pTempItem); Result := Result + pTempItem^.WordLength; pTempItem := pTempItem^.NextItem; end; // Free Items FreeLineItems(pItemList); end; procedure TtsRenderer.TextOut(pText: pWideChar); var pItemList: PtsLineItem; pTempItem: PtsLineItem; TempLength: Integer; begin pItemList := SplitText(pText); if isBlock then begin SplitIntoLines(pItemList); end else begin DrawSetPosition(0, 0); // Calculate Word length TempLength := 0; pTempItem := pItemList; while pTempItem <> nil do begin CalculateWordLength(fActiveFont, pTempItem); TempLength := TempLength + pTempItem^.WordLength; pTempItem := pTempItem^.NextItem; end; // remove last Char Spacing TempLength := TempLength - fActiveFont.CharSpacing; // if single line is top then set the Position to the baseline if tsGetParameteri(TS_SINGLE_LINE) = TS_SINGLE_LINE_TOP then DrawSetPositionRelative(0, fActiveFont.Ascent); // draw DrawLine(pItemList, TempLength, False); // Free Items FreeLineItems(pItemList); end; end; procedure TtsRenderer.TrimSpaces(pLinesItem: PtsLinesItem); var pTempLoopItem, pTempItem: PtsLineItem; begin if pLinesItem <> nil then begin // delete all spaces at beginning while pLinesItem^.LineItemFirst <> nil do begin if pLinesItem^.LineItemFirst^.ItemType <> TS_BLOCK_SPACE then Break; // save first pTempItem := pLinesItem^.LineItemFirst; // remove first item fromlist pLinesItem^.LineItemFirst := pLinesItem^.LineItemFirst^.NextItem; if pLinesItem^.LineItemFirst = nil then pLinesItem^.LineItemLast := nil else pLinesItem^.LineItemFirst^.PrevItem := nil; pLinesItem^.LineLength := pLinesItem^.LineLength - pTempItem^.WordLength; // dispose item pTempItem^.NextItem := nil; FreeLineItems(pTempItem); end; // delete all spaces at the end while pLinesItem^.LineItemLast <> nil do begin if pLinesItem^.LineItemLast^.ItemType <> TS_BLOCK_SPACE then break; // save last item pTempItem := pLinesItem^.LineItemLast; // remove last item from list pLinesItem^.LineItemLast := pLinesItem^.LineItemLast^.PrevItem; if pLinesItem^.LineItemLast = nil then pLinesItem^.LineItemFirst := nil else pLinesItem^.LineItemLast^.NextItem := nil; pLinesItem^.LineLength := pLinesItem^.LineLength - pTempItem^.WordLength; // dispose item FreeLineItems(pTempItem); end; // delete all spaces until some text comes pTempLoopItem := pLinesItem^.LineItemFirst; while pTempLoopItem <> nil do begin // exit if we have an word if pTempLoopItem^.ItemType = TS_BLOCK_WORD then Break; pTempItem := pTempLoopItem; pTempLoopItem := pTempLoopItem^.NextItem; if pTempItem^.ItemType = TS_BLOCK_SPACE then begin pLinesItem^.LineLength := pLinesItem^.LineLength - pTempItem^.WordLength; // set new next/prev if pTempItem^.NextItem <> nil then pTempItem^.NextItem^.PrevItem := pTempItem^.PrevItem; if pTempItem^.PrevItem <> nil then pTempItem^.PrevItem^.NextItem := pTempItem^.NextItem; // remove item pTempItem^.PrevItem := nil; pTempItem^.NextItem := nil; FreeLineItems(pTempItem); end; end; // delete all spaces until some text comes pTempLoopItem := pLinesItem^.LineItemLast; while pTempLoopItem <> nil do begin // exit if we have an word if pTempLoopItem^.ItemType = TS_BLOCK_WORD then Break; pTempItem := pTempLoopItem; pTempLoopItem := pTempLoopItem^.PrevItem; if pTempItem^.ItemType = TS_BLOCK_SPACE then begin pLinesItem^.LineLength := pLinesItem^.LineLength - pTempItem^.WordLength; // set new next/prev if pTempItem^.PrevItem <> nil then pTempItem^.PrevItem^.NextItem := pTempItem^.NextItem; if pTempItem^.NextItem <> nil then pTempItem^.NextItem^.PrevItem := pTempItem^.PrevItem; // remove item pTempItem^.PrevItem := nil; pTempItem^.NextItem := nil; FreeLineItems(pTempItem); end; end; end; end; procedure TtsRenderer.CharOut(CharCode: WideChar); var tsChar: TtsChar; begin tsChar := fActiveFont.GetChar(CharCode); if tsChar <> nil then DrawChar(fActiveFont, tsChar); end; { TtsRendererNULL } function TtsRendererNULL.AddImage(Char: TtsChar; CharImage: TtsImage): TtsRendererImageReference; begin Result := TtsRendererNULLImageReference.Create; if fSaveImages then with TtsRendererNULLImageReference(Result) do begin Image := TtsImage.Create; Image.AssignFrom(CharImage); end; end; procedure TtsRendererNULL.DrawChar(Font: TtsFont; Char: TtsChar); begin // nothing end; procedure TtsRendererNULL.DrawSetColor(Red, Green, Blue, Alpha: Single); begin // nothing end; procedure TtsRendererNULL.DrawSetPosition(X, Y: Integer); begin // nothing end; procedure TtsRendererNULL.DrawSetPositionRelative(X, Y: Integer); begin // nothing end; procedure TtsRendererNULL.RemoveImageReference(ImageReference: TtsRendererImageReference); begin if (ImageReference is TtsRendererNULLImageReference) then with TtsRendererNULLImageReference(ImageReference) do if Image <> nil then Image.Free; end; { TtsRendererOpenGL } function TtsRendererOpenGL.AddImage(Char: TtsChar; CharImage: TtsImage): TtsRendererImageReference; var Idx: Integer; TextureEntry: PtsRendererOpenGLTextureEntry; TextureAdded: Boolean; Texture: PtsRendererOpenGLTexture; CharHeight, CharWidth: Integer; W1, H1, TempBorder: Single; begin Result := nil; if not CharImage.Empty then begin Result := TtsRendererOpenGLImageReference.Create; with TtsRendererOpenGLImageReference(Result) do begin Coordinates.Top := 0; Coordinates.Left := 0; Coordinates.Right := 0; Coordinates.Bottom := 0; TextureAdded := False; TextureEntry := nil; // look if we can add the image to an texture for Idx := 0 to fTextures.Count - 1 do begin if AddImageToTexture(fTextures[Idx], CharImage, TexID, Coordinates) then begin TextureEntry := fTextures[Idx]; TextureAdded := True; Break; end; end; // could not added so create new texture if not TextureAdded then begin TextureEntry := CreateNewTexture; AddImageToTexture(TextureEntry, CharImage, TexID, Coordinates); end; // generating coords if TextureEntry <> nil then begin Texture := TextureEntry^.Texture; if Texture <> nil then begin with Char do begin CharHeight := Coordinates.Bottom - Coordinates.Top; CharWidth := Coordinates.Right - Coordinates.Left; // Set Variables for resizing border if HasResizingBorder then begin W1 := 1 / Texture^.Width; H1 := 1 / Texture^.Height; TempBorder := 2; end else begin W1 := 0; H1 := 0; TempBorder := 0; end; // Top Left TexCoords[0].X := Coordinates.Left / Texture^.Width + W1; TexCoords[0].Y := Coordinates.Top / Texture^.Height + H1; // Vertex[0].X := - GlyphRect.Left + Size1; // Vertex[0].Y := - GlyphRect.Top - GlyphOriginY + Size1; Vertex[0].X := - GlyphRect.Left; Vertex[0].Y := - GlyphRect.Top - GlyphOriginY; // Bottom Left TexCoords[1].X := Coordinates.Left / Texture^.Width + W1; TexCoords[1].Y := Coordinates.Bottom / Texture^.Height - H1; // Vertex[1].X := - GlyphRect.Left + Size1; // Vertex[1].Y := CharHeight - GlyphRect.Top - GlyphOriginY - Size1; Vertex[1].X := - GlyphRect.Left; Vertex[1].Y := CharHeight - GlyphRect.Top - GlyphOriginY - TempBorder; // Bottom Right TexCoords[2].X := Coordinates.Right / Texture^.Width - W1; TexCoords[2].Y := Coordinates.Bottom / Texture^.Height - H1; // Vertex[2].X := CharWidth - GlyphRect.Left - Size1; // Vertex[2].Y := CharHeight - GlyphRect.Top - GlyphOriginY - Size1; Vertex[2].X := CharWidth - GlyphRect.Left - TempBorder; Vertex[2].Y := CharHeight - GlyphRect.Top - GlyphOriginY - TempBorder; // Top Right TexCoords[3].X := Coordinates.Right / Texture^.Width - W1; TexCoords[3].Y := Coordinates.Top / Texture^.Height + H1; // Vertex[3].X := CharWidth - GlyphRect.Left - Size1; // Vertex[3].Y := - GlyphRect.Top - GlyphOriginY + Size1; Vertex[3].X := CharWidth - GlyphRect.Left - TempBorder; Vertex[3].Y := - GlyphRect.Top - GlyphOriginY; end; end; end; end; end; end; function TtsRendererOpenGL.AddImageToTexture(Texture: PtsRendererOpenGLTextureEntry; Image: TtsImage; var TextureID: Integer; var Coordinates: tsRect): boolean; var NeedX, NeedY: Word; Start: Word; Y, Y2: Integer; Managed: PtsRendererOpenGLManagedEntry; function CheckVertical(StartPos, EndPos: Integer): Boolean; var TempY: Integer; TempManaged: PtsRendererOpenGLManagedEntry; Found: Boolean; begin Result := False; for TempY := Y +1 to Y + NeedY -1 do begin TempManaged := Texture^.Lines[TempY]; // Überprüfen ob der entsprechende Bereich noch frei ist. Found := False; while TempManaged <> nil do begin if (TempManaged^.Start <= StartPos) and (TempManaged^.Start + TempManaged^.Count >= EndPos) then Found := True; TempManaged := TempManaged^.NextEntry; end; if not Found then Exit; end; Result := True; end; begin Result := False; NeedX := Image.Width shr 1; if (Image.Width and 1) > 0 then Inc(NeedX); NeedY := Image.Height shr 1; if (Image.Height and 1) > 0 then Inc(NeedY); // scan for free space for Y := Low(Texture^.Lines) to High(Texture^.Lines) - NeedY do begin Managed := Texture^.Lines[Y]; while Managed <> nil do begin if Managed^.Count >= NeedX then begin if CheckVertical(Managed^.Start, Managed^.Start + NeedX) then begin Start := Managed^.Start; // allocating space for Y2 := Y to Y + NeedY -1 do AllocSpace(Texture^.Lines[Y2], Start, NeedX); // setting texturecoordinates values TextureID := Texture^.ID; Coordinates.Left := Start shl 1; Coordinates.Top := Y shl 1; Coordinates.Right := Coordinates.Left + Image.Width; Coordinates.Bottom := Coordinates.Top + Image.Height; Texture^.Usage := Texture^.Usage + NeedX * NeedY; // copy charimage with Texture^.Texture^ do begin glBindTexture(GL_TEXTURE_2D, Texture^.Texture^.glTextureID); glTexSubImage2D(GL_TEXTURE_2D, 0, Coordinates.Left, Coordinates.Top, Image.Width, Image.Height, GL_RGBA, GL_UNSIGNED_BYTE, Image.Data); end; Result := True; Exit; end; end; Managed := Managed^.NextEntry; end; end; end; procedure TtsRendererOpenGL.AfterConstruction; begin inherited; fTextures := TList.Create; fTextureSize := 256; end; procedure TtsRendererOpenGL.AllocSpace(var FirstManaged: PtsRendererOpenGLManagedEntry; Start, Count: Word); var Managed, TempManaged: PtsRendererOpenGLManagedEntry; procedure RemoveManagedItem(pItem: PtsRendererOpenGLManagedEntry); var pTemp, pTemp2: PtsRendererOpenGLManagedEntry; begin pTemp := FirstManaged; while pTemp <> nil do begin pTemp2 := pTemp^.NextEntry; if pTemp2 = pItem then begin pTemp^.NextEntry := pItem^.NextEntry; Break; end; pTemp := pTemp2; end; end; begin // complete remove of the FIRST item (spezial handling for first item removal.) if (Start = FirstManaged^.Start) and (Count = FirstManaged^.Count) then begin TempManaged := FirstManaged; FirstManaged := FirstManaged^.NextEntry; Dispose(TempManaged); end else // look for matching item begin Managed := FirstManaged; while Managed <> nil do begin // matched item? if (Start >= Managed^.Start) and ((Start + Count) <= (Managed^.Start + Managed^.Count)) then begin // cut at start if (Start = Managed^.Start) then begin // remove the whole item if (Count = Managed^.Count) then begin RemoveManagedItem(Managed); // no need to preserve Managed because we leaving the loop Dispose(Managed); end else // cut at start begin Managed^.Start := Managed^.Start + Count; Managed^.Count := Managed^.Count - Count; end; end else // cut at end if (Start + Count) = (Managed^.Start + Managed^.Count) then begin Managed^.Count := Managed^.Count - Count; end else // cut in the middle begin New(TempManaged); TempManaged^.NextEntry := Managed^.NextEntry; Managed^.NextEntry := TempManaged; TempManaged^.Start := Start + Count; TempManaged^.Count := (Managed^.Start + Managed^.Count) - TempManaged^.Start; Managed^.Count := Start - Managed^.Start; end; // we found an item so leave the loop Break; end; Managed := Managed^.NextEntry; end; end; end; procedure TtsRendererOpenGL.BeforeDestruction; begin ClearTextures; fTextures.Free; inherited; end; procedure TtsRendererOpenGL.BeginBlock(Left, Top, Width, Height: Integer; Flags: tsBitmask); begin fPos.X := 0; fPos.Y := 0; inherited; end; procedure TtsRendererOpenGL.ClearTextures; var Idx: Integer; begin // Disposing items for Idx := fTextures.Count - 1 downto 0 do DeleteTexture(Idx); // Clear list fTextures.Clear; end; function TtsRendererOpenGL.CreateNewTexture: PtsRendererOpenGLTextureEntry; var Idx: Integer; begin New (Result); with Result^ do begin ID := fTextures.Add(Result); Usage := 0; // create opengl texture New(Texture); with Texture^ do begin Width := TextureSize; Height := TextureSize; glGenTextures(1, @glTextureID); glBindTexture(GL_TEXTURE_2D, glTextureID); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, TextureSize, TextureSize, 0, GL_RGBA, GL_UNSIGNED_BYTE, nil); end; // initiale memory manager value SetLength(Lines, Texture^.Height shr 1); for Idx := Low(Lines) to High(Lines) do begin New(Lines[Idx]); Lines[Idx]^.NextEntry := nil; Lines[Idx]^.Start := 0; Lines[Idx]^.Count := Texture^.Width shr 1; end; end; end; procedure TtsRendererOpenGL.DeleteTexture(Idx: Integer); var pItem: PtsRendererOpenGLTextureEntry; LineIdx: Integer; pManaged, pTempManaged: PtsRendererOpenGLManagedEntry; begin pItem := fTextures[Idx]; fTextures.Delete(Idx); if pItem <> nil then begin with pItem^ do begin // Free opengl texture if Texture <> nil then begin glDeleteTextures(1, @(Texture^.glTextureID)); Dispose(Texture); end; // free lines for LineIdx := Low(Lines) to High(Lines) do begin pManaged := Lines[LineIdx]; Lines[LineIdx] := nil; while pManaged <> nil do begin pTempManaged := pManaged; pManaged := pManaged^.NextEntry; Dispose(pTempManaged); end; end; SetLength(Lines, 0); end; Dispose(pItem); end; end; procedure TtsRendererOpenGL.DrawChar(Font: TtsFont; Char: TtsChar); var Texture: PtsRendererOpenGLTexture; TempVertex: tsQuadFloat; begin if Char.RendererImageReference <> nil then begin with Char.RendererImageReference as TtsRendererOpenGLImageReference do begin Texture := GetTextureByID(TexID); if Texture <> nil then begin glBindTexture(GL_TEXTURE_2D, Texture^.glTextureID); glEnable(GL_TEXTURE_2D); // calculate new quad TranslateQuad(TempVertex, Vertex, fPos); glBegin(GL_QUADS); glTexCoord2fv(@TexCoords[0]); glVertex2fv(@TempVertex[0]); glTexCoord2fv(@TexCoords[1]); glVertex2fv(@TempVertex[1]); glTexCoord2fv(@TexCoords[2]); glVertex2fv(@TempVertex[2]); glTexCoord2fv(@TexCoords[3]); glVertex2fv(@TempVertex[3]); glEnd; // if debug is enabled if fContext.gDebugDrawCharRects then begin glDisable(GL_TEXTURE_2D); // image Rect glColor4f(0, 1, 0, 0.1); glBegin(GL_QUADS); glVertex2fv(@TempVertex[0]); glVertex2fv(@TempVertex[1]); glVertex2fv(@TempVertex[2]); glVertex2fv(@TempVertex[3]); glEnd; // glyph rect glColor4f(1, 0, 0, 0.1); glBegin(GL_QUADS); glVertex2f(TempVertex[0].X + Char.GlyphRect.Left, TempVertex[0].Y + Char.GlyphRect.Top); glVertex2f(TempVertex[0].X + Char.GlyphRect.Left, TempVertex[0].Y + Char.GlyphRect.Bottom); glVertex2f(TempVertex[0].X + Char.GlyphRect.Right, TempVertex[0].Y + Char.GlyphRect.Bottom); glVertex2f(TempVertex[0].X + Char.GlyphRect.Right, TempVertex[0].Y + Char.GlyphRect.Top); glEnd; // baseline glColor4f(0, 0, 1, 0.25); glBegin(GL_LINES); glVertex2f(TempVertex[0].X, 0); glVertex2f(TempVertex[2].X, 0); glEnd; glColor4f(1, 1, 1, 1); end; end; end; end; end; procedure TtsRendererOpenGL.DrawSetColor(Red, Green, Blue, Alpha: Single); begin glColor4f(Red, Green, Blue, Alpha); end; procedure TtsRendererOpenGL.DrawSetPosition(X, Y: Integer); begin fPos.X := X; fPos.Y := Y; end; procedure TtsRendererOpenGL.DrawSetPositionRelative(X, Y: Integer); begin DrawSetPosition(fPos.X + X, fPos.Y + Y); end; procedure TtsRendererOpenGL.FreeSpace(var FirstManaged: PtsRendererOpenGLManagedEntry; Start, Count: Word); var Last, Managed, Temp: PtsRendererOpenGLManagedEntry; AddItem: Boolean; begin // if we have no space we can add item directly if FirstManaged = nil then begin New(Temp); Temp^.Start := Start; Temp^.Count := Count; Temp^.NextEntry := nil; FirstManaged := Temp; end else // Special handling for first Item if Start + Count < FirstManaged^.Start then begin New(Temp); Temp^.Start := Start; Temp^.Count := Count; Temp^.NextEntry := FirstManaged; FirstManaged := Temp; end else begin Managed := FirstManaged; Last := nil; while Managed <> nil do begin // block is in front of another if Start + Count = Managed^.Start then begin Managed^.Start := Managed^.Start - Count; Managed^.Count := Managed^.Count + Count; if Last <> nil then begin if Last^.Start + Last^.Count = Managed^.Start then begin // Remove Item Last^.Count := Last^.Count + Managed^.Count; Last^.NextEntry := Managed^.NextEntry; Dispose(Managed); end; end; Break; end else // block is behind another if Start = Managed^.Start + Managed^.Count then begin Managed^.Count := Managed^.Count + Count; Temp := Managed^.NextEntry; if Temp <> nil then begin if Managed^.Start + Managed^.Count = Temp^.Start then begin // Remove Item Managed^.Count := Managed^.Count + Temp^.Count; Managed^.NextEntry := Temp^.NextEntry; Dispose(Temp); end; end; Break; end else // the block dosn't border an other so we must create some other begin AddItem := False; if not (Managed^.NextEntry <> nil) then AddItem := True else if (Managed^.Start + Managed^.Count < Start) and (Managed^.NextEntry^.Start > Start + Count) then AddItem := True; if AddItem then begin New(Temp); Temp^.Start := Start; Temp^.Count := Count; Temp^.NextEntry := Managed^.NextEntry; Managed^.NextEntry := Temp; Break; end; end; Last := Managed; Managed := Managed^.NextEntry; end; end; end; function TtsRendererOpenGL.GetTextureByID(ID: Integer): PtsRendererOpenGLTexture; var Idx: Integer; pTexture: PtsRendererOpenGLTextureEntry; begin Result := nil; for Idx := 0 to fTextures.Count - 1 do begin pTexture := fTextures[Idx]; if pTexture <> nil then if pTexture^.ID = ID then begin Result := pTexture^.Texture; Break; end; end; end; procedure TtsRendererOpenGL.RemoveImageReference(ImageReference: TtsRendererImageReference); var OpenGLRef: TtsRendererOpenGLImageReference; pItem: PtsRendererOpenGLTextureEntry; Idx, TempIdx: Integer; TempWidth, TempHeight: Integer; NeedX, NeedY: Integer; LinesY, TempX, TempY: Integer; begin OpenGLRef := TtsRendererOpenGLImageReference(ImageReference); // freeing texture for Idx := 0 to fTextures.Count - 1 do begin pItem := fTextures[Idx]; if pItem <> nil then begin if pItem^.ID = OpenGLRef.TexID then begin TempWidth := OpenGLRef.Coordinates.Right - OpenGLRef.Coordinates.Left; TempHeight := OpenGLRef.Coordinates.Bottom - OpenGLRef.Coordinates.Top; with pItem^ do begin // calc size NeedX := TempWidth shr 1; if (TempWidth and 1) > 0 then Inc(NeedX); NeedY := TempHeight shr 1; if (TempHeight and 1) > 0 then Inc(NeedY); TempY := OpenGLRef.Coordinates.Top shr 1; TempX := OpenGLRef.Coordinates.Left shr 1; Usage := Usage - NeedX * NeedY; Assert(Usage >= 0); // Points for LinesY := 0 to NeedY - 1 do FreeSpace(Lines[TempY + LinesY], TempX, NeedX); // freeing opengltexture if Usage = 0 then begin for TempIdx := 0 to fTextures.Count - 1 do begin if PtsRendererOpenGLTextureEntry(fTextures[TempIdx])^.ID = pItem^.ID then begin DeleteTexture(TempIdx); Break; end; end; end; end; Break; end; end; end; end; { TtsContext } function TtsContext.AnsiToWide(pText: pAnsiChar): pWideChar; function GetDefaultChar: WideChar; begin Result := #0; if tsGetParameteri(TS_EMPTY_CP_ENTRY) = TS_EMPTY_CP_ENTRY_USE_DEFAULT then if ActiveFont <> nil then Result := ActiveFont.DefaultChar; end; begin Result := nil; // UTF-8 if gCodePage = TS_CODEPAGE_UTF8 then begin Result := tsStrAlloc(Length(pText)); tsAnsiUTF8ToWide(Result, pText, GetDefaultChar); end else // ISO 8859-1 if gCodePage = TS_CODEPAGE_8859_1 then begin Result := tsStrAlloc(Length(pText)); tsAnsiISO_8859_1_ToWide(Result, pText); end else // single or double byte CodePage begin if (Addr(gCodePageFunc) <> nil) and (gCodePagePtr <> nil) then begin Result := tsStrAlloc(Length(pText)); gCodePageFunc(Result, pText, gCodePagePtr, GetDefaultChar); end; end; end; procedure TtsContext.ClearFonts; var List: TList; Idx: Integer; pItem: PtsContextFontEntry; begin List := TList.Create; try fFonts.GetValues(List); fFonts.Clear; for Idx := 0 to List.Count - 1 do begin pItem := List[Idx]; pItem^.Font.Free; Dispose(pItem); end; finally List.Free; end; end; procedure TtsContext.ClearImages; var List: TList; Idx: Integer; pItem: PtsContextImageEntry; begin List := TList.Create; try fImages.GetValues(List); fImages.Clear; for Idx := 0 to List.Count - 1 do begin pItem := List[Idx]; pItem^.Image.Free; Dispose(pItem); end; finally List.Free; end; end; constructor TtsContext.Create; begin inherited; Inc(gLastContextID); fContextID := gLastContextID; // hashes fFonts := TtsHash.Create(127); fImages := TtsHash.Create(127); // defaults gEmptyCodePageEntry := TS_EMPTY_CP_ENTRY_USE_DEFAULT; gCodePage := TS_CODEPAGE_8859_1; gCodePagePtr := nil; //@CP_8859_1; gCodePageFunc := nil; //tsAnsiSBCDToWide; gGlobalFormat := TS_FORMAT_RGBA8; gGlobalAntiAliasing := TS_ANTIALIASING_NORMAL; gSingleLine := TS_SINGLE_LINE_BASELINE; gAlign := TS_ALIGN_LEFT; gVAlign := TS_VALIGN_TOP; gClip := TS_CLIP_COMPLETE; gImageMode[tsModeRed] := TS_MODE_REPLACE; gImageMode[tsModeGreen] := TS_MODE_REPLACE; gImageMode[tsModeBlue] := TS_MODE_REPLACE; gImageMode[tsModeAlpha] := TS_MODE_MODULATE; gImageMode[tsModeLuminance] := TS_MODE_REPLACE; gImageLibrary := 0; end; destructor TtsContext.Destroy; begin ClearFonts; fFonts.Free; ClearImages; fImages.Free; if Renderer <> nil then Renderer.Free; inherited; end; function TtsContext.FontAdd(Font: TtsFont): Cardinal; var Entry: PtsContextFontEntry; begin New(Entry); Inc(fLastFontID); Entry^.FontID := fLastFontID; Entry^.Font := Font; fFonts.Add(fLastFontID, Entry); Result := fLastFontID; end; function TtsContext.FontCount: Cardinal; begin Result := fFonts.Count; end; procedure TtsContext.FontDelete(Font: Cardinal); var Entry: PtsContextFontEntry; begin if fLastFontID = Font then Renderer.FontActivate(0); Entry := fFonts.Get(Font); if Entry <> nil then begin fFonts.Delete(Entry^.FontID); Dispose(Entry); end; end; function TtsContext.FontGet(Font: Cardinal): TtsFont; var Entry: PtsContextFontEntry; begin Entry := fFonts.Get(Font); if Entry <> nil then Result := Entry^.Font else Result := nil; end; function TtsContext.GetActiveFont: TtsFont; begin Result := nil; if Renderer <> nil then Result := Renderer.ActiveFont; end; function TtsContext.GetIsLocked: boolean; begin if Renderer <> nil then Result := Renderer.isBlock else Result := False; end; function TtsContext.ImageAdd(Image: TtsImage): Cardinal; var Entry: PtsContextImageEntry; begin New(Entry); Inc(fLastImageID); Entry^.ImageID := fLastImageID; Entry^.Image := Image; fImages.Add(fLastImageID, Entry); Result := fLastImageID; end; function TtsContext.ImageCount: Cardinal; begin Result := fImages.Count; end; procedure TtsContext.ImageDelete(Image: Cardinal); var Entry: PtsContextImageEntry; begin Entry := fImages.Get(Image); if Entry <> nil then begin fImages.Delete(Entry^.ImageID); Dispose(Entry); end; end; function TtsContext.ImageGet(Image: Cardinal): TtsImage; var Entry: PtsContextImageEntry; begin Entry := fImages.Get(Image); if Entry <> nil then Result := Entry^.Image else Result := nil; end; end.