DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / d2df-sdl.git / blob


ee54d5c5550dcb6a8389dcdf212fb64b8911bbe2
[d2df-sdl.git] / src / gx / gh_ui.pas
1 (* Copyright (C) DooM 2D:Forever Developers
2 *
3 * This program is free software: you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation, either version 3 of the License, or
6 * (at your option) any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this program. If not, see <http://www.gnu.org/licenses/>.
15 *)
16 {$INCLUDE ../shared/a_modes.inc}
17 {$M+}
18 unit gh_ui;
19
20 interface
21
22 uses
23 SysUtils, Classes,
24 GL, GLExt, SDL2,
25 gh_ui_common,
26 sdlcarcass, glgfx,
27 xparser;
28
29
30 // ////////////////////////////////////////////////////////////////////////// //
31 type
32 THControlClass = class of THControl;
33
34 THControl = class
35 public
36 type TActionCB = procedure (me: THControl; uinfo: Integer);
37
38 private
39 mParent: THControl;
40 mId: AnsiString;
41 mX, mY: Integer;
42 mWidth, mHeight: Integer;
43 mFrameWidth, mFrameHeight: Integer;
44 mEnabled: Boolean;
45 mCanFocus: Boolean;
46 mChildren: array of THControl;
47 mFocused: THControl; // valid only for top-level controls
48 mGrab: THControl; // valid only for top-level controls
49 mEscClose: Boolean; // valid only for top-level controls
50 mEatKeys: Boolean;
51 mDrawShadow: Boolean;
52
53 private
54 scis: TScissorSave;
55 scallowed: Boolean;
56
57 protected
58 function getEnabled (): Boolean;
59 procedure setEnabled (v: Boolean); inline;
60
61 function getFocused (): Boolean; inline;
62 procedure setFocused (v: Boolean); inline;
63
64 function isMyChild (ctl: THControl): Boolean;
65
66 function findFirstFocus (): THControl;
67 function findLastFocus (): THControl;
68
69 function findNextFocus (cur: THControl): THControl;
70 function findPrevFocus (cur: THControl): THControl;
71
72 procedure activated (); virtual;
73 procedure blurred (); virtual;
74
75 //WARNING! do not call scissor functions outside `.draw*()` API!
76 // set scissor to this rect (in local coords)
77 procedure setScissor (lx, ly, lw, lh: Integer);
78 // reset scissor to whole control
79 procedure resetScissor (fullArea: Boolean); inline; // "full area" means "with frame"
80
81 // DO NOT USE!
82 // set scissor to this rect (in global coords)
83 procedure setScissorGLInternal (x, y, w, h: Integer);
84
85 public
86 actionCB: TActionCB;
87
88 private
89 mDefSize: TLaySize; // default size
90 mMaxSize: TLaySize; // maximum size
91 mFlex: Integer;
92 mHoriz: Boolean;
93 mCanWrap: Boolean;
94 mLineStart: Boolean;
95 mHGroup: AnsiString;
96 mVGroup: AnsiString;
97 mAlign: Integer;
98 mExpand: Boolean;
99 mLayDefSize: TLaySize;
100 mLayMaxSize: TLaySize;
101
102 public
103 // layouter interface
104 function getDefSize (): TLaySize; inline; // default size; <0: use max size
105 //procedure setDefSize (const sz: TLaySize); inline; // default size; <0: use max size
106 function getMargins (): TLayMargins; inline;
107 function getMaxSize (): TLaySize; inline; // max size; <0: set to some huge value
108 //procedure setMaxSize (const sz: TLaySize); inline; // max size; <0: set to some huge value
109 function getFlex (): Integer; inline; // <=0: not flexible
110 function isHorizBox (): Boolean; inline; // horizontal layout for children?
111 procedure setHorizBox (v: Boolean); inline; // horizontal layout for children?
112 function canWrap (): Boolean; inline; // for horizontal boxes: can wrap children? for child: `false` means 'nonbreakable at *next* ctl'
113 procedure setCanWrap (v: Boolean); inline; // for horizontal boxes: can wrap children? for child: `false` means 'nonbreakable at *next* ctl'
114 function isLineStart (): Boolean; inline; // `true` if this ctl should start a new line; ignored for vertical boxes
115 procedure setLineStart (v: Boolean); inline; // `true` if this ctl should start a new line; ignored for vertical boxes
116 function getAlign (): Integer; inline; // aligning in non-main direction: <0: left/up; 0: center; >0: right/down
117 procedure setAlign (v: Integer); inline; // aligning in non-main direction: <0: left/up; 0: center; >0: right/down
118 function getExpand (): Boolean; inline; // expanding in non-main direction: `true` will ignore align and eat all available space
119 procedure setExpand (v: Boolean); inline; // expanding in non-main direction: `true` will ignore align and eat all available space
120 function getHGroup (): AnsiString; inline; // empty: not grouped
121 procedure setHGroup (const v: AnsiString); inline; // empty: not grouped
122 function getVGroup (): AnsiString; inline; // empty: not grouped
123 procedure setVGroup (const v: AnsiString); inline; // empty: not grouped
124
125 procedure setActualSizePos (constref apos: TLayPos; constref asize: TLaySize); inline;
126
127 procedure layPrepare (); virtual; // called before registering control in layouter
128
129 public
130 property flex: Integer read mFlex write mFlex;
131 property flDefaultSize: TLaySize read mDefSize write mDefSize;
132 property flMaxSize: TLaySize read mMaxSize write mMaxSize;
133 property flHoriz: Boolean read isHorizBox write setHorizBox;
134 property flCanWrap: Boolean read canWrap write setCanWrap;
135 property flLineStart: Boolean read isLineStart write setLineStart;
136 property flAlign: Integer read getAlign write setAlign;
137 property flExpand: Boolean read getExpand write setExpand;
138 property flHGroup: AnsiString read getHGroup write setHGroup;
139 property flVGroup: AnsiString read getVGroup write setVGroup;
140
141 protected
142 function parsePos (par: TTextParser): TLayPos;
143 function parseSize (par: TTextParser): TLaySize;
144 function parseBool (par: TTextParser): Boolean;
145 function parseAnyAlign (par: TTextParser): Integer;
146 function parseHAlign (par: TTextParser): Integer;
147 function parseVAlign (par: TTextParser): Integer;
148 function parseOrientation (const prname: AnsiString; par: TTextParser): Boolean;
149 procedure parseTextAlign (par: TTextParser; var h, v: Integer);
150 procedure parseChildren (par: TTextParser); // par should be on '{'; final '}' is eaten
151
152 public
153 // par is on property data
154 // there may be more data in text stream, don't eat it!
155 // return `true` if property name is valid and value was parsed
156 // return `false` if property name is invalid; don't advance parser in this case
157 // throw on property data errors
158 function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; virtual;
159
160 // par should be on '{'; final '}' is eaten
161 procedure parseProperties (par: TTextParser);
162
163 public
164 constructor Create ();
165 constructor Create (ax, ay, aw, ah: Integer);
166 destructor Destroy (); override;
167
168 // `sx` and `sy` are screen coordinates
169 procedure drawControl (gx, gy: Integer); virtual;
170
171 // called after all children drawn
172 procedure drawControlPost (gx, gy: Integer); virtual;
173
174 procedure draw (); virtual;
175
176 function topLevel (): THControl; inline;
177
178 // returns `true` if global coords are inside this control
179 function toLocal (var x, y: Integer): Boolean;
180 function toLocal (gx, gy: Integer; out x, y: Integer): Boolean; inline;
181 procedure toGlobal (var x, y: Integer);
182 procedure toGlobal (lx, ly: Integer; out x, y: Integer); inline;
183
184 // x and y are global coords
185 function controlAtXY (x, y: Integer): THControl;
186
187 function mouseEvent (var ev: THMouseEvent): Boolean; virtual; // returns `true` if event was eaten
188 function keyEvent (var ev: THKeyEvent): Boolean; virtual; // returns `true` if event was eaten
189
190 function prevSibling (): THControl;
191 function nextSibling (): THControl;
192 function firstChild (): THControl; inline;
193 function lastChild (): THControl; inline;
194
195 procedure appendChild (ctl: THControl); virtual;
196
197 public
198 property id: AnsiString read mId;
199 property x0: Integer read mX;
200 property y0: Integer read mY;
201 property height: Integer read mHeight;
202 property width: Integer read mWidth;
203 property enabled: Boolean read getEnabled write setEnabled;
204 property parent: THControl read mParent;
205 property focused: Boolean read getFocused write setFocused;
206 property escClose: Boolean read mEscClose write mEscClose;
207 property eatKeys: Boolean read mEatKeys write mEatKeys;
208 end;
209
210
211 THTopWindow = class(THControl)
212 private
213 mTitle: AnsiString;
214 mDragging: Boolean;
215 mDragStartX, mDragStartY: Integer;
216 mWaitingClose: Boolean;
217 mInClose: Boolean;
218 mFreeOnClose: Boolean; // default: false
219 mDoCenter: Boolean; // after layouting
220
221 protected
222 procedure activated (); override;
223 procedure blurred (); override;
224
225 public
226 closeCB: TActionCB; // called after window was removed from ui window list
227
228 public
229 constructor Create (const atitle: AnsiString; ax, ay: Integer; aw: Integer=-1; ah: Integer=-1);
230
231 function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override;
232
233 procedure centerInScreen ();
234
235 // `sx` and `sy` are screen coordinates
236 procedure drawControl (gx, gy: Integer); override;
237 procedure drawControlPost (gx, gy: Integer); override;
238
239 function keyEvent (var ev: THKeyEvent): Boolean; override; // returns `true` if event was eaten
240 function mouseEvent (var ev: THMouseEvent): Boolean; override; // returns `true` if event was eaten
241
242 public
243 property freeOnClose: Boolean read mFreeOnClose write mFreeOnClose;
244 end;
245
246
247 THCtlSimpleText = class(THControl)
248 private
249 type
250 PItem = ^TItem;
251 TItem = record
252 title: AnsiString;
253 centered: Boolean;
254 hline: Boolean;
255 end;
256 private
257 mItems: array of TItem;
258
259 public
260 constructor Create (ax, ay: Integer);
261 destructor Destroy (); override;
262
263 procedure appendItem (const atext: AnsiString; acentered: Boolean=false; ahline: Boolean=false);
264
265 procedure drawControl (gx, gy: Integer); override;
266
267 function mouseEvent (var ev: THMouseEvent): Boolean; override;
268 function keyEvent (var ev: THKeyEvent): Boolean; override;
269 end;
270
271
272 THCtlCBListBox = class(THControl)
273 private
274 type
275 PItem = ^TItem;
276 TItem = record
277 title: AnsiString;
278 varp: PBoolean;
279 actionCB: TActionCB;
280 end;
281 private
282 mItems: array of TItem;
283 mCurIndex: Integer;
284
285 public
286 constructor Create (ax, ay: Integer);
287 destructor Destroy (); override;
288
289 procedure appendItem (const atext: AnsiString; bv: PBoolean; aaction: TActionCB=nil);
290
291 procedure drawControl (gx, gy: Integer); override;
292
293 function mouseEvent (var ev: THMouseEvent): Boolean; override;
294 function keyEvent (var ev: THKeyEvent): Boolean; override;
295 end;
296
297 // ////////////////////////////////////////////////////////////////////// //
298 THCtlBox = class(THControl)
299 private
300 mHasFrame: Boolean;
301 mCaption: AnsiString;
302
303 public
304 constructor Create (ahoriz: Boolean);
305
306 function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override;
307
308 procedure drawControl (gx, gy: Integer); override;
309
310 function mouseEvent (var ev: THMouseEvent): Boolean; override;
311 function keyEvent (var ev: THKeyEvent): Boolean; override;
312 end;
313
314 THCtlHBox = class(THCtlBox)
315 public
316 procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
317 end;
318
319 THCtlVBox = class(THCtlBox)
320 public
321 procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
322 end;
323
324 // ////////////////////////////////////////////////////////////////////// //
325 THCtlSpan = class(THControl)
326 public
327 procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
328
329 function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override;
330
331 procedure drawControl (gx, gy: Integer); override;
332 end;
333
334 // ////////////////////////////////////////////////////////////////////// //
335 THCtlLine = class(THControl)
336 public
337 function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override;
338
339 procedure drawControl (gx, gy: Integer); override;
340 end;
341
342 THCtlHLine = class(THCtlLine)
343 public
344 procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
345 end;
346
347 THCtlVLine = class(THCtlLine)
348 public
349 procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
350 end;
351
352 // ////////////////////////////////////////////////////////////////////// //
353 THCtlTextLabel = class(THControl)
354 private
355 mText: AnsiString;
356 mHAlign: Integer; // -1: left; 0: center; 1: right; default: left
357 mVAlign: Integer; // -1: top; 0: center; 1: bottom; default: center
358
359 public
360 constructor Create (const atext: AnsiString);
361
362 procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
363
364 function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override;
365
366 procedure drawControl (gx, gy: Integer); override;
367
368 function mouseEvent (var ev: THMouseEvent): Boolean; override;
369 function keyEvent (var ev: THKeyEvent): Boolean; override;
370 end;
371
372
373 // ////////////////////////////////////////////////////////////////////////// //
374 function uiMouseEvent (ev: THMouseEvent): Boolean;
375 function uiKeyEvent (ev: THKeyEvent): Boolean;
376 procedure uiDraw ();
377
378
379 // ////////////////////////////////////////////////////////////////////////// //
380 procedure uiAddWindow (ctl: THControl);
381 procedure uiRemoveWindow (ctl: THControl); // will free window if `mFreeOnClose` is `true`
382 function uiVisibleWindow (ctl: THControl): Boolean;
383
384
385 // ////////////////////////////////////////////////////////////////////////// //
386 // do layouting
387 procedure uiLayoutCtl (ctl: THControl);
388
389
390 // ////////////////////////////////////////////////////////////////////////// //
391 var
392 gh_ui_scale: Single = 1.0;
393
394
395 implementation
396
397 uses
398 gh_flexlay,
399 utils;
400
401
402 // ////////////////////////////////////////////////////////////////////////// //
403 var
404 knownCtlClasses: array of record
405 klass: THControlClass;
406 name: AnsiString;
407 end = nil;
408
409
410 procedure registerCtlClass (aklass: THControlClass; const aname: AnsiString);
411 begin
412 assert(aklass <> nil);
413 assert(Length(aname) > 0);
414 SetLength(knownCtlClasses, Length(knownCtlClasses)+1);
415 knownCtlClasses[High(knownCtlClasses)].klass := aklass;
416 knownCtlClasses[High(knownCtlClasses)].name := aname;
417 end;
418
419
420 function findCtlClass (const aname: AnsiString): THControlClass;
421 var
422 f: Integer;
423 begin
424 for f := 0 to High(knownCtlClasses) do
425 begin
426 if (strEquCI1251(aname, knownCtlClasses[f].name)) then
427 begin
428 result := knownCtlClasses[f].klass;
429 exit;
430 end;
431 end;
432 result := nil;
433 end;
434
435
436 // ////////////////////////////////////////////////////////////////////////// //
437 type
438 TFlexLayouter = specialize TFlexLayouterBase<THControl>;
439
440 procedure uiLayoutCtl (ctl: THControl);
441 var
442 lay: TFlexLayouter;
443 begin
444 if (ctl = nil) then exit;
445 lay := TFlexLayouter.Create();
446 try
447 lay.setup(ctl);
448 //lay.layout();
449
450 //writeln('============================'); lay.dumpFlat();
451
452 //writeln('=== initial ==='); lay.dump();
453
454 //lay.calcMaxSizeInternal(0);
455 {
456 lay.firstPass();
457 writeln('=== after first pass ===');
458 lay.dump();
459
460 lay.secondPass();
461 writeln('=== after second pass ===');
462 lay.dump();
463 }
464
465 lay.layout();
466 //writeln('=== final ==='); lay.dump();
467
468 if (ctl.mParent = nil) and (ctl is THTopWindow) and (THTopWindow(ctl).mDoCenter) then
469 begin
470 THTopWindow(ctl).centerInScreen();
471 end;
472
473 finally
474 FreeAndNil(lay);
475 end;
476 end;
477
478
479 // ////////////////////////////////////////////////////////////////////////// //
480 var
481 uiTopList: array of THControl = nil;
482
483
484 function uiMouseEvent (ev: THMouseEvent): Boolean;
485 var
486 f, c: Integer;
487 lx, ly: Integer;
488 ctmp: THControl;
489 begin
490 ev.x := trunc(ev.x/gh_ui_scale);
491 ev.y := trunc(ev.y/gh_ui_scale);
492 ev.dx := trunc(ev.dx/gh_ui_scale); //FIXME
493 ev.dy := trunc(ev.dy/gh_ui_scale); //FIXME
494 if (Length(uiTopList) = 0) then result := false else result := uiTopList[High(uiTopList)].mouseEvent(ev);
495 if not result and (ev.press) then
496 begin
497 for f := High(uiTopList) downto 0 do
498 begin
499 if uiTopList[f].toLocal(ev.x, ev.y, lx, ly) then
500 begin
501 result := true;
502 if uiTopList[f].mEnabled and (f <> High(uiTopList)) then
503 begin
504 uiTopList[High(uiTopList)].blurred();
505 ctmp := uiTopList[f];
506 ctmp.mGrab := nil;
507 for c := f+1 to High(uiTopList) do uiTopList[c-1] := uiTopList[c];
508 uiTopList[High(uiTopList)] := ctmp;
509 ctmp.activated();
510 result := ctmp.mouseEvent(ev);
511 end;
512 exit;
513 end;
514 end;
515 end;
516 end;
517
518
519 function uiKeyEvent (ev: THKeyEvent): Boolean;
520 begin
521 ev.x := trunc(ev.x/gh_ui_scale);
522 ev.y := trunc(ev.y/gh_ui_scale);
523 if (Length(uiTopList) = 0) then result := false else result := uiTopList[High(uiTopList)].keyEvent(ev);
524 if (ev.release) then begin result := true; exit; end;
525 end;
526
527
528 procedure uiDraw ();
529 var
530 f: Integer;
531 ctl: THControl;
532 begin
533 glMatrixMode(GL_MODELVIEW);
534 glPushMatrix();
535 try
536 glLoadIdentity();
537 glScalef(gh_ui_scale, gh_ui_scale, 1);
538 for f := 0 to High(uiTopList) do
539 begin
540 ctl := uiTopList[f];
541 ctl.draw();
542 if (f <> High(uiTopList)) then darkenRect(ctl.x0, ctl.y0, ctl.width, ctl.height, 128);
543 end;
544 finally
545 glMatrixMode(GL_MODELVIEW);
546 glPopMatrix();
547 end;
548 end;
549
550
551 procedure uiAddWindow (ctl: THControl);
552 var
553 f, c: Integer;
554 begin
555 if (ctl = nil) then exit;
556 ctl := ctl.topLevel;
557 if not (ctl is THTopWindow) then exit; // alas
558 for f := 0 to High(uiTopList) do
559 begin
560 if (uiTopList[f] = ctl) then
561 begin
562 if (f <> High(uiTopList)) then
563 begin
564 uiTopList[High(uiTopList)].blurred();
565 for c := f+1 to High(uiTopList) do uiTopList[c-1] := uiTopList[c];
566 uiTopList[High(uiTopList)] := ctl;
567 ctl.activated();
568 end;
569 exit;
570 end;
571 end;
572 if (Length(uiTopList) > 0) then uiTopList[High(uiTopList)].blurred();
573 SetLength(uiTopList, Length(uiTopList)+1);
574 uiTopList[High(uiTopList)] := ctl;
575 ctl.activated();
576 end;
577
578
579 procedure uiRemoveWindow (ctl: THControl);
580 var
581 f, c: Integer;
582 begin
583 if (ctl = nil) then exit;
584 ctl := ctl.topLevel;
585 if not (ctl is THTopWindow) then exit; // alas
586 for f := 0 to High(uiTopList) do
587 begin
588 if (uiTopList[f] = ctl) then
589 begin
590 ctl.blurred();
591 for c := f+1 to High(uiTopList) do uiTopList[c-1] := uiTopList[c];
592 SetLength(uiTopList, Length(uiTopList)-1);
593 if (ctl is THTopWindow) then
594 begin
595 try
596 if assigned(THTopWindow(ctl).closeCB) then THTopWindow(ctl).closeCB(ctl, 0);
597 finally
598 if (THTopWindow(ctl).mFreeOnClose) then FreeAndNil(ctl);
599 end;
600 end;
601 exit;
602 end;
603 end;
604 end;
605
606
607 function uiVisibleWindow (ctl: THControl): Boolean;
608 var
609 f: Integer;
610 begin
611 result := false;
612 if (ctl = nil) then exit;
613 ctl := ctl.topLevel;
614 if not (ctl is THTopWindow) then exit; // alas
615 for f := 0 to High(uiTopList) do
616 begin
617 if (uiTopList[f] = ctl) then begin result := true; exit; end;
618 end;
619 end;
620
621
622 // ////////////////////////////////////////////////////////////////////////// //
623 constructor THControl.Create ();
624 begin
625 mParent := nil;
626 mX := 0;
627 mY := 0;
628 mWidth := 64;
629 mHeight := 8;
630 mFrameWidth := 0;
631 mFrameHeight := 0;
632 mEnabled := true;
633 mCanFocus := true;
634 mChildren := nil;
635 mFocused := nil;
636 mGrab := nil;
637 mEscClose := false;
638 mEatKeys := false;
639 scallowed := false;
640 mDrawShadow := false;
641 actionCB := nil;
642 // layouter interface
643 //mDefSize := TLaySize.Create(64, 8); // default size
644 mDefSize := TLaySize.Create(0, 0); // default size
645 mMaxSize := TLaySize.Create(-1, -1); // maximum size
646 mFlex := 0;
647 mHoriz := true;
648 mCanWrap := false;
649 mLineStart := false;
650 mHGroup := '';
651 mVGroup := '';
652 mAlign := -1; // left/top
653 mExpand := false;
654 end;
655
656
657 constructor THControl.Create (ax, ay, aw, ah: Integer);
658 begin
659 Create();
660 mX := ax;
661 mY := ay;
662 mWidth := aw;
663 mHeight := ah;
664 end;
665
666
667 destructor THControl.Destroy ();
668 var
669 f, c: Integer;
670 begin
671 if (mParent <> nil) then
672 begin
673 setFocused(false);
674 for f := 0 to High(mParent.mChildren) do
675 begin
676 if (mParent.mChildren[f] = self) then
677 begin
678 for c := f+1 to High(mParent.mChildren) do mParent.mChildren[c-1] := mParent.mChildren[c];
679 SetLength(mParent.mChildren, Length(mParent.mChildren)-1);
680 end;
681 end;
682 end;
683 for f := 0 to High(mChildren) do
684 begin
685 mChildren[f].mParent := nil;
686 mChildren[f].Free();
687 end;
688 mChildren := nil;
689 end;
690
691
692 // ////////////////////////////////////////////////////////////////////////// //
693 function THControl.getDefSize (): TLaySize; inline; begin result := mLayDefSize; end;
694 function THControl.getMaxSize (): TLaySize; inline; begin result := mLayMaxSize; end;
695 function THControl.getFlex (): Integer; inline; begin result := mFlex; end;
696 function THControl.isHorizBox (): Boolean; inline; begin result := mHoriz; end;
697 procedure THControl.setHorizBox (v: Boolean); inline; begin mHoriz := v; end;
698 function THControl.canWrap (): Boolean; inline; begin result := mCanWrap; end;
699 procedure THControl.setCanWrap (v: Boolean); inline; begin mCanWrap := v; end;
700 function THControl.isLineStart (): Boolean; inline; begin result := mLineStart; end;
701 procedure THControl.setLineStart (v: Boolean); inline; begin mLineStart := v; end;
702 function THControl.getAlign (): Integer; inline; begin result := mAlign; end;
703 procedure THControl.setAlign (v: Integer); inline; begin mAlign := v; end;
704 function THControl.getExpand (): Boolean; inline; begin result := mExpand; end;
705 procedure THControl.setExpand (v: Boolean); inline; begin mExpand := v; end;
706 function THControl.getHGroup (): AnsiString; inline; begin result := mHGroup; end;
707 procedure THControl.setHGroup (const v: AnsiString); inline; begin mHGroup := v; end;
708 function THControl.getVGroup (): AnsiString; inline; begin result := mVGroup; end;
709 procedure THControl.setVGroup (const v: AnsiString); inline; begin mVGroup := v; end;
710
711 function THControl.getMargins (): TLayMargins; inline;
712 begin
713 result := TLayMargins.Create(mFrameHeight, mFrameWidth, mFrameHeight, mFrameWidth);
714 end;
715
716 procedure THControl.setActualSizePos (constref apos: TLayPos; constref asize: TLaySize); inline; begin
717 //writeln(self.className, '; pos=', apos.toString, '; size=', asize.toString);
718 if (mParent <> nil) then
719 begin
720 mX := apos.x;
721 mY := apos.y;
722 end;
723 mWidth := asize.w;
724 mHeight := asize.h;
725 end;
726
727 procedure THControl.layPrepare ();
728 begin
729 mLayDefSize := mDefSize;
730 mLayMaxSize := mMaxSize;
731 if (mLayMaxSize.w >= 0) then mLayMaxSize.w += mFrameWidth*2;
732 if (mLayMaxSize.h >= 0) then mLayMaxSize.h += mFrameHeight*2;
733 end;
734
735
736 // ////////////////////////////////////////////////////////////////////////// //
737 function THControl.parsePos (par: TTextParser): TLayPos;
738 var
739 ech: AnsiChar = ')';
740 begin
741 if (par.eatDelim('[')) then ech := ']' else par.expectDelim('(');
742 result.x := par.expectInt();
743 par.eatDelim(','); // optional comma
744 result.y := par.expectInt();
745 par.eatDelim(','); // optional comma
746 par.expectDelim(ech);
747 end;
748
749 function THControl.parseSize (par: TTextParser): TLaySize;
750 var
751 ech: AnsiChar = ')';
752 begin
753 if (par.eatDelim('[')) then ech := ']' else par.expectDelim('(');
754 result.w := par.expectInt();
755 par.eatDelim(','); // optional comma
756 result.h := par.expectInt();
757 par.eatDelim(','); // optional comma
758 par.expectDelim(ech);
759 end;
760
761 function THControl.parseBool (par: TTextParser): Boolean;
762 begin
763 result :=
764 par.eatIdOrStr('true', false) or
765 par.eatIdOrStr('yes', false) or
766 par.eatIdOrStr('tan', false);
767 if not result then
768 begin
769 if (not par.eatIdOrStr('false', false)) and (not par.eatIdOrStr('no', false)) and (not par.eatIdOrStr('ona', false)) then
770 begin
771 par.error('boolean value expected');
772 end;
773 end;
774 end;
775
776 function THControl.parseAnyAlign (par: TTextParser): Integer;
777 begin
778 if (par.eatIdOrStr('left', false)) or (par.eatIdOrStr('top', false)) then result := -1
779 else if (par.eatIdOrStr('right', false)) or (par.eatIdOrStr('bottom', false)) then result := 1
780 else if (par.eatIdOrStr('center', false)) then result := 0
781 else par.error('invalid align value');
782 end;
783
784 function THControl.parseHAlign (par: TTextParser): Integer;
785 begin
786 if (par.eatIdOrStr('left', false)) then result := -1
787 else if (par.eatIdOrStr('right', false)) then result := 1
788 else if (par.eatIdOrStr('center', false)) then result := 0
789 else par.error('invalid horizontal align value');
790 end;
791
792 function THControl.parseVAlign (par: TTextParser): Integer;
793 begin
794 if (par.eatIdOrStr('top', false)) then result := -1
795 else if (par.eatIdOrStr('bottom', false)) then result := 1
796 else if (par.eatIdOrStr('center', false)) then result := 0
797 else par.error('invalid vertical align value');
798 end;
799
800 procedure THControl.parseTextAlign (par: TTextParser; var h, v: Integer);
801 var
802 wasH: Boolean = false;
803 wasV: Boolean = false;
804 begin
805 while true do
806 begin
807 if (par.eatIdOrStr('left', false)) then
808 begin
809 if wasH then par.error('too many align directives');
810 wasH := true;
811 h := -1;
812 continue;
813 end;
814 if (par.eatIdOrStr('right', false)) then
815 begin
816 if wasH then par.error('too many align directives');
817 wasH := true;
818 h := 1;
819 continue;
820 end;
821 if (par.eatIdOrStr('hcenter', false)) then
822 begin
823 if wasH then par.error('too many align directives');
824 wasH := true;
825 h := 0;
826 continue;
827 end;
828 if (par.eatIdOrStr('top', false)) then
829 begin
830 if wasV then par.error('too many align directives');
831 wasV := true;
832 v := -1;
833 continue;
834 end;
835 if (par.eatIdOrStr('bottom', false)) then
836 begin
837 if wasV then par.error('too many align directives');
838 wasV := true;
839 v := 1;
840 continue;
841 end;
842 if (par.eatIdOrStr('vcenter', false)) then
843 begin
844 if wasV then par.error('too many align directives');
845 wasV := true;
846 v := 0;
847 continue;
848 end;
849 if (par.eatIdOrStr('center', false)) then
850 begin
851 if wasV or wasH then par.error('too many align directives');
852 wasV := true;
853 wasH := true;
854 h := 0;
855 v := 0;
856 continue;
857 end;
858 break;
859 end;
860 if not wasV and not wasH then par.error('invalid align value');
861 end;
862
863 function THControl.parseOrientation (const prname: AnsiString; par: TTextParser): Boolean;
864 begin
865 if (strEquCI1251(prname, 'orientation')) or (strEquCI1251(prname, 'orient')) then
866 begin
867 if (par.eatIdOrStr('horizontal', false)) or (par.eatIdOrStr('horiz', false)) then mHoriz := true
868 else if (par.eatIdOrStr('vertical', false)) or (par.eatIdOrStr('vert', false)) then mHoriz := false
869 else par.error('`horizontal` or `vertical` expected');
870 result := true;
871 end
872 else
873 begin
874 result := false;
875 end;
876 end;
877
878 // par should be on '{'; final '}' is eaten
879 procedure THControl.parseProperties (par: TTextParser);
880 var
881 pn: AnsiString;
882 begin
883 if (not par.eatDelim('{')) then exit;
884 while (not par.eatDelim('}')) do
885 begin
886 if (not par.isIdOrStr) then par.error('property name expected');
887 pn := par.tokStr;
888 par.skipToken();
889 par.eatDelim(':'); // optional
890 if not parseProperty(pn, par) then par.errorfmt('invalid property name ''%s''', [pn]);
891 par.eatDelim(','); // optional
892 end;
893 end;
894
895 // par should be on '{'
896 procedure THControl.parseChildren (par: TTextParser);
897 var
898 cc: THControlClass;
899 ctl: THControl;
900 begin
901 par.expectDelim('{');
902 while (not par.eatDelim('}')) do
903 begin
904 if (not par.isIdOrStr) then par.error('control name expected');
905 cc := findCtlClass(par.tokStr);
906 if (cc = nil) then par.errorfmt('unknown control name: ''%s''', [par.tokStr]);
907 //writeln('children for <', par.tokStr, '>: <', cc.className, '>');
908 par.skipToken();
909 par.eatDelim(':'); // optional
910 ctl := cc.Create();
911 //writeln(' mHoriz=', ctl.mHoriz);
912 try
913 ctl.parseProperties(par);
914 except
915 FreeAndNil(ctl);
916 raise;
917 end;
918 //writeln(': ', ctl.mDefSize.toString);
919 appendChild(ctl);
920 par.eatDelim(','); // optional
921 end;
922 end;
923
924
925 function THControl.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
926 begin
927 result := true;
928 if (strEquCI1251(prname, 'id')) then begin mId := par.expectStrOrId(true); exit; end; // allow empty strings
929 if (strEquCI1251(prname, 'flex')) then begin flex := par.expectInt(); exit; end;
930 // sizes
931 if (strEquCI1251(prname, 'defsize')) or (strEquCI1251(prname, 'size')) then begin mDefSize := parseSize(par); exit; end;
932 if (strEquCI1251(prname, 'maxsize')) then begin mMaxSize := parseSize(par); exit; end;
933 if (strEquCI1251(prname, 'defwidth')) or (strEquCI1251(prname, 'width')) then begin mDefSize.w := par.expectInt(); exit; end;
934 if (strEquCI1251(prname, 'defheight')) or (strEquCI1251(prname, 'height')) then begin mDefSize.h := par.expectInt(); exit; end;
935 if (strEquCI1251(prname, 'maxwidth')) then begin mMaxSize.w := par.expectInt(); exit; end;
936 if (strEquCI1251(prname, 'maxheight')) then begin mMaxSize.h := par.expectInt(); exit; end;
937 // flags
938 if (strEquCI1251(prname, 'wrap')) then begin mCanWrap := parseBool(par); exit; end;
939 if (strEquCI1251(prname, 'linestart')) then begin mLineStart := parseBool(par); exit; end;
940 if (strEquCI1251(prname, 'expand')) then begin mExpand := parseBool(par); exit; end;
941 // align
942 if (strEquCI1251(prname, 'align')) then begin mAlign := parseAnyAlign(par); exit; end;
943 if (strEquCI1251(prname, 'hgroup')) then begin mHGroup := par.expectStrOrId(true); exit; end; // allow empty strings
944 if (strEquCI1251(prname, 'vgroup')) then begin mVGroup := par.expectStrOrId(true); exit; end; // allow empty strings
945 // other
946 if (strEquCI1251(prname, 'canfocus')) then begin mCanFocus := parseBool(par); exit; end;
947 if (strEquCI1251(prname, 'enabled')) then begin mEnabled := parseBool(par); exit; end;
948 if (strEquCI1251(prname, 'disabled')) then begin mEnabled := not parseBool(par); exit; end;
949 if (strEquCI1251(prname, 'escclose')) then begin mEscClose := not parseBool(par); exit; end;
950 if (strEquCI1251(prname, 'eatkeys')) then begin mEatKeys := not parseBool(par); exit; end;
951 result := false;
952 end;
953
954
955 // ////////////////////////////////////////////////////////////////////////// //
956 procedure THControl.activated ();
957 begin
958 end;
959
960
961 procedure THControl.blurred ();
962 begin
963 mGrab := nil;
964 end;
965
966
967 function THControl.topLevel (): THControl; inline;
968 begin
969 result := self;
970 while (result.mParent <> nil) do result := result.mParent;
971 end;
972
973
974 function THControl.getEnabled (): Boolean;
975 var
976 ctl: THControl;
977 begin
978 result := false;
979 if (not mEnabled) or (mWidth < 1) or (mHeight < 1) then exit;
980 ctl := mParent;
981 while (ctl <> nil) do
982 begin
983 if (not ctl.mEnabled) or (ctl.mWidth < 1) or (ctl.mHeight < 1) then exit;
984 ctl := ctl.mParent;
985 end;
986 result := true;
987 end;
988
989
990 procedure THControl.setEnabled (v: Boolean); inline;
991 begin
992 if (mEnabled = v) then exit;
993 mEnabled := v;
994 if not v and focused then setFocused(false);
995 end;
996
997
998 function THControl.getFocused (): Boolean; inline;
999 begin
1000 if (mParent = nil) then result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = self) else result := (topLevel.mFocused = self);
1001 end;
1002
1003
1004 procedure THControl.setFocused (v: Boolean); inline;
1005 var
1006 tl: THControl;
1007 begin
1008 tl := topLevel;
1009 if not v then
1010 begin
1011 if (tl.mFocused = self) then
1012 begin
1013 tl.blurred();
1014 tl.mFocused := tl.findNextFocus(self);
1015 if (tl.mFocused = self) then tl.mFocused := nil;
1016 end;
1017 exit;
1018 end;
1019 if (not mEnabled) or (not mCanFocus) then exit;
1020 if (tl.mFocused <> self) then
1021 begin
1022 if (tl.mFocused <> nil) then tl.mFocused.blurred();
1023 tl.mFocused := self;
1024 if (tl.mGrab <> self) then tl.mGrab := nil;
1025 activated();
1026 end;
1027 end;
1028
1029
1030 function THControl.isMyChild (ctl: THControl): Boolean;
1031 begin
1032 result := true;
1033 while (ctl <> nil) do
1034 begin
1035 if (ctl.mParent = self) then exit;
1036 ctl := ctl.mParent;
1037 end;
1038 result := false;
1039 end;
1040
1041
1042 // returns `true` if global coords are inside this control
1043 function THControl.toLocal (var x, y: Integer): Boolean;
1044 var
1045 ctl: THControl;
1046 begin
1047 ctl := self;
1048 while (ctl <> nil) do
1049 begin
1050 Dec(x, ctl.mX);
1051 Dec(y, ctl.mY);
1052 ctl := ctl.mParent;
1053 end;
1054 result := (x >= 0) and (y >= 0) and (x < mWidth) and (y < mHeight);
1055 end;
1056
1057 function THControl.toLocal (gx, gy: Integer; out x, y: Integer): Boolean; inline;
1058 begin
1059 x := gx;
1060 y := gy;
1061 result := toLocal(x, y);
1062 end;
1063
1064 procedure THControl.toGlobal (var x, y: Integer);
1065 var
1066 ctl: THControl;
1067 begin
1068 ctl := self;
1069 while (ctl <> nil) do
1070 begin
1071 Inc(x, ctl.mX);
1072 Inc(y, ctl.mY);
1073 ctl := ctl.mParent;
1074 end;
1075 end;
1076
1077 procedure THControl.toGlobal (lx, ly: Integer; out x, y: Integer); inline;
1078 begin
1079 x := lx;
1080 y := ly;
1081 toGlobal(x, y);
1082 end;
1083
1084
1085 // x and y are global coords
1086 function THControl.controlAtXY (x, y: Integer): THControl;
1087 var
1088 lx, ly: Integer;
1089 f: Integer;
1090 begin
1091 result := nil;
1092 if (not mEnabled) or (mWidth < 1) or (mHeight < 1) then exit;
1093 if not toLocal(x, y, lx, ly) then exit;
1094 for f := High(mChildren) downto 0 do
1095 begin
1096 result := mChildren[f].controlAtXY(x, y);
1097 if (result <> nil) then exit;
1098 end;
1099 result := self;
1100 end;
1101
1102
1103 function THControl.prevSibling (): THControl;
1104 var
1105 f: Integer;
1106 begin
1107 if (mParent <> nil) then
1108 begin
1109 for f := 1 to High(mParent.mChildren) do
1110 begin
1111 if (mParent.mChildren[f] = self) then begin result := mParent.mChildren[f-1]; exit; end;
1112 end;
1113 end;
1114 result := nil;
1115 end;
1116
1117 function THControl.nextSibling (): THControl;
1118 var
1119 f: Integer;
1120 begin
1121 if (mParent <> nil) then
1122 begin
1123 for f := 0 to High(mParent.mChildren)-1 do
1124 begin
1125 if (mParent.mChildren[f] = self) then begin result := mParent.mChildren[f+1]; exit; end;
1126 end;
1127 end;
1128 result := nil;
1129 end;
1130
1131 function THControl.firstChild (): THControl; inline;
1132 begin
1133 if (Length(mChildren) <> 0) then result := mChildren[0] else result := nil;
1134 end;
1135
1136 function THControl.lastChild (): THControl; inline;
1137 begin
1138 if (Length(mChildren) <> 0) then result := mChildren[High(mChildren)] else result := nil;
1139 end;
1140
1141
1142 function THControl.findFirstFocus (): THControl;
1143 var
1144 f: Integer;
1145 begin
1146 result := nil;
1147 if enabled then
1148 begin
1149 for f := 0 to High(mChildren) do
1150 begin
1151 result := mChildren[f].findFirstFocus();
1152 if (result <> nil) then exit;
1153 end;
1154 if mCanFocus then result := self;
1155 end;
1156 end;
1157
1158
1159 function THControl.findLastFocus (): THControl;
1160 var
1161 f: Integer;
1162 begin
1163 result := nil;
1164 if enabled then
1165 begin
1166 for f := High(mChildren) downto 0 do
1167 begin
1168 result := mChildren[f].findLastFocus();
1169 if (result <> nil) then exit;
1170 end;
1171 if mCanFocus then result := self;
1172 end;
1173 end;
1174
1175
1176 function THControl.findNextFocus (cur: THControl): THControl;
1177 begin
1178 result := nil;
1179 if enabled then
1180 begin
1181 if not isMyChild(cur) then cur := nil;
1182 if (cur = nil) then begin result := findFirstFocus(); exit; end;
1183 result := cur.findFirstFocus();
1184 if (result <> nil) and (result <> cur) then exit;
1185 while true do
1186 begin
1187 cur := cur.nextSibling;
1188 if (cur = nil) then break;
1189 result := cur.findFirstFocus();
1190 if (result <> nil) then exit;
1191 end;
1192 result := findFirstFocus();
1193 end;
1194 end;
1195
1196
1197 function THControl.findPrevFocus (cur: THControl): THControl;
1198 begin
1199 result := nil;
1200 if enabled then
1201 begin
1202 if not isMyChild(cur) then cur := nil;
1203 if (cur = nil) then begin result := findLastFocus(); exit; end;
1204 //FIXME!
1205 result := cur.findLastFocus();
1206 if (result <> nil) and (result <> cur) then exit;
1207 while true do
1208 begin
1209 cur := cur.prevSibling;
1210 if (cur = nil) then break;
1211 result := cur.findLastFocus();
1212 if (result <> nil) then exit;
1213 end;
1214 result := findLastFocus();
1215 end;
1216 end;
1217
1218
1219 procedure THControl.appendChild (ctl: THControl);
1220 begin
1221 if (ctl = nil) then exit;
1222 if (ctl.mParent <> nil) then exit;
1223 SetLength(mChildren, Length(mChildren)+1);
1224 mChildren[High(mChildren)] := ctl;
1225 ctl.mParent := self;
1226 Inc(ctl.mX, mFrameWidth);
1227 Inc(ctl.mY, mFrameHeight);
1228 if (ctl.mWidth > 0) and (ctl.mHeight > 0) and
1229 (ctl.mX+ctl.mWidth > mFrameWidth) and (ctl.mY+ctl.mHeight > mFrameHeight) then
1230 begin
1231 if (mWidth+mFrameWidth < ctl.mX+ctl.mWidth) then mWidth := ctl.mX+ctl.mWidth+mFrameWidth;
1232 if (mHeight+mFrameHeight < ctl.mY+ctl.mHeight) then mHeight := ctl.mY+ctl.mHeight+mFrameHeight;
1233 end;
1234 //if (mFocused = nil) and ctl.mEnabled and ctl.mCanFocus and (ctl.mWidth > 0) and (ctl.mHeight > 0) then mFocused := ctl;
1235 end;
1236
1237
1238 // ////////////////////////////////////////////////////////////////////////// //
1239 procedure THControl.setScissorGLInternal (x, y, w, h: Integer);
1240 begin
1241 if not scallowed then exit;
1242 x := trunc(x*gh_ui_scale);
1243 y := trunc(y*gh_ui_scale);
1244 w := trunc(w*gh_ui_scale);
1245 h := trunc(h*gh_ui_scale);
1246 scis.combineRect(x, y, w, h);
1247 end;
1248
1249 procedure THControl.setScissor (lx, ly, lw, lh: Integer);
1250 var
1251 gx, gy: Integer;
1252 //ox, oy, ow, oh: Integer;
1253 begin
1254 if not scallowed then exit;
1255 //ox := lx; oy := ly; ow := lw; oh := lh;
1256 if not intersectRect(lx, ly, lw, lh, 0, 0, mWidth, mHeight) then
1257 begin
1258 //writeln('oops: <', self.className, '>: old=(', ox, ',', oy, ')-[', ow, ',', oh, ']');
1259 glScissor(0, 0, 0, 0);
1260 exit;
1261 end;
1262 toGlobal(lx, ly, gx, gy);
1263 setScissorGLInternal(gx, gy, lw, lh);
1264 end;
1265
1266 procedure THControl.resetScissor (fullArea: Boolean); inline;
1267 begin
1268 if not scallowed then exit;
1269 if (fullArea) then
1270 begin
1271 setScissor(0, 0, mWidth, mHeight);
1272 end
1273 else
1274 begin
1275 setScissor(mFrameWidth, mFrameHeight, mWidth-mFrameWidth*2, mHeight-mFrameHeight*2);
1276 end;
1277 end;
1278
1279
1280 // ////////////////////////////////////////////////////////////////////////// //
1281 procedure THControl.draw ();
1282 var
1283 f: Integer;
1284 gx, gy: Integer;
1285 begin
1286 if (mWidth < 1) or (mHeight < 1) then exit;
1287 toGlobal(0, 0, gx, gy);
1288 //conwritefln('[%s]: (%d,%d)-(%d,%d) (%d,%d)', [ClassName, mX, mY, mWidth, mHeight, x, y]);
1289
1290 scis.save(true); // scissoring enabled
1291 try
1292 scallowed := true;
1293 resetScissor(true); // full area
1294 drawControl(gx, gy);
1295 resetScissor(false); // client area
1296 for f := 0 to High(mChildren) do mChildren[f].draw();
1297 resetScissor(true); // full area
1298 drawControlPost(gx, gy);
1299 finally
1300 scis.restore();
1301 scallowed := false;
1302 end;
1303 end;
1304
1305 procedure THControl.drawControl (gx, gy: Integer);
1306 begin
1307 if (mParent = nil) then darkenRect(gx, gy, mWidth, mHeight, 64);
1308 end;
1309
1310 procedure THControl.drawControlPost (gx, gy: Integer);
1311 begin
1312 // shadow
1313 if mDrawShadow and (mWidth > 0) and (mHeight > 0) then
1314 begin
1315 setScissorGLInternal(gx+8, gy+8, mWidth, mHeight);
1316 darkenRect(gx+mWidth, gy+8, 8, mHeight, 128);
1317 darkenRect(gx+8, gy+mHeight, mWidth-8, 8, 128);
1318 end;
1319 end;
1320
1321
1322 // ////////////////////////////////////////////////////////////////////////// //
1323 function THControl.mouseEvent (var ev: THMouseEvent): Boolean;
1324 var
1325 ctl: THControl;
1326 begin
1327 result := false;
1328 if not mEnabled then exit;
1329 if (mParent = nil) then
1330 begin
1331 if (mGrab <> nil) then
1332 begin
1333 result := mGrab.mouseEvent(ev);
1334 if (ev.release) then mGrab := nil;
1335 exit;
1336 end;
1337 end;
1338 if (mWidth < 1) or (mHeight < 1) then exit;
1339 ctl := controlAtXY(ev.x, ev.y);
1340 if (ctl <> nil) and (ctl <> self) then
1341 begin
1342 if (ctl <> topLevel.mFocused) then ctl.setFocused(true);
1343 result := ctl.mouseEvent(ev);
1344 end
1345 else if (ctl = self) and assigned(actionCB) then
1346 begin
1347 actionCB(self, 0);
1348 end;
1349 end;
1350
1351
1352 function THControl.keyEvent (var ev: THKeyEvent): Boolean;
1353 var
1354 ctl: THControl;
1355 begin
1356 result := false;
1357 if not mEnabled then exit;
1358 if (topLevel.mFocused <> self) and isMyChild(topLevel.mFocused) and topLevel.mFocused.mEnabled then result := topLevel.mFocused.keyEvent(ev);
1359 if (mParent = nil) then
1360 begin
1361 if (ev = 'S-Tab') then
1362 begin
1363 result := true;
1364 ctl := findPrevFocus(mFocused);
1365 if (ctl <> mFocused) then
1366 begin
1367 mGrab := nil;
1368 mFocused := ctl;
1369 end;
1370 exit;
1371 end;
1372 if (ev = 'Tab') then
1373 begin
1374 result := true;
1375 ctl := findNextFocus(mFocused);
1376 if (ctl <> mFocused) then
1377 begin
1378 mGrab := nil;
1379 mFocused := ctl;
1380 end;
1381 exit;
1382 end;
1383 if mEscClose and (ev = 'Escape') then
1384 begin
1385 result := true;
1386 uiRemoveWindow(self);
1387 exit;
1388 end;
1389 end;
1390 if mEatKeys then result := true;
1391 end;
1392
1393
1394 // ////////////////////////////////////////////////////////////////////////// //
1395 constructor THTopWindow.Create (const atitle: AnsiString; ax, ay: Integer; aw: Integer=-1; ah: Integer=-1);
1396 begin
1397 inherited Create(ax, ay, aw, ah);
1398 mFrameWidth := 8;
1399 mFrameHeight := 8;
1400 mTitle := atitle;
1401 if (mWidth < mFrameWidth*2+3*8) then mWidth := mFrameWidth*2+3*8;
1402 if (mHeight < mFrameHeight*2) then mHeight := mFrameHeight*2;
1403 if (Length(mTitle) > 0) then
1404 begin
1405 if (mWidth < Length(mTitle)*8+mFrameWidth*2+3*8) then mWidth := Length(mTitle)*8+mFrameWidth*2+3*8;
1406 end;
1407 mDragging := false;
1408 mDrawShadow := true;
1409 mWaitingClose := false;
1410 mInClose := false;
1411 closeCB := nil;
1412 end;
1413
1414
1415 function THTopWindow.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
1416 begin
1417 if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then
1418 begin
1419 mTitle := par.expectStrOrId(true);
1420 result := true;
1421 exit;
1422 end;
1423 if (strEquCI1251(prname, 'children')) then
1424 begin
1425 parseChildren(par);
1426 result := true;
1427 exit;
1428 end;
1429 if (strEquCI1251(prname, 'position')) then
1430 begin
1431 if (par.eatIdOrStr('default', false)) then mDoCenter := false
1432 else if (par.eatIdOrStr('center', false)) then mDoCenter := true
1433 else par.error('`center` or `default` expected');
1434 result := true;
1435 exit;
1436 end;
1437 if (parseOrientation(prname, par)) then begin result := true; exit; end;
1438 result := inherited parseProperty(prname, par);
1439 end;
1440
1441
1442 procedure THTopWindow.centerInScreen ();
1443 begin
1444 if (mWidth > 0) and (mHeight > 0) then
1445 begin
1446 mX := trunc((gScrWidth/gh_ui_scale-mWidth)/2);
1447 mY := trunc((gScrHeight/gh_ui_scale-mHeight)/2);
1448 end;
1449 end;
1450
1451
1452 procedure THTopWindow.drawControl (gx, gy: Integer);
1453 begin
1454 fillRect(gx, gy, mWidth, mHeight, TGxRGBA.Create(0, 0, 128));
1455 end;
1456
1457
1458 procedure THTopWindow.drawControlPost (gx, gy: Integer);
1459 const r = 255;
1460 const g = 255;
1461 const b = 255;
1462 var
1463 tx: Integer;
1464 begin
1465 if mDragging then
1466 begin
1467 drawRectUI(mX+4, mY+4, mWidth-8, mHeight-8, TGxRGBA.Create(r, g, b));
1468 end
1469 else
1470 begin
1471 drawRectUI(mX+3, mY+3, mWidth-6, mHeight-6, TGxRGBA.Create(r, g, b));
1472 drawRectUI(mX+5, mY+5, mWidth-10, mHeight-10, TGxRGBA.Create(r, g, b));
1473 setScissor(mFrameWidth, 0, 3*8, 8);
1474 fillRect(mX+mFrameWidth, mY, 3*8, 8, TGxRGBA.Create(0, 0, 128));
1475 drawText8(mX+mFrameWidth, mY, '[ ]', TGxRGBA.Create(r, g, b));
1476 if mInClose then drawText8(mX+mFrameWidth+7, mY, '#', TGxRGBA.Create(0, 255, 0))
1477 else drawText8(mX+mFrameWidth+7, mY, '*', TGxRGBA.Create(0, 255, 0));
1478 end;
1479 if (Length(mTitle) > 0) then
1480 begin
1481 setScissor(mFrameWidth+3*8, 0, mWidth-mFrameWidth*2-3*8, 8);
1482 tx := (mX+3*8)+((mWidth-3*8)-Length(mTitle)*8) div 2;
1483 fillRect(tx-3, mY, Length(mTitle)*8+3+2, 8, TGxRGBA.Create(0, 0, 128));
1484 drawText8(tx, mY, mTitle, TGxRGBA.Create(r, g, b));
1485 end;
1486 inherited drawControlPost(gx, gy);
1487 end;
1488
1489
1490 procedure THTopWindow.activated ();
1491 begin
1492 if (mFocused = nil) or (mFocused = self) then
1493 begin
1494 mFocused := findFirstFocus();
1495 if (mFocused <> nil) and (mFocused <> self) then mFocused.activated();
1496 end;
1497 inherited;
1498 end;
1499
1500
1501 procedure THTopWindow.blurred ();
1502 begin
1503 mDragging := false;
1504 mWaitingClose := false;
1505 mInClose := false;
1506 inherited;
1507 end;
1508
1509
1510 function THTopWindow.keyEvent (var ev: THKeyEvent): Boolean;
1511 begin
1512 result := inherited keyEvent(ev);
1513 if not getFocused then exit;
1514 if (ev = 'M-F3') then
1515 begin
1516 uiRemoveWindow(self);
1517 result := true;
1518 exit;
1519 end;
1520 end;
1521
1522
1523 function THTopWindow.mouseEvent (var ev: THMouseEvent): Boolean;
1524 var
1525 lx, ly: Integer;
1526 begin
1527 result := false;
1528 if not mEnabled then exit;
1529 if (mWidth < 1) or (mHeight < 1) then exit;
1530
1531 if mDragging then
1532 begin
1533 mX += ev.x-mDragStartX;
1534 mY += ev.y-mDragStartY;
1535 mDragStartX := ev.x;
1536 mDragStartY := ev.y;
1537 if (ev.release) then mDragging := false;
1538 result := true;
1539 exit;
1540 end;
1541
1542 if toLocal(ev.x, ev.y, lx, ly) then
1543 begin
1544 if (ev.press) then
1545 begin
1546 if (ly < 8) then
1547 begin
1548 if (lx >= mFrameWidth) and (lx < mFrameWidth+3*8) then
1549 begin
1550 //uiRemoveWindow(self);
1551 mWaitingClose := true;
1552 mInClose := true;
1553 end
1554 else
1555 begin
1556 mDragging := true;
1557 mDragStartX := ev.x;
1558 mDragStartY := ev.y;
1559 end;
1560 result := true;
1561 exit;
1562 end;
1563 if (lx < mFrameWidth) or (lx >= mWidth-mFrameWidth) or (ly >= mHeight-mFrameHeight) then
1564 begin
1565 mDragging := true;
1566 mDragStartX := ev.x;
1567 mDragStartY := ev.y;
1568 result := true;
1569 exit;
1570 end;
1571 end;
1572
1573 if (ev.release) then
1574 begin
1575 if mWaitingClose and (lx >= mFrameWidth) and (lx < mFrameWidth+3*8) then
1576 begin
1577 uiRemoveWindow(self);
1578 result := true;
1579 exit;
1580 end;
1581 mWaitingClose := false;
1582 mInClose := false;
1583 end;
1584
1585 if (ev.motion) then
1586 begin
1587 if mWaitingClose then
1588 begin
1589 mInClose := (lx >= mFrameWidth) and (lx < mFrameWidth+3*8);
1590 result := true;
1591 exit;
1592 end;
1593 end;
1594 end
1595 else
1596 begin
1597 mInClose := false;
1598 if (not ev.motion) then mWaitingClose := false;
1599 end;
1600
1601 result := inherited mouseEvent(ev);
1602 end;
1603
1604
1605 // ////////////////////////////////////////////////////////////////////////// //
1606 constructor THCtlSimpleText.Create (ax, ay: Integer);
1607 begin
1608 mItems := nil;
1609 inherited Create(ax, ay, 4, 4);
1610 end;
1611
1612
1613 destructor THCtlSimpleText.Destroy ();
1614 begin
1615 mItems := nil;
1616 inherited;
1617 end;
1618
1619
1620 procedure THCtlSimpleText.appendItem (const atext: AnsiString; acentered: Boolean=false; ahline: Boolean=false);
1621 var
1622 it: PItem;
1623 begin
1624 if (Length(atext)*8+3*8+2 > mWidth) then mWidth := Length(atext)*8+3*8+2;
1625 SetLength(mItems, Length(mItems)+1);
1626 it := @mItems[High(mItems)];
1627 it.title := atext;
1628 it.centered := acentered;
1629 it.hline := ahline;
1630 if (Length(mItems)*8 > mHeight) then mHeight := Length(mItems)*8;
1631 end;
1632
1633
1634 procedure THCtlSimpleText.drawControl (gx, gy: Integer);
1635 var
1636 f, tx: Integer;
1637 it: PItem;
1638 r, g, b: Integer;
1639 begin
1640 for f := 0 to High(mItems) do
1641 begin
1642 it := @mItems[f];
1643 tx := gx;
1644 r := 255;
1645 g := 255;
1646 b := 0;
1647 if it.centered then begin b := 255; tx := gx+(mWidth-Length(it.title)*8) div 2; end;
1648 if it.hline then
1649 begin
1650 b := 255;
1651 if (Length(it.title) = 0) then
1652 begin
1653 drawHLine(gx+4, gy+3, mWidth-8, TGxRGBA.Create(r, g, b));
1654 end
1655 else if (tx-3 > gx+4) then
1656 begin
1657 drawHLine(gx+4, gy+3, tx-3-(gx+3), TGxRGBA.Create(r, g, b));
1658 drawHLine(tx+Length(it.title)*8, gy+3, mWidth-4, TGxRGBA.Create(r, g, b));
1659 end;
1660 end;
1661 drawText8(tx, gy, it.title, TGxRGBA.Create(r, g, b));
1662 Inc(gy, 8);
1663 end;
1664 end;
1665
1666
1667 function THCtlSimpleText.mouseEvent (var ev: THMouseEvent): Boolean;
1668 var
1669 lx, ly: Integer;
1670 begin
1671 result := inherited mouseEvent(ev);
1672 if not result and toLocal(ev.x, ev.y, lx, ly) then
1673 begin
1674 result := true;
1675 end;
1676 end;
1677
1678
1679 function THCtlSimpleText.keyEvent (var ev: THKeyEvent): Boolean;
1680 begin
1681 result := inherited keyEvent(ev);
1682 end;
1683
1684
1685 // ////////////////////////////////////////////////////////////////////////// //
1686 constructor THCtlCBListBox.Create (ax, ay: Integer);
1687 begin
1688 mItems := nil;
1689 mCurIndex := -1;
1690 inherited Create(ax, ay, 4, 4);
1691 end;
1692
1693
1694 destructor THCtlCBListBox.Destroy ();
1695 begin
1696 mItems := nil;
1697 inherited;
1698 end;
1699
1700
1701 procedure THCtlCBListBox.appendItem (const atext: AnsiString; bv: PBoolean; aaction: TActionCB=nil);
1702 var
1703 it: PItem;
1704 begin
1705 if (Length(atext)*8+3*8+2 > mWidth) then mWidth := Length(atext)*8+3*8+2;
1706 SetLength(mItems, Length(mItems)+1);
1707 it := @mItems[High(mItems)];
1708 it.title := atext;
1709 it.varp := bv;
1710 it.actionCB := aaction;
1711 if (Length(mItems)*8 > mHeight) then mHeight := Length(mItems)*8;
1712 if (mCurIndex < 0) then mCurIndex := 0;
1713 end;
1714
1715
1716 procedure THCtlCBListBox.drawControl (gx, gy: Integer);
1717 var
1718 f, tx: Integer;
1719 it: PItem;
1720 begin
1721 for f := 0 to High(mItems) do
1722 begin
1723 it := @mItems[f];
1724 if (mCurIndex = f) then fillRect(gx, gy, mWidth, 8, TGxRGBA.Create(0, 128, 0));
1725 if (it.varp <> nil) then
1726 begin
1727 if it.varp^ then drawText8(gx, gy, '[x]', TGxRGBA.Create(255, 255, 255)) else drawText8(gx, gy, '[ ]', TGxRGBA.Create(255, 255, 255));
1728 drawText8(gx+3*8+2, gy, it.title, TGxRGBA.Create(255, 255, 0));
1729 end
1730 else if (Length(it.title) > 0) then
1731 begin
1732 tx := gx+(mWidth-Length(it.title)*8) div 2;
1733 if (tx-3 > gx+4) then
1734 begin
1735 drawHLine(gx+4, gy+3, tx-3-(gx+3), TGxRGBA.Create(255, 255, 255));
1736 drawHLine(tx+Length(it.title)*8, gy+3, mWidth-4, TGxRGBA.Create(255, 255, 255));
1737 end;
1738 drawText8(tx, gy, it.title, TGxRGBA.Create(255, 255, 255));
1739 end
1740 else
1741 begin
1742 drawHLine(gx+4, gy+3, mWidth-8, TGxRGBA.Create(255, 255, 255));
1743 end;
1744 Inc(gy, 8);
1745 end;
1746 end;
1747
1748
1749 function THCtlCBListBox.mouseEvent (var ev: THMouseEvent): Boolean;
1750 var
1751 lx, ly: Integer;
1752 it: PItem;
1753 begin
1754 result := inherited mouseEvent(ev);
1755 if not result and toLocal(ev.x, ev.y, lx, ly) then
1756 begin
1757 result := true;
1758 if (ev = 'lmb') then
1759 begin
1760 ly := ly div 8;
1761 if (ly >= 0) and (ly < Length(mItems)) then
1762 begin
1763 it := @mItems[ly];
1764 if (it.varp <> nil) then
1765 begin
1766 mCurIndex := ly;
1767 it.varp^ := not it.varp^;
1768 if assigned(it.actionCB) then it.actionCB(self, Integer(it.varp^));
1769 if assigned(actionCB) then actionCB(self, ly);
1770 end;
1771 end;
1772 end;
1773 end;
1774 end;
1775
1776
1777 function THCtlCBListBox.keyEvent (var ev: THKeyEvent): Boolean;
1778 var
1779 it: PItem;
1780 begin
1781 result := inherited keyEvent(ev);
1782 if not getFocused then exit;
1783 //result := true;
1784 if (ev = 'Home') or (ev = 'PageUp') then
1785 begin
1786 result := true;
1787 mCurIndex := 0;
1788 end;
1789 if (ev = 'End') or (ev = 'PageDown') then
1790 begin
1791 result := true;
1792 mCurIndex := High(mItems);
1793 end;
1794 if (ev = 'Up') then
1795 begin
1796 result := true;
1797 if (Length(mItems) > 0) then
1798 begin
1799 if (mCurIndex < 0) then mCurIndex := Length(mItems);
1800 while (mCurIndex > 0) do
1801 begin
1802 Dec(mCurIndex);
1803 if (mItems[mCurIndex].varp <> nil) then break;
1804 end;
1805 end
1806 else
1807 begin
1808 mCurIndex := -1;
1809 end;
1810 end;
1811 if (ev = 'Down') then
1812 begin
1813 result := true;
1814 if (Length(mItems) > 0) then
1815 begin
1816 if (mCurIndex < 0) then mCurIndex := -1;
1817 while (mCurIndex < High(mItems)) do
1818 begin
1819 Inc(mCurIndex);
1820 if (mItems[mCurIndex].varp <> nil) then break;
1821 end;
1822 end
1823 else
1824 begin
1825 mCurIndex := -1;
1826 end;
1827 end;
1828 if (ev = 'Space') or (ev = 'Enter') then
1829 begin
1830 result := true;
1831 if (mCurIndex >= 0) and (mCurIndex < Length(mItems)) and (mItems[mCurIndex].varp <> nil) then
1832 begin
1833 it := @mItems[mCurIndex];
1834 it.varp^ := not it.varp^;
1835 if assigned(it.actionCB) then it.actionCB(self, Integer(it.varp^));
1836 if assigned(actionCB) then actionCB(self, mCurIndex);
1837 end;
1838 end;
1839 end;
1840
1841
1842 // ////////////////////////////////////////////////////////////////////////// //
1843 constructor THCtlBox.Create (ahoriz: Boolean);
1844 begin
1845 inherited Create();
1846 mHoriz := ahoriz;
1847 mCanFocus := false;
1848 end;
1849
1850
1851 function THCtlBox.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
1852 begin
1853 if (parseOrientation(prname, par)) then begin result := true; exit; end;
1854 if (strEquCI1251(prname, 'frame')) then
1855 begin
1856 mHasFrame := parseBool(par);
1857 if (mHasFrame) then begin mFrameWidth := 8; mFrameHeight := 8; end else begin mFrameWidth := 0; mFrameHeight := 0; end;
1858 result := true;
1859 exit;
1860 end;
1861 if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then
1862 begin
1863 mCaption := par.expectStrOrId(true);
1864 mDefSize := TLaySize.Create(Length(mCaption)*8+3, 8);
1865 result := true;
1866 exit;
1867 end;
1868 if (strEquCI1251(prname, 'children')) then
1869 begin
1870 parseChildren(par);
1871 result := true;
1872 exit;
1873 end;
1874 result := inherited parseProperty(prname, par);
1875 end;
1876
1877
1878 procedure THCtlBox.drawControl (gx, gy: Integer);
1879 var
1880 r, g, b: Integer;
1881 tx: Integer;
1882 begin
1883 if focused then begin r := 255; g := 255; b := 255; end else begin r := 255; g := 255; b := 0; end;
1884 if mHasFrame then
1885 begin
1886 // draw frame
1887 drawRectUI(gx+3, gy+3, mWidth-6, mHeight-6, TGxRGBA.Create(r, g, b));
1888 end;
1889 // draw caption
1890 if (Length(mCaption) > 0) then
1891 begin
1892 setScissor(mFrameWidth+1, 0, mWidth-mFrameWidth-2, 8);
1893 tx := gx+((mWidth-Length(mCaption)*8) div 2);
1894 if mHasFrame then fillRect(tx-2, gy, Length(mCaption)*8+3, 8, TGxRGBA.Create(0, 0, 128));
1895 drawText8(tx, gy, mCaption, TGxRGBA.Create(r, g, b));
1896 end;
1897 end;
1898
1899
1900 function THCtlBox.mouseEvent (var ev: THMouseEvent): Boolean;
1901 var
1902 lx, ly: Integer;
1903 begin
1904 result := inherited mouseEvent(ev);
1905 if not result and toLocal(ev.x, ev.y, lx, ly) then
1906 begin
1907 result := true;
1908 end;
1909 end;
1910
1911
1912 //TODO: navigation with arrow keys, according to box orientation
1913 function THCtlBox.keyEvent (var ev: THKeyEvent): Boolean;
1914 begin
1915 result := inherited keyEvent(ev);
1916 end;
1917
1918
1919 // ////////////////////////////////////////////////////////////////////////// //
1920 procedure THCtlHBox.AfterConstruction ();
1921 begin
1922 inherited AfterConstruction();
1923 mHoriz := true;
1924 end;
1925
1926
1927 // ////////////////////////////////////////////////////////////////////////// //
1928 procedure THCtlVBox.AfterConstruction ();
1929 begin
1930 inherited AfterConstruction();
1931 mHoriz := false;
1932 mCanFocus := false;
1933 end;
1934
1935
1936 // ////////////////////////////////////////////////////////////////////////// //
1937 procedure THCtlSpan.AfterConstruction ();
1938 begin
1939 inherited AfterConstruction();
1940 mExpand := true;
1941 mCanFocus := false;
1942 end;
1943
1944
1945 function THCtlSpan.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
1946 begin
1947 if (parseOrientation(prname, par)) then begin result := true; exit; end;
1948 result := inherited parseProperty(prname, par);
1949 end;
1950
1951
1952 procedure THCtlSpan.drawControl (gx, gy: Integer);
1953 begin
1954 end;
1955
1956
1957 // ////////////////////////////////////////////////////////////////////// //
1958 function THCtlLine.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
1959 begin
1960 if (parseOrientation(prname, par)) then begin result := true; exit; end;
1961 result := inherited parseProperty(prname, par);
1962 end;
1963
1964
1965 procedure THCtlLine.drawControl (gx, gy: Integer);
1966 begin
1967 if mHoriz then
1968 begin
1969 drawHLine(gx, gy+(mHeight div 2), mWidth, TGxRGBA.Create(255, 255, 255));
1970 end
1971 else
1972 begin
1973 drawVLine(gx+(mWidth div 2), gy, mHeight, TGxRGBA.Create(255, 255, 255));
1974 end;
1975 end;
1976
1977
1978 // ////////////////////////////////////////////////////////////////////////// //
1979 procedure THCtlHLine.AfterConstruction ();
1980 begin
1981 mHoriz := true;
1982 mExpand := true;
1983 mDefSize.h := 1;
1984 end;
1985
1986
1987 // ////////////////////////////////////////////////////////////////////////// //
1988 procedure THCtlVLine.AfterConstruction ();
1989 begin
1990 mHoriz := false;
1991 mExpand := true;
1992 mDefSize.w := 1;
1993 //mDefSize.h := 8;
1994 end;
1995
1996
1997 // ////////////////////////////////////////////////////////////////////////// //
1998 constructor THCtlTextLabel.Create (const atext: AnsiString);
1999 begin
2000 inherited Create();
2001 mText := atext;
2002 mDefSize := TLaySize.Create(Length(atext)*8, 8);
2003 end;
2004
2005
2006 procedure THCtlTextLabel.AfterConstruction ();
2007 begin
2008 inherited AfterConstruction();
2009 mHAlign := -1;
2010 mVAlign := 0;
2011 mCanFocus := false;
2012 if (mDefSize.h <= 0) then mDefSize.h := 8;
2013 end;
2014
2015
2016 function THCtlTextLabel.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
2017 begin
2018 if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then
2019 begin
2020 mText := par.expectStrOrId(true);
2021 mDefSize := TLaySize.Create(Length(mText)*8, 8);
2022 result := true;
2023 exit;
2024 end;
2025 if (strEquCI1251(prname, 'textalign')) then
2026 begin
2027 parseTextAlign(par, mHAlign, mVAlign);
2028 result := true;
2029 exit;
2030 end;
2031 result := inherited parseProperty(prname, par);
2032 end;
2033
2034
2035 procedure THCtlTextLabel.drawControl (gx, gy: Integer);
2036 var
2037 xpos, ypos: Integer;
2038 begin
2039 // debug
2040 fillRect(gx, gy, mWidth, mHeight, TGxRGBA.Create(96, 96, 0));
2041 drawRectUI(gx, gy, mWidth, mHeight, TGxRGBA.Create(96, 96, 96));
2042
2043 if (Length(mText) > 0) then
2044 begin
2045 if (mHAlign < 0) then xpos := 0
2046 else if (mHAlign > 0) then xpos := mWidth-Length(mText)*8
2047 else xpos := (mWidth-Length(mText)*8) div 2;
2048
2049 if (mVAlign < 0) then ypos := 0
2050 else if (mVAlign > 0) then ypos := mHeight-8
2051 else ypos := (mHeight-8) div 2;
2052
2053 drawText8(gx+xpos, gy+ypos, mText, TGxRGBA.Create(255, 255, 255));
2054 end;
2055 end;
2056
2057
2058 function THCtlTextLabel.mouseEvent (var ev: THMouseEvent): Boolean;
2059 var
2060 lx, ly: Integer;
2061 begin
2062 result := inherited mouseEvent(ev);
2063 if not result and toLocal(ev.x, ev.y, lx, ly) then
2064 begin
2065 result := true;
2066 end;
2067 end;
2068
2069
2070 function THCtlTextLabel.keyEvent (var ev: THKeyEvent): Boolean;
2071 begin
2072 result := inherited keyEvent(ev);
2073 end;
2074
2075
2076 initialization
2077 registerCtlClass(THCtlHBox, 'hbox');
2078 registerCtlClass(THCtlVBox, 'vbox');
2079 registerCtlClass(THCtlSpan, 'span');
2080 registerCtlClass(THCtlHLine, 'hline');
2081 registerCtlClass(THCtlVLine, 'vline');
2082 registerCtlClass(THCtlTextLabel, 'label');
2083 end.
[MIRROR] a port of Doom 2D Forever to FPC/SDL
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024