LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   OpenGL windows management classes and structures
6

7
  History :  
8
       10/11/12 - PW - Added CPP compatibility: changed vector arrays to records,
9
                          renamed lowercase sender and accept to uppercase Sender and Accept
10
       16/03/11 - Yar - Fixes after emergence of GLMaterialEx
11
       23/08/10 - Yar - Added OpenGLTokens to uses, replaced OpenGL1x functions to OpenGLAdapter
12
       11/06/10 - YP - Link GUI elements to their parent
13
       22/04/10 - Yar - Fixes after GLState revision
14
       05/03/10 - DanB - More state added to TGLStateCache
15
       17/10/08 - DanB - reversed order of vertices in TGLCustomControl.InternalRender,
16
                            which fixes the GUIPaint demo
17
       27/04/08 - DaStr - Fixed bug in TGLButton.InternalRender()
18
                             (thanks Nicoara Adrian) (BugtrackerID = 1952711)
19
       06/06/07 - DaStr - Added GLColor to uses (BugtrackerID = 1732211)
20
       20/12/06 - DaStr - Added: TGLEdit.ReadOnly, TGLScrollbar.Locked,
21
                                    TGLStringGrid.ColSelect
22
       10/11/05 - Mathx - Fixed TGLPopupMenu stack overflow on method internalRender.
23
                             Related to bug 1193909.
24
       24/05/02 - JAJ - Base Unit built on basis of Jan Horn's demo at
25
                            (http://www.sulaco.co.za/opengl/windows.zip)
26
       01/06/02 - JAJ - After not having received Jan Horn's blessing, the
27
                            system have been revised all parts have been rewritten.
28
       01/01/03 - JAJ - Updated so that focused controls pass focus on hide...
29
       05/01/03 - JAJ - Cleaned up the DesignTime AccessViolations...
30
       07/01/03 - JAJ - Jeremy Darling modified the TGLEdit's Render, more
31
                            updates on TGLEdit expected...
32
       18/01/03 - JAJ - Added TGLStringList, TGLScrollbar, TGLPopupMenu...
33
       08/08/03 - PS  - Added Horizontal to GLScrollbar...
34
       14/08/03 - SG  - Fixed TGLBaseComponent.SetGuiLayout (Joen Joensen)
35
       08/08/03 - JAJ - Merged PS's and SG's update... Added TitleOffset...
36
       03/07/04 - LR - Added constant for Keyboard (glKey_TAB, ...)
37
                          Added function GLOKMessageBox to avoid the uses of Forms
38
                          Replace TColor, TBitmap, TMouseEvent, TKeyEvent, ...
39
                          by TGLColor, TGLBitmap, TGLMouseEvent, TGLKeyEvent, ...
40
       25/01/05 - AX - Corrected AlphaChannel default value, must be 1
41
                          TGLButton, TGLForm - AlphaChannel behaviour text.
42
                          Added events OnMouseEnter/OnMouseLeave for all controls
43
       05/02/05 - AX - TGLLabel correct layout depending on Aligment and TextLayout.
44
  
45
}
46

47
unit GLWindows;
48

49
interface
50

51
{$I GLScene.inc}
52

53
uses
54
  Classes, SysUtils,
55
  GLScene, GLHUDObjects, GLMaterial, OpenGLTokens, GLContext,
56
  GLBitmapFont, GLWindowsFont, GLVectorGeometry, GLGui,
57
  GLCrossPlatform, GLColor, GLRenderContextInfo, GLBaseClasses;
58

59
type
60

61
  TGLBaseComponent = class(TGLBaseGuiObject)
62
  private
63
    FGUIRedraw: Boolean;
64
    FGuiLayout: TGLGuiLayout;
65
    FGuiLayoutName: TGLGuiComponentName;
66
    FGuiComponent: TGLGuiComponent;
67
    FReBuildGui: Boolean;
68
    FRedrawAtOnce: Boolean;
69
    MoveX, MoveY: TGLFloat;
70
    FRenderStatus: TGUIDrawResult;
71

72
    FAlphaChannel: Single;
73
    FRotation: TGLFloat;
74
    FNoZWrite: Boolean;
75

76
    BlockRendering: Boolean;
77
    RenderingCount: Integer;
78
    BlockedCount: Integer;
79
    GuiDestroying: Boolean;
80
    FDoChangesOnProgress: Boolean;
81
    FAutosize: Boolean;
82

83
    procedure SetGUIRedraw(value: Boolean);
84
    procedure SetDoChangesOnProgress(const Value: Boolean);
85
    procedure SetAutosize(const Value: Boolean);
86
  protected
87
    procedure RenderHeader(var rci: TGLRenderContextInfo; renderSelf,
88
      renderChildren: Boolean);
89
    procedure RenderFooter(var rci: TGLRenderContextInfo; renderSelf,
90
      renderChildren: Boolean);
91

92
    procedure SetGuiLayout(NewGui: TGLGuiLayout); virtual;
93
    procedure SetGuiLayoutName(NewName: TGLGuiComponentName);
94

95
    procedure Notification(AComponent: TComponent; Operation: TOperation);
96
      override;
97

98
    procedure SetRotation(const val: TGLFloat);
99
    procedure SetAlphaChannel(const val: Single);
100
    function StoreAlphaChannel: Boolean;
101
    procedure SetNoZWrite(const val: Boolean);
102

103
  public
104
    procedure BlockRender;
105
    procedure UnBlockRender;
106

107
    constructor Create(AOwner: TComponent); override;
108
    destructor Destroy; override;
109

110
    procedure NotifyChange(Sender: TObject); override;
111
    procedure DoChanges; virtual;
112
    procedure MoveGUI(XRel, YRel: Single);
113
    procedure PlaceGUI(XPos, YPos: Single);
114

115
    procedure DoProgress(const progressTime: TProgressTimes); override;
116

117
    procedure DoRender(var rci: TGLRenderContextInfo; renderSelf, renderChildren:
118
      Boolean); override;
119
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
120
      renderChildren: Boolean); virtual;
121
    property GUIRedraw: Boolean read FGUIRedraw write SetGUIRedraw;
122
    property ReBuildGui: Boolean read FReBuildGui write FReBuildGui;
123
  published
124
    property Autosize: Boolean read FAutosize write SetAutosize;
125
    property RedrawAtOnce: Boolean read FRedrawAtOnce write FRedrawAtOnce;
126
    property GuiLayout: TGLGuiLayout read FGuiLayout write SetGuiLayout;
127
    property GuiLayoutName: TGLGuiComponentName read FGuiLayoutName write
128
      SetGuiLayoutName;
129

130
    { This the ON-SCREEN rotation of the GuiComponent.
131
       Rotatation=0 is handled faster. }
132
    property Rotation: TGLFloat read FRotation write SetRotation;
133
    { If different from 1, this value will replace that of Diffuse.Alpha }
134
    property AlphaChannel: Single read FAlphaChannel write SetAlphaChannel stored
135
      StoreAlphaChannel;
136
    { If True, GuiComponent will not write to Z-Buffer.
137
       GuiComponent will STILL be maskable by ZBuffer test. }
138
    property NoZWrite: Boolean read FNoZWrite write SetNoZWrite;
139

140
    property DoChangesOnProgress: Boolean read FDoChangesOnProgress write
141
      SetDoChangesOnProgress;
142
    property Visible;
143
    property Width;
144
    property Height;
145
    property Left;
146
    property Top;
147
    property Position;
148
  end;
149

150
  TGLFocusControl = class;
151
  TGLBaseControl = class;
152

153
  TGLMouseAction = (ma_mouseup, ma_mousedown, ma_mousemove);
154

155
  TGLAcceptMouseQuery = procedure(Sender: TGLBaseControl; Shift: TShiftState;
156
    Action: TGLMouseAction; Button: TGLMouseButton; X, Y: Integer; var Accept:
157
    boolean) of object;
158
  TGLBaseControl = class(TGLBaseComponent)
159
  private
160
    FOnMouseDown: TGLMouseEvent;
161
    FOnMouseMove: TGLMouseMoveEvent;
162
    FOnMouseUp: TGLMouseEvent;
163
    FKeepMouseEvents: Boolean;
164
    FActiveControl: TGLBaseControl;
165
    FFocusedControl: TGLFocusControl;
166
    FOnAcceptMouseQuery: TGLAcceptMouseQuery;
167
    FOnMouseLeave: TNotifyEvent;
168
    FOnMouseEnter: TNotifyEvent;
169
    FEnteredControl: TGLBaseControl;
170
  protected
171
    procedure InternalMouseDown(Shift: TShiftState; Button: TGLMouseButton; X,
172
      Y: Integer); virtual;
173
    procedure InternalMouseUp(Shift: TShiftState; Button: TGLMouseButton; X, Y:
174
      Integer); virtual;
175
    procedure InternalMouseMove(Shift: TShiftState; X, Y: Integer); virtual;
176
    procedure SetActiveControl(NewControl: TGLBaseControl);
177
    procedure SetFocusedControl(NewControl: TGLFocusControl);
178
    function FindFirstGui: TGLBaseControl;
179
    procedure Notification(AComponent: TComponent; Operation: TOperation);
180
      override;
181

182
    procedure DoMouseEnter;
183
    procedure DoMouseLeave;
184
  public
185
    function MouseDown(Sender: TObject; Button: TGLMouseButton; Shift:
186
      TShiftState; X, Y: Integer): Boolean; virtual;
187
    function MouseUp(Sender: TObject; Button: TGLMouseButton; Shift:
188
      TShiftState; X, Y: Integer): Boolean; virtual;
189
    function MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer):
190
      Boolean; virtual;
191
    procedure KeyPress(Sender: TObject; var Key: Char); virtual;
192
    procedure KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
193
      virtual;
194
    procedure KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
195
      virtual;
196
    property ActiveControl: TGLBaseControl read FActiveControl write
197
      SetActiveControl;
198
    property KeepMouseEvents: Boolean read FKeepMouseEvents write
199
      FKeepMouseEvents default false;
200
  published
201
    property FocusedControl: TGLFocusControl read FFocusedControl write
202
      SetFocusedControl;
203
    property OnMouseDown: TGLMouseEvent read FOnMouseDown write FOnMouseDown;
204
    property OnMouseMove: TGLMouseMoveEvent read FOnMouseMove write
205
      FOnMouseMove;
206
    property OnMouseUp: TGLMouseEvent read FOnMouseUp write FOnMouseUp;
207
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
208
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
209
    property OnAcceptMouseQuery: TGLAcceptMouseQuery read FOnAcceptMouseQuery
210
      write FOnAcceptMouseQuery;
211
  end;
212

213
  TGLBaseFontControl = class(TGLBaseControl)
214
  private
215
    FBitmapFont: TGLCustomBitmapFont;
216
    FDefaultColor: TColorVector;
217
  protected
218
    function GetDefaultColor: TDelphiColor;
219
    procedure SetDefaultColor(value: TDelphiColor);
220
    procedure SetBitmapFont(NewFont: TGLCustomBitmapFont);
221
    function GetBitmapFont: TGLCustomBitmapFont;
222
    procedure WriteTextAt(var rci: TGLRenderContextInfo; const X, Y: TGLFloat;
223
      const Data: UnicodeString; const Color: TColorVector); overload;
224
    procedure WriteTextAt(var rci: TGLRenderContextInfo; const X1, Y1, X2, Y2:
225
      TGLFloat; const Data: UnicodeString; const Color: TColorVector); overload;
226
    function GetFontHeight: Integer;
227
  public
228
    constructor Create(AOwner: TComponent); override;
229
    destructor Destroy; override;
230
    procedure Notification(AComponent: TComponent; Operation: TOperation);
231
      override;
232
  published
233
    property BitmapFont: TGLCustomBitmapFont read GetBitmapFont write
234
      SetBitmapFont;
235
    property DefaultColor: TDelphiColor read GetDefaultColor write
236
      SetDefaultColor;
237
  end;
238

239
  TGLBaseTextControl = class(TGLBaseFontControl)
240
  private
241
    FCaption: UnicodeString;
242
  protected
243
    procedure SetCaption(const NewCaption: UnicodeString);
244
  public
245
  published
246
    property Caption: UnicodeString read FCaption write SetCaption;
247
  end;
248

249
  TGLFocusControl = class(TGLBaseTextControl)
250
  private
251
    FRootControl: TGLBaseControl;
252
    FFocused: Boolean;
253
    FOnKeyDown: TGLKeyEvent;
254
    FOnKeyUp: TGLKeyEvent;
255
    FOnKeyPress: TGLKeyPressEvent;
256
    FShiftState: TShiftState;
257
    FFocusedColor: TColorVector;
258
  protected
259
    procedure InternalKeyPress(var Key: Char); virtual;
260
    procedure InternalKeyDown(var Key: Word; Shift: TShiftState); virtual;
261
    procedure InternalKeyUp(var Key: Word; Shift: TShiftState); virtual;
262
    procedure SetFocused(Value: Boolean); virtual;
263
    function GetRootControl: TGLBaseControl;
264
    function GetFocusedColor: TDelphiColor;
265
    procedure SetFocusedColor(const Val: TDelphiColor);
266
  public
267
    destructor Destroy; override;
268
    procedure NotifyHide; override;
269
    procedure MoveTo(newParent: TGLBaseSceneObject); override;
270
    procedure ReGetRootControl;
271
    procedure SetFocus;
272
    procedure PrevControl;
273
    procedure NextControl;
274
    procedure KeyPress(Sender: TObject; var Key: Char); override;
275
    procedure KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
276
      override;
277
    procedure KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
278
      override;
279
  published
280
    property RootControl: TGLBaseControl read GetRootControl;
281
    property Focused: Boolean read FFocused write SetFocused;
282
    property FocusedColor: TDelphiColor read GetFocusedColor write
283
      SetFocusedColor;
284
    property OnKeyDown: TGLKeyEvent read FOnKeyDown write FOnKeyDown;
285
    property OnKeyUp: TGLKeyEvent read FOnKeyUp write FOnKeyUp;
286
    property OnKeyPress: TGLKeyPressEvent read FOnKeyPress write FOnKeyPress;
287
  end;
288

289
  TGLCustomControl = class;
290
  TGLCustomRenderEvent = procedure(Sender: TGLCustomControl; Bitmap: TGLBitmap)
291
    of object;
292
  TGLCustomControl = class(TGLFocusControl)
293
  private
294
    FCustomData: Pointer;
295
    FCustomObject: TObject;
296
    FOnRender: TGLCustomRenderEvent;
297
    FMaterial: TGLMaterial;
298
    FBitmap: TGLBitmap;
299
    FInternalBitmap: TGLBitmap;
300
    FBitmapChanged: Boolean;
301
    FXTexCoord: Single;
302
    FYTexCoord: Single;
303
    FInvalidRenderCount: Integer;
304
    FMaxInvalidRenderCount: Integer;
305
    FCentered: Boolean;
306
    procedure SetCentered(const Value: Boolean);
307
  protected
308
    procedure OnBitmapChanged(Sender: TObject);
309
    procedure SetBitmap(ABitmap: TGLBitmap);
310
  public
311
    constructor Create(AOwner: TComponent); override;
312
    destructor Destroy; override;
313
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
314
      renderChildren: Boolean); override;
315
    procedure SetMaterial(AMaterial: TGLMaterial);
316
    property CustomData: Pointer read FCustomData write FCustomData;
317
    property CustomObject: TObject read FCustomObject write FCustomObject;
318
  published
319
    property OnRender: TGLCustomRenderEvent read FOnRender write FOnRender;
320
    property Centered: Boolean read FCentered write SetCentered;
321
    property Material: TGLMaterial read FMaterial write SetMaterial;
322
    property Bitmap: TGLBitmap read FBitmap write SetBitmap;
323
    property MaxInvalidRenderCount: Integer read FMaxInvalidRenderCount write
324
      FMaxInvalidRenderCount;
325
  end;
326

327
  TGLPopupMenu = class;
328
  TGLPopupMenuClick = procedure(Sender: TGLPopupMenu; index: Integer; const
329
    MenuItemText: string) of object;
330

331
  TGLPopupMenu = class(TGLFocusControl)
332
  private
333
    FOnClick: TGLPopupMenuClick;
334
    FMenuItems: TStrings;
335
    FSelIndex: Integer;
336
    FMarginSize: Single;
337
    NewHeight: Single;
338
  protected
339
    procedure SetFocused(Value: Boolean); override;
340
    procedure SetMenuItems(Value: TStrings);
341
    procedure SetMarginSize(const val: Single);
342
    procedure SetSelIndex(const val: Integer);
343
    procedure InternalMouseDown(Shift: TShiftState; Button: TGLMouseButton; X,
344
      Y: Integer); override;
345
    procedure InternalMouseMove(Shift: TShiftState; X, Y: Integer); override;
346
    procedure OnStringListChange(Sender: TObject);
347
  public
348
    constructor Create(AOwner: TComponent); override;
349
    destructor Destroy; override;
350
    procedure PopUp(Px, Py: Integer);
351
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
352
      renderChildren: Boolean); override;
353
    procedure DoRender(var rci: TGLRenderContextInfo; renderSelf, renderChildren:
354
      Boolean); override;
355
    function MouseDown(Sender: TObject; Button: TGLMouseButton; Shift:
356
      TShiftState; X, Y: Integer): Boolean; override;
357
  published
358
    property MenuItems: TStrings read FMenuItems write SetMenuItems;
359
    property OnClick: TGLPopupMenuClick read FOnClick write FOnClick;
360
    property MarginSize: Single read FMarginSize write SetMarginSize;
361
    property SelIndex: Integer read FSelIndex write SetSelIndex;
362
  end;
363
  TGLForm = class;
364

365
  TGLFormCanRequest = procedure(Sender: TGLForm; var Can: Boolean) of object;
366
  TGLFormCloseOptions = (co_Hide, co_Ignore, co_Destroy);
367
  TGLFormCanClose = procedure(Sender: TGLForm; var CanClose: TGLFormCloseOptions)
368
    of object;
369
  TGLFormNotify = procedure(Sender: TGLForm) of object;
370
  TGLFormMove = procedure(Sender: TGLForm; var Left, Top: Single) of object;
371

372
  TGLForm = class(TGLBaseTextControl)
373
  private
374
    FOnCanMove: TGLFormCanRequest;
375
    FOnCanResize: TGLFormCanRequest;
376
    FOnCanClose: TGLFormCanClose;
377
    FOnShow: TGLFormNotify;
378
    FOnHide: TGLFormNotify;
379
    FOnMoving: TGLFormMove;
380
    Moving: Boolean;
381
    OldX: Integer;
382
    OldY: Integer;
383
    FTitleColor: TColorVector;
384
    FTitleOffset: Single;
385
  protected
386
    procedure InternalMouseDown(Shift: TShiftState; Button: TGLMouseButton; X,
387
      Y: Integer); override;
388
    procedure InternalMouseUp(Shift: TShiftState; Button: TGLMouseButton; X, Y:
389
      Integer); override;
390
    procedure InternalMouseMove(Shift: TShiftState; X, Y: Integer); override;
391
    function GetTitleColor: TDelphiColor;
392
    procedure SetTitleColor(value: TDelphiColor);
393
  public
394
    constructor Create(AOwner: TComponent); override;
395
    procedure Close;
396

397
    procedure NotifyShow; override;
398
    procedure NotifyHide; override;
399
    function MouseUp(Sender: TObject; Button: TGLMouseButton; Shift:
400
      TShiftState; X, Y: Integer): Boolean; override;
401
    function MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer):
402
      Boolean; override;
403
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
404
      renderChildren: Boolean); override;
405
  published
406
    property TitleColor: TDelphiColor read GetTitleColor write SetTitleColor;
407
    property OnCanMove: TGLFormCanRequest read FOnCanMove write FOnCanMove;
408
    property OnCanResize: TGLFormCanRequest read FOnCanResize write
409
      FOnCanResize;
410
    property OnCanClose: TGLFormCanClose read FOnCanClose write FOnCanClose;
411
    property OnShow: TGLFormNotify read FOnShow write FOnShow;
412
    property OnHide: TGLFormNotify read FOnHide write FOnHide;
413
    property OnMoving: TGLFormMove read FOnMoving write FOnMoving;
414
    property TitleOffset: Single read FTitleOffset write FTitleOffset;
415
  end;
416

417
  TGLPanel = class(TGLBaseControl)
418
  end;
419

420
  TGLCheckBox = class(TGLBaseControl)
421
  private
422
    FChecked: Boolean;
423
    FOnChange: TNotifyEvent;
424
    FGuiLayoutNameChecked: TGLGuiComponentName;
425
    FGuiCheckedComponent: TGLGuiComponent;
426
    FGroup: Integer;
427
  protected
428
    procedure SetChecked(NewChecked: Boolean);
429
    procedure InternalMouseDown(Shift: TShiftState; Button: TGLMouseButton; X,
430
      Y: Integer); override;
431
    procedure InternalMouseUp(Shift: TShiftState; Button: TGLMouseButton; X, Y:
432
      Integer); override;
433
    procedure SetGuiLayoutNameChecked(newName: TGLGuiComponentName);
434
    procedure SetGuiLayout(NewGui: TGLGuiLayout); override;
435
    procedure SetGroup(const val: Integer);
436
  public
437
    constructor Create(AOwner: TComponent); override;
438
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
439
      renderChildren: Boolean); override;
440
    procedure NotifyChange(Sender: TObject); override;
441
  published
442
    property Group: Integer read FGroup write SetGroup;
443
    property Checked: Boolean read FChecked write SetChecked;
444
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
445
    property GuiLayoutNameChecked: TGLGuiComponentName read FGuiLayoutNameChecked
446
      write SetGuiLayoutNameChecked;
447
  end;
448

449
  TGLButton = class(TGLFocusControl)
450
  private
451
    FPressed: Boolean;
452
    FOnButtonClick: TNotifyEvent;
453
    FGuiLayoutNamePressed: TGLGuiComponentName;
454
    FGuiPressedComponent: TGLGuiComponent;
455
    FBitBtn: TGLMaterial;
456
    FGroup: Integer;
457
    FLogicWidth: Single;
458
    FLogicHeight: Single;
459
    FXOffSet: Single;
460
    FYOffSet: Single;
461
    FAllowUp: Boolean;
462
  protected
463
    procedure SetPressed(NewPressed: Boolean);
464
    procedure InternalMouseDown(Shift: TShiftState; Button: TGLMouseButton; X,
465
      Y: Integer); override;
466
    procedure InternalMouseUp(Shift: TShiftState; Button: TGLMouseButton; X, Y:
467
      Integer); override;
468
    procedure InternalKeyDown(var Key: Word; Shift: TShiftState); override;
469
    procedure InternalKeyUp(var Key: Word; Shift: TShiftState); override;
470
    procedure SetFocused(Value: Boolean); override;
471
    procedure SetGuiLayoutNamePressed(newName: TGLGuiComponentName);
472
    procedure SetGuiLayout(NewGui: TGLGuiLayout); override;
473
    procedure SetBitBtn(AValue: TGLMaterial);
474
    procedure DestroyHandle; override;
475
    procedure SetGroup(const val: Integer);
476
    procedure SetLogicWidth(const val: single);
477
    procedure SetLogicHeight(const val: single);
478
    procedure SetXOffset(const val: single);
479
    procedure SetYOffset(const val: single);
480
  public
481
    constructor Create(AOwner: TComponent); override;
482
    destructor Destroy; override;
483
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
484
      renderChildren: Boolean); override;
485
  published
486
    property Group: Integer read FGroup write SetGroup;
487
    property BitBtn: TGLMaterial read FBitBtn write SetBitBtn;
488
    property Pressed: Boolean read FPressed write SetPressed;
489
    property OnButtonClick: TNotifyEvent read FOnButtonClick write
490
      FOnButtonClick;
491
    property GuiLayoutNamePressed: TGLGuiComponentName read FGuiLayoutNamePressed
492
      write SetGuiLayoutNamePressed;
493
    property LogicWidth: Single read FLogicWidth write SetLogicWidth;
494
    property LogicHeight: Single read FLogicHeight write SetLogicHeight;
495
    property XOffset: Single read FXOffset write SetXOffset;
496
    property YOffset: Single read FYOffset write SetYOffset;
497
    property AllowUp: Boolean read FAllowUp write FAllowUp;
498
  end;
499

500
  TGLEdit = class(TGLFocusControl)
501
  private
502
    FOnChange: TNotifyEvent;
503
    FSelStart: Integer;
504
    FReadOnly: Boolean;
505
    FEditChar: string;
506
  protected
507
    procedure InternalMouseDown(Shift: TShiftState; Button: TGLMouseButton; X,
508
      Y: Integer); override;
509
    procedure InternalKeyPress(var Key: Char); override;
510
    procedure InternalKeyDown(var Key: Word; Shift: TShiftState); override;
511
    procedure InternalKeyUp(var Key: Word; Shift: TShiftState); override;
512
    procedure SetFocused(Value: Boolean); override;
513
    procedure SetSelStart(const Value: Integer);
514
    procedure SetEditChar(const Value: string);
515
  public
516
    constructor Create(AOwner: TComponent); override;
517
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
518
      renderChildren: Boolean); override;
519
  published
520
    property EditChar: string read FEditChar write SetEditChar;
521
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
522
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
523
    property SelStart: Integer read FSelStart write SetSelStart;
524
  end;
525

526
  TGLLabel = class(TGLBaseTextControl)
527
  private
528
    FAlignment: TAlignment;
529
    FTextLayout: TGLTextLayout;
530
    procedure SetAlignment(const Value: TAlignment);
531
    procedure SetTextLayout(const Value: TGLTextLayout);
532
  protected
533
  public
534
    constructor Create(AOwner: TComponent); override;
535
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
536
      renderChildren: Boolean); override;
537
  published
538
    property Alignment: TAlignment read FAlignment write SetAlignment;
539
    property TextLayout: TGLTextLayout read FTextLayout write SetTextLayout;
540
  end;
541

542
  TGLAdvancedLabel = class(TGLFocusControl)
543
  private
544
  protected
545
  public
546
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
547
      renderChildren: Boolean); override;
548
  published
549
  end;
550

551
  TGLScrollbar = class(TGLFocusControl)
552
  private
553
    FMin: Single;
554
    FMax: Single;
555
    FStep: Single;
556
    FPos: Single;
557
    FPageSize: Single;
558
    FOnChange: TNotifyEvent;
559
    FGuiLayoutKnobName: TGLGuiComponentName;
560
    FGuiKnobComponent: TGLGuiComponent;
561
    FKnobRenderStatus: TGUIDrawResult;
562
    FScrollOffs: Single;
563
    FScrolling: Boolean;
564
    FHorizontal: Boolean;
565
    FLocked: Boolean;
566
  protected
567
    procedure SetMin(const val: Single);
568
    procedure SetMax(const val: Single);
569
    procedure SetPos(const val: Single);
570
    procedure SetPageSize(const val: Single);
571
    procedure SetHorizontal(const val: Boolean);
572
    procedure SetGuiLayoutKnobName(newName: TGLGuiComponentName);
573
    procedure SetGuiLayout(NewGui: TGLGuiLayout); override;
574

575
    function GetScrollPosY(ScrollPos: Single): Single;
576
    function GetYScrollPos(Y: Single): Single;
577

578
    function GetScrollPosX(ScrollPos: Single): Single;
579
    function GetXScrollPos(X: Single): Single;
580

581
    procedure InternalMouseDown(Shift: TShiftState; Button: TGLMouseButton; X,
582
      Y: Integer); override;
583
    procedure InternalMouseUp(Shift: TShiftState; Button: TGLMouseButton; X, Y:
584
      Integer); override;
585
    procedure InternalMouseMove(Shift: TShiftState; X, Y: Integer); override;
586
  public
587
    constructor Create(AOwner: TComponent); override;
588

589
    procedure StepUp;
590
    procedure StepDown;
591
    procedure PageUp;
592
    procedure PageDown;
593
    function MouseUp(Sender: TObject; Button: TGLMouseButton; Shift:
594
      TShiftState; X, Y: Integer): Boolean; override;
595
    function MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer):
596
      Boolean; override;
597
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
598
      renderChildren: Boolean); override;
599
  published
600
    property Horizontal: Boolean read FHorizontal write SetHorizontal;
601
    property Pos: Single read FPos write SetPos;
602
    property Min: Single read FMin write SetMin;
603
    property Max: Single read FMax write SetMax;
604
    property Step: Single read FStep write FStep;
605
    property PageSize: Single read FPageSize write SetPageSize;
606
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
607
    property GuiLayoutKnobName: TGLGuiComponentName read FGuiLayoutKnobName write
608
      SetGuiLayoutKnobName;
609
    property Locked: Boolean read FLocked write FLocked default False;
610
  end;
611

612
  TGLStringGrid = class(TGLFocusControl)
613
  private
614
    FSelCol, FSelRow: Integer;
615
    FRowSelect: Boolean;
616
    FColSelect: Boolean;
617
    FColumns: TStrings;
618
    FRows: TList;
619
    FHeaderColor: TColorVector;
620
    FMarginSize: Integer;
621
    FColumnSize: Integer;
622
    FRowHeight: Integer;
623
    FScrollbar: TGLScrollbar;
624
    FDrawHeader: Boolean;
625
  protected
626
    function GetCell(X, Y: Integer; out oCol, oRow: Integer): Boolean;
627
    procedure InternalMouseDown(Shift: TShiftState; Button: TGLMouseButton; X,
628
      Y: Integer); override;
629
    procedure SetColumns(const val: TStrings);
630
    procedure SetColSelect(const val: Boolean);
631
    function GetRow(index: Integer): TStringList;
632
    procedure SetRow(index: Integer; const val: TStringList);
633
    function GetRowCount: Integer;
634
    procedure SetRowCount(const val: Integer);
635
    procedure SetSelCol(const val: Integer);
636
    procedure SetSelRow(const val: Integer);
637
    procedure SetRowSelect(const val: Boolean);
638
    procedure SetDrawHeader(const val: Boolean);
639
    function GetHeaderColor: TDelphiColor;
640
    procedure SetHeaderColor(const val: TDelphiColor);
641
    procedure SetMarginSize(const val: Integer);
642
    procedure SetColumnSize(const val: Integer);
643
    procedure SetRowHeight(const val: Integer);
644
    procedure SetScrollbar(const val: TGLScrollbar);
645
    procedure SetGuiLayout(NewGui: TGLGuiLayout); override;
646
  public
647
    constructor Create(AOwner: TComponent); override;
648
    destructor Destroy; override;
649
    procedure Clear;
650
    function Add(Data: array of string): Integer; overload;
651
    function Add(const Data: string): Integer; overload;
652
    procedure SetText(Data: string);
653
    procedure Notification(AComponent: TComponent; Operation: TOperation);
654
      override;
655
    procedure NotifyChange(Sender: TObject); override;
656
    procedure InternalRender(var rci: TGLRenderContextInfo; renderSelf,
657
      renderChildren: Boolean); override;
658
    procedure OnStringListChange(Sender: TObject);
659
    property Row[index: Integer]: TStringList read GetRow write SetRow;
660
  published
661
    property HeaderColor: TDelphiColor read GetHeaderColor write SetHeaderColor;
662
    property Columns: TStrings read FColumns write SetColumns;
663
    property MarginSize: Integer read FMarginSize write SetMarginSize;
664
    property ColumnSize: Integer read FColumnSize write SetColumnSize;
665
    property RowHeight: Integer read FRowHeight write SetRowHeight;
666
    property RowCount: Integer read GetRowCount write SetRowCount;
667
    property SelCol: Integer read FSelCol write SetSelCol;
668
    property SelRow: Integer read FSelRow write SetSelRow;
669
    property RowSelect: Boolean read FRowSelect write SetRowSelect;
670
    property ColSelect: Boolean read FColSelect write SetColSelect;
671
    property DrawHeader: Boolean read FDrawHeader write SetDrawHeader;
672
    property Scrollbar: TGLScrollbar read FScrollbar write SetScrollbar;
673
  end;
674

675
function UnpressGroup(CurrentObject: TGLBaseSceneObject; AGroupID: Integer):
676
  Boolean;
677

678
implementation
679

680
uses GLObjects, GLState, GLUtils, Math;
681

682
function UnpressGroup(CurrentObject: TGLBaseSceneObject; AGroupID: Integer):
683
  Boolean;
684

685
var
686
  XC: Integer;
687

688
begin
689
  Result := False;
690
  if CurrentObject is TGLButton then
691
    with CurrentObject as TGLButton do
692
    begin
693
      if Group = AGroupID then
694
        if Pressed then
695
        begin
696
          Pressed := False;
697
          Result := True;
698
          Exit;
699
        end;
700
    end;
701

702
  if CurrentObject is TGLCheckBox then
703
    with CurrentObject as TGLCheckBox do
704
    begin
705
      if Group = AGroupID then
706
        if Checked then
707
        begin
708
          Checked := False;
709
          Result := True;
710
          Exit;
711
        end;
712
    end;
713

714
  for XC := 0 to CurrentObject.Count - 1 do
715
  begin
716
    if UnpressGroup(CurrentObject.Children[XC], AGroupID) then
717
    begin
718
      Result := True;
719
      Exit;
720
    end;
721
  end;
722
end;
723

724
procedure TGLBaseComponent.SetGUIRedraw(value: Boolean);
725

726
begin
727
  FGUIRedraw := Value;
728
  if Value then
729
  begin
730
    if csDestroying in ComponentState then
731
      Exit;
732
    if (FRedrawAtOnce) or (csDesigning in ComponentState) then
733
    begin
734
      FGUIRedraw := False;
735
      StructureChanged;
736
    end;
737
  end;
738
end;
739

740
procedure TGLBaseComponent.BlockRender;
741

742
begin
743
  while BlockedCount <> 0 do
744
    Sleep(1);
745
  BlockRendering := True;
746
  while RenderingCount <> BlockedCount do
747
    Sleep(1);
748
end;
749

750
procedure TGLBaseComponent.UnBlockRender;
751

752
begin
753
  BlockRendering := False;
754
end;
755

756
procedure TGLBaseComponent.RenderHeader(var rci: TGLRenderContextInfo; renderSelf,
757
  renderChildren: Boolean);
758

759
var
760
  f: Single;
761
begin
762
  FGuiLayout.Material.Apply(rci);
763
  if AlphaChannel <> 1 then
764
    rci.GLStates.SetGLMaterialAlphaChannel(GL_FRONT, AlphaChannel);
765
  // Prepare matrices
766
  GL.MatrixMode(GL_MODELVIEW);
767
  GL.PushMatrix;
768
  GL.LoadMatrixf(@TGLSceneBuffer(rci.buffer).BaseProjectionMatrix);
769
  if rci.renderDPI = 96 then
770
    f := 1
771
  else
772
    f := rci.renderDPI / 96;
773
  GL.Scalef(f * 2 / rci.viewPortSize.cx, f * 2 / rci.viewPortSize.cy, 1);
774
  GL.Translatef(f * Position.X - rci.viewPortSize.cx * 0.5,
775
    rci.viewPortSize.cy * 0.5 - f * Position.Y, 0);
776
  if Rotation <> 0 then
777
    GL.Rotatef(Rotation, 0, 0, 1);
778
  GL.MatrixMode(GL_PROJECTION);
779
  GL.PushMatrix;
780
  GL.LoadIdentity;
781
  rci.GLStates.Disable(stDepthTest);
782
  rci.GLStates.DepthWriteMask := False;
783
end;
784

785
procedure TGLBaseComponent.RenderFooter(var rci: TGLRenderContextInfo; renderSelf,
786
  renderChildren: Boolean);
787

788
begin
789
  GL.PopMatrix;
790
  GL.MatrixMode(GL_MODELVIEW);
791
  GL.PopMatrix;
792
  FGuiLayout.Material.UnApply(rci);
793
end;
794

795
procedure TGLBaseComponent.SetGuiLayout(NewGui: TGLGuiLayout);
796

797
begin
798
  if FGuiLayout <> NewGui then
799
  begin
800
    if Assigned(FGuiLayout) then
801
    begin
802
      FGuiLayout.RemoveGuiComponent(Self);
803
    end;
804
    FGuiComponent := nil;
805
    FGuiLayout := NewGui;
806
    if Assigned(FGuiLayout) then
807
      if FGuiLayoutName <> '' then
808
        FGuiComponent := FGuiLayout.GuiComponents.FindItem(FGuiLayoutName);
809

810
    // in effect this code have been moved...
811
    if Assigned(FGuiLayout) then
812
      FGuiLayout.AddGuiComponent(Self);
813

814
    NotifyChange(Self);
815
  end;
816
end;
817

818
procedure TGLBaseComponent.SetGuiLayoutName(NewName: TGLGuiComponentName);
819

820
begin
821
  if FGuiLayoutName <> NewName then
822
  begin
823
    FGuiComponent := nil;
824
    FGuiLayoutName := NewName;
825
    if FGuiLayoutName <> '' then
826
      if Assigned(FGuiLayout) then
827
      begin
828
        FGuiComponent := FGuiLayout.GuiComponents.FindItem(FGuiLayoutName);
829
      end;
830
    NotifyChange(Self);
831
  end;
832
end;
833

834
procedure TGLBaseComponent.Notification(AComponent: TComponent; Operation:
835
  TOperation);
836

837
begin
838
  if Operation = opRemove then
839
  begin
840
    if AComponent = FGuiLayout then
841
    begin
842
      BlockRender;
843
      GuiLayout := nil;
844
      UnBlockRender;
845
    end;
846
  end;
847

848
  inherited;
849
end;
850

851
// SetRotation
852
//
853

854
procedure TGLBaseComponent.SetRotation(const val: TGLFloat);
855
begin
856
  if FRotation <> val then
857
  begin
858
    FRotation := val;
859
    NotifyChange(Self);
860
  end;
861
end;
862

863
// SetAlphaChannel
864
//
865

866
procedure TGLBaseComponent.SetAlphaChannel(const val: Single);
867
begin
868
  if val <> FAlphaChannel then
869
  begin
870
    if val < 0 then
871
      FAlphaChannel := 0
872
    else if val > 1 then
873
      FAlphaChannel := 1
874
    else
875
      FAlphaChannel := val;
876
    NotifyChange(Self);
877
  end;
878
end;
879

880
procedure TGLBaseComponent.SetAutosize(const Value: Boolean);
881
var
882
  MarginLeft, MarginCenter, MarginRight: TGLFloat;
883
  MarginTop, MarginMiddle, MarginBottom: TGLFloat;
884
  MaxWidth: TGLFloat;
885
  MaxHeight: TGLFloat;
886
  i: integer;
887
begin
888
  if FAutosize <> Value then
889
  begin
890
    FAutosize := Value;
891

892
    if FAutosize and Assigned(FGuiComponent) then
893
    begin
894
      MarginLeft := 0;
895
      MarginCenter := 0;
896
      MarginRight := 0;
897
      MarginTop := 0;
898
      MarginMiddle := 0;
899
      MarginBottom := 0;
900

901
      for i := 0 to FGuiComponent.Elements.Count - 1 do
902
        with FGuiComponent.Elements[i] do
903
        begin
904
          case Align of
905
            GLAlTopLeft, GLAlLeft, GLAlBottomLeft:
906
              begin
907
                MarginLeft := Max(MarginLeft, abs(BottomRight.X - TopLeft.X) *
908
                  Scale.X);
909
              end;
910
            GLAlTop, GLAlCenter, GLAlBottom:
911
              begin
912
                MarginCenter := Max(MarginCenter, abs(BottomRight.X - TopLeft.X)
913
                  * Scale.X);
914
              end;
915
            GLAlTopRight, GLAlRight, GLAlBottomRight:
916
              begin
917
                MarginRight := Max(MarginRight, abs(BottomRight.X - TopLeft.X) *
918
                  Scale.X);
919
              end;
920
          end;
921
        end;
922

923
      for i := 0 to FGuiComponent.Elements.Count - 1 do
924
        with FGuiComponent.Elements[i] do
925
        begin
926
          case Align of
927
            GLAlTopLeft, GLAlTop, GLAlTopRight:
928
              begin
929
                MarginTop := Max(MarginTop, abs(BottomRight.Y - TopLeft.Y) *
930
                  Scale.Y);
931
              end;
932
            GLAlLeft, GLAlCenter, GLAlRight:
933
              begin
934
                MarginMiddle := Max(MarginMiddle, abs(BottomRight.Y - TopLeft.Y)
935
                  * Scale.Y);
936
              end;
937
            GLAlBottomLeft, GLAlBottom, GLAlBottomRight:
938
              begin
939
                MarginBottom := Max(MarginBottom, abs(BottomRight.Y - TopLeft.Y)
940
                  * Scale.Y);
941
              end;
942
          end;
943
        end;
944

945
      MaxWidth := MarginLeft + MarginCenter + MarginRight;
946
      MaxHeight := MarginTop + MarginMiddle + MarginBottom;
947

948
      if MaxWidth > 0 then
949
        Width := MaxWidth;
950

951
      if MaxHeight > 0 then
952
        Height := MaxHeight;
953
    end;
954
  end;
955
end;
956

957
// StoreAlphaChannel
958
//
959

960
function TGLBaseComponent.StoreAlphaChannel: Boolean;
961
begin
962
  Result := (FAlphaChannel <> 1);
963
end;
964

965
// SetNoZWrite
966
//
967

968
procedure TGLBaseComponent.SetNoZWrite(const val: Boolean);
969
begin
970
  FNoZWrite := val;
971
  NotifyChange(Self);
972
end;
973

974
constructor TGLBaseComponent.Create(AOwner: TComponent);
975

976
begin
977
  inherited;
978
  FGuiLayout := nil;
979
  FGuiComponent := nil;
980
  BlockRendering := False;
981
  BlockedCount := 0;
982
  RenderingCount := 0;
983
  Width := 50;
984
  Height := 50;
985
  FReBuildGui := True;
986
  GuiDestroying := False;
987
  FAlphaChannel := 1;
988
end;
989

990
destructor TGLBaseComponent.Destroy;
991

992
begin
993
  GuiDestroying := True;
994
  while RenderingCount > 0 do
995
    Sleep(1);
996

997
  GuiLayout := nil;
998
  inherited;
999
end;
1000

1001
procedure TGLBaseComponent.NotifyChange(Sender: TObject);
1002

1003
begin
1004
  if Sender = FGuiLayout then
1005
  begin
1006
    if (FGuiLayoutName <> '') and (GuiLayout <> nil) then
1007
    begin
1008
      BlockRender;
1009
      FGuiComponent := GuiLayout.GuiComponents.FindItem(FGuiLayoutName);
1010
      ReBuildGui := True;
1011
      GUIRedraw := True;
1012
      UnBlockRender;
1013
    end
1014
    else
1015
    begin
1016
      BlockRender;
1017
      FGuiComponent := nil;
1018
      ReBuildGui := True;
1019
      GUIRedraw := True;
1020
      UnBlockRender;
1021
    end;
1022
  end;
1023
  if Sender = Self then
1024
  begin
1025
    ReBuildGui := True;
1026
    GUIRedraw := True;
1027
  end;
1028
  inherited;
1029
end;
1030

1031
procedure TGLBaseComponent.MoveGUI(XRel, YRel: Single);
1032

1033
var
1034
  XC: Integer;
1035

1036
begin
1037
  if RedrawAtOnce then
1038
  begin
1039
    BeginUpdate;
1040
    try
1041
      MoveX := MoveX + XRel;
1042
      MoveY := MoveY + YRel;
1043
      for XC := 0 to Count - 1 do
1044
        if Children[XC] is TGLBaseComponent then
1045
        begin
1046
          (Children[XC] as TGLBaseComponent).MoveGUI(XRel, YRel);
1047
        end;
1048
      GUIRedraw := True;
1049
      DoChanges;
1050
    finally
1051
      Endupdate;
1052
    end;
1053
  end
1054
  else
1055
  begin
1056
    MoveX := MoveX + XRel;
1057
    MoveY := MoveY + YRel;
1058
    for XC := 0 to Count - 1 do
1059
      if Children[XC] is TGLBaseComponent then
1060
      begin
1061
        (Children[XC] as TGLBaseComponent).MoveGUI(XRel, YRel);
1062
      end;
1063
    GUIRedraw := True;
1064
  end;
1065
end;
1066

1067
procedure TGLBaseComponent.PlaceGUI(XPos, YPos: Single);
1068
begin
1069
  MoveGUI(XPos - Position.X, YPos - Position.Y);
1070
end;
1071

1072
procedure TGLBaseComponent.DoChanges;
1073

1074
var
1075
  XC: Integer;
1076

1077
begin
1078
  if GUIRedraw then
1079
  begin
1080
    GUIRedraw := False;
1081
    BeginUpdate;
1082
    try
1083
      if MoveX <> 0 then
1084
        Position.X := Position.X + MoveX;
1085
      if MoveY <> 0 then
1086
        Position.Y := Position.Y + MoveY;
1087
      MoveX := 0;
1088
      MoveY := 0;
1089

1090
      for XC := 0 to Count - 1 do
1091
        if Children[XC] is TGLBaseComponent then
1092
        begin
1093
          (Children[XC] as TGLBaseComponent).DoChanges;
1094
        end;
1095
    finally
1096
      EndUpdate;
1097
    end;
1098
  end
1099
  else
1100
  begin
1101
    for XC := 0 to Count - 1 do
1102
      if Children[XC] is TGLBaseComponent then
1103
      begin
1104
        (Children[XC] as TGLBaseComponent).DoChanges;
1105
      end;
1106
  end;
1107
end;
1108

1109
procedure TGLBaseComponent.InternalRender(var rci: TGLRenderContextInfo;
1110
  renderSelf, renderChildren: Boolean);
1111

1112
begin
1113
  if Assigned(FGuiComponent) then
1114
  begin
1115
    try
1116
      FGuiComponent.RenderToArea(0, 0, Width, Height, FRenderStatus,
1117
        FReBuildGui);
1118
    except
1119
      on E: Exception do
1120
        GLOKMessageBox(E.Message,
1121
          'Exception in GuiComponents InternalRender function');
1122
    end;
1123
  end;
1124
end;
1125

1126
procedure TGLBaseComponent.DoRender(var rci: TGLRenderContextInfo; renderSelf,
1127
  renderChildren: Boolean);
1128

1129
var
1130
  B: Boolean;
1131
begin
1132
  Inc(RenderingCount);
1133
  B := BlockRendering;
1134
  if B then
1135
  begin
1136
    Inc(BlockedCount);
1137
    while BlockRendering do
1138
      sleep(1);
1139
    Dec(BlockedCount);
1140
  end;
1141

1142
  if not GuiDestroying then
1143
    if RenderSelf then
1144
      if FGuiLayout <> nil then
1145
      begin
1146
        RenderHeader(rci, renderSelf, renderChildren);
1147

1148
        InternalRender(rci, RenderSelf, RenderChildren);
1149

1150
        RenderFooter(rci, renderSelf, renderChildren);
1151
        FReBuildGui := False;
1152
      end;
1153

1154
  if renderChildren then
1155
    if Count > 0 then
1156
      Self.RenderChildren(0, Count - 1, rci);
1157
  Dec(RenderingCount);
1158
end;
1159

1160
procedure TGLBaseControl.InternalMouseDown(Shift: TShiftState; Button:
1161
  TGLMouseButton; X, Y: Integer);
1162

1163
begin
1164
  if Assigned(FOnMouseDown) then
1165
    FOnMouseDown(Self, Button, Shift, X, Y);
1166
end;
1167

1168
procedure TGLBaseControl.InternalMouseUp(Shift: TShiftState; Button:
1169
  TGLMouseButton; X, Y: Integer);
1170

1171
begin
1172
  if Assigned(FOnMouseUp) then
1173
    FOnMouseUp(Self, Button, Shift, X, Y);
1174
end;
1175

1176
procedure TGLBaseControl.InternalMouseMove(Shift: TShiftState; X, Y: Integer);
1177

1178
begin
1179
  if Assigned(FOnMouseMove) then
1180
    FOnMouseMove(Self, Shift, X, Y);
1181
end;
1182

1183
procedure TGLBaseControl.SetActiveControl(NewControl: TGLBaseControl);
1184

1185
begin
1186
  FActiveControl := NewControl;
1187
end;
1188

1189
procedure TGLBaseControl.SetFocusedControl(NewControl: TGLFocusControl);
1190

1191
begin
1192
  if NewControl <> FFocusedControl then
1193
  begin
1194
    if Assigned(FFocusedControl) then
1195
      FFocusedControl.Focused := False;
1196
    FFocusedControl := NewControl;
1197
    if Assigned(FFocusedControl) then
1198
      FFocusedControl.Focused := True;
1199
  end;
1200
end;
1201

1202
function TGLBaseControl.FindFirstGui: TGLBaseControl;
1203

1204
var
1205
  tmpFirst: TGLBaseControl;
1206
  TmpRoot: TGLBaseSceneObject;
1207

1208
begin
1209
  tmpFirst := Self;
1210

1211
  TmpRoot := Self;
1212
  while (TmpRoot is TGLBaseComponent) do
1213
  begin
1214
    if Assigned(TmpRoot.parent) then
1215
    begin
1216
      if TmpRoot.parent is TGLBaseComponent then
1217
      begin
1218
        TmpRoot := TmpRoot.parent as TGLBaseComponent;
1219
        if TmpRoot is TGLBaseControl then
1220
          tmpFirst := TmpRoot as TGLBaseControl;
1221
      end
1222
      else
1223
        Break;
1224
    end
1225
    else
1226
      Break;
1227
  end;
1228
  Result := tmpFirst;
1229
end;
1230

1231
procedure TGLBaseControl.Notification(AComponent: TComponent;
1232
  Operation: TOperation);
1233
begin
1234
  if Operation = opRemove then
1235
  begin
1236
    if FEnteredControl <> nil then
1237
    begin
1238
      FEnteredControl.DoMouseLeave;
1239
      FEnteredControl := nil;
1240
    end;
1241
  end;
1242

1243
  inherited;
1244
end;
1245

1246
function TGLBaseControl.MouseDown(Sender: TObject; Button: TGLMouseButton;
1247
  Shift: TShiftState; X, Y: Integer): Boolean;
1248
var
1249
  Xc: Integer;
1250
  AcceptMouseEvent: Boolean;
1251

1252
begin
1253
  Result := False;
1254

1255
  AcceptMouseEvent := RecursiveVisible and ((Position.X <= X) and (Position.X +
1256
    Width > X) and (Position.Y <= Y) and (Position.Y + Height > Y));
1257
  if Assigned(OnAcceptMouseQuery) then
1258
    OnAcceptMouseQuery(Self, shift, ma_mousedown, Button, X, Y,
1259
      AcceptMouseEvent);
1260

1261
  if AcceptMouseEvent then
1262
  begin
1263
    Result := True;
1264
    if not FKeepMouseEvents then
1265
    begin
1266
      if Assigned(FActiveControl) then
1267
        if FActiveControl.MouseDown(Sender, Button, Shift, X, Y) then
1268
          Exit;
1269

1270
      for XC := count - 1 downto 0 do
1271
        if FActiveControl <> Children[XC] then
1272
        begin
1273
          if Children[XC] is TGLBaseControl then
1274
          begin
1275
            if (Children[XC] as TGLBaseControl).MouseDown(Sender, button, shift,
1276
              x, y) then
1277
              Exit;
1278
          end;
1279
        end;
1280
    end;
1281
    InternalMouseDown(Shift, Button, X, Y);
1282
  end;
1283
end;
1284

1285
function TGLBaseControl.MouseUp(Sender: TObject; Button: TGLMouseButton; Shift:
1286
  TShiftState; X, Y: Integer): Boolean;
1287
var
1288
  Xc: Integer;
1289
  AcceptMouseEvent: Boolean;
1290

1291
begin
1292
  Result := False;
1293

1294
  AcceptMouseEvent := RecursiveVisible and ((Position.X <= X) and (Position.X +
1295
    Width > X) and (Position.Y <= Y) and (Position.Y + Height > Y));
1296
  if Assigned(OnAcceptMouseQuery) then
1297
    OnAcceptMouseQuery(Self, shift, ma_mouseup, Button, X, Y, AcceptMouseEvent);
1298

1299
  if AcceptMouseEvent then
1300
  begin
1301
    Result := True;
1302
    if not FKeepMouseEvents then
1303
    begin
1304
      if Assigned(FActiveControl) then
1305
        if FActiveControl.MouseUp(Sender, button, shift, x, y) then
1306
          Exit;
1307

1308
      for XC := count - 1 downto 0 do
1309
        if FActiveControl <> Children[XC] then
1310
        begin
1311
          if Children[XC] is TGLBaseControl then
1312
          begin
1313
            if (Children[XC] as TGLBaseControl).MouseUp(Sender, button, shift,
1314
              x, y) then
1315
              Exit;
1316
          end;
1317
        end;
1318
    end;
1319
    InternalMouseUp(Shift, Button, X, Y);
1320
  end;
1321
end;
1322

1323
function TGLBaseControl.MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
1324
  Integer): Boolean;
1325
var
1326
  Xc: Integer;
1327
  AcceptMouseEvent: Boolean;
1328

1329
begin
1330
  Result := False;
1331

1332
  AcceptMouseEvent := RecursiveVisible and ((Position.X <= X) and (Position.X +
1333
    Width > X) and (Position.Y <= Y) and (Position.Y + Height > Y));
1334
  if Assigned(OnAcceptMouseQuery) then
1335
    OnAcceptMouseQuery(Self, shift, ma_mousemove, mbMiddle, X, Y,
1336
      AcceptMouseEvent);
1337

1338
  if AcceptMouseEvent then
1339
  begin
1340
    Result := True;
1341
    if not FKeepMouseEvents then
1342
    begin
1343
      if Assigned(FActiveControl) then
1344
        if FActiveControl.MouseMove(Sender, shift, x, y) then
1345
          Exit;
1346

1347
      for XC := count - 1 downto 0 do
1348
        if FActiveControl <> Children[XC] then
1349
        begin
1350
          if Children[XC] is TGLBaseControl then
1351
          begin
1352
            if (Children[XC] as TGLBaseControl).MouseMove(Sender, shift, x, y)
1353
              then
1354
            begin
1355
              if FEnteredControl <> (Children[XC] as TGLBaseControl) then
1356
              begin
1357
                if FEnteredControl <> nil then
1358
                begin
1359
                  FEnteredControl.DoMouseLeave;
1360
                end;
1361

1362
                FEnteredControl := (Children[XC] as TGLBaseControl);
1363

1364
                if FEnteredControl <> nil then
1365
                begin
1366
                  FEnteredControl.DoMouseEnter;
1367
                end;
1368
              end;
1369

1370
              Exit;
1371
            end;
1372
          end;
1373
        end;
1374
    end;
1375

1376
    if FEnteredControl <> nil then
1377
    begin
1378
      FEnteredControl.DoMouseLeave;
1379
      FEnteredControl := nil;
1380
    end;
1381

1382
    InternalMouseMove(Shift, X, Y);
1383
  end;
1384
end;
1385

1386
procedure TGLBaseControl.KeyDown(Sender: TObject; var Key: Word; Shift:
1387
  TShiftState);
1388
begin
1389
  if Assigned(FFocusedControl) then
1390
  begin
1391
    FFocusedControl.KeyDown(Sender, Key, Shift);
1392
  end;
1393
end;
1394

1395
procedure TGLBaseControl.KeyUp(Sender: TObject; var Key: Word; Shift:
1396
  TShiftState);
1397
begin
1398
  if Assigned(FFocusedControl) then
1399
  begin
1400
    FFocusedControl.KeyUp(Sender, Key, Shift);
1401
  end;
1402
end;
1403

1404
procedure TGLBaseControl.KeyPress(Sender: TObject; var Key: Char);
1405

1406
begin
1407
  if Assigned(FFocusedControl) then
1408
  begin
1409
    FFocusedControl.KeyPress(Sender, Key);
1410
  end;
1411
end;
1412

1413
procedure TGLFocusControl.InternalKeyPress(var Key: Char);
1414
begin
1415
  if assigned(FOnKeyPress) then
1416
    FOnKeyPress(Self, Key);
1417
end;
1418

1419
procedure TGLFocusControl.InternalKeyDown(var Key: Word; Shift: TShiftState);
1420
begin
1421
  if assigned(FOnKeyDown) then
1422
    FOnKeyDown(Self, Key, shift);
1423
end;
1424

1425
procedure TGLFocusControl.InternalKeyUp(var Key: Word; Shift: TShiftState);
1426
begin
1427
  if assigned(FOnKeyUp) then
1428
    FOnKeyUp(Self, Key, shift);
1429
end;
1430

1431
procedure TGLBaseControl.DoMouseEnter;
1432
begin
1433
  if Assigned(OnMouseEnter) then
1434
    OnMouseEnter(Self);
1435
end;
1436

1437
procedure TGLBaseControl.DoMouseLeave;
1438
begin
1439
  //leave all child controls
1440
  if FEnteredControl <> nil then
1441
  begin
1442
    FEnteredControl.DoMouseLeave;
1443
    FEnteredControl := nil;
1444
  end;
1445

1446
  if Assigned(OnMouseLeave) then
1447
    OnMouseLeave(Self);
1448
end;
1449

1450
procedure TGLFocusControl.SetFocused(Value: Boolean);
1451
begin
1452
  if Value <> FFocused then
1453
  begin
1454
    FFocused := Value;
1455
    GUIRedraw := True;
1456
  end;
1457
end;
1458

1459
function TGLFocusControl.GetRootControl: TGLBaseControl;
1460

1461
begin
1462
  if not Assigned(FRootControl) then
1463
  begin
1464
    FRootControl := FindFirstGui;
1465
  end;
1466
  Result := FRootControl;
1467
end;
1468

1469
procedure TGLFocusControl.NotifyHide;
1470

1471
begin
1472
  inherited;
1473
  if (RootControl.FFocusedControl = Self) and (self.focused) then
1474
  begin
1475
    RootControl.FocusedControl.PrevControl;
1476
  end;
1477
end;
1478

1479
procedure TGLFocusControl.ReGetRootControl;
1480

1481
begin
1482
  FRootControl := FindFirstGui;
1483
end;
1484

1485
function TGLFocusControl.GetFocusedColor: TDelphiColor;
1486

1487
begin
1488
  Result := ConvertColorVector(FFocusedColor);
1489
end;
1490

1491
procedure TGLFocusControl.SetFocusedColor(const Val: TDelphiColor);
1492

1493
begin
1494
  FFocusedColor := ConvertWinColor(val);
1495
  GUIRedraw := True;
1496
end;
1497

1498
procedure TGLFocusControl.SetFocus;
1499

1500
begin
1501
  RootControl.FocusedControl := Self;
1502
end;
1503

1504
procedure TGLFocusControl.NextControl;
1505

1506
var
1507
  Host: TGLBaseComponent;
1508
  Index: Integer;
1509
  IndexedChild: TGLBaseComponent;
1510
  RestartedLoop: Boolean;
1511

1512
begin
1513
  RestartedLoop := False;
1514
  if Parent is TGLBaseComponent then
1515
  begin
1516
    Host := Parent as TGLBaseComponent;
1517
    Index := Host.IndexOfChild(Self);
1518
    while not Host.RecursiveVisible do
1519
    begin
1520
      if Host.Parent is TGLBaseComponent then
1521
      begin
1522
        IndexedChild := Host;
1523
        Host := Host.Parent as TGLBaseComponent;
1524
        Index := Host.IndexOfChild(IndexedChild);
1525
      end
1526
      else
1527
      begin
1528
        RootControl.FocusedControl := nil;
1529
        Exit;
1530
      end;
1531
    end;
1532

1533
    while true do
1534
    begin
1535
      if Index > 0 then
1536
      begin
1537
        Dec(Index);
1538
        if Host.Children[Index] is TGLFocusControl then
1539
        begin
1540
          with (Host.Children[Index] as TGLFocusControl) do
1541
            if RecursiveVisible then
1542
            begin
1543
              SetFocus;
1544
              Exit;
1545
            end;
1546
        end
1547
        else
1548
        begin
1549
          if Host.Children[Index] is TGLBaseComponent then
1550
          begin
1551
            IndexedChild := Host.Children[Index] as TGLBaseComponent;
1552
            if IndexedChild.RecursiveVisible then
1553
            begin
1554
              Host := IndexedChild;
1555
              Index := Host.Count;
1556
            end;
1557
          end;
1558
        end;
1559
      end
1560
      else
1561
      begin
1562
        if Host.Parent is TGLBaseComponent then
1563
        begin
1564
          Index := Host.Parent.IndexOfChild(Host);
1565
          Host := Host.Parent as TGLBaseComponent;
1566
        end
1567
        else
1568
        begin
1569
          if RestartedLoop then
1570
          begin
1571
            SetFocus;
1572
            Exit;
1573
          end;
1574
          Index := Host.Count;
1575
          RestartedLoop := True;
1576
        end;
1577
      end;
1578
    end;
1579
  end;
1580
end;
1581

1582
procedure TGLFocusControl.PrevControl;
1583

1584
var
1585
  Host: TGLBaseComponent;
1586
  Index: Integer;
1587
  IndexedChild: TGLBaseComponent;
1588
  RestartedLoop: Boolean;
1589

1590
begin
1591
  RestartedLoop := False;
1592
  if Parent is TGLBaseComponent then
1593
  begin
1594
    Host := Parent as TGLBaseComponent;
1595
    Index := Host.IndexOfChild(Self);
1596
    while not Host.RecursiveVisible do
1597
    begin
1598
      if Host.Parent is TGLBaseComponent then
1599
      begin
1600
        IndexedChild := Host;
1601
        Host := Host.Parent as TGLBaseComponent;
1602
        Index := Host.IndexOfChild(IndexedChild);
1603
      end
1604
      else
1605
      begin
1606
        RootControl.FocusedControl := nil;
1607
        Exit;
1608
      end;
1609
    end;
1610

1611
    while true do
1612
    begin
1613
      Inc(Index);
1614

1615
      if Index < Host.Count then
1616
      begin
1617
        if Host.Children[Index] is TGLFocusControl then
1618
        begin
1619
          with (Host.Children[Index] as TGLFocusControl) do
1620
            if RecursiveVisible then
1621
            begin
1622
              SetFocus;
1623
              Exit;
1624
            end;
1625
        end;
1626
        if Host.Children[Index] is TGLBaseComponent then
1627
        begin
1628
          IndexedChild := Host.Children[Index] as TGLBaseComponent;
1629
          if IndexedChild.RecursiveVisible then
1630
          begin
1631
            Host := IndexedChild;
1632
            Index := -1;
1633
          end;
1634
        end;
1635
      end
1636
      else
1637
      begin
1638
        if Host.Parent is TGLBaseComponent then
1639
        begin
1640
          IndexedChild := Host;
1641
          Host := Host.Parent as TGLBaseComponent;
1642
          Index := Host.IndexOfChild(IndexedChild);
1643
        end
1644
        else
1645
        begin
1646
          if RestartedLoop then
1647
          begin
1648
            RootControl.FocusedControl := nil;
1649
            Exit;
1650
          end;
1651
          Index := -1;
1652
          RestartedLoop := True;
1653
        end;
1654
      end;
1655
    end;
1656
  end;
1657
end;
1658

1659
procedure TGLFocusControl.KeyPress(Sender: TObject; var Key: Char);
1660

1661
begin
1662
  InternalKeyPress(Key);
1663
  if Key = #9 then
1664
  begin
1665
    if ssShift in FShiftState then
1666
    begin
1667
      PrevControl;
1668
    end
1669
    else
1670
    begin
1671
      NextControl;
1672
    end;
1673
  end;
1674
end;
1675

1676
procedure TGLFocusControl.KeyDown(Sender: TObject; var Key: Word; Shift:
1677
  TShiftState);
1678
begin
1679
  FShiftState := Shift;
1680
  InternalKeyDown(Key, Shift);
1681
  if Key = glKey_TAB then
1682
  begin
1683
    if ssShift in FShiftState then
1684
    begin
1685
      PrevControl;
1686
    end
1687
    else
1688
    begin
1689
      NextControl;
1690
    end;
1691
  end;
1692
end;
1693

1694
procedure TGLFocusControl.KeyUp(Sender: TObject; var Key: Word; Shift:
1695
  TShiftState);
1696
begin
1697
  FShiftState := Shift;
1698
  InternalKeyUp(Key, Shift);
1699
  if Key = glKey_TAB then
1700
  begin
1701
    if ssShift in FShiftState then
1702
    begin
1703
      PrevControl;
1704
    end
1705
    else
1706
    begin
1707
      NextControl;
1708
    end;
1709
  end;
1710

1711
end;
1712

1713
{ base font control }
1714

1715
constructor TGLBaseFontControl.Create(AOwner: TComponent);
1716

1717
begin
1718
  inherited;
1719
  FBitmapFont := nil;
1720
  FDefaultColor := clrBlack;
1721
end;
1722

1723
destructor TGLBaseFontControl.Destroy;
1724
begin
1725
  inherited;
1726
  BitmapFont := nil;
1727
end;
1728

1729
procedure TGLBaseFontControl.SetBitmapFont(NewFont: TGLCustomBitmapFont);
1730

1731
begin
1732
  if NewFont <> FBitmapFont then
1733
  begin
1734
    if Assigned(FBitmapFont) then
1735
    begin
1736
      FBitmapFont.RemoveFreeNotification(Self);
1737
      FBitmapFont.UnRegisterUser(Self);
1738
    end;
1739
    FBitmapFont := NewFont;
1740
    if Assigned(FBitmapFont) then
1741
    begin
1742
      FBitmapFont.RegisterUser(Self);
1743
      FBitmapFont.FreeNotification(Self);
1744
    end;
1745
    GUIRedraw := True;
1746
  end;
1747
end;
1748

1749
function TGLBaseFontControl.GetBitmapFont: TGLCustomBitmapFont;
1750

1751
begin
1752
  Result := nil;
1753
  if Assigned(FBitmapFont) then
1754
    Result := FBitmapFont
1755
  else if Assigned(GuiLayout) then
1756
    if Assigned(GuiLayout.BitmapFont) then
1757
    begin
1758
      if not (csDesigning in ComponentState) then
1759
      begin
1760
        if not GuiDestroying then
1761
        begin
1762
          BitmapFont := GuiLayout.BitmapFont;
1763
          Result := FBitmapFont;
1764
        end;
1765
      end
1766
      else
1767
        Result := GuiLayout.BitmapFont;
1768
    end;
1769
end;
1770

1771
function TGLBaseFontControl.GetDefaultColor: TDelphiColor;
1772

1773
begin
1774
  Result := ConvertColorVector(FDefaultColor);
1775
end;
1776

1777
procedure TGLBaseFontControl.SetDefaultColor(value: TDelphiColor);
1778

1779
begin
1780
  FDefaultColor := ConvertWinColor(value);
1781
  GUIRedraw := True;
1782
  NotifyChange(Self);
1783
end;
1784

1785
procedure TGLBaseFontControl.Notification(AComponent: TComponent; Operation:
1786
  TOperation);
1787
begin
1788
  if (Operation = opRemove) and (AComponent = FBitmapFont) then
1789
  begin
1790
    BlockRender;
1791
    BitmapFont := nil;
1792
    UnBlockRender;
1793
  end;
1794
  inherited;
1795
end;
1796

1797
{ GLWindow }
1798

1799
procedure TGLBaseTextControl.SetCaption(const NewCaption: UnicodeString);
1800

1801
begin
1802
  FCaption := NewCaption;
1803
  GuiRedraw := True;
1804
end;
1805

1806
procedure TGLBaseFontControl.WriteTextAt(var rci: TGLRenderContextInfo; const X,
1807
  Y: TGLFloat; const Data: UnicodeString; const Color: TColorVector);
1808
var
1809
  Position: TVector;
1810
begin
1811
  if Assigned(BitmapFont) then
1812
  begin
1813
    Position.V[0] := Round(X);
1814
    Position.V[1] := Round(Y);
1815
    Position.V[2] := 0;
1816
    Position.V[3] := 0;
1817
    BitmapFont.RenderString(rci, Data, taLeftJustify, tlTop, Color, @Position);
1818
  end;
1819
end;
1820

1821
procedure TGLBaseFontControl.WriteTextAt(var rci: TGLRenderContextInfo; const X1,
1822
  Y1, X2, Y2: TGLFloat; const Data: UnicodeString; const Color: TColorVector);
1823
var
1824
  Position: TVector;
1825
begin
1826
  if Assigned(BitmapFont) then
1827
  begin
1828
    Position.V[0] := Round(((X2 + X1 -
1829
      BitmapFont.CalcStringWidth(Data)) * 0.5));
1830
    Position.V[1] := Round(-((Y2 + Y1 - GetFontHeight) * 0.5)) + 2;
1831
    Position.V[2] := 0;
1832
    Position.V[3] := 0;
1833
    BitmapFont.RenderString(rci, Data, taLeftJustify, tlTop, Color, @Position);
1834
  end;
1835
end;
1836

1837
function TGLBaseFontControl.GetFontHeight: Integer;
1838

1839
begin
1840
  if Assigned(BitmapFont) then
1841
    if BitmapFont is TGLWindowsBitmapFont then
1842
      Result := Abs((BitmapFont as TGLWindowsBitmapFont).Font.Height)
1843
    else
1844
      Result := BitmapFont.CharHeight
1845
  else
1846
    Result := -1;
1847
end;
1848

1849
constructor TGLCustomControl.Create(AOwner: TComponent);
1850

1851
begin
1852
  inherited;
1853
  FMaterial := TGLMaterial.create(Self);
1854
  FBitmap := TGLBitmap.create;
1855
  FBitmap.OnChange := OnBitmapChanged;
1856
  FInternalBitmap := nil;
1857
  FInvalidRenderCount := 0;
1858

1859
  FXTexCoord := 1;
1860
  FYTexCoord := 1;
1861
end;
1862

1863
destructor TGLCustomControl.Destroy;
1864
begin
1865
  if Assigned(FInternalBitmap) then
1866
    FInternalBitmap.Free;
1867
  Bitmap.Free;
1868
  FMaterial.Free;
1869
  inherited;
1870
end;
1871

1872
procedure TGLCustomControl.SetCentered(const Value: Boolean);
1873
begin
1874
  FCentered := Value;
1875
end;
1876

1877
procedure TGLCustomControl.OnBitmapChanged(Sender: TObject);
1878
begin
1879
  FBitmapChanged := True;
1880
end;
1881

1882
procedure TGLCustomControl.SetBitmap(ABitmap: TGLBitmap);
1883
begin
1884
  FBitmap.Assign(ABitmap);
1885
end;
1886

1887
procedure TGLCustomControl.InternalRender(var rci: TGLRenderContextInfo;
1888
  renderSelf, renderChildren: Boolean);
1889

1890
var
1891
  X1, X2, Y1, Y2: Single;
1892

1893
begin
1894
  if Assigned(OnRender) then
1895
    OnRender(self, FBitmap);
1896

1897
  if FBitmapChanged then
1898
    if FInvalidRenderCount >= FMaxInvalidRenderCount then
1899
    begin
1900
      FInvalidRenderCount := 0;
1901
      if not Assigned(FInternalBitmap) then
1902
        FInternalBitmap := TGLBitmap.Create;
1903

1904
      FInternalBitmap.PixelFormat := FBitmap.PixelFormat;
1905
      FInternalBitmap.Width := RoundUpToPowerOf2(FBitmap.Width);
1906
      FInternalBitmap.Height := RoundUpToPowerOf2(FBitmap.Height);
1907
      FInternalBitmap.Canvas.CopyRect(FBitmap.Canvas.ClipRect, FBitmap.Canvas,
1908
        FBitmap.Canvas.ClipRect);
1909
      FBitmapChanged := False;
1910
      with Material.GetActualPrimaryTexture do
1911
      begin
1912
        Disabled := False;
1913
        Image.Assign(FInternalBitmap);
1914
      end;
1915
      FXTexCoord := FBitmap.Width / FInternalBitmap.Width;
1916
      FYTexCoord := FBitmap.Height / FInternalBitmap.Height;
1917
    end
1918
    else
1919
      Inc(FInvalidRenderCount);
1920

1921
  if Assigned(FGuiComponent) then
1922
  begin
1923
    try
1924
      if Centered then
1925
        FGuiComponent.RenderToArea(-Width / 2, -Height / 2, Width, Height,
1926
          FRenderStatus, FReBuildGui)
1927
      else
1928
        FGuiComponent.RenderToArea(0, 0, Width, Height, FRenderStatus,
1929
          FReBuildGui);
1930
    except
1931
      on E: Exception do
1932
        GLOKMessageBox(E.Message,
1933
          'Exception in TGLCustomControl InternalRender function');
1934
    end;
1935
    X1 := FRenderStatus[GLAlCenter].X1;
1936
    X2 := FRenderStatus[GLAlCenter].X2;
1937
    Y1 := -FRenderStatus[GLAlCenter].Y2;
1938
    Y2 := -FRenderStatus[GLAlCenter].Y1;
1939
  end
1940
  else
1941
  begin
1942
    if Centered then
1943
    begin
1944
      X2 := Width / 2;
1945
      Y1 := -Height / 2;
1946
      X1 := -X2;
1947
      Y2 := -Y1;
1948
    end
1949
    else
1950
    begin
1951
      X2 := Width;
1952
      Y2 := -Height;
1953
      X1 := 0;
1954
      Y1 := 0;
1955
    end;
1956
  end;
1957

1958
  GuiLayout.Material.UnApply(rci);
1959
  Material.Apply(rci);
1960
  GL.Begin_(GL_QUADS);
1961

1962
  GL.TexCoord2f(FXTexCoord, -FYTexCoord);
1963
  GL.Vertex2f(X2, Y2);
1964

1965
  GL.TexCoord2f(FXTexCoord, 0);
1966
  GL.Vertex2f(X2, Y1);
1967

1968
  GL.TexCoord2f(0, 0);
1969
  GL.Vertex2f(X1, Y1);
1970

1971
  GL.TexCoord2f(0, -FYTexCoord);
1972
  GL.Vertex2f(X1, Y2);
1973

1974
  GL.End_();
1975

1976
  Material.UnApply(rci);
1977
  GuiLayout.Material.Apply(rci);
1978
end;
1979

1980
procedure TGLCustomControl.SetMaterial(AMaterial: TGLMaterial);
1981

1982
begin
1983
  FMaterial.Assign(AMaterial);
1984
end;
1985

1986
procedure TGLPopupMenu.SetFocused(Value: Boolean);
1987

1988
begin
1989
  inherited;
1990
  if not (csDesigning in ComponentState) then
1991
    if not FFocused then
1992
      Visible := False;
1993
end;
1994

1995
procedure TGLPopupMenu.SetMenuItems(Value: TStrings);
1996

1997
begin
1998
  FMenuItems.Assign(Value);
1999
  NotifyChange(Self);
2000
end;
2001

2002
procedure TGLPopupMenu.SetMarginSize(const val: Single);
2003

2004
begin
2005
  if FMarginSize <> val then
2006
  begin
2007
    FMarginSize := val;
2008
    NotifyChange(Self);
2009
  end;
2010
end;
2011

2012
procedure TGLPopupMenu.SetSelIndex(const val: Integer);
2013

2014
begin
2015
  if FSelIndex <> val then
2016
  begin
2017
    FSelIndex := val;
2018
    NotifyChange(Self);
2019
  end;
2020
end;
2021

2022
procedure TGLPopupMenu.InternalMouseDown(Shift: TShiftState; Button:
2023
  TGLMouseButton; X, Y: Integer);
2024
var
2025
  ClickIndex: Integer;
2026
  Tx: Single;
2027
  Ty: Single;
2028

2029
begin
2030
  Tx := X - Position.X;
2031
  Ty := Y - Position.Y;
2032
  if Button = mbLeft then
2033
    if IsInRect(fRenderStatus[glAlCenter], Tx, Ty) then
2034
      if Assigned(BitmapFont) then
2035
      begin
2036
        ClickIndex := Round(Int((Ty - fRenderStatus[glAlCenter].y1) /
2037
          BitmapFont.CharHeight));
2038
        if (ClickIndex >= 0) and (ClickIndex < FMenuItems.Count) then
2039
        begin
2040
          if Assigned(OnClick) then
2041
            OnClick(Self, ClickIndex, FMenuItems[ClickIndex]);
2042
          Visible := False;
2043
        end;
2044
      end;
2045
end;
2046

2047
procedure TGLPopupMenu.InternalMouseMove(Shift: TShiftState; X, Y: Integer);
2048
var
2049
  Tx: Single;
2050
  Ty: Single;
2051
begin
2052
  Tx := X - Position.X;
2053
  Ty := Y - Position.Y;
2054
  if IsInRect(fRenderStatus[glAlCenter], Tx, Ty) then
2055
    if Assigned(BitmapFont) then
2056
    begin
2057
      SelIndex := Round(Int((Ty - fRenderStatus[glAlCenter].y1) /
2058
        BitmapFont.CharHeight));
2059
    end;
2060
end;
2061

2062
procedure TGLPopupMenu.OnStringListChange(Sender: TObject);
2063

2064
var
2065
  CenterHeight: Single;
2066
  TextHeight: Single;
2067
begin
2068
  if not FReBuildGui then
2069
  begin
2070
    if Assigned(BitmapFont) then
2071
      with FRenderStatus[GLalCenter] do
2072
      begin
2073
        CenterHeight := Y2 - Y1;
2074
        CenterHeight := Round(CenterHeight + 0.499);
2075
        TextHeight := BitmapFont.CharHeight * FMenuItems.Count;
2076
        if CenterHeight <> TextHeight then // allways round up!
2077
        begin
2078
          Height := Height + TextHeight - CenterHeight;
2079
        end;
2080
      end;
2081
  end;
2082
end;
2083

2084
constructor TGLPopupMenu.Create(AOwner: TComponent);
2085
begin
2086
  inherited;
2087
  FOnClick := nil;
2088
  FMenuItems := TStringList.Create;
2089
  (FMenuItems as TStringList).OnChange := OnStringListChange;
2090
  FSelIndex := 0;
2091
  NewHeight := -1;
2092
end;
2093

2094
destructor TGLPopupMenu.Destroy;
2095
begin
2096
  inherited;
2097
  FMenuItems.Free;
2098
end;
2099

2100
procedure TGLPopupMenu.PopUp(Px, Py: Integer);
2101
begin
2102
  Position.X := PX;
2103
  Position.Y := PY;
2104
  Visible := True;
2105
  SetFocus;
2106
  RootControl.ActiveControl := Self;
2107
end;
2108

2109
procedure TGLPopupMenu.InternalRender(var rci: TGLRenderContextInfo; renderSelf,
2110
  renderChildren: Boolean);
2111

2112
var
2113
  CenterHeight: Single;
2114
  TextHeight: Single;
2115
  YPos: Single;
2116
  XPos: Single;
2117
  XC: Integer;
2118
  changedHeight: single;
2119
begin
2120
  if Assigned(FGuiComponent) then
2121
  begin
2122
    try
2123
      if NewHeight <> -1 then
2124
        FGuiComponent.RenderToArea(0, 0, Width, NewHeight, FRenderStatus,
2125
          FReBuildGui)
2126
      else
2127
        FGuiComponent.RenderToArea(0, 0, Width, Height, FRenderStatus,
2128
          FReBuildGui);
2129
    except
2130
      on E: Exception do
2131
        GLOKMessageBox(E.Message,
2132
          'Exception in GuiComponents InternalRender function');
2133
    end;
2134
  end;
2135
  if Assigned(BitmapFont) and (FMenuItems.Count > 0) then
2136
    with FRenderStatus[GLalCenter] do
2137
    begin
2138
      CenterHeight := Y2 - Y1;
2139
      CenterHeight := Round(CenterHeight + 0.499);
2140
      TextHeight := BitmapFont.CharHeight * FMenuItems.Count;
2141
      if CenterHeight <> TextHeight then // allways round up!
2142
      begin
2143
        changedHeight := Height + TextHeight - CenterHeight;
2144
        if changedHeight <> newHeight then
2145
        begin
2146
          newHeight := changedHeight;
2147
          InternalRender(rci, RenderSelf, RenderChildren);
2148
        end;
2149
      end
2150
      else
2151
      begin
2152
        YPos := -Y1;
2153
        XPos := X1 + MarginSize;
2154
        for XC := 0 to FMenuItems.count - 1 do
2155
        begin
2156
          if FSelIndex = XC then
2157
            WriteTextAt(rci, XPos, YPos, FMenuItems[XC], FFocusedColor)
2158
          else
2159
            WriteTextAt(rci, XPos, YPos, FMenuItems[XC], FDefaultColor);
2160
          YPos := YPos - BitmapFont.CharHeight;
2161
        end;
2162
      end;
2163
    end;
2164
end;
2165

2166
procedure TGLPopupMenu.DoRender(var rci: TGLRenderContextInfo; renderSelf,
2167
  renderChildren: Boolean);
2168

2169
begin
2170
  inherited;
2171
  // to avoid gui render-block deadlock!
2172
  if NewHeight <> -1 then
2173
  begin
2174
    Height := NewHeight;
2175
    NewHeight := -1;
2176
  end;
2177
end;
2178

2179
function TGLPopupMenu.MouseDown(Sender: TObject; Button: TGLMouseButton; Shift:
2180
  TShiftState; X, Y: Integer): Boolean;
2181
begin
2182
  Result := inherited MouseDown(Sender, Button, Shift, X, Y);
2183

2184
  if (not Result) and (RootControl.ActiveControl = Self) then
2185
  begin
2186
    RootControl.ActiveControl := nil;
2187
    NextControl;
2188
  end;
2189
end;
2190

2191
procedure TGLForm.InternalMouseDown(Shift: TShiftState; Button: TGLMouseButton;
2192
  X, Y: Integer);
2193

2194
var
2195
  CanMove: Boolean;
2196
  YHere: TGLFloat;
2197

2198
begin
2199
  YHere := Y - Position.Y;
2200
  if YHere < FRenderStatus[GLALTop].Y2 then
2201
  begin
2202
    if Button = mbLeft then
2203
    begin
2204
      {      If contains(Width-22,Width-6,XHere) and contains(8,24,YHere) then
2205
            Begin
2206
              Close;
2207
            End else{}
2208
      begin
2209
        CanMove := True;
2210
        if Assigned(FOnCanMove) then
2211
          FOnCanMove(Self, CanMove);
2212
        if CanMove then
2213
        begin
2214
          OldX := X;
2215
          OldY := Y;
2216
          Moving := True;
2217
          if Parent is TGLFocusControl then
2218
            (Parent as TGLFocusControl).ActiveControl := Self;
2219
        end;
2220
      end;
2221
    end;
2222
  end
2223
  else
2224
    inherited;
2225
end;
2226

2227
procedure TGLForm.InternalMouseUp(Shift: TShiftState; Button: TGLMouseButton; X,
2228
  Y: Integer);
2229

2230
begin
2231
  if (Button = mbLeft) and Moving then
2232
  begin
2233
    Moving := False;
2234
    if Parent is TGLFocusControl then
2235
      (Parent as TGLFocusControl).ActiveControl := nil;
2236
    Exit;
2237
  end;
2238

2239
  if Y - Position.Y < 27 then
2240
  begin
2241
  end
2242
  else
2243
    inherited;
2244
end;
2245

2246
procedure TGLForm.InternalMouseMove(Shift: TShiftState; X, Y: Integer);
2247

2248
var
2249
  XRel, YRel: Single;
2250

2251
begin
2252
  if Moving then
2253
  begin
2254
    if (X <> OldX) or (Y <> OldY) then
2255
    begin
2256
      XRel := X - OldX;
2257
      YRel := Y - OldY;
2258

2259
      XRel := XRel + Position.X;
2260
      YRel := YRel + Position.Y;
2261
      if Assigned(OnMoving) then
2262
        OnMoving(Self, XRel, YRel);
2263
      XRel := XRel - Position.X;
2264
      YRel := YRel - Position.Y;
2265

2266
      MoveGUI(XRel, YRel);
2267
      OldX := X;
2268
      OldY := Y;
2269

2270
    end;
2271
  end
2272
  else if Y - Position.Y < 27 then
2273
  begin
2274

2275
  end
2276
  else
2277
    inherited;
2278
end;
2279

2280
function TGLForm.GetTitleColor: TDelphiColor;
2281

2282
begin
2283
  Result := ConvertColorVector(FTitleColor);
2284
end;
2285

2286
procedure TGLForm.SetTitleColor(value: TDelphiColor);
2287

2288
begin
2289
  FTitleColor := ConvertWinColor(value);
2290
  GUIRedraw := True;
2291
end;
2292

2293
constructor TGLForm.Create(AOwner: TComponent);
2294

2295
begin
2296
  inherited;
2297
  FTitleOffset := 2;
2298
end;
2299

2300
procedure TGLForm.Close;
2301

2302
var
2303
  HowClose: TGLFormCloseOptions;
2304

2305
begin
2306
  HowClose := co_hide;
2307
  if Assigned(FOnCanClose) then
2308
    FOnCanClose(Self, HowClose);
2309
  case HowClose of
2310
    co_hide: Visible := False;
2311
    co_ignore: ;
2312
    co_Destroy: Free;
2313
  end;
2314
end;
2315

2316
procedure TGLForm.NotifyShow;
2317

2318
begin
2319
  inherited;
2320
  if Assigned(FOnShow) then
2321
    FOnShow(Self);
2322
end;
2323

2324
procedure TGLForm.NotifyHide;
2325

2326
begin
2327
  inherited;
2328
  if Assigned(FOnHide) then
2329
    FOnHide(Self);
2330
end;
2331

2332
function TGLForm.MouseUp(Sender: TObject; Button: TGLMouseButton; Shift:
2333
  TShiftState; X, Y: Integer): Boolean;
2334

2335
begin
2336
  if (Button = mbLeft) and (Moving) then
2337
  begin
2338
    Result := True;
2339
    InternalMouseUp(Shift, Button, X, Y);
2340
  end
2341
  else
2342
    Result := inherited MouseUp(Sender, Button, Shift, X, Y);
2343
end;
2344

2345
function TGLForm.MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer):
2346
  Boolean;
2347

2348
begin
2349
  if (Moving) then
2350
  begin
2351
    Result := True;
2352
    InternalMouseMove(Shift, X, Y);
2353
  end
2354
  else
2355
    Result := inherited MouseMove(Sender, Shift, X, Y);
2356
end;
2357

2358
procedure TGLForm.InternalRender(var rci: TGLRenderContextInfo; renderSelf,
2359
  renderChildren: Boolean);
2360
var
2361
  ATitleColor: TColorVector;
2362
begin
2363
  if Assigned(FGuiComponent) then
2364
  begin
2365
    FGuiComponent.RenderToArea(0, 0, Width, Height, FRenderStatus, FReBuildGui);
2366

2367
    ATitleColor := FTitleColor;
2368
    ATitleColor.V[3] := AlphaChannel;
2369

2370
    WriteTextAt(rci, ((FRenderStatus[GLAlTop].X2 + FRenderStatus[GLAlTop].X1 -
2371
      BitmapFont.CalcStringWidth(Caption)) * 0.5),
2372
      -((FRenderStatus[GLAlTop].Y2 + FRenderStatus[GLAlTop].Y1 - GetFontHeight) *
2373
      0.5) + TitleOffset, Caption, ATitleColor);
2374
  end;
2375
end;
2376

2377
procedure TGLCheckBox.SetChecked(NewChecked: Boolean);
2378

2379
begin
2380
  if NewChecked <> FChecked then
2381
  begin
2382
    BlockRender;
2383
    try
2384
      if NewChecked then
2385
        if Group >= 0 then
2386
          UnpressGroup(FindFirstGui, Group);
2387

2388
      FChecked := NewChecked;
2389
    finally
2390
      UnBlockRender;
2391
    end;
2392

2393
    NotifyChange(Self);
2394
    if Assigned(FOnChange) then
2395
      FOnChange(Self);
2396
  end;
2397
end;
2398

2399
procedure TGLCheckBox.InternalMouseDown(Shift: TShiftState; Button:
2400
  TGLMouseButton; X, Y: Integer);
2401
begin
2402
  Checked := not Checked;
2403
  inherited;
2404
end;
2405

2406
procedure TGLCheckBox.InternalMouseUp(Shift: TShiftState; Button:
2407
  TGLMouseButton; X, Y: Integer);
2408

2409
begin
2410
  inherited;
2411
end;
2412

2413
procedure TGLCheckBox.SetGuiLayoutNameChecked(newName: TGLGuiComponentName);
2414

2415
begin
2416
  if FGuiLayoutNameChecked <> NewName then
2417
  begin
2418
    FGuiCheckedComponent := nil;
2419
    FGuiLayoutNameChecked := NewName;
2420
    if Assigned(FGuiLayout) then
2421
    begin
2422
      FGuiCheckedComponent :=
2423
        FGuiLayout.GuiComponents.FindItem(FGuiLayoutNameChecked);
2424
      FReBuildGui := True;
2425
      GUIRedraw := True;
2426
    end;
2427
  end;
2428
end;
2429

2430
procedure TGLCheckBox.SetGuiLayout(NewGui: TGLGuiLayout);
2431

2432
begin
2433
  FGuiCheckedComponent := nil;
2434
  inherited;
2435
  if Assigned(FGuiLayout) then
2436
  begin
2437
    FGuiCheckedComponent :=
2438
      FGuiLayout.GuiComponents.FindItem(FGuiLayoutNameChecked);
2439
    FReBuildGui := True;
2440
    GUIRedraw := True;
2441
  end;
2442
end;
2443

2444
procedure TGLCheckBox.SetGroup(const val: Integer);
2445

2446
begin
2447
  FGroup := val;
2448
  if Checked then
2449
  begin
2450
    BlockRender;
2451
    FChecked := False;
2452
    UnpressGroup(FindFirstGui, val);
2453
    FChecked := true;
2454
    UnBlockRender;
2455
  end;
2456
end;
2457

2458
constructor TGLCheckBox.Create(AOwner: TComponent);
2459

2460
begin
2461
  inherited;
2462
  FChecked := False;
2463
  FGroup := -1;
2464
end;
2465

2466
procedure TGLCheckBox.InternalRender(var rci: TGLRenderContextInfo; renderSelf,
2467
  renderChildren: Boolean);
2468
begin
2469
  if Checked then
2470
  begin
2471
    if Assigned(FGuiCheckedComponent) then
2472
    begin
2473
      FGuiCheckedComponent.RenderToArea(0, 0, Width, Height, FRenderStatus,
2474
        FReBuildGui);
2475
    end;
2476
  end
2477
  else
2478
  begin
2479
    if Assigned(FGuiComponent) then
2480
    begin
2481
      FGuiComponent.RenderToArea(0, 0, Width, Height, FRenderStatus,
2482
        FReBuildGui);
2483
    end;
2484
  end;
2485
end;
2486

2487
procedure TGLCheckBox.NotifyChange(Sender: TObject);
2488

2489
begin
2490
  if Sender = FGuiLayout then
2491
  begin
2492
    if (FGuiLayoutNameChecked <> '') and (GuiLayout <> nil) then
2493
    begin
2494
      BlockRender;
2495
      FGuiCheckedComponent :=
2496
        GuiLayout.GuiComponents.FindItem(FGuiLayoutNameChecked);
2497
      ReBuildGui := True;
2498
      GUIRedraw := True;
2499
      UnBlockRender;
2500
    end
2501
    else
2502
    begin
2503
      BlockRender;
2504
      FGuiCheckedComponent := nil;
2505
      ReBuildGui := True;
2506
      GUIRedraw := True;
2507
      UnBlockRender;
2508
    end;
2509
  end;
2510
  inherited;
2511
end;
2512

2513
procedure TGLButton.SetPressed(NewPressed: Boolean);
2514

2515
begin
2516
  if FPressed <> NewPressed then
2517
  begin
2518
    BlockRender;
2519
    try
2520
      if NewPressed then
2521
        if Group >= 0 then
2522
          UnpressGroup(RootControl, Group);
2523

2524
      FPressed := NewPressed;
2525
    finally
2526
      UnBlockRender;
2527
    end;
2528

2529
    if FPressed then
2530
      if Assigned(FOnButtonClick) then
2531
        FOnButtonClick(Self);
2532

2533
    NotifyChange(Self);
2534
  end;
2535
end;
2536

2537
procedure TGLButton.InternalMouseDown(Shift: TShiftState; Button:
2538
  TGLMouseButton; X, Y: Integer);
2539
begin
2540
  SetFocus;
2541
  inherited;
2542
  if Button = mbLeft then
2543
    if AllowUp then
2544
      Pressed := not Pressed
2545
    else
2546
      Pressed := True;
2547
end;
2548

2549
procedure TGLButton.InternalMouseUp(Shift: TShiftState; Button: TGLMouseButton;
2550
  X, Y: Integer);
2551

2552
begin
2553
  if (Button = mbLeft) and (Group < 0) then
2554
    Pressed := False;
2555
  inherited;
2556
end;
2557

2558
procedure TGLButton.InternalKeyDown(var Key: Word; Shift: TShiftState);
2559

2560
begin
2561
  inherited;
2562
  if Key = glKey_SPACE then
2563
  begin
2564
    Pressed := True;
2565
  end;
2566
  if Key = glKey_RETURN then
2567
  begin
2568
    Pressed := True;
2569
  end;
2570
end;
2571

2572
procedure TGLButton.InternalKeyUp(var Key: Word; Shift: TShiftState);
2573

2574
begin
2575
  if ((Key = glKey_SPACE) or (Key = glKey_RETURN)) and (Group < 0) then
2576
  begin
2577
    Pressed := False;
2578
  end;
2579
  inherited;
2580
end;
2581

2582
procedure TGLButton.SetFocused(Value: Boolean);
2583
begin
2584
  inherited;
2585
  if (not FFocused) and (Group < 0) then
2586
    Pressed := False;
2587
end;
2588

2589
procedure TGLButton.SetGuiLayoutNamePressed(newName: TGLGuiComponentName);
2590

2591
begin
2592
  if FGuiLayoutNamePressed <> NewName then
2593
  begin
2594
    FGuiPressedComponent := nil;
2595
    FGuiLayoutNamePressed := NewName;
2596
    if Assigned(FGuiLayout) then
2597
    begin
2598
      FGuiPressedComponent :=
2599
        FGuiLayout.GuiComponents.FindItem(FGuiLayoutNamePressed);
2600
      FReBuildGui := True;
2601
      GUIRedraw := True;
2602
    end;
2603
  end;
2604
end;
2605

2606
procedure TGLButton.SetGuiLayout(NewGui: TGLGuiLayout);
2607

2608
begin
2609
  FGuiPressedComponent := nil;
2610
  inherited;
2611
  if Assigned(FGuiLayout) then
2612
  begin
2613
    FGuiPressedComponent :=
2614
      FGuiLayout.GuiComponents.FindItem(FGuiLayoutNamePressed);
2615
    FReBuildGui := True;
2616
    GUIRedraw := True;
2617
  end;
2618
end;
2619

2620
procedure TGLButton.SetBitBtn(AValue: TGLMaterial);
2621

2622
begin
2623
  FBitBtn.Assign(AValue);
2624
  NotifyChange(Self);
2625
end;
2626

2627
procedure TGLButton.DestroyHandle;
2628
begin
2629
  inherited;
2630
  FBitBtn.DestroyHandles;
2631
end;
2632

2633
procedure TGLButton.SetGroup(const val: Integer);
2634

2635
begin
2636
  FGroup := val;
2637
  if Pressed then
2638
  begin
2639
    BlockRender;
2640
    FPressed := False;
2641
    UnpressGroup(RootControl, Group);
2642
    FPressed := True;
2643
    UnBlockRender;
2644
  end;
2645
end;
2646

2647
procedure TGLButton.SetLogicWidth(const val: single);
2648

2649
begin
2650
  FLogicWidth := val;
2651
  NotifyChange(Self);
2652
end;
2653

2654
procedure TGLButton.SetLogicHeight(const val: single);
2655

2656
begin
2657
  FLogicHeight := val;
2658
  NotifyChange(Self);
2659
end;
2660

2661
procedure TGLButton.SetXOffset(const val: single);
2662

2663
begin
2664
  FXOffSet := val;
2665
  NotifyChange(Self);
2666
end;
2667

2668
procedure TGLButton.SetYOffset(const val: single);
2669

2670
begin
2671
  FYOffSet := val;
2672
  NotifyChange(Self);
2673
end;
2674

2675
constructor TGLButton.Create(AOwner: TComponent);
2676
begin
2677
  inherited Create(AOwner);
2678
  FBitBtn := TGLMaterial.Create(Self);
2679
  FGroup := -1;
2680
  FPressed := False;
2681
end;
2682

2683
destructor TGLButton.Destroy;
2684
begin
2685
  inherited Destroy;
2686
  FBitBtn.Free;
2687
end;
2688

2689
procedure TGLButton.InternalRender(var rci: TGLRenderContextInfo; renderSelf,
2690
  renderChildren: Boolean);
2691

2692
var
2693
  B: Boolean;
2694
  TexWidth: Integer;
2695
  TexHeight: Integer;
2696
  Material: TGLMaterial;
2697
  LibMaterial: TGLLibMaterial;
2698
  TextColor: TColorVector;
2699

2700
begin
2701
  if Pressed then
2702
  begin
2703
    if Assigned(FGuiPressedComponent) then
2704
    begin
2705
      FGuiPressedComponent.RenderToArea(0, 0, Width, Height, FRenderStatus,
2706
        FReBuildGui);
2707
    end;
2708
  end
2709
  else
2710
  begin
2711
    if Assigned(FGuiComponent) then
2712
    begin
2713
      FGuiComponent.RenderToArea(0, 0, Width, Height, FRenderStatus,
2714
        FReBuildGui);
2715
    end;
2716
  end;
2717

2718
  B := not BitBtn.Texture.Disabled;
2719
  Material := nil;
2720
  if not B then
2721
  begin
2722
    if (BitBtn.MaterialLibrary <> nil) and (BitBtn.MaterialLibrary is
2723
      TGLMaterialLibrary) then
2724
    begin
2725

2726
      LibMaterial :=
2727
        TGLMaterialLibrary(BitBtn.MaterialLibrary).Materials.GetLibMaterialByName(BitBtn.LibMaterialName);
2728
      if LibMaterial <> nil then
2729
      begin
2730
        Material := LibMaterial.Material;
2731
        B := True;
2732
      end;
2733
    end;
2734
  end
2735
  else
2736
  begin
2737
    Material := BitBtn;
2738
  end;
2739

2740
  if B then
2741
    with FRenderStatus[GLAlCenter] do
2742
    begin
2743
      GuiLayout.Material.UnApply(rci);
2744
      BitBtn.Apply(rci);
2745

2746
      TexWidth := Material.Texture.TexWidth;
2747
      if TexWidth = 0 then
2748
        TexWidth := Material.Texture.Image.Width;
2749

2750
      TexHeight := Material.Texture.TexHeight;
2751
      if TexHeight = 0 then
2752
        TexHeight := Material.Texture.Image.Height;
2753

2754
      GL.Begin_(GL_QUADS);
2755

2756
      GL.TexCoord2f(0, 0);
2757
      GL.Vertex2f(X1 - XOffSet, -Y1 + YOffSet);
2758

2759
      GL.TexCoord2f(0, -(LogicHeight - 1) / TexHeight);
2760
      GL.Vertex2f(X1 - XOffSet, -Y1 + YOffset - LogicHeight + 1);
2761

2762
      GL.TexCoord2f((LogicWidth - 1) / TexWidth, -(LogicHeight - 1) /
2763
        TexHeight);
2764
      GL.Vertex2f(X1 - XOffSet + LogicWidth - 1, -Y1 + YOffset - LogicHeight +
2765
        1);
2766

2767
      GL.TexCoord2f((LogicWidth - 1) / TexWidth, 0);
2768
      GL.Vertex2f(X1 - XOffSet + LogicWidth - 1, -Y1 + YOffSet);
2769

2770
      GL.End_();
2771
      BitBtn.UnApply(rci);
2772
      GuiLayout.Material.Apply(rci);
2773
    end;
2774

2775
  if Assigned(BitmapFont) then
2776
  begin
2777

2778
    if FFocused then
2779
    begin
2780
      TextColor := FFocusedColor;
2781
    end
2782
    else
2783
    begin
2784
      TextColor := FDefaultColor;
2785
    end;
2786
    TextColor.V[3] := AlphaChannel;
2787

2788
    WriteTextAt(rci, FRenderStatus[GLALCenter].X1,
2789
      FRenderStatus[GLALCenter].Y1,
2790
      FRenderStatus[GLALCenter].X2,
2791
      FRenderStatus[GLALCenter].Y2,
2792
      Caption,
2793
      TextColor);
2794
  end;
2795
end;
2796

2797
procedure TGLEdit.InternalMouseDown(Shift: TShiftState; Button: TGLMouseButton;
2798
  X, Y: Integer);
2799
begin
2800
  if not FReadOnly then
2801
    SetFocus;
2802
  inherited;
2803
end;
2804

2805
procedure TGLEdit.InternalKeyPress(var Key: Char);
2806
begin
2807
  if FReadOnly then
2808
    exit;
2809
  inherited;
2810
  case Key of
2811
    #8:
2812
      begin
2813
        if FSelStart > 1 then
2814
        begin
2815
          system.Delete(FCaption, FSelStart - 1, 1);
2816
          Dec(FSelStart);
2817
          GUIRedraw := True;
2818
        end;
2819
      end;
2820
  else
2821
    begin
2822
      if Key >= #32 then
2823
      begin
2824
        system.Insert(Key, FCaption, SelStart);
2825
        inc(FSelStart);
2826
        GUIRedraw := True;
2827
      end;
2828
    end;
2829
  end;
2830
end;
2831

2832
procedure TGLEdit.InternalKeyDown(var Key: Word; Shift: TShiftState);
2833
begin
2834
  if FReadOnly then
2835
    exit;
2836
  inherited;
2837
  case Key of
2838
    glKey_DELETE:
2839
      begin
2840
        if FSelStart <= Length(Caption) then
2841
        begin
2842
          System.Delete(FCaption, FSelStart, 1);
2843
          GUIRedraw := True;
2844
        end;
2845
      end;
2846
    glKey_LEFT:
2847
      begin
2848
        if FSelStart > 1 then
2849
        begin
2850
          Dec(FSelStart);
2851
          GUIRedraw := True;
2852
        end;
2853
      end;
2854
    glKey_RIGHT:
2855
      begin
2856
        if FSelStart < Length(Caption) + 1 then
2857
        begin
2858
          Inc(FSelStart);
2859
          GUIRedraw := True;
2860
        end;
2861
      end;
2862
    glKey_HOME:
2863
      begin
2864
        if FSelStart > 1 then
2865
        begin
2866
          FSelStart := 1;
2867
          GUIRedraw := True;
2868
        end;
2869
      end;
2870
    glKey_END:
2871
      begin
2872
        if FSelStart < Length(Caption) + 1 then
2873
        begin
2874
          FSelStart := Length(Caption) + 1;
2875
          GUIRedraw := True;
2876
        end;
2877
      end;
2878
  end;
2879

2880
end;
2881

2882
procedure TGLEdit.InternalKeyUp(var Key: Word; Shift: TShiftState);
2883

2884
begin
2885
  inherited;
2886
end;
2887

2888
procedure TGLEdit.SetFocused(Value: Boolean);
2889

2890
begin
2891
  inherited;
2892
  if Value then
2893
    SelStart := Length(Caption) + 1;
2894
end;
2895

2896
procedure TGLEdit.SetSelStart(const Value: Integer);
2897

2898
begin
2899
  FSelStart := Value;
2900
  GUIRedraw := True;
2901
end;
2902

2903
procedure TGLEdit.SetEditChar(const Value: string);
2904

2905
begin
2906
  FEditChar := Value;
2907
  GUIRedraw := True;
2908
end;
2909

2910
constructor TGLEdit.Create(AOwner: TComponent);
2911

2912
begin
2913
  inherited;
2914
  FEditChar := '*';
2915
end;
2916

2917
procedure TGLEdit.InternalRender(var rci: TGLRenderContextInfo; renderSelf,
2918
  renderChildren: Boolean);
2919
var
2920
  Tekst: UnicodeString;
2921
  pBig: Integer;
2922
begin
2923
  // Renders the background
2924
  if Assigned(FGuiComponent) then
2925
  begin
2926
    FGuiComponent.RenderToArea(0, 0, Width, Height, FRenderStatus, FReBuildGui);
2927
  end;
2928
  // Renders the text
2929
  if Assigned(FBitmapFont) then
2930
  begin
2931
    Tekst := Caption;
2932

2933
    if FFocused then
2934
    begin
2935
      // First put in the edit character where it should be.
2936
      system.insert(FEditChar, Tekst, SelStart);
2937
      // Next figure out if the string is too long.
2938
      if FBitmapFont.CalcStringWidth(Tekst) > Width - 2 then
2939
      begin
2940
        // if it is then we need to check to see where SelStart is
2941
        if SelStart >= Length(Tekst) - 1 then
2942
        begin
2943
          // SelStart is within close proximity of the end of the string
2944
          // Calculate the % of text that we can use and return it against the length of the string.
2945
          pBig := Trunc(Int(((Width - 2) /
2946
            FBitmapFont.CalcStringWidth(Tekst)) * Length(Tekst)));
2947
          dec(pBig);
2948
          Tekst := Copy(Tekst, Length(Tekst) - pBig + 1, pBig);
2949
        end
2950
        else
2951
        begin
2952
          // SelStart is within close proximity of the end of the string
2953
          // Calculate the % of text that we can use and return it against the length of the string.
2954
          pBig := Trunc(Int(((Width - 2) /
2955
            FBitmapFont.CalcStringWidth(Tekst)) * Length(Tekst)));
2956
          dec(pBig);
2957
          if SelStart + pBig < Length(Tekst) then
2958
            Tekst := Copy(Tekst, SelStart, pBig)
2959
          else
2960
            Tekst := Copy(Tekst, Length(Tekst) - pBig + 1, pBig);
2961
        end;
2962
      end;
2963
    end
2964
    else
2965
      { if FFocused then } if FBitmapFont.CalcStringWidth(Tekst) >
2966
      Width - 2 then
2967
      begin
2968
        // The while loop should never execute more then once, but just in case its here.
2969
        while FBitmapFont.CalcStringWidth(Tekst) > Width - 2 do
2970
        begin
2971
          // Calculate the % of text that we can use and return it against the length of the string.
2972
          pBig := Trunc(Int(((Width - 2) /
2973
            FBitmapFont.CalcStringWidth(Tekst)) * Length(Tekst)));
2974
          Tekst := Copy(Tekst, 1, pBig);
2975
        end;
2976
      end;
2977

2978
    if FFocused then
2979
    begin
2980
      WriteTextAt(rci, FRenderStatus[GLAlLeft].X1, FRenderStatus[GLAlCenter].Y1,
2981
        FRenderStatus[GLALCenter].X2, FRenderStatus[GLALCenter].Y2, Tekst,
2982
        FFocusedColor);
2983
    end
2984
    else
2985
    begin
2986
      WriteTextAt(rci, FRenderStatus[GLAlLeft].X1, FRenderStatus[GLAlCenter].Y1,
2987
        FRenderStatus[GLALCenter].X2, FRenderStatus[GLALCenter].Y2, Tekst,
2988
        FDefaultColor);
2989
    end;
2990
  end;
2991
end;
2992

2993
constructor TGLLabel.Create(AOwner: TComponent);
2994
begin
2995
  inherited;
2996
  FTextLayout := tlCenter;
2997
end;
2998

2999
procedure TGLLabel.InternalRender(var rci: TGLRenderContextInfo; renderSelf,
3000
  renderChildren: Boolean);
3001

3002
var
3003
  TekstPos: TVector;
3004
  Tekst: UnicodeString;
3005
  TextColor: TColorVector;
3006
begin
3007
  if Assigned(BitmapFont) then
3008
  begin
3009
    case Alignment of
3010
      taLeftJustify:
3011
        begin
3012
          TekstPos.V[0] := 0;
3013
        end;
3014
      taCenter:
3015
        begin
3016
          TekstPos.V[0] := Width / 2;
3017
        end;
3018
      taRightJustify:
3019
        begin
3020
          TekstPos.V[0] := Width;
3021
        end;
3022
    end;
3023

3024
    case TextLayout of
3025
      tlTop:
3026
        begin
3027
          TekstPos.V[1] := 0;
3028
        end;
3029
      tlCenter:
3030
        begin
3031
          TekstPos.V[1] := Round(-Height / 2);
3032
        end;
3033
      tlBottom:
3034
        begin
3035
          TekstPos.V[1] := -Height;
3036
        end;
3037
    end;
3038

3039
    TekstPos.V[2] := 0;
3040
    TekstPos.V[3] := 0;
3041

3042
    Tekst := Caption;
3043

3044
    TextColor := FDefaultColor;
3045
    TextColor.V[3] := AlphaChannel;
3046

3047
    BitmapFont.RenderString(rci, Tekst, FAlignment, FTextLayout, TextColor,
3048
      @TekstPos);
3049
  end;
3050
end;
3051

3052
procedure TGLLabel.SetAlignment(const Value: TAlignment);
3053
begin
3054
  if FAlignment <> Value then
3055
  begin
3056
    FAlignment := Value;
3057
    NotifyChange(Self);
3058
  end;
3059
end;
3060

3061
procedure TGLLabel.SetTextLayout(const Value: TGLTextLayout);
3062
begin
3063
  if FTextLayout <> Value then
3064
  begin
3065
    FTextLayout := Value;
3066
    NotifyChange(Self);
3067
  end;
3068
end;
3069

3070
procedure TGLAdvancedLabel.InternalRender(var rci: TGLRenderContextInfo;
3071
  renderSelf, renderChildren: Boolean);
3072

3073
begin
3074
  if Assigned(BitmapFont) then
3075
  begin
3076
    if Focused then
3077
    begin
3078
      WriteTextAt(rci, 8, -((Height - GetFontHeight) / 2) + 1, Caption,
3079
        FFocusedColor);
3080
    end
3081
    else
3082
    begin
3083
      WriteTextAt(rci, 8, -((Height - GetFontHeight) / 2) + 1, Caption,
3084
        FDefaultColor);
3085
    end;
3086
  end;
3087
end;
3088

3089
procedure TGLScrollbar.SetMin(const val: Single);
3090
begin
3091
  if FMin <> val then
3092
  begin
3093
    FMin := val;
3094
    if FPos < FMin then
3095
      Pos := FMin;
3096
    NotifyChange(Self);
3097
  end;
3098
end;
3099

3100
procedure TGLScrollbar.SetMax(const val: Single);
3101
begin
3102
  if FMax <> val then
3103
  begin
3104
    FMax := val;
3105
    if FMax < FMin then
3106
      FMax := FMin;
3107
    if FPos > (FMax - FPageSize + 1) then
3108
      Pos := (FMax - FPageSize + 1);
3109
    NotifyChange(Self);
3110
  end;
3111
end;
3112

3113
procedure TGLScrollbar.SetPos(const val: Single);
3114
begin
3115
  if FPos <> val then
3116
  begin
3117
    FPos := val;
3118
    if FPos < FMin then
3119
      FPos := FMin;
3120
    if FPos > (FMax - FPageSize + 1) then
3121
      FPos := (FMax - FPageSize + 1);
3122

3123
    NotifyChange(Self);
3124
    if Assigned(FOnChange) then
3125
      FOnChange(Self);
3126
  end;
3127
end;
3128

3129
procedure TGLScrollbar.SetPageSize(const val: Single);
3130

3131
begin
3132
  if FPageSize <> val then
3133
  begin
3134
    FPageSize := val;
3135
    if FPos > (FMax - FPageSize + 1) then
3136
      Pos := (FMax - FPageSize + 1);
3137
    NotifyChange(Self);
3138
  end;
3139
end;
3140

3141
procedure TGLScrollbar.SetHorizontal(const val: Boolean);
3142

3143
begin
3144
  if FHorizontal <> val then
3145
  begin
3146
    FHorizontal := val;
3147
    NotifyChange(Self);
3148
  end;
3149
end;
3150

3151
procedure TGLScrollbar.SetGuiLayoutKnobName(newName: TGLGuiComponentName);
3152

3153
begin
3154
  if newName <> FGuiLayoutKnobName then
3155
  begin
3156
    FGuiKnobComponent := nil;
3157
    FGuiLayoutKnobName := NewName;
3158
    if Assigned(FGuiLayout) then
3159
    begin
3160
      FGuiKnobComponent :=
3161
        FGuiLayout.GuiComponents.FindItem(FGuiLayoutKnobName);
3162
      FReBuildGui := True;
3163
      GUIRedraw := True;
3164
    end;
3165
  end;
3166
end;
3167

3168
procedure TGLScrollbar.SetGuiLayout(NewGui: TGLGuiLayout);
3169

3170
begin
3171
  FGuiKnobComponent := nil;
3172
  inherited;
3173
  if Assigned(FGuiLayout) then
3174
  begin
3175
    FGuiKnobComponent := FGuiLayout.GuiComponents.FindItem(FGuiLayoutKnobName);
3176
    FReBuildGui := True;
3177
    GUIRedraw := True;
3178
  end;
3179
end;
3180

3181
function TGLScrollbar.GetScrollPosY(ScrollPos: Single): Single;
3182
begin
3183
  with FRenderStatus[GLAlCenter] do
3184
  begin
3185
    Result := (ScrollPos - FMin) / (FMax - FMin) * (Y2 - Y1) + Y1;
3186
  end;
3187
end;
3188

3189
function TGLScrollbar.GetYScrollPos(Y: Single): Single;
3190
begin
3191
  with FRenderStatus[GLAlCenter] do
3192
  begin
3193
    Result := (Y - Y1) / (Y2 - Y1) * (FMax - FMin) + FMin;
3194
  end;
3195
end;
3196

3197
function TGLScrollbar.GetScrollPosX(ScrollPos: Single): Single;
3198
begin
3199
  with FRenderStatus[GLAlCenter] do
3200
  begin
3201
    Result := (ScrollPos - FMin) / (FMax - FMin) * (X2 - X1) + X1;
3202
  end;
3203
end;
3204

3205
function TGLScrollbar.GetXScrollPos(X: Single): Single;
3206
begin
3207
  with FRenderStatus[GLAlCenter] do
3208
  begin
3209
    Result := (X - X1) / (X2 - X1) * (FMax - FMin) + FMin;
3210
  end;
3211
end;
3212

3213
procedure TGLScrollbar.InternalMouseDown(Shift: TShiftState; Button:
3214
  TGLMouseButton; X, Y: Integer);
3215

3216
var
3217
  Tx, Ty: Single;
3218

3219
begin
3220
  if (Button = mbLeft)
3221
    and not FLocked then
3222
  begin
3223
    Tx := x - Position.X;
3224
    Ty := y - Position.Y;
3225
    // is in mid area ?
3226
    if IsInRect(FRenderStatus[GLAlCenter], Tx, Ty) then
3227
    begin
3228
      if FHorizontal then
3229
      begin
3230
        Tx := GetxScrollPos(Tx);
3231
        if Tx < FPos then
3232
          PageUp
3233
        else if Tx > FPos + FPageSize - 1 then
3234
          PageDown
3235
        else
3236
        begin
3237
          fScrolling := True;
3238
          FScrollOffs := Tx - FPos;
3239
          RootControl.ActiveControl := Self;
3240
        end;
3241
      end
3242
      else
3243
      begin
3244
        Ty := GetYScrollPos(Ty);
3245
        if Ty < FPos then
3246
          PageUp
3247
        else if Ty > FPos + FPageSize - 1 then
3248
          PageDown
3249
        else
3250
        begin
3251
          fScrolling := True;
3252
          FScrollOffs := Ty - FPos;
3253
          RootControl.ActiveControl := Self;
3254
        end;
3255
      end;
3256
    end
3257
    else
3258
    begin
3259
      // if not, is at end buttons ?
3260
      if horizontal then
3261
      begin
3262
        if IsInRect(FRenderStatus[GLAlLeft], Tx, Ty) then
3263
          StepUp;
3264
        if IsInRect(FRenderStatus[GLAlRight], Tx, Ty) then
3265
          StepDown;
3266
      end
3267
      else
3268
      begin
3269
        if IsInRect(FRenderStatus[GLAlTop], Tx, Ty) then
3270
          StepUp;
3271
        if IsInRect(FRenderStatus[GLAlBottom], Tx, Ty) then
3272
          StepDown;
3273
      end;
3274
    end;
3275
  end;
3276
  inherited;
3277
end;
3278

3279
procedure TGLScrollbar.InternalMouseUp(Shift: TShiftState; Button:
3280
  TGLMouseButton; X, Y: Integer);
3281
begin
3282
  if fScrolling then
3283
  begin
3284
    fScrolling := False;
3285
    RootControl.ActiveControl := nil;
3286
  end;
3287

3288
  inherited;
3289
end;
3290

3291
procedure TGLScrollbar.InternalMouseMove(Shift: TShiftState; X, Y: Integer);
3292

3293
var
3294
  Tx: Single;
3295
  Ty: Single;
3296
begin
3297
  if fScrolling then
3298
    if FHorizontal then
3299
    begin
3300
      Tx := GetXScrollPos(x - Position.X) - FScrollOffs;
3301
      Pos := Round(Tx);
3302
    end
3303
    else
3304
    begin
3305
      Ty := GetYScrollPos(y - Position.Y) - FScrollOffs;
3306
      Pos := Round(Ty);
3307
    end;
3308

3309
  inherited;
3310
end;
3311

3312
constructor TGLScrollbar.Create(AOwner: TComponent);
3313

3314
begin
3315
  inherited;
3316
  FGuiKnobComponent := nil;
3317
  FMin := 1;
3318
  FMax := 10;
3319
  FPos := 1;
3320
  FStep := 1;
3321
  FPageSize := 3;
3322
  FOnChange := nil;
3323
  FGuiLayoutKnobName := '';
3324
  FScrollOffs := 0;
3325
  FScrolling := False;
3326
  FHorizontal := False;
3327
end;
3328

3329
procedure TGLScrollbar.StepUp;
3330

3331
begin
3332
  Pos := Pos - FStep;
3333
end;
3334

3335
procedure TGLScrollbar.StepDown;
3336
begin
3337
  Pos := Pos + FStep;
3338
end;
3339

3340
procedure TGLScrollbar.PageUp;
3341
begin
3342
  Pos := Pos - FPageSize;
3343
end;
3344

3345
procedure TGLScrollbar.PageDown;
3346
begin
3347
  Pos := Pos + FPageSize;
3348
end;
3349

3350
function TGLScrollbar.MouseUp(Sender: TObject; Button: TGLMouseButton; Shift:
3351
  TShiftState; X, Y: Integer): Boolean;
3352

3353
begin
3354
  if (Button = mbLeft) and (FScrolling) then
3355
  begin
3356
    Result := True;
3357
    InternalMouseUp(Shift, Button, X, Y);
3358
  end
3359
  else
3360
    Result := inherited MouseUp(Sender, Button, Shift, X, Y);
3361
end;
3362

3363
function TGLScrollbar.MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
3364
  Integer): Boolean;
3365

3366
begin
3367
  if (FScrolling) then
3368
  begin
3369
    Result := True;
3370
    InternalMouseMove(Shift, X, Y);
3371
  end
3372
  else
3373
    Result := inherited MouseMove(Sender, Shift, X, Y);
3374
end;
3375

3376
procedure TGLScrollbar.InternalRender(var rci: TGLRenderContextInfo; renderSelf,
3377
  renderChildren: Boolean);
3378

3379
var
3380
  Start, Size: Integer;
3381
begin
3382
  if Assigned(FGuiComponent) then
3383
  begin
3384
    try
3385
      FGuiComponent.RenderToArea(0, 0, Width, Height, FRenderStatus,
3386
        FReBuildGui);
3387
    except
3388
      on E: Exception do
3389
        GLOKMessageBox(E.Message,
3390
          'Exception in GuiComponents InternalRender function');
3391
    end;
3392
  end;
3393
  if Assigned(FGuiKnobComponent) then
3394
  begin
3395
    try
3396
      with FRenderStatus[GLAlCenter] do
3397
      begin
3398
        if FHorizontal then
3399
        begin
3400
          Start := Round(GetScrollPosX(FPos));
3401
          if FPageSize + FPos > FMax + 1 then
3402
            Size := Round(GetScrollPosX(FMax) - X1)
3403
          else
3404
            Size := Round(GetScrollPosX(FPageSize) - X1);
3405

3406
          FGuiKnobComponent.RenderToArea(Start, Y1, Start + Size, Y2,
3407
            FKnobRenderStatus, True);
3408
          //           Tag := start;
3409
          //           tagfloat := size;
3410
        end
3411
        else
3412
        begin
3413
          Start := Round(GetScrollPosY(FPos));
3414
          if FPageSize + FPos > FMax + 1 then
3415
            Size := Round(GetScrollPosY(FMax) - Y1)
3416
          else
3417
            Size := Round(GetScrollPosY(FPageSize) - Y1);
3418
          FGuiKnobComponent.RenderToArea(X1, Start, X2, Start + Size,
3419
            FKnobRenderStatus, True);
3420
          //           Tag := start;
3421
          //           tagfloat := size;
3422
        end;
3423
      end;
3424
    except
3425
      on E: Exception do
3426
        GLOKMessageBox(E.Message,
3427
          'Exception in GuiComponents InternalRender function');
3428
    end;
3429
  end;
3430
end;
3431

3432
function TGLStringGrid.GetCell(X, Y: Integer; out oCol, oRow: Integer): Boolean;
3433

3434
var
3435
  ClientRect: TRectangle;
3436
  XPos: Integer;
3437
  YPos: Integer;
3438
  XC, YC: Integer;
3439

3440
begin
3441
  Result := False;
3442
  if Assigned(BitmapFont) then
3443
  begin
3444
    if Assigned(FGuiComponent) then
3445
    begin
3446
      ClientRect.Left := Round(FRenderStatus[GLAlCenter].X1);
3447
      ClientRect.Top := Round(FRenderStatus[GLAlCenter].Y1);
3448
      ClientRect.Width := Round(FRenderStatus[GLAlCenter].X2);
3449
      ClientRect.Height := Round(FRenderStatus[GLAlCenter].Y2);
3450
    end
3451
    else
3452
    begin
3453
      ClientRect.Left := 0;
3454
      ClientRect.Top := 0;
3455
      ClientRect.Width := Round(Width);
3456
      ClientRect.Height := Round(Height);
3457
    end;
3458

3459
    YPos := ClientRect.Top;
3460
    if FDrawHeader then
3461
      YPos := YPos + RowHeight;
3462
    XPos := ClientRect.Left;
3463

3464
    if y < YPos then
3465
      Exit;
3466
    if x < XPos then
3467
      Exit;
3468

3469
    XPos := XPos + MarginSize;
3470

3471
    for XC := 0 to Columns.Count - 1 do
3472
    begin
3473
      XPos := XPos + Integer(Columns.Objects[XC]);
3474

3475
      if x > XPos then
3476
        continue;
3477

3478
      for YC := 0 to RowCount - 1 do
3479
      begin
3480
        YPos := YPos + RowHeight;
3481
        if y < YPos then
3482
        begin
3483
          Result := True;
3484
          if Assigned(Scrollbar) then
3485
            oRow := YC + Round(Scrollbar.Pos) - 1
3486
          else
3487
            oRow := YC;
3488

3489
          oCol := XC;
3490
          Exit;
3491
        end;
3492
      end;
3493
    end;
3494
  end;
3495
end;
3496

3497
procedure TGLStringGrid.InternalMouseDown(Shift: TShiftState; Button:
3498
  TGLMouseButton; X, Y: Integer);
3499

3500
var
3501
  tRow, tCol: Integer;
3502
begin
3503
  SetFocus;
3504
  if GetCell(Round(X - Position.X), Round(Y - Position.Y), tCol, tRow) then
3505
  begin
3506
    SelCol := tCol;
3507
    SelRow := tRow;
3508
  end;
3509
  inherited;
3510
end;
3511

3512
procedure TGLStringGrid.SetColumns(const val: TStrings);
3513
var
3514
  XC: Integer;
3515
begin
3516
  FColumns.Assign(val);
3517
  for XC := 0 to Columns.Count - 1 do
3518
    Columns.Objects[XC] := TObject(ColumnSize);
3519
end;
3520

3521
procedure TGLStringGrid.SetColSelect(const val: Boolean);
3522
begin
3523
  FColSelect := Val;
3524
  NotifyChange(Self);
3525
end;
3526

3527
function TGLStringGrid.GetRow(index: Integer): TStringList;
3528

3529
begin
3530
  if (index >= 0) and (index < FRows.Count) then
3531
    Result := TStringList(FRows[index])
3532
  else
3533
    Result := nil;
3534
end;
3535

3536
procedure TGLStringGrid.SetRow(index: Integer; const val: TStringList);
3537

3538
begin
3539
  if (index >= 0) then
3540
  begin
3541
    if (index >= RowCount) then
3542
      RowCount := index + 1;
3543

3544
    TStringList(FRows[index]).Assign(val);
3545
  end;
3546
end;
3547

3548
function TGLStringGrid.GetRowCount: Integer;
3549

3550
begin
3551
  Result := FRows.count;
3552
end;
3553

3554
procedure TGLStringGrid.SetRowCount(const val: Integer);
3555

3556
var
3557
  XC: Integer;
3558

3559
begin
3560
  XC := FRows.count;
3561
  if val <> XC then
3562
  begin
3563
    if val > XC then
3564
    begin
3565
      FRows.count := val;
3566
      for XC := XC to val - 1 do
3567
      begin
3568
        FRows[XC] := TStringList.Create;
3569
        TStringList(FRows[XC]).OnChange := OnStringListChange;
3570
      end;
3571
    end
3572
    else
3573
    begin
3574
      for XC := XC - 1 downto val do
3575
      begin
3576
        TStringList(FRows[XC]).Free;
3577
      end;
3578
      FRows.count := val;
3579
    end;
3580
    if Assigned(Scrollbar) then
3581
      Scrollbar.FMax := FRows.Count;
3582
    NotifyChange(Self);
3583
  end;
3584
end;
3585

3586
procedure TGLStringGrid.SetSelCol(const val: Integer);
3587
begin
3588
  if FSelCol <> Val then
3589
  begin
3590
    FSelCol := Val;
3591
    NotifyChange(Self);
3592
  end;
3593
end;
3594

3595
procedure TGLStringGrid.SetSelRow(const val: Integer);
3596
begin
3597
  if FSelRow <> Val then
3598
  begin
3599
    FSelRow := Val;
3600
    NotifyChange(Self);
3601
  end;
3602
end;
3603

3604
procedure TGLStringGrid.SetRowSelect(const val: Boolean);
3605
begin
3606
  FRowSelect := Val;
3607
  NotifyChange(Self);
3608
end;
3609

3610
procedure TGLStringGrid.SetDrawHeader(const val: Boolean);
3611

3612
begin
3613
  FDrawHeader := Val;
3614
  NotifyChange(Self);
3615
end;
3616

3617
function TGLStringGrid.GetHeaderColor: TDelphiColor;
3618

3619
begin
3620
  Result := ConvertColorVector(FHeaderColor);
3621
end;
3622

3623
procedure TGLStringGrid.SetHeaderColor(const val: TDelphiColor);
3624

3625
begin
3626
  FHeaderColor := ConvertWinColor(val);
3627
  GUIRedraw := True;
3628
end;
3629

3630
procedure TGLStringGrid.SetMarginSize(const val: Integer);
3631

3632
begin
3633
  if FMarginSize <> val then
3634
  begin
3635
    FMarginSize := val;
3636
    GUIRedraw := True;
3637
  end;
3638
end;
3639

3640
procedure TGLStringGrid.SetColumnSize(const val: Integer);
3641

3642
var
3643
  XC: Integer;
3644

3645
begin
3646
  if FColumnSize <> val then
3647
  begin
3648
    FColumnSize := val;
3649
    for XC := 0 to Columns.Count - 1 do
3650
      Columns.Objects[XC] := TObject(ColumnSize);
3651
    GUIRedraw := True;
3652
  end;
3653
end;
3654

3655
procedure TGLStringGrid.SetRowHeight(const val: Integer);
3656

3657
begin
3658
  if FRowHeight <> val then
3659
  begin
3660
    FRowHeight := val;
3661
    GUIRedraw := True;
3662
  end;
3663
end;
3664

3665
procedure TGLStringGrid.SetScrollbar(const val: TGLScrollbar);
3666

3667
begin
3668
  if FScrollbar <> Val then
3669
  begin
3670
    if Assigned(FScrollbar) then
3671
      FScrollbar.RemoveFreeNotification(Self);
3672
    FScrollbar := Val;
3673
    if Assigned(FScrollbar) then
3674
      FScrollbar.FreeNotification(Self);
3675
  end;
3676
end;
3677

3678
procedure TGLStringGrid.SetGuiLayout(NewGui: TGLGuiLayout);
3679

3680
begin
3681
  inherited;
3682
  if Assigned(Scrollbar) then
3683
    if Scrollbar.GuiLayout <> nil then
3684
      Scrollbar.GuiLayout := NewGui;
3685
end;
3686

3687
constructor TGLStringGrid.Create(AOwner: TComponent);
3688

3689
begin
3690
  inherited;
3691
  FRows := TList.Create;
3692
  FColumns := TStringList.Create;
3693
  TStringList(FColumns).OnChange := OnStringListChange;
3694
  FSelCol := 0;
3695
  FSelRow := 0;
3696
  FRowSelect := True;
3697
  FScrollbar := nil;
3698
  FDrawHeader := True;
3699
end;
3700

3701
destructor TGLStringGrid.Destroy;
3702

3703
begin
3704
  Scrollbar := nil;
3705
  inherited;
3706
  Clear;
3707
  FRows.Free;
3708
  FColumns.Free;
3709
end;
3710

3711
procedure TGLStringGrid.Clear;
3712

3713
begin
3714
  RowCount := 0;
3715
end;
3716

3717
procedure TGLStringGrid.Notification(AComponent: TComponent; Operation:
3718
  TOperation);
3719

3720
begin
3721
  if (AComponent = FScrollbar) and (Operation = opRemove) then
3722
  begin
3723
    FScrollbar := nil;
3724
  end;
3725
  inherited;
3726
end;
3727

3728
procedure TGLStringGrid.NotifyChange(Sender: TObject);
3729

3730
begin
3731
  if Sender = Scrollbar then
3732
  begin
3733
    ReBuildGui := True;
3734
    GUIRedraw := True;
3735
  end;
3736
  inherited;
3737
end;
3738

3739
procedure TGLStringGrid.InternalRender(var rci: TGLRenderContextInfo; renderSelf,
3740
  renderChildren: Boolean);
3741

3742
  function CellSelected(X, Y: Integer): Boolean;
3743
  begin
3744
    if (RowSelect and ColSelect) then
3745
      Result := (Y = SelRow) or (x = SelCol)
3746
    else if RowSelect then
3747
      Result := Y = SelRow
3748
    else if ColSelect then
3749
      Result := X = SelCol
3750
    else
3751
      Result := (Y = SelRow) and (x = SelCol);
3752
  end;
3753

3754
  function CellText(X, Y: Integer): string;
3755

3756
  begin
3757
    with Row[y] do
3758
      if (X >= 0) and (X < Count) then
3759
        Result := strings[x]
3760
      else
3761
        Result := '';
3762
  end;
3763

3764
var
3765
  ClientRect: TRectangle;
3766
  XPos: Integer;
3767
  YPos: Integer;
3768
  XC, YC: Integer;
3769
  From, Till: Integer;
3770

3771
begin
3772
  if Assigned(FGuiComponent) then
3773
  begin
3774
    try
3775
      FGuiComponent.RenderToArea(0, 0, Width, Height, FRenderStatus,
3776
        FReBuildGui);
3777
      ClientRect.Left := Round(FRenderStatus[GLAlCenter].X1);
3778
      ClientRect.Top := Round(FRenderStatus[GLAlCenter].Y1);
3779
      ClientRect.Width := Round(FRenderStatus[GLAlCenter].X2);
3780
      ClientRect.Height := Round(FRenderStatus[GLAlCenter].Y2);
3781
    except
3782
      on E: Exception do
3783
        GLOKMessageBox(E.Message,
3784
          'Exception in GuiComponents InternalRender function');
3785
    end;
3786
  end
3787
  else
3788
  begin
3789
    ClientRect.Left := 0;
3790
    ClientRect.Top := 0;
3791
    ClientRect.Width := Round(Width);
3792
    ClientRect.Height := Round(Height);
3793
  end;
3794

3795
  if Assigned(BitmapFont) then
3796
  begin
3797
    XPos := ClientRect.Left + MarginSize;
3798

3799
    if Assigned(Scrollbar) then
3800
    begin
3801
      Scrollbar.Position.X := Position.X + FRenderStatus[GLAlCenter].X2 -
3802
        Scrollbar.Width;
3803
      Scrollbar.Position.Y := Position.Y + FRenderStatus[GLAlCenter].Y1;
3804
      Scrollbar.Height := FRenderStatus[GLAlCenter].Y2 -
3805
        FRenderStatus[GLAlCenter].Y1;
3806
      XC := (ClientRect.Height - ClientRect.Top);
3807
      if FDrawHeader then
3808
        YC := (XC div RowHeight) - 1
3809
      else
3810
        YC := (XC div RowHeight);
3811

3812
      Scrollbar.PageSize := YC;
3813
      From := Round(Scrollbar.pos - 1);
3814
      Till := Round(Scrollbar.pageSize + From - 1);
3815
      if Till > RowCount - 1 then
3816
        Till := RowCount - 1;
3817
    end
3818
    else
3819
    begin
3820
      From := 0;
3821
      Till := RowCount - 1;
3822
    end;
3823

3824
    for XC := 0 to Columns.Count - 1 do
3825
    begin
3826
      YPos := -ClientRect.Top;
3827
      if FDrawHeader then
3828
      begin
3829
        WriteTextAt(rci, XPos, YPos, Columns[XC], FHeaderColor);
3830
        YPos := YPos - RowHeight;
3831
      end;
3832
      for YC := From to Till do
3833
      begin
3834
        if CellSelected(XC, YC) then
3835
          WriteTextAt(rci, XPos, YPos, CellText(XC, YC), FFocusedColor)
3836
        else
3837
          WriteTextAt(rci, XPos, YPos, CellText(XC, YC), FDefaultColor);
3838
        YPos := YPos - RowHeight;
3839
      end;
3840
      XPos := XPos + Integer(Columns.Objects[XC]);
3841
    end;
3842
  end;
3843
end;
3844

3845
procedure TGLStringGrid.OnStringListChange(Sender: TObject);
3846

3847
begin
3848
  NotifyChange(Self);
3849
end;
3850

3851
function TGLStringGrid.Add(Data: array of string): Integer;
3852
var
3853
  XC: Integer;
3854
begin
3855
  Result := RowCount;
3856
  RowCount := RowCount + 1;
3857
  for XC := 0 to Length(Data) - 1 do
3858
    Row[Result].Add(Data[XC]);
3859
end;
3860

3861
function TGLStringGrid.Add(const Data: string): Integer;
3862
begin
3863
  Result := Add([Data]);
3864
  if Assigned(Scrollbar) then
3865
  begin
3866
    if Result > Round(Scrollbar.pageSize + Scrollbar.pos - 2) then
3867
      Scrollbar.pos := Result - Scrollbar.pageSize + 2;
3868
  end;
3869
end;
3870

3871
procedure TGLStringGrid.SetText(Data: string);
3872

3873
var
3874
  Posi: Integer;
3875
begin
3876
  Clear;
3877
  while Data <> '' do
3878
  begin
3879
    Posi := Pos(#13#10, Data);
3880
    if Posi > 0 then
3881
    begin
3882
      Add(Copy(Data, 1, Posi - 1));
3883
      Delete(Data, 1, Posi + 1);
3884
    end
3885
    else
3886
    begin
3887
      Add(Data);
3888
      Data := '';
3889
    end;
3890
  end;
3891
end;
3892

3893
destructor TGLFocusControl.Destroy;
3894
begin
3895
  if Focused then
3896
    RootControl.FocusedControl := nil;
3897
  inherited;
3898
end;
3899

3900
procedure TGLBaseComponent.DoProgress(const progressTime: TProgressTimes);
3901
begin
3902
  inherited;
3903
  if FDoChangesOnProgress then
3904
    DoChanges;
3905

3906
end;
3907

3908
procedure TGLBaseComponent.SetDoChangesOnProgress(const Value: Boolean);
3909
begin
3910
  FDoChangesOnProgress := Value;
3911
end;
3912

3913
procedure TGLFocusControl.MoveTo(newParent: TGLBaseSceneObject);
3914
begin
3915
  inherited;
3916
  ReGetRootControl;
3917
end;
3918

3919
initialization
3920
  RegisterClasses([TGLBaseControl, TGLPopupMenu, TGLForm, TGLPanel, TGLButton,
3921
    TGLCheckBox, TGLEdit, TGLLabel, TGLAdvancedLabel, TGLScrollbar, TGLStringGrid,
3922
    TGLCustomControl]);
3923
end.
3924

3925