LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
  3D Text component.
6

7
  Note: You can get valid extents (including AABB's) of this component only
8
  after it has been rendered for the first time. It means if you ask its
9
  extents during / after its creation, you will get zeros.
10

11
  Also extents are valid only when SpaceText has one line. 
12

13
   History :  
14
   25/03/11 - Yar - Fixed issue with unsharable virtual handle of font entry
15
   22/09/10 - Yar - Added unicode support (Delphi 2009 & up only)
16
   23/08/10 - Yar - Added OpenGLTokens to uses, replaced OpenGL1x functions to OpenGLAdapter
17
   22/04/10 - Yar - Fixes after GLState revision
18
   05/03/10 - DanB - More state added to TGLStateCache
19
   25/12/07 - DaStr - Added MultiLine support (thanks Lexer)
20
  Fixed Memory leak in TFontManager.Destroy
21
  (Bugtracker ID = 1857814)
22
   19/09/07 - DaStr - Added some comments
23
  Optimized TGLSpaceText.BarycenterAbsolutePosition
24
   12/09/07 - DaStr - Bugfixed TGLSpaceText.BarycenterAbsolutePosition
25
  (Didn't consider rotations)
26
   08/09/07 - DaStr - Implemented AxisAlignedDimensionsUnscaled and
27
  BarycenterAbsolutePosition for TGLSpaceText
28
   28/03/07 - DaStr - Renamed parameters in some methods
29
  (thanks Burkhard Carstens) (Bugtracker ID = 1678658)
30
   17/03/07 - DaStr - Dropped Kylix support in favor of FPC (BugTracekrID=1681585)
31
   16/03/07 - DaStr - Added explicit pointer dereferencing
32
  (thanks Burkhard Carstens) (Bugtracker ID = 1678644)
33
   19/10/06 - LC - Added TGLSpaceText.Assign. Bugtracker ID=1576445 (thanks Zapology)
34
   16/09/06 - NC - TGLVirtualHandle update (thx Lionel Reynaud)
35
   03/06/02 - EG - VirtualHandle notification fix (Sören Mühlbauer)
36
   07/03/02 - EG - GetFontBase fix (Sören Mühlbauer)
37
   30/01/02 - EG - Text Alignment (Sören Mühlbauer),
38
  TFontManager now GLContext compliant (RenderToBitmap ok!)
39
   28/12/01 - EG - Event persistence change (GliGli / Dephi bug)
40
   12/12/01 - EG - Creation (split from GLScene.pas)
41
   
42
}
43
unit GLSpaceText;
44

45
interface
46

47
{$I GLScene.inc}
48
{$IFDEF UNIX}{$MESSAGE Error 'Unit not supported'}{$ENDIF}
49

50
uses
51
  Windows, Messages, Classes,
52
  Dialogs, Graphics, Controls,
53
   
54
  GLScene, OpenGLTokens, GLTexture, GLContext, GLVectorGeometry, GLStrings,
55
  GLRenderContextInfo, GLState;
56

57
type
58

59
  // TSpaceTextCharRange
60
  //
61
  TSpaceTextCharRange = (stcrDefault, stcrAlphaNum, stcrNumbers, stcrWide);
62

63
  // TGLTextHorzAdjust
64
  //
65
  // Note: haAligned, haCentrically, haFitIn have not been implemented!
66
  //
67
  TGLTextHorzAdjust = (haLeft, haCenter, haRight, haAligned,
68
    haCentrically, haFitIn);
69

70
  // TGLTextVertAdjust
71
  //
72
  TGLTextVertAdjust = (vaTop, vaCenter, vaBottom, vaBaseLine);
73

74
  // TGLTextAdjust
75
  //
76
  TGLTextAdjust = class(TPersistent)
77
  private
78
     
79
    FHorz: TGLTextHorzAdjust;
80
    FVert: TGLTextVertAdjust;
81
    FOnChange: TNotifyEvent;
82
    procedure SetHorz(const Value: TGLTextHorzAdjust);
83
    procedure SetVert(const Value: TGLTextVertAdjust);
84

85
  public
86
     
87
    constructor Create;
88
    procedure Assign(Source: TPersistent); override;
89

90
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
91

92
  published
93
     
94
    property Horz: TGLTextHorzAdjust read FHorz write SetHorz default haLeft;
95
    property Vert: TGLTextVertAdjust read FVert write SetVert
96
      default vaBaseLine;
97
  end;
98

99
  // holds an entry in the font manager list (used in TGLSpaceText)
100
  PFontEntry = ^TFontEntry;
101

102
  TFontEntry = record
103
    Name: string;
104
    FVirtualHandle: TGLVirtualHandleTransf;
105
    Styles: TFontStyles;
106
    Extrusion: Single;
107
    RefCount: Integer;
108
    allowedDeviation: Single;
109
    firstChar, lastChar: Integer;
110
    glyphMetrics: array of TGlyphMetricsFloat;
111
    FClients: TList;
112
  end;
113

114
  // TGLSpaceText
115
  //
116
  { : Renders a text in 3D. }
117
  TGLSpaceText = class(TGLSceneObject)
118
  private
119
     
120
    FFont: TFont;
121
    FExtrusion: Single;
122
    FAllowedDeviation: Single;
123
    FCharacterRange: TSpaceTextCharRange;
124
    FAdjust: TGLTextAdjust;
125
    FAspectRatio: Single;
126
    FOblique: Single;
127
    FTextHeight: Single;
128
    FLines: TStringList;
129
    procedure SetCharacterRange(const val: TSpaceTextCharRange);
130
    procedure SetAllowedDeviation(const val: Single);
131
    procedure SetExtrusion(AValue: Single);
132
    procedure SetFont(AFont: TFont);
133
    function GetText: WideString;
134
    procedure SetLines(const Value: TStringList);
135
    procedure SetText(const AText: WideString);
136
    procedure SetAdjust(const Value: TGLTextAdjust);
137
    procedure SetAspectRatio(const Value: Single);
138
    procedure SetOblique(const Value: Single);
139
    procedure SetTextHeight(const Value: Single);
140
  protected
141
     
142
    FTextFontEntry: PFontEntry;
143
    FontChanged: Boolean;
144
    procedure DestroyHandle; override;
145
    procedure OnFontChange(sender: TObject);
146
    procedure GetFirstAndLastChar(var firstChar, lastChar: Integer);
147
    procedure DoOnLinesChange(sender: TObject); virtual;
148
  public
149
     
150
    constructor Create(AOwner: TComponent); override;
151
    destructor Destroy; override;
152

153
    procedure Assign(Source: TPersistent); override;
154

155
    procedure BuildList(var rci: TGLRenderContextInfo); override;
156
    procedure DoRender(var ARci: TGLRenderContextInfo;
157
      ARenderSelf, ARenderChildren: Boolean); override;
158

159
    function TextWidth(const str: WideString = ''): Single;
160
    function TextMaxHeight(const str: WideString = ''): Single;
161
    function TextMaxUnder(const str: WideString = ''): Single;
162

163
    { : Note: this fuction is valid only after text has been rendered
164
      the first time. Before that it returns zeros. }
165
    procedure TextMetrics(const str: WideString;
166
      out width, maxHeight, maxUnder: Single);
167
    procedure NotifyFontChanged;
168
    procedure NotifyChange(sender: TObject); override;
169
    procedure DefaultHandler(var Message); override;
170
    function AxisAlignedDimensionsUnscaled: TVector; override;
171
    function BarycenterAbsolutePosition: TVector; override;
172
  published
173
     
174
    { : Adjusts the 3D font extrusion.
175
      If Extrusion=0, the characters will be flat (2D), values >0 will
176
      give them a third dimension. }
177
    property Extrusion: Single read FExtrusion write SetExtrusion;
178
    property Font: TFont read FFont write SetFont;
179
    property Text: WideString read GetText write SetText stored False;
180
    property Lines: TStringList read FLines write SetLines;
181
    { : Quality related, see Win32 help for wglUseFontOutlines }
182
    property allowedDeviation: Single read FAllowedDeviation
183
      write SetAllowedDeviation;
184
    { : Character range to convert.
185
      Converting less characters saves time and memory... }
186
    property CharacterRange: TSpaceTextCharRange read FCharacterRange
187
      write SetCharacterRange default stcrDefault;
188
    property AspectRatio: Single read FAspectRatio write SetAspectRatio;
189
    property TextHeight: Single read FTextHeight write SetTextHeight;
190
    property Oblique: Single read FOblique write SetOblique;
191
    property Adjust: TGLTextAdjust read FAdjust write SetAdjust;
192
  end;
193

194
  // TFontManager
195
  //
196
  { : Manages a list of fonts for which display lists were created. }
197
  TFontManager = class(TList)
198
  private
199
     
200
    FCurrentBase: Integer;
201

202
  protected
203
     
204
    procedure NotifyClients(Clients: TList);
205
    procedure VirtualHandleAlloc(sender: TGLVirtualHandle;
206
      var handle: Cardinal);
207
    procedure VirtualHandleDestroy(sender: TGLVirtualHandle;
208
      var handle: Cardinal);
209

210
  public
211
     
212
    constructor Create;
213
    destructor Destroy; override;
214

215
    function FindFont(AName: string; FStyles: TFontStyles; FExtrusion: Single;
216
      FAllowedDeviation: Single; FFirstChar, FLastChar: Integer): PFontEntry;
217
    function GetFontBase(AName: string; FStyles: TFontStyles;
218
      FExtrusion: Single; allowedDeviation: Single;
219
      firstChar, lastChar: Integer; client: TObject): PFontEntry;
220
    procedure Release(entry: PFontEntry; client: TObject);
221
  end;
222

223
function FontManager: TFontManager;
224
procedure ReleaseFontManager;
225

226
var
227
  vFontManagerMsgID: Cardinal;
228

229
  // ------------------------------------------------------------------
230
  // ------------------------------------------------------------------
231
  // ------------------------------------------------------------------
232
implementation
233

234
// ------------------------------------------------------------------
235
// ------------------------------------------------------------------
236
// ------------------------------------------------------------------
237

238
uses
239
  SysUtils;
240

241
const
242
  cFontManagerMsg = 'GLScene FontManagerMessage';
243

244
var
245
  vFontManager: TFontManager;
246

247
  // FontManager
248
  //
249

250
function FontManager: TFontManager;
251
begin
252
  if not Assigned(vFontManager) then
253
    vFontManager := TFontManager.Create;
254
  Result := vFontManager;
255
end;
256

257
// ReleaseFontManager
258
//
259

260
procedure ReleaseFontManager;
261
begin
262
  if Assigned(vFontManager) then
263
  begin
264
    vFontManager.Free;
265
    vFontManager := nil;
266
  end;
267
end;
268

269
// ------------------
270
// ------------------ TGLTextAdjust ------------------
271
// ------------------
272

273
// Create
274
//
275

276
constructor TGLTextAdjust.Create;
277
begin
278
  inherited;
279
  FHorz := haLeft;
280
  FVert := vaBaseLine;
281
end;
282

283
 
284
//
285

286
procedure TGLTextAdjust.Assign(Source: TPersistent);
287
begin
288
  if Source is TGLTextAdjust then
289
  begin
290
    FHorz := TGLTextAdjust(Source).Horz;
291
    FVert := TGLTextAdjust(Source).Vert;
292
    if Assigned(FOnChange) then
293
      FOnChange(Self);
294
  end
295
  else
296
    inherited Assign(Source);
297
end;
298

299
// SetHorz
300
//
301

302
procedure TGLTextAdjust.SetHorz(const Value: TGLTextHorzAdjust);
303
begin
304
  if FHorz <> Value then
305
  begin
306
    FHorz := Value;
307
    if Assigned(FOnChange) then
308
      FOnChange(Self);
309
  end;
310
end;
311

312
// SetVert
313
//
314

315
procedure TGLTextAdjust.SetVert(const Value: TGLTextVertAdjust);
316
begin
317
  if Value <> FVert then
318
  begin
319
    FVert := Value;
320
    if Assigned(FOnChange) then
321
      FOnChange(Self);
322
  end;
323
end;
324

325
// ------------------
326
// ------------------ TGLSpaceText ------------------
327
// ------------------
328

329
// Create
330
//
331

332
constructor TGLSpaceText.Create(AOwner: TComponent);
333
begin
334
  inherited Create(AOwner);
335
  FFont := TFont.Create;
336
  FFont.Name := 'Arial';
337
  FontChanged := True;
338
  CharacterRange := stcrDefault;
339
  FFont.OnChange := OnFontChange;
340
  FAdjust := TGLTextAdjust.Create;
341
  FAdjust.OnChange := OnFontChange;
342
  FLines := TStringList.Create;
343
  FLines.OnChange := DoOnLinesChange;
344
end;
345

346
// Destroy
347
//
348

349
destructor TGLSpaceText.Destroy;
350
begin
351
  FAdjust.OnChange := nil;
352
  FAdjust.Free;
353
  FFont.OnChange := nil;
354
  FFont.Free;
355
  FLines.Free;
356
  FontManager.Release(FTextFontEntry, Self);
357
  inherited Destroy;
358
end;
359

360
// TextMetrics
361
//
362

363
procedure TGLSpaceText.TextMetrics(const str: WideString;
364
  out width, maxHeight, maxUnder: Single);
365
var
366
  i, firstChar, lastChar, diff: Integer;
367
  buf: WideString;
368
  gmf: TGlyphMetricsFloat;
369
begin
370
  width := 0;
371
  maxUnder := 0;
372
  maxHeight := 0;
373
  if Assigned(FTextFontEntry) then
374
  begin
375
    GetFirstAndLastChar(firstChar, lastChar);
376
    if str = '' then
377
      buf := GetText
378
    else
379
      buf := str;
380
    for i := 1 to Length(buf) do
381
    begin
382
      diff := Integer(buf[i]) - firstChar;
383
      if diff > High(FTextFontEntry^.glyphMetrics) then
384
        continue;
385
      gmf := FTextFontEntry^.glyphMetrics[diff];
386
      width := width + gmf.gmfCellIncX;
387
      if gmf.gmfptGlyphOrigin.y > maxHeight then
388
        maxHeight := gmf.gmfptGlyphOrigin.y;
389
      if gmf.gmfptGlyphOrigin.y - gmf.gmfBlackBoxY < maxUnder then
390
        maxUnder := gmf.gmfptGlyphOrigin.y - gmf.gmfBlackBoxY;
391
    end;
392
  end;
393
end;
394

395
// TextWidth
396
//
397

398
function TGLSpaceText.TextWidth(const str: WideString = ''): Single;
399
var
400
  mh, mu: Single;
401
begin
402
  TextMetrics(str, Result, mh, mu);
403
end;
404

405
// TextMaxHeight
406
//
407

408
function TGLSpaceText.TextMaxHeight(const str: WideString = ''): Single;
409
var
410
  w, mu: Single;
411
begin
412
  TextMetrics(str, w, Result, mu);
413
end;
414

415
// TextMaxUnder
416
//
417

418
function TGLSpaceText.TextMaxUnder(const str: WideString = ''): Single;
419
var
420
  w, mh: Single;
421
begin
422
  TextMetrics(str, w, mh, Result);
423
end;
424

425
 
426

427
procedure TGLSpaceText.Assign(Source: TPersistent);
428
begin
429
  inherited Assign(Source);
430
  if Source is TGLSpaceText then
431
  begin
432
    FAdjust.Assign(TGLSpaceText(Source).FAdjust);
433
    FFont.Assign(TGLSpaceText(Source).FFont);
434
    FAllowedDeviation := TGLSpaceText(Source).allowedDeviation;
435
    FAspectRatio := TGLSpaceText(Source).FAspectRatio;
436
    FCharacterRange := TGLSpaceText(Source).CharacterRange;
437
    FExtrusion := TGLSpaceText(Source).FExtrusion;
438
    FOblique := TGLSpaceText(Source).FOblique;
439
    FLines.Text := TGLSpaceText(Source).FLines.Text;
440
    FTextHeight := TGLSpaceText(Source).FTextHeight;
441
    StructureChanged;
442
  end;
443
end;
444

445
// BuildList
446
//
447

448
procedure TGLSpaceText.BuildList(var rci: TGLRenderContextInfo);
449
var
450
  textL, maxUnder, maxHeight: Single;
451
  charScale: Single;
452
  i, j, k, c: Integer;
453
  glBase: TGLuint;
454
  dirtyLine, cleanLine: WideString;
455
begin
456
  if Length(GetText) > 0 then
457
  begin
458
    GL.PushMatrix;
459

460
    // FAspectRatio ignore
461
    if FAspectRatio <> 0 then
462
      GL.Scalef(FAspectRatio, 1, 1);
463
    if FOblique <> 0 then
464
      GL.Rotatef(FOblique, 0, 0, 1);
465

466
    glBase := FTextFontEntry^.FVirtualHandle.handle;
467
    case FCharacterRange of
468
      stcrAlphaNum:
469
        GL.ListBase(TGLuint(Integer(glBase) - 32));
470
      stcrNumbers:
471
        GL.ListBase(TGLuint(Integer(glBase) - Integer('0')));
472
    else
473
      GL.ListBase(glBase);
474
    end;
475

476
    rci.GLStates.PushAttrib([sttPolygon]);
477
    for i := 0 to FLines.Count - 1 do
478
    begin
479
      GL.PushMatrix;
480

481
      TextMetrics(FLines.Strings[i], textL, maxHeight, maxUnder);
482
      if (FAdjust.Horz <> haLeft) or (FAdjust.Vert <> vaBaseLine) or
483
        (FTextHeight <> 0) then
484
      begin
485
        if FTextHeight <> 0 then
486
        begin
487
          charScale := FTextHeight / maxHeight;
488
          GL.Scalef(charScale, charScale, 1);
489
        end;
490
        case FAdjust.Horz of
491
          haLeft:
492
            ; // nothing
493
          haCenter:
494
            GL.Translatef(-textL * 0.5, 0, 0);
495
          haRight:
496
            GL.Translatef(-textL, 0, 0);
497
        end;
498
        case FAdjust.Vert of
499
          vaBaseLine:
500
            ; // nothing;
501
          vaBottom:
502
            GL.Translatef(0, abs(maxUnder), 0);
503
          vaCenter:
504
            GL.Translatef(0, abs(maxUnder) * 0.5 - maxHeight * 0.5, 0);
505
          vaTop:
506
            GL.Translatef(0, -maxHeight, 0);
507
        end;
508
      end;
509

510
      GL.Translatef(0, -i * (maxHeight + FAspectRatio), 0);
511
      if FCharacterRange = stcrWide then
512
      begin
513
        dirtyLine := FLines.Strings[i];
514
        SetLength(cleanLine, Length(dirtyLine));
515
        k := 1;
516
        for j := 1 to Length(dirtyLine) do
517
        begin
518
          c := Integer(dirtyLine[j]);
519
          if (c >= FTextFontEntry^.firstChar) and
520
            (c <= FTextFontEntry^.lastChar) then
521
          begin
522
            cleanLine[k] := dirtyLine[j];
523
            Inc(k);
524
          end;
525
        end;
526
        if k > 1 then
527
          GL.CallLists(k - 1, GL_UNSIGNED_SHORT, PWideChar(cleanLine))
528
      end
529
      else
530
        GL.CallLists(Length(FLines.Strings[i]), GL_UNSIGNED_BYTE,
531
          PGLChar(TGLString(FLines.Strings[i])));
532
      GL.PopMatrix;
533
    end;
534
    rci.GLStates.PopAttrib();
535
    GL.PopMatrix;
536
  end;
537
end;
538

539
// DestroyHandle
540
//
541

542
procedure TGLSpaceText.DestroyHandle;
543
begin
544
  FontChanged := True;
545
  inherited;
546
end;
547

548
// GetFirstAndLastChar
549
//
550

551
procedure TGLSpaceText.GetFirstAndLastChar(var firstChar, lastChar: Integer);
552
begin
553
  case FCharacterRange of
554
    stcrAlphaNum:
555
      begin
556
        firstChar := 32;
557
        lastChar := 127;
558
      end;
559
    stcrNumbers:
560
      begin
561
        firstChar := Integer('0');
562
        lastChar := Integer('9');
563
      end;
564
    stcrDefault:
565
      begin
566
        firstChar := 0;
567
        lastChar := 255;
568
      end;
569
    stcrWide:
570
      begin
571
        firstChar := 0;
572
        lastChar := $077F;
573
      end;
574
  end;
575
end;
576

577
// DoRender
578
//
579

580
procedure TGLSpaceText.DoRender(var ARci: TGLRenderContextInfo;
581
  ARenderSelf, ARenderChildren: Boolean);
582
var
583
  firstChar, lastChar: Integer;
584
begin
585
  if GetText <> '' then
586
  begin
587
    if Assigned(FTextFontEntry) then
588
      FTextFontEntry^.FVirtualHandle.AllocateHandle;
589
    if FontChanged or (Assigned(FTextFontEntry) and
590
      (FTextFontEntry^.FVirtualHandle.IsDataNeedUpdate)) then
591
      with FFont do
592
      begin
593
        FontManager.Release(FTextFontEntry, Self);
594
        GetFirstAndLastChar(firstChar, lastChar);
595
        FTextFontEntry := FontManager.GetFontBase(Name, Style, FExtrusion,
596
          FAllowedDeviation, firstChar, lastChar, Self);
597
        FontChanged := False;
598
        FTextFontEntry^.FVirtualHandle.NotifyDataUpdated;
599
      end;
600
  end;
601
  inherited;
602
end;
603

604
// SetExtrusion
605
//
606

607
procedure TGLSpaceText.SetExtrusion(AValue: Single);
608
begin
609
  Assert(AValue >= 0, 'Extrusion must be >=0');
610
  if FExtrusion <> AValue then
611
  begin
612
    FExtrusion := AValue;
613
    OnFontChange(nil);
614
  end;
615
end;
616

617
// SetAllowedDeviation
618
//
619

620
procedure TGLSpaceText.SetAllowedDeviation(const val: Single);
621
begin
622
  if FAllowedDeviation <> val then
623
  begin
624
    if val > 0 then
625
      FAllowedDeviation := val
626
    else
627
      FAllowedDeviation := 0;
628
    OnFontChange(nil);
629
  end;
630
end;
631

632
// SetCharacterRange
633
//
634

635
procedure TGLSpaceText.SetCharacterRange(const val: TSpaceTextCharRange);
636
begin
637
  if FCharacterRange <> val then
638
  begin
639
    FCharacterRange := val;
640
    OnFontChange(nil);
641
  end;
642
end;
643

644
// SetFont
645
//
646

647
procedure TGLSpaceText.SetFont(AFont: TFont);
648
begin
649
  FFont.Assign(AFont);
650
  OnFontChange(nil);
651
end;
652

653
// OnFontChange
654
//
655

656
procedure TGLSpaceText.OnFontChange(sender: TObject);
657
begin
658
  FontChanged := True;
659
  StructureChanged;
660
end;
661

662
// SetText
663
//
664

665
procedure TGLSpaceText.SetText(const AText: WideString);
666
begin
667
  if GetText <> AText then
668
  begin
669
    FLines.Text := AText;
670
    // StructureChanged is Called in DoOnLinesChange.
671
  end;
672
end;
673

674
procedure TGLSpaceText.DoOnLinesChange(sender: TObject);
675
begin
676
  StructureChanged;
677
end;
678

679
// SetAdjust
680
//
681

682
function TGLSpaceText.GetText: WideString;
683
begin
684
  if FLines.Count = 1 then
685
    Result := FLines[0]
686
  else
687
    Result := FLines.Text;
688
end;
689

690
// SetAdjust
691
//
692

693
procedure TGLSpaceText.SetLines(const Value: TStringList);
694
begin
695
  FLines.Assign(Value);
696
end;
697

698
// SetAdjust
699
//
700

701
procedure TGLSpaceText.SetAdjust(const Value: TGLTextAdjust);
702
begin
703
  FAdjust.Assign(Value);
704
  StructureChanged;
705
end;
706

707
// SetAspectRatio
708
//
709

710
procedure TGLSpaceText.SetAspectRatio(const Value: Single);
711
begin
712
  if FAspectRatio <> Value then
713
  begin
714
    FAspectRatio := Value;
715
    StructureChanged;
716
  end;
717
end;
718

719
// SetOblique
720
//
721

722
procedure TGLSpaceText.SetOblique(const Value: Single);
723
begin
724
  if FOblique <> Value then
725
  begin
726
    FOblique := Value;
727
    StructureChanged;
728
  end;
729
end;
730

731
// SetTextHeight
732
//
733

734
procedure TGLSpaceText.SetTextHeight(const Value: Single);
735
begin
736
  if Value <> FTextHeight then
737
  begin
738
    FTextHeight := Value;
739
    StructureChanged;
740
  end;
741
end;
742

743
// NotifyFontChanged
744
//
745

746
procedure TGLSpaceText.NotifyFontChanged;
747
begin
748
  FTextFontEntry := nil;
749
  FontChanged := True;
750
end;
751

752
// NotifyChange
753
//
754

755
procedure TGLSpaceText.NotifyChange(sender: TObject);
756
begin
757
  if sender is TFontManager then
758
    NotifyFontChanged
759
  else
760
    inherited;
761
end;
762

763
// DefaultHandler
764
//
765

766
procedure TGLSpaceText.DefaultHandler(var Message);
767
begin
768
  with TMessage(Message) do
769
  begin
770
    if Msg = vFontManagerMsgID then
771
      NotifyFontChanged
772
    else
773
      inherited;
774
  end;
775
end;
776

777
// BarycenterAbsolutePosition
778
//
779

780
function TGLSpaceText.BarycenterAbsolutePosition: TVector;
781
var
782
  lWidth, lHeightMax, lHeightMin: Single;
783
  AdjustVector: TVector;
784
begin
785
  TextMetrics(Text, lWidth, lHeightMax, lHeightMin);
786

787
  case FAdjust.FHorz of
788
    haLeft:
789
      AdjustVector.V[0] := lWidth / 2;
790
    haCenter:
791
      AdjustVector.V[0] := 0; // Nothing.
792
    haRight:
793
      AdjustVector.V[0] := -lWidth / 2;
794
  else
795
    begin
796
      AdjustVector.V[0] := 0;
797
      Assert(False, glsErrorEx + glsUnknownType); // Not implemented...
798
    end;
799
  end;
800

801
  case FAdjust.FVert of
802
    vaTop:
803
      AdjustVector.V[1] := -(abs(lHeightMin) * 0.5 + lHeightMax * 0.5);
804
    vaCenter:
805
      AdjustVector.V[1] := 0; // Nothing.
806
    vaBottom:
807
      AdjustVector.V[1] := (abs(lHeightMin) * 0.5 + lHeightMax * 0.5);
808
    vaBaseLine:
809
      AdjustVector.V[1] := -(abs(lHeightMin) * 0.5 - lHeightMax * 0.5);
810
  else
811
    begin
812
      AdjustVector.V[1] := 0;
813
      Assert(False, glsErrorEx + glsUnknownType); // Not implemented...
814
    end;
815
  end;
816

817
  AdjustVector.V[2] := -(FExtrusion / 2);
818
  AdjustVector.V[3] := 1;
819
  Result := LocalToAbsolute(AdjustVector);
820
end;
821

822
// AxisAlignedDimensionsUnscaled
823
//
824

825
function TGLSpaceText.AxisAlignedDimensionsUnscaled: TVector;
826
var
827
  lWidth, lHeightMax, lHeightMin: Single;
828
  charScale: Single;
829
begin
830
  TextMetrics(Text, lWidth, lHeightMax, lHeightMin);
831

832
  if FTextHeight = 0 then
833
    charScale := 1
834
  else
835
    charScale := FTextHeight / lHeightMax;
836

837
  Result.V[0] := lWidth / 2 * charScale;
838
  Result.V[1] := (lHeightMax + abs(lHeightMin)) / 2 * charScale;
839
  Result.V[2] := FExtrusion / 2;
840
  Result.V[3] := 0;
841
end;
842

843
// ------------------
844
// ------------------ TFontManager ------------------
845
// ------------------
846

847
// Create
848
//
849

850
constructor TFontManager.Create;
851
begin
852
  inherited;
853
end;
854

855
// Destroy
856
//
857

858
destructor TFontManager.Destroy;
859
var
860
  i: Integer;
861
begin
862
  for i := 0 to Count - 1 do
863
  begin
864
    TFontEntry(Items[i]^).FVirtualHandle.Free;
865
    NotifyClients(TFontEntry(Items[i]^).FClients);
866
    TFontEntry(Items[i]^).FClients.Free;
867
    TFontEntry(Items[i]^).Name := '';
868
    FreeMem(Items[i], SizeOf(TFontEntry));
869
  end;
870
  inherited Destroy;
871
end;
872

873
// VirtualHandleAlloc
874
//
875

876
procedure TFontManager.VirtualHandleAlloc(sender: TGLVirtualHandle;
877
  var handle: Cardinal);
878
begin
879
  handle := FCurrentBase;
880
end;
881

882
// VirtualHandleDestroy
883
//
884

885
procedure TFontManager.VirtualHandleDestroy(sender: TGLVirtualHandle;
886
  var handle: Cardinal);
887
begin
888
  if handle <> 0 then
889
    GL.DeleteLists(handle, sender.Tag);
890
end;
891

892
// FindFond
893
//
894

895
function TFontManager.FindFont(AName: string; FStyles: TFontStyles;
896
  FExtrusion: Single; FAllowedDeviation: Single; FFirstChar, FLastChar: Integer)
897
  : PFontEntry;
898
var
899
  i: Integer;
900
begin
901
  Result := nil;
902
  // try to find an entry with the required attributes
903
  for i := 0 to Count - 1 do
904
    with TFontEntry(Items[i]^) do
905
      if (CompareText(Name, AName) = 0) and (Styles = FStyles) and
906
        (Extrusion = FExtrusion) and (allowedDeviation = FAllowedDeviation) and
907
        (firstChar = FFirstChar) and (lastChar = FLastChar) then
908
      begin
909
        // entry found
910
        Result := Items[i];
911
        Break;
912
      end;
913
end;
914

915
// GetFontBase
916
//
917

918
function TFontManager.GetFontBase(AName: string; FStyles: TFontStyles;
919
  FExtrusion: Single; allowedDeviation: Single; firstChar, lastChar: Integer;
920
  client: TObject): PFontEntry;
921
var
922
  NewEntry: PFontEntry;
923
  MemDC: HDC;
924
  AFont: TFont;
925
  nbLists: Integer;
926
  success: Boolean;
927
begin
928
  NewEntry := FindFont(AName, FStyles, FExtrusion, allowedDeviation, firstChar,
929
    lastChar);
930
  if Assigned(NewEntry) then
931
  begin
932
    Inc(NewEntry^.RefCount);
933
    if NewEntry^.FClients.IndexOf(client) < 0 then
934
      NewEntry^.FClients.Add(client);
935
    Result := NewEntry;
936
  end
937
  else
938
    Result := nil;
939
  if (Result = nil) or (Assigned(Result) and
940
    (Result^.FVirtualHandle.handle = 0)) then
941
  begin
942
    // no entry found, or entry was purged
943
    nbLists := lastChar - firstChar + 1;
944
    if not Assigned(NewEntry) then
945
    begin
946
      // no entry found, so create one
947
      New(NewEntry);
948
      NewEntry^.Name := AName;
949
      NewEntry^.FVirtualHandle := TGLVirtualHandleTransf.Create;
950
      NewEntry^.FVirtualHandle.OnAllocate := VirtualHandleAlloc;
951
      NewEntry^.FVirtualHandle.OnDestroy := VirtualHandleDestroy;
952
      NewEntry^.FVirtualHandle.Tag := nbLists;
953
      NewEntry^.Styles := FStyles;
954
      NewEntry^.Extrusion := FExtrusion;
955
      NewEntry^.RefCount := 1;
956
      NewEntry^.firstChar := firstChar;
957
      NewEntry^.lastChar := lastChar;
958
      SetLength(NewEntry^.glyphMetrics, nbLists);
959
      NewEntry^.allowedDeviation := allowedDeviation;
960
      NewEntry^.FClients := TList.Create;
961
      NewEntry^.FClients.Add(client);
962
      Add(NewEntry);
963
    end;
964
    // create a font to be used while display list creation
965
    AFont := TFont.Create;
966
    MemDC := CreateCompatibleDC(0);
967
    try
968
      AFont.Name := AName;
969
      AFont.Style := FStyles;
970
      SelectObject(MemDC, AFont.handle);
971
      FCurrentBase := GL.GenLists(nbLists);
972
      if FCurrentBase = 0 then
973
        raise Exception.Create('FontManager: no more display lists available');
974
      NewEntry^.FVirtualHandle.AllocateHandle;
975
      if lastChar < 256 then
976
      begin
977
        success := wglUseFontOutlinesA(MemDC, firstChar, nbLists, FCurrentBase,
978
          allowedDeviation, FExtrusion, WGL_FONT_POLYGONS,
979
          @NewEntry^.glyphMetrics[0]);
980
      end
981
      else
982
      begin
983
        success := wglUseFontOutlinesW(MemDC, firstChar, nbLists, FCurrentBase,
984
          allowedDeviation, FExtrusion, WGL_FONT_POLYGONS,
985
          @NewEntry^.glyphMetrics[0]);
986
      end;
987
      if not success then
988
        raise Exception.Create('FontManager: font creation failed');
989
    finally
990
      AFont.Free;
991
      DeleteDC(MemDC);
992
    end;
993
    Result := NewEntry;
994
  end;
995
end;
996

997
// Release
998
//
999

1000
procedure TFontManager.Release(entry: PFontEntry; client: TObject);
1001
var
1002
  hMsg: TMessage;
1003
begin
1004
  if Assigned(entry) then
1005
  begin
1006
    Dec(entry^.RefCount);
1007
    if Assigned(client) then
1008
    begin
1009
      hMsg.Msg := vFontManagerMsgID;
1010
      client.DefaultHandler(hMsg);
1011
    end;
1012
    entry^.FClients.Remove(client);
1013
    if entry^.RefCount = 0 then
1014
    begin
1015
      entry^.FVirtualHandle.Free;
1016
      NotifyClients(entry^.FClients);
1017
      entry^.FClients.Free;
1018
      Remove(entry);
1019
      Dispose(entry)
1020
    end;
1021
  end;
1022
end;
1023

1024
// NotifyClients
1025
//
1026

1027
procedure TFontManager.NotifyClients(Clients: TList);
1028
var
1029
  i: Integer;
1030
  hMsg: TMessage;
1031
begin
1032
  hMsg.Msg := vFontManagerMsgID;
1033
  for i := 0 to Clients.Count - 1 do
1034
    TObject(Clients[i]).DefaultHandler(hMsg);
1035
end;
1036

1037
// -------------------------------------------------------------
1038
// -------------------------------------------------------------
1039
// -------------------------------------------------------------
1040
initialization
1041

1042
// -------------------------------------------------------------
1043
// -------------------------------------------------------------
1044
// -------------------------------------------------------------
1045

1046
vFontManagerMsgID := RegisterWindowMessage(cFontManagerMsg);
1047
RegisterClass(TGLSpaceText);
1048

1049
finalization
1050

1051
ReleaseFontManager;
1052

1053
end.
1054