2
// This unit is part of the GLScene Engine https://github.com/glscene
5
Bitmap Fonts management classes for GLScene
8
04/12/14 - PW - Corrected the usage of pixel formats for Lazarus (by Gabriel Corneanu)
9
20/11/12 - PW - CPP compatibility: replaced direct access to some properties with records
10
01/09/11 - Yar - Bugfixed StartASCII, StopASCII properties for non-Unicode compiler
11
30/06/11 - DaStr - Bugfixed TGLBitmapFontRanges.Add(for AnsiChar)
12
16/05/11 - Yar - Redesign to use multiple textures (by Gabriel Corneanu)
13
13/05/11 - Yar - Adapted to unicode (by Gabriel Corneanu)
14
23/08/10 - Yar - Added OpenGLTokens to uses, replaced OpenGL1x functions to OpenGLAdapter
15
05/07/10 - Yar - Now HSpace and VSpace can take negative values (thanks Sandor Domokos) (BugtrackerID = 3024975)
16
22/04/10 - Yar - Fixes after GLState revision
17
05/03/10 - DanB - More state added to TGLStateCache
18
24/02/10 - Yar - Bugfix in TGLCustomBitmapFont.PrepareImage when image is not RGBA8
19
25/01/10 - Yar - Replace Char to AnsiChar
20
11/11/09 - DaStr - Added Delphi 2009 compatibility (thanks mal)
21
16/10/08 - UweR - Removed unneeded typecast in TGLBitmapFontRange.SetStartGlyphIdx
22
06/06/07 - DaStr - Added GLColor to uses (BugtrackerID = 1732211)
23
30/03/07 - DaStr - Added $I GLScene.inc
24
22/12/06 - LC - Fixed TGLCustomBitmapFont.RenderString, it now unbinds the texture.
25
Bugtracker ID=1619243 (thanks Da Stranger)
26
09/03/05 - EG - Fixed space width during rendering
27
12/15/04 - Eugene Kryukov - Moved FCharRects to protected declaration in TGLCustomBitmapFont
28
18/10/04 - NelC - Fixed a texture reset bug in RenderString
29
02/08/04 - LR, YHC - BCB corrections: use record instead array
30
28/06/04 - LR - Change TTextLayout to TGLTextLayout for Linux
31
27/06/04 - NelC - Added TGLFlatText.Assign
32
01/03/04 - SG - TGLCustomBitmapFont.RenderString now saves GL_CURRENT_BIT state
33
01/07/03 - EG - TGLCustomBitmapFont.TextOut now saves and restore state
34
07/05/03 - EG - TGLFlatText Notification fix, added Options
35
30/10/02 - EG - Added TGLFlatText
36
29/09/02 - EG - Added TexCoords LUT, faster RenderString,
37
removed TGLBitmapFontRange.Widths
38
28/09/02 - EG - Introduced TGLCustomBitmapFont
39
06/09/02 - JAJ - Prepared for TGLWindowsBitmapFont
40
28/08/02 - EG - Repaired fixed CharWidth, variable CharWidth not yet repaired
41
12/08/02 - JAJ - Merged Dual Development, Alpha Channel and CharWidth are now side by side
42
UNKNOWN - EG - Added Alpha Channel.
43
02/06/02 - JAJ - Modified to flexible character width
44
20/01/02 - EG - Dropped 'Graphics' dependency
45
10/09/01 - EG - Fixed visibility of tile 0
46
12/08/01 - EG - Completely rewritten handles management
47
21/02/01 - EG - Now XOpenGL based (multitexture)
48
15/01/01 - EG - Creation
55
{$DEFINE GLS_UNICODE_SUPPORT}61
Classes, Graphics, SysUtils, Types,
62
GLScene, GLVectorGeometry, GLContext, GLCrossPlatform,
63
GLTexture, GLState, GLUtils, GLGraphics, GLColor, GLBaseClasses,
64
GLRenderContextInfo, GLTextureFormat,
65
OpenGLTokens, XOpenGL, GLVectorTypes;
68
{$IFNDEF GLS_UNICODE_SUPPORT}69
UnicodeString = WideString; // Use WideString for earlier versions
74
{ : An individual character range in a bitmap font.75
A range allows mapping ASCII characters to character tiles in a font
76
bitmap, tiles are enumerated line then column (raster). }
77
TGLBitmapFontRange = class(TCollectionItem)
79
function GetStartASCII: WideString;
80
function GetStopASCII: WideString;
83
FStartASCII, FStopASCII: WideChar;
84
FStartGlyphIdx, FStopGlyphIdx, FCharCount: Integer;
85
procedure SetStartASCII(const val: WideString);
86
procedure SetStopASCII(const val: WideString);
87
procedure SetStartGlyphIdx(val: Integer);
88
function GetDisplayName: string; override;
91
constructor Create(Collection: TCollection); override;
92
destructor Destroy; override;
94
procedure Assign(Source: TPersistent); override;
95
procedure NotifyChange;
98
property StartASCII: WideString read GetStartASCII write SetStartASCII;
99
property StopASCII: WideString read GetStopASCII write SetStopASCII;
100
property StartGlyphIdx: Integer read FStartGlyphIdx write SetStartGlyphIdx;
101
property StopGlyphIdx: Integer read FStopGlyphIdx;
102
property CharCount: Integer read FCharCount;
105
// TGLBitmapFontRanges
107
TGLBitmapFontRanges = class(TCollection)
114
function GetOwner: TPersistent; override;
115
procedure SetItems(index: Integer; const val: TGLBitmapFontRange);
116
function GetItems(index: Integer): TGLBitmapFontRange;
117
function CalcCharacterCount: Integer;
118
procedure Update(Item: TCollectionItem); override;
122
constructor Create(AOwner: TComponent);
123
destructor Destroy; override;
125
function Add: TGLBitmapFontRange; overload;
126
function Add(const StartASCII, StopASCII: WideChar)
127
: TGLBitmapFontRange; overload;
128
function Add(const StartASCII, StopASCII: AnsiChar)
129
: TGLBitmapFontRange; overload;
130
function FindItemID(ID: Integer): TGLBitmapFontRange;
131
property Items[index: Integer]: TGLBitmapFontRange read GetItems
132
write SetItems; default;
134
{ : Converts an ASCII character into a tile index.135
Return -1 if character cannot be rendered. }
136
function CharacterToTileIndex(aChar: WideChar): Integer;
137
function TileIndexToChar(aIndex: Integer): WideChar;
138
procedure NotifyChange;
140
// : Total number of characters in the ranges; cached for performance
141
property CharacterCount: Integer read FCharCount;
144
PCharInfo = ^TCharInfo;
150
// TGLCustomBitmapFont
152
{ : Provides access to individual characters in a BitmapFont.153
Only fixed-width bitmap fonts are supported, the characters are enumerated
154
in a raster fashion (line then column).
155
Transparency is all or nothing, the transparent color being that of the
156
top left pixel of the Glyphs bitmap.
157
Performance note: as usual, for best performance, you base font bitmap
158
dimensions should be close to a power of two, and have at least 1 pixel
159
spacing between characters (horizontally and vertically) to avoid artefacts
160
when rendering with linear filtering. }
161
TGLCustomBitmapFont = class(TGLUpdateAbleComponent)
164
FRanges: TGLBitmapFontRanges;
166
FCharWidth, FCharHeight: Integer;
167
FGlyphsIntervalX, FGlyphsIntervalY: Integer;
168
FHSpace, FVSpace, FHSpaceFix: Integer;
170
FMinFilter: TGLMinFilter;
171
FMagFilter: TGLMagFilter;
172
FTextureWidth, FTextureHeight: Integer;
173
FTextRows, FTextCols: Integer;
174
FGlyphsAlpha: TGLTextureImageAlpha;
176
FTextureModified: boolean;
177
FLastTexture: TGLTextureHandle;
180
FChars: array of TCharInfo;
181
FCharsLoaded: boolean;
182
procedure ResetCharWidths(w: Integer = -1);
183
procedure SetCharWidths(index, value: Integer);
185
procedure SetRanges(const val: TGLBitmapFontRanges);
186
procedure SetGlyphs(const val: TGLPicture);
187
procedure SetCharWidth(const val: Integer);
188
procedure SetCharHeight(const val: Integer);
189
procedure SetGlyphsIntervalX(const val: Integer);
190
procedure SetGlyphsIntervalY(const val: Integer);
191
procedure OnGlyphsChanged(Sender: TObject);
192
procedure SetHSpace(const val: Integer);
193
procedure SetVSpace(const val: Integer);
194
procedure SetMagFilter(AValue: TGLMagFilter);
195
procedure SetMinFilter(AValue: TGLMinFilter);
196
procedure SetGlyphsAlpha(val: TGLTextureImageAlpha);
198
procedure TextureChanged;
199
procedure FreeTextureHandle; dynamic;
200
function TextureFormat: Integer; dynamic;
202
procedure InvalidateUsers;
203
function CharactersPerRow: Integer;
204
procedure GetCharTexCoords(Ch: WideChar;
205
var TopLeft, BottomRight: TTexPoint);
206
procedure GetICharTexCoords(var ARci: TGLRenderContextInfo; Chi: Integer;
207
out TopLeft, BottomRight: TTexPoint);
208
procedure PrepareImage(var ARci: TGLRenderContextInfo); virtual;
209
procedure PrepareParams(var ARci: TGLRenderContextInfo);
211
{ : A single bitmap containing all the characters.212
The transparent color is that of the top left pixel. }
213
property Glyphs: TGLPicture read FGlyphs write SetGlyphs;
214
{ : Nb of horizontal pixels between two columns in the Glyphs. }215
property GlyphsIntervalX: Integer read FGlyphsIntervalX
216
write SetGlyphsIntervalX;
217
{ : Nb of vertical pixels between two rows in the Glyphs. }218
property GlyphsIntervalY: Integer read FGlyphsIntervalY
219
write SetGlyphsIntervalY;
220
{ : Ranges allow converting between ASCII and tile indexes.221
See TGLCustomBitmapFontRange. }
222
property Ranges: TGLBitmapFontRanges read FRanges write SetRanges;
224
{ : Width of a single character. }225
property CharWidth: Integer read FCharWidth write SetCharWidth default 16;
226
{ : Pixels in between rendered characters (horizontally). }227
property HSpace: Integer read FHSpace write SetHSpace default 1;
228
{ : Pixels in between rendered lines (vertically). }229
property VSpace: Integer read FVSpace write SetVSpace default 1;
230
{ : Horizontal spacing fix offset.231
This property is for internal use, and is added to the hspacing
232
of each character when rendering, typically to fix extra spacing. }
233
property HSpaceFix: Integer read FHSpaceFix write FHSpaceFix;
235
property MagFilter: TGLMagFilter read FMagFilter write SetMagFilter
237
property MinFilter: TGLMinFilter read FMinFilter write SetMinFilter
239
property GlyphsAlpha: TGLTextureImageAlpha read FGlyphsAlpha
240
write FGlyphsAlpha default tiaDefault;
244
constructor Create(AOwner: TComponent); override;
245
destructor Destroy; override;
247
procedure RegisterUser(anObject: TGLBaseSceneObject); virtual;
248
procedure UnRegisterUser(anObject: TGLBaseSceneObject); virtual;
250
{ : Renders the given string at current position or at position given by the optional position variable.251
The current matrix is blindly used, meaning you can render all kinds
252
of rotated and linear distorted text with this method, OpenGL
253
Enable states are also possibly altered. }
254
procedure RenderString(var ARci: TGLRenderContextInfo;
255
const aText: UnicodeString; aAlignment: TAlignment;
256
aLayout: TGLTextLayout; const aColor: TColorVector;
257
aPosition: PVector = nil; aReverseY: boolean = False); overload; virtual;
259
{ : A simpler canvas-style TextOut helper for RenderString.260
The rendering is reversed along Y by default, to allow direct use
262
procedure TextOut(var rci: TGLRenderContextInfo; X, Y: Single;
263
const Text: UnicodeString; const Color: TColorVector); overload;
264
procedure TextOut(var rci: TGLRenderContextInfo; X, Y: Single;
265
const Text: UnicodeString; const Color: TColor); overload;
266
function TextWidth(const Text: UnicodeString): Integer;
268
function CharacterToTileIndex(aChar: WideChar): Integer; virtual;
269
function TileIndexToChar(aIndex: Integer): WideChar; virtual;
270
function CharacterCount: Integer; virtual;
272
{ : Get the actual width for this char. }273
function GetCharWidth(Ch: WideChar): Integer;
274
{ : Get the actual pixel width for this string. }275
function CalcStringWidth(const aText: UnicodeString): Integer;
278
// make texture if needed
279
procedure CheckTexture(var ARci: TGLRenderContextInfo);
281
{ : Height of a single character. }282
property CharHeight: Integer read FCharHeight write SetCharHeight
285
property TextureWidth: Integer read FTextureWidth write FTextureWidth;
286
property TextureHeight: Integer read FTextureHeight write FTextureHeight;
291
{ : See TGLCustomBitmapFont.292
This class only publuishes some of the properties. }
293
TGLBitmapFont = class(TGLCustomBitmapFont)
297
property GlyphsIntervalX;
298
property GlyphsIntervalY;
306
property GlyphsAlpha;
309
// TGLFlatTextOptions
311
TGLFlatTextOption = (ftoTwoSided);
312
TGLFlatTextOptions = set of TGLFlatTextOption;
316
{ : A 2D text displayed and positionned in 3D coordinates.317
The FlatText uses a character font defined and stored by a TGLBitmapFont
318
component. Default character scale is 1 font pixel = 1 space unit. }
319
TGLFlatText = class(TGLImmaterialSceneObject)
322
FBitmapFont: TGLCustomBitmapFont;
323
FText: UnicodeString;
324
FAlignment: TAlignment;
325
FLayout: TGLTextLayout;
326
FModulateColor: TGLColor;
327
FOptions: TGLFlatTextOptions;
331
procedure SetBitmapFont(const val: TGLCustomBitmapFont);
332
procedure SetText(const val: UnicodeString);
333
procedure SetAlignment(const val: TAlignment);
334
procedure SetLayout(const val: TGLTextLayout);
335
procedure SetModulateColor(const val: TGLColor);
336
procedure SetOptions(const val: TGLFlatTextOptions);
338
procedure Notification(AComponent: TComponent;
339
Operation: TOperation); override;
343
constructor Create(AOwner: TComponent); override;
344
destructor Destroy; override;
346
procedure DoRender(var rci: TGLRenderContextInfo;
347
renderSelf, renderChildren: boolean); override;
349
procedure Assign(Source: TPersistent); override;
353
{ : Refers the bitmap font to use.354
The referred bitmap font component stores and allows access to
355
individual character bitmaps. }
356
property BitmapFont: TGLCustomBitmapFont read FBitmapFont
359
Be aware that only the characters available in the bitmap font will
360
be rendered. CR LF sequences are allowed. }
361
property Text: UnicodeString read FText write SetText;
362
{ : Controls the text alignment (horizontal).363
Possible values : taLeftJustify, taRightJustify, taCenter }
364
property Alignment: TAlignment read FAlignment write SetAlignment;
365
{ : Controls the text layout (vertical).366
Possible values : tlTop, tlCenter, tlBottom }
367
property Layout: TGLTextLayout read FLayout write SetLayout;
368
{ : Color modulation, can be used for fade in/out too. }369
property ModulateColor: TGLColor read FModulateColor write SetModulateColor;
370
{ : Flat text options.371
ftoTwoSided : when set the text will be visible from its two
372
sides even if faceculling is on (at the scene-level).
374
property Options: TGLFlatTextOptions read FOptions write SetOptions;
377
// ------------------------------------------------------------------
378
// ------------------------------------------------------------------
379
// ------------------------------------------------------------------
382
// ------------------------------------------------------------------
383
// ------------------------------------------------------------------
384
// ------------------------------------------------------------------
387
// ------------------ TGLBitmapFontRange ------------------
392
constructor TGLBitmapFontRange.Create(Collection: TCollection);
394
inherited Create(Collection);
399
destructor TGLBitmapFontRange.Destroy;
406
procedure TGLBitmapFontRange.Assign(Source: TPersistent);
408
if Source is TGLBitmapFontRange then
410
FStartASCII := TGLBitmapFontRange(Source).FStartASCII;
411
FStopASCII := TGLBitmapFontRange(Source).FStopASCII;
412
FStartGlyphIdx := TGLBitmapFontRange(Source).FStartGlyphIdx;
421
procedure TGLBitmapFontRange.NotifyChange;
423
FCharCount := Integer(FStopASCII) - Integer(FStartASCII) + 1;
424
FStopGlyphIdx := FStartGlyphIdx + FCharCount - 1;
425
if Assigned(Collection) then
426
(Collection as TGLBitmapFontRanges).NotifyChange;
431
function TGLBitmapFontRange.GetDisplayName: string;
433
Result := Format('ASCII [#%d, #%d] -> Glyphs [%d, %d]',434
[Integer(FStartASCII), Integer(FStopASCII), StartGlyphIdx, StopGlyphIdx]);
437
function TGLBitmapFontRange.GetStartASCII: WideString;
439
Result := FStartASCII;
442
function TGLBitmapFontRange.GetStopASCII: WideString;
444
Result := FStopASCII;
449
procedure TGLBitmapFontRange.SetStartASCII(const val: WideString);
451
if (Length(val) > 0) and (val[1] <> FStartASCII) then
453
FStartASCII := val[1];
454
if FStartASCII > FStopASCII then
455
FStopASCII := FStartASCII;
462
procedure TGLBitmapFontRange.SetStopASCII(const val: WideString);
464
if (Length(val) > 0) and (FStopASCII <> val[1]) then
466
FStopASCII := val[1];
467
if FStopASCII < FStartASCII then
468
FStartASCII := FStopASCII;
475
procedure TGLBitmapFontRange.SetStartGlyphIdx(val: Integer);
477
val := MaxInteger(0, val);
478
if val <> FStartGlyphIdx then
480
FStartGlyphIdx := val;
486
// ------------------ TGLBitmapFontRanges ------------------
491
constructor TGLBitmapFontRanges.Create(AOwner: TComponent);
494
inherited Create(TGLBitmapFontRange);
499
destructor TGLBitmapFontRanges.Destroy;
506
function TGLBitmapFontRanges.GetOwner: TPersistent;
514
procedure TGLBitmapFontRanges.SetItems(index: Integer;
515
const val: TGLBitmapFontRange);
517
inherited Items[index] := val;
522
function TGLBitmapFontRanges.GetItems(index: Integer): TGLBitmapFontRange;
524
Result := TGLBitmapFontRange(inherited Items[index]);
529
function TGLBitmapFontRanges.Add: TGLBitmapFontRange;
531
Result := (inherited Add) as TGLBitmapFontRange;
536
function TGLBitmapFontRanges.Add(const StartASCII, StopASCII: WideChar)
537
: TGLBitmapFontRange;
540
Result.StartASCII := StartASCII;
541
Result.StopASCII := StopASCII;
546
function TGLBitmapFontRanges.Add(const StartASCII, StopASCII: AnsiChar)
547
: TGLBitmapFontRange;
549
Result := Add(CharToWideChar(StartASCII), CharToWideChar(StopASCII));
554
function TGLBitmapFontRanges.FindItemID(ID: Integer): TGLBitmapFontRange;
556
Result := (inherited FindItemID(ID)) as TGLBitmapFontRange;
559
// CharacterToTileIndex
561
function TGLBitmapFontRanges.CharacterToTileIndex(aChar: WideChar): Integer;
566
for i := 0 to Count - 1 do
569
if (aChar >= FStartASCII) and (aChar <= FStopASCII) then
571
Result := StartGlyphIdx + Integer(aChar) - Integer(FStartASCII);
577
function TGLBitmapFontRanges.TileIndexToChar(aIndex: Integer): WideChar;
582
for i := 0 to Count - 1 do
585
if (aIndex >= StartGlyphIdx) and (aIndex <= StopGlyphIdx) then
587
Result := WideChar(aIndex - StartGlyphIdx + Integer(FStartASCII));
593
procedure TGLBitmapFontRanges.Update(Item: TCollectionItem);
601
procedure TGLBitmapFontRanges.NotifyChange;
603
FCharCount := CalcCharacterCount;
605
if Assigned(FOwner) then
607
if FOwner is TGLBaseSceneObject then
608
TGLBaseSceneObject(FOwner).StructureChanged
609
else if FOwner is TGLCustomBitmapFont then
610
TGLCustomBitmapFont(FOwner).NotifyChange(Self);
616
function TGLBitmapFontRanges.CalcCharacterCount: Integer;
621
for i := 0 to Count - 1 do
623
Inc(Result, Integer(FStopASCII) - Integer(FStartASCII) + 1);
627
// ------------------ TGLCustomBitmapFont ------------------
632
constructor TGLCustomBitmapFont.Create(AOwner: TComponent);
634
inherited Create(AOwner);
635
FRanges := TGLBitmapFontRanges.Create(Self);
636
FGlyphs := TGLPicture.Create;
637
FGlyphs.OnChange := OnGlyphsChanged;
642
FUsers := TList.Create;
643
FMinFilter := miLinear;
644
FMagFilter := maLinear;
645
FTextures := TList.Create;
646
FTextureModified := true;
651
destructor TGLCustomBitmapFont.Destroy;
658
Assert(FUsers.Count = 0);
664
function TGLCustomBitmapFont.GetCharWidth(Ch: WideChar): Integer;
668
chi := CharacterToTileIndex(ch);
669
if Length(FChars) = 0 then
672
Result := FChars[chi].w
679
function TGLCustomBitmapFont.CalcStringWidth(const aText
680
: UnicodeString): Integer;
686
Result := -HSpace + Length(aText) * (HSpaceFix + HSpace);
687
for i := 1 to Length(aText) do
688
Result := Result + GetCharWidth(aText[i]);
696
procedure TGLCustomBitmapFont.ResetCharWidths(w: Integer = -1);
700
FCharsLoaded := False;
702
if Length(FChars) < i then
703
SetLength(FChars, i);
706
for i := 0 to High(FChars) do
712
procedure TGLCustomBitmapFont.SetCharWidths(index, value: Integer);
715
FChars[index].w := value;
720
procedure TGLCustomBitmapFont.SetRanges(const val: TGLBitmapFontRanges);
728
procedure TGLCustomBitmapFont.SetGlyphs(const val: TGLPicture);
735
procedure TGLCustomBitmapFont.SetCharWidth(const val: Integer);
737
if val <> FCharWidth then
749
procedure TGLCustomBitmapFont.SetCharHeight(const val: Integer);
751
if val <> FCharHeight then
763
procedure TGLCustomBitmapFont.SetGlyphsIntervalX(const val: Integer);
766
FGlyphsIntervalX := val
768
FGlyphsIntervalX := 0;
774
procedure TGLCustomBitmapFont.SetGlyphsIntervalY(const val: Integer);
777
FGlyphsIntervalY := val
779
FGlyphsIntervalY := 0;
785
procedure TGLCustomBitmapFont.SetHSpace(const val: Integer);
787
if val <> FHSpace then
796
procedure TGLCustomBitmapFont.SetVSpace(const val: Integer);
798
if val <> FVSpace then
807
procedure TGLCustomBitmapFont.SetMagFilter(AValue: TGLMagFilter);
809
if AValue <> FMagFilter then
811
FMagFilter := AValue;
819
procedure TGLCustomBitmapFont.SetMinFilter(AValue: TGLMinFilter);
821
if AValue <> FMinFilter then
823
FMinFilter := AValue;
831
procedure TGLCustomBitmapFont.SetGlyphsAlpha(val: TGLTextureImageAlpha);
833
if val <> FGlyphsAlpha then
843
procedure TGLCustomBitmapFont.OnGlyphsChanged(Sender: TObject);
846
// when empty, width is 0 and roundup give 1
847
if not Glyphs.Graphic.Empty then
849
if FTextureWidth = 0 then
850
FTextureWidth := RoundUpToPowerOf2(Glyphs.Width);
851
if FTextureHeight = 0 then
852
FTextureHeight := RoundUpToPowerOf2(Glyphs.Height);
858
procedure TGLCustomBitmapFont.RegisterUser(anObject: TGLBaseSceneObject);
860
Assert(FUsers.IndexOf(anObject) < 0);
861
FUsers.Add(anObject);
866
procedure TGLCustomBitmapFont.UnRegisterUser(anObject: TGLBaseSceneObject);
868
FUsers.Remove(anObject);
873
procedure TGLCustomBitmapFont.PrepareImage(var ARci: TGLRenderContextInfo);
876
bitmap32: TGLBitmap32;
881
// only check when really used
882
if FTextureWidth = 0 then
884
FTextureWidth := ARci.GLStates.MaxTextureSize;
885
if FTextureWidth > 512 then
886
FTextureWidth := 512;
887
if FTextureWidth < 64 then
890
if FTextureHeight = 0 then
892
FTextureHeight := ARci.GLStates.MaxTextureSize;
893
if FTextureHeight > 512 then
894
FTextureHeight := 512;
895
if FTextureHeight < 64 then
896
FTextureHeight := 64;
905
FTextRows := 1 + (h - 1) div FTextureHeight;
906
FTextCols := 1 + (w - 1) div FTextureWidth;
908
bitmap := TGLBitmap.Create;
912
// due to lazarus doesn't properly support pixel formats
913
PixelFormat := glpf32bit;
915
{$IFDEF GLS_DELPHI_XE2_UP}916
Width := RoundUpToPowerOf2(FTextureWidth);
917
Height := RoundUpToPowerOf2(FTextureHeight);
919
SetSize(RoundUpToPowerOf2(FTextureWidth),
920
RoundUpToPowerOf2(FTextureHeight));
924
bitmap32 := TGLBitmap32.Create;
926
while (X < w) and (Y < h) do
928
t := TGLTextureHandle.Create;
932
// texture registration
933
t.Target := ttTexture2D;
934
ARci.GLStates.TextureBinding[0, ttTexture2D] := t.Handle;
937
bitmap.Canvas.Draw(-X, -Y, Glyphs.Graphic);
938
// Clipboard.Assign(bitmap);
939
bitmap32.Assign(bitmap);
944
tiaAlphaFromIntensity:
945
SetAlphaFromIntensity;
946
tiaSuperBlackTransparent:
947
SetAlphaTransparentForColor($000000);
949
SetAlphaFromIntensity;
952
SetAlphaFromIntensity;
956
SetAlphaToValue(255);
957
tiaDefault, tiaTopLeftPointColorTransparent:
958
SetAlphaTransparentForColor(Data[Width * (Height - 1)]);
962
RegisterAsOpenGLTexture(t, not(FMinFilter in [miNearest, miLinear]),
963
TextureFormat, cap, cap, cap);
969
Inc(X, FTextureWidth);
972
Inc(Y, FTextureHeight);
982
procedure TGLCustomBitmapFont.PrepareParams(var ARci: TGLRenderContextInfo);
984
cTextureMagFilter: array [maNearest .. maLinear] of TGLEnum = (GL_NEAREST,
986
cTextureMinFilter: array [miNearest .. miLinearMipmapLinear] of TGLEnum =
987
(GL_NEAREST, GL_LINEAR, GL_NEAREST_MIPMAP_NEAREST, GL_LINEAR_MIPMAP_NEAREST,
988
GL_NEAREST_MIPMAP_LINEAR, GL_LINEAR_MIPMAP_LINEAR);
991
with ARci.GLStates do
993
UnpackAlignment := 4;
994
UnpackRowLength := 0;
996
UnpackSkipPixels := 0;
1001
Hint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST);
1003
TexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
1004
TexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);
1006
TexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER,
1007
cTextureMinFilter[FMinFilter]);
1008
TexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER,
1009
cTextureMagFilter[FMagFilter]);
1013
function TGLCustomBitmapFont.TileIndexToChar(aIndex: Integer): WideChar;
1015
Result := FRanges.TileIndexToChar(aIndex);
1018
function TGLCustomBitmapFont.CharacterToTileIndex(aChar: WideChar): Integer;
1020
Result := FRanges.CharacterToTileIndex(aChar);
1025
procedure TGLCustomBitmapFont.RenderString(var ARci: TGLRenderContextInfo;
1026
const aText: UnicodeString; aAlignment: TAlignment; aLayout: TGLTextLayout;
1027
const aColor: TColorVector; aPosition: PVector = nil;
1028
aReverseY: boolean = False);
1030
function AlignmentAdjustement(p: Integer): Single;
1035
while (p <= Length(aText)) and (aText[p] <> #13) do
1044
Result := -CalcStringWidth(Copy(aText, p - i, i))
1046
Result := Round(-CalcStringWidth(Copy(aText, p - i, i)) * 0.5);
1050
function LayoutAdjustement: Single;
1055
for i := 1 to Length(aText) do
1056
if aText[i] = #13 then
1058
case TGLTextLayout(aLayout) of
1062
Result := (n * (CharHeight + VSpace) - VSpace);
1064
Result := Round((n * (CharHeight + VSpace) - VSpace) * 0.5);
1071
TopLeft, BottomRight: TTexPoint;
1072
vTopLeft, vBottomRight: TVector;
1073
deltaV, spaceDeltaH: Single;
1074
currentChar: WideChar;
1076
if (aText = '') then
1078
// prepare texture if necessary
1081
if Assigned(aPosition) then
1082
MakePoint(vTopLeft, aPosition.V[0] + AlignmentAdjustement(1),
1083
aPosition.V[1] + LayoutAdjustement, 0)
1085
MakePoint(vTopLeft, AlignmentAdjustement(1), LayoutAdjustement, 0);
1086
deltaV := -(CharHeight + VSpace);
1088
vBottomRight.V[1] := vTopLeft.V[1] + CharHeight
1090
vBottomRight.V[1] := vTopLeft.V[1] - CharHeight;
1091
vBottomRight.V[2] := 0;
1092
vBottomRight.V[3] := 1;
1093
spaceDeltaH := GetCharWidth(#32) + HSpaceFix + HSpace;
1095
with ARci.GLStates do
1097
ActiveTextureEnabled[ttTexture2D] := true;
1098
Disable(stLighting);
1100
SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha);
1101
FLastTexture := nil;
1105
GL.Color4fv(@aColor);
1106
GL.Begin_(GL_QUADS);
1107
for i := 1 to Length(aText) do
1109
currentChar := WideChar(aText[i]);
1111
#0 .. #12, #14 .. #31:
1115
if Assigned(aPosition) then
1116
vTopLeft.V[0] := aPosition.V[0] + AlignmentAdjustement(i + 1)
1118
vTopLeft.V[0] := AlignmentAdjustement(i + 1);
1119
vTopLeft.V[1] := vTopLeft.V[1] + deltaV;
1121
vBottomRight.V[1] := vTopLeft.V[1] + CharHeight
1123
vBottomRight.V[1] := vTopLeft.V[1] - CharHeight;
1126
vTopLeft.V[0] := vTopLeft.V[0] + spaceDeltaH;
1128
chi := CharacterToTileIndex(currentChar);
1130
continue; // not found
1131
pch := @FChars[chi];
1135
GetICharTexCoords(ARci, chi, TopLeft, BottomRight);
1136
vBottomRight.V[0] := vTopLeft.V[0] + pch.w;
1138
TexCoord2fv(@TopLeft);
1139
Vertex4fv(@vTopLeft);
1141
TexCoord2f(TopLeft.S, BottomRight.t);
1142
Vertex2f(vTopLeft.V[0], vBottomRight.V[1]);
1144
TexCoord2fv(@BottomRight);
1145
Vertex4fv(@vBottomRight);
1147
TexCoord2f(BottomRight.S, TopLeft.t);
1148
Vertex2f(vBottomRight.V[0], vTopLeft.V[1]);
1150
vTopLeft.V[0] := vTopLeft.V[0] + pch.w + HSpace;
1156
ARci.GLStates.TextureBinding[0, ttTexture2D] := 0;
1157
ARci.GLStates.ActiveTextureEnabled[ttTexture2D] := False;
1162
procedure TGLCustomBitmapFont.TextOut(var rci: TGLRenderContextInfo; X, Y: Single;
1163
const Text: UnicodeString; const Color: TColorVector);
1171
RenderString(rci, Text, taLeftJustify, tlTop, Color, @V, true);
1177
procedure TGLCustomBitmapFont.TextOut(var rci: TGLRenderContextInfo; X, Y: Single;
1178
const Text: UnicodeString; const Color: TColor);
1180
TextOut(rci, X, Y, Text, ConvertWinColor(Color));
1185
function TGLCustomBitmapFont.TextWidth(const Text: UnicodeString): Integer;
1187
Result := CalcStringWidth(Text);
1192
function TGLCustomBitmapFont.CharactersPerRow: Integer;
1194
if FGlyphs.Width > 0 then
1195
Result := (FGlyphs.Width + FGlyphsIntervalX)
1196
div (FGlyphsIntervalX + FCharWidth)
1201
function TGLCustomBitmapFont.CharacterCount: Integer;
1203
Result := FRanges.CharacterCount;
1206
procedure TGLCustomBitmapFont.GetCharTexCoords(Ch: WideChar;
1207
var TopLeft, BottomRight: TTexPoint);
1209
chi, tileIndex: Integer;
1213
chi := CharacterToTileIndex(ch);
1214
if not FCharsLoaded then
1217
FCharsLoaded := true;
1218
r := CharactersPerRow;
1219
for tileIndex := 0 to CharacterCount - 1 do
1221
FChars[tileIndex].l := (tileIndex mod r) * (CharWidth + GlyphsIntervalX);
1222
FChars[tileIndex].t := (tileIndex div r) * (CharHeight + GlyphsIntervalY);
1226
if (chi < 0) or (chi >= CharacterCount) then
1229
TopLeft := NullTexPoint;
1230
BottomRight := NullTexPoint;
1235
ci.l := ci.l mod FTextureWidth;
1236
ci.t := ci.t mod FTextureHeight;
1238
TopLeft.S := ci.l / FTextureWidth;
1239
TopLeft.t := 1 - ci.t / FTextureHeight;
1240
BottomRight.S := (ci.l + ci.w) / FTextureWidth;
1241
BottomRight.t := 1 - (ci.t + CharHeight) / FTextureHeight;
1244
// TileIndexToTexCoords
1245
// it also activates the target texture
1247
procedure TGLCustomBitmapFont.GetICharTexCoords(var ARci: TGLRenderContextInfo;
1248
Chi: Integer; out TopLeft, BottomRight: TTexPoint);
1252
t: TGLTextureHandle;
1255
if not FCharsLoaded then
1257
r := CharactersPerRow;
1261
FCharsLoaded := true;
1262
for tileIndex := 0 to CharacterCount - 1 do
1264
FChars[tileIndex].l := (tileIndex mod r) * (CharWidth + GlyphsIntervalX);
1265
FChars[tileIndex].t := (tileIndex div r) * (CharHeight + GlyphsIntervalY);
1269
if (chi < 0) or (chi >= CharacterCount) then
1272
TopLeft := NullTexPoint;
1273
BottomRight := NullTexPoint;
1279
c := ci.l div FTextureWidth;
1280
r := ci.t div FTextureHeight;
1281
ci.l := ci.l mod FTextureWidth;
1282
ci.t := ci.t mod FTextureHeight;
1283
t := FTextures[r * FTextCols + c];
1285
TopLeft.S := ci.l / FTextureWidth;
1286
TopLeft.t := 1 - ci.t / FTextureHeight;
1287
BottomRight.S := (ci.l + ci.w) / FTextureWidth;
1288
BottomRight.t := 1 - (ci.t + CharHeight) / FTextureHeight;
1290
if t <> FLastTexture then
1295
ARci.GLStates.TextureBinding[0, ttTexture2D] := t.Handle;
1296
TexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);
1303
procedure TGLCustomBitmapFont.InvalidateUsers;
1307
FCharsLoaded := False;
1308
FTextureModified := true;
1309
for i := FUsers.Count - 1 downto 0 do
1310
TGLBaseSceneObject(FUsers[i]).NotifyChange(Self);
1315
procedure TGLCustomBitmapFont.FreeTextureHandle;
1319
FTextureModified := true;
1320
for i := 0 to FTextures.Count - 1 do
1321
TObject(FTextures[i]).Free;
1325
procedure TGLCustomBitmapFont.TextureChanged;
1327
FTextureModified := true;
1330
// force texture when needed
1331
procedure TGLCustomBitmapFont.CheckTexture(var ARci: TGLRenderContextInfo);
1335
// important: IsDataNeedUpdate might come from another source!
1336
for i := 0 to FTextures.Count - 1 do
1337
FTextureModified := FTextureModified or TGLTextureHandle(FTextures[i])
1340
if FTextureModified then
1342
FreeTextureHandle; // instances are recreated in prepare
1344
FTextureModified := False;
1350
function TGLCustomBitmapFont.TextureFormat: Integer;
1355
// ------------------
1356
// ------------------ TGLFlatText ------------------
1357
// ------------------
1361
constructor TGLFlatText.Create(AOwner: TComponent);
1364
ObjectStyle := ObjectStyle + [osDirectDraw, osNoVisibilityCulling];
1365
FModulateColor := TGLColor.CreateInitialized(Self, clrWhite);
1370
destructor TGLFlatText.Destroy;
1372
FModulateColor.Free;
1379
procedure TGLFlatText.Notification(AComponent: TComponent;
1380
Operation: TOperation);
1382
if (Operation = opRemove) and (AComponent = FBitmapFont) then
1389
procedure TGLFlatText.SetBitmapFont(const val: TGLCustomBitmapFont);
1391
if val <> FBitmapFont then
1393
if Assigned(FBitmapFont) then
1394
FBitmapFont.UnRegisterUser(Self);
1396
if Assigned(FBitmapFont) then
1398
FBitmapFont.RegisterUser(Self);
1399
FBitmapFont.FreeNotification(Self);
1407
procedure TGLFlatText.SetText(const val: UnicodeString);
1415
procedure TGLFlatText.SetAlignment(const val: TAlignment);
1423
procedure TGLFlatText.SetLayout(const val: TGLTextLayout);
1431
procedure TGLFlatText.SetModulateColor(const val: TGLColor);
1433
FModulateColor.Assign(val);
1438
procedure TGLFlatText.SetOptions(const val: TGLFlatTextOptions);
1440
if val <> FOptions then
1449
procedure TGLFlatText.DoRender(var rci: TGLRenderContextInfo;
1450
renderSelf, renderChildren: boolean);
1452
if Assigned(FBitmapFont) and (Text <> '') then
1454
rci.GLStates.PolygonMode := pmFill;
1455
if FModulateColor.Alpha <> 1 then
1457
rci.GLStates.Enable(stBlend);
1458
rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha);
1460
if ftoTwoSided in FOptions then
1461
rci.GLStates.Disable(stCullFace);
1462
FBitmapFont.RenderString(rci, Text, FAlignment, FLayout,
1463
FModulateColor.Color);
1466
Self.renderChildren(0, Count - 1, rci);
1471
procedure TGLFlatText.Assign(Source: TPersistent);
1473
if Assigned(Source) and (Source is TGLFlatText) then
1475
BitmapFont := TGLFlatText(Source).BitmapFont;
1476
Text := TGLFlatText(Source).Text;
1477
Alignment := TGLFlatText(Source).Alignment;
1478
Layout := TGLFlatText(Source).Layout;
1479
ModulateColor := TGLFlatText(Source).ModulateColor;
1480
Options := TGLFlatText(Source).Options;
1482
inherited Assign(Source);
1485
// ------------------------------------------------------------------
1486
// ------------------------------------------------------------------
1487
// ------------------------------------------------------------------
1491
// ------------------------------------------------------------------
1492
// ------------------------------------------------------------------
1493
// ------------------------------------------------------------------
1495
// class registrations
1496
RegisterClasses([TGLBitmapFont, TGLFlatText]);