summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 4cf7f08)
raw | patch | inline | side by side (parent: 4cf7f08)
| author | Ketmar Dark <ketmar@ketmar.no-ip.org> | |
| Sat, 30 Sep 2017 18:35:15 +0000 (21:35 +0300) | ||
| committer | Ketmar Dark <ketmar@ketmar.no-ip.org> | |
| Mon, 2 Oct 2017 23:34:41 +0000 (02:34 +0300) |
diff --git a/src/game/g_holmes.pas b/src/game/g_holmes.pas
index 79c4349a32a98180e1be54c1ee5524f99d5b2a16..b47011af62e2516f986d9e48794430de986f9bc5 100644 (file)
--- a/src/game/g_holmes.pas
+++ b/src/game/g_holmes.pas
g_textures, g_basic, e_graphics, g_phys, g_grid, g_player, g_monsters,
g_window, g_map, g_triggers, g_items, g_game, g_panel, g_console, g_gfx,
xprofiler,
- sdlcarcass, glgfx, gh_ui;
+ sdlcarcass, glgfx, gh_ui_common, gh_ui;
procedure g_Holmes_Draw ();
procedure createHelpWindow ();
+ procedure addHelpEmptyLine ();
+ var
+ stx: TUIStaticText;
+ begin
+ stx := TUIStaticText.Create();
+ stx.flExpand := true;
+ stx.halign := 0; // center
+ stx.text := '';
+ stx.header := false;
+ stx.line := false;
+ winHelp.appendChild(stx);
+ end;
+
+ procedure addHelpCaptionLine (const txt: AnsiString);
+ var
+ stx: TUIStaticText;
+ begin
+ stx := TUIStaticText.Create();
+ stx.flExpand := true;
+ stx.halign := 0; // center
+ stx.text := txt;
+ stx.header := true;
+ stx.line := true;
+ winHelp.appendChild(stx);
+ end;
+
+ procedure addHelpCaption (const txt: AnsiString);
+ var
+ stx: TUIStaticText;
+ begin
+ stx := TUIStaticText.Create();
+ stx.flExpand := true;
+ stx.halign := 0; // center
+ stx.text := txt;
+ stx.header := true;
+ stx.line := false;
+ winHelp.appendChild(stx);
+ end;
+
+ procedure addHelpKeyMouse (const key, txt, grp: AnsiString);
+ var
+ box: TUIHBox;
+ span: TUISpan;
+ stx: TUIStaticText;
+ begin
+ box := TUIHBox.Create();
+ box.flExpand := true;
+ // key
+ stx := TUIStaticText.Create();
+ stx.flExpand := true;
+ stx.halign := 1; // right
+ stx.valign := 0; // center
+ stx.text := key;
+ stx.header := true;
+ stx.line := false;
+ stx.flHGroup := grp;
+ box.appendChild(stx);
+ // span
+ span := TUISpan.Create();
+ span.flDefaultSize := TLaySize.Create(4, 1);
+ span.flExpand := true;
+ box.appendChild(span);
+ // text
+ stx := TUIStaticText.Create();
+ stx.flExpand := true;
+ stx.halign := -1; // left
+ stx.valign := 0; // center
+ stx.text := txt;
+ stx.header := false;
+ stx.line := false;
+ box.appendChild(stx);
+ winHelp.appendChild(box);
+ end;
+
+ procedure addHelpKey (const key, txt: AnsiString); begin addHelpKeyMouse(key, txt, 'help-keys'); end;
+ procedure addHelpMouse (const key, txt: AnsiString); begin addHelpKeyMouse(key, txt, 'help-mouse'); end;
+
var
- llb: TUISimpleText;
slist: array of AnsiString = nil;
cmd: PHolmesCommand;
bind: THolmesBinding;
- f, maxkeylen: Integer;
+ f: Integer;
+ {
+ llb: TUISimpleText;
+ maxkeylen: Integer;
s: AnsiString;
+ }
begin
+ winHelp := TUITopWindow.Create('Holmes Help', 10, 10);
+ winHelp.escClose := true;
+ winHelp.flHoriz := false;
+
+ // keyboard
for cmd in cmdlist do cmd.helpmark := false;
- maxkeylen := 0;
+ //maxkeylen := 0;
for bind in keybinds do
begin
if (Length(bind.key) = 0) then continue;
if (Length(cmd.help) > 0) then
begin
cmd.helpmark := true;
- if (maxkeylen < Length(bind.key)) then maxkeylen := Length(bind.key);
+ //if (maxkeylen < Length(bind.key)) then maxkeylen := Length(bind.key);
end;
end;
end;
for cmd in cmdlist do
begin
if not cmd.helpmark then continue;
- if (Length(cmd.help) = 0) then continue;
+ if (Length(cmd.help) = 0) then begin cmd.helpmark := false; continue; end;
f := 0;
while (f < Length(slist)) and (CompareText(slist[f], cmd.section) <> 0) do Inc(f);
if (f = Length(slist)) then
end;
end;
- llb := TUISimpleText.Create(0, 0);
+ addHelpCaptionLine('KEYBOARD');
+ //llb := TUISimpleText.Create(0, 0);
for f := 0 to High(slist) do
begin
- if (f > 0) then llb.appendItem('');
- llb.appendItem(slist[f], true, true);
+ //if (f > 0) then llb.appendItem('');
+ if (f > 0) then addHelpEmptyLine();
+ //llb.appendItem(slist[f], true, true);
+ addHelpCaption(slist[f]);
for cmd in cmdlist do
begin
if not cmd.helpmark then continue;
if (Length(bind.key) = 0) then continue;
if (cmd.name = bind.cmdName) then
begin
- s := bind.key;
- while (Length(s) < maxkeylen) do s += ' ';
- s := ' '+s+' -- '+cmd.help;
- llb.appendItem(s);
+ //s := bind.key;
+ //while (Length(s) < maxkeylen) do s += ' ';
+ //s := ' '+s+' -- '+cmd.help;
+ //llb.appendItem(s);
+ addHelpMouse(bind.key, cmd.help);
end;
end;
end;
end;
- maxkeylen := 0;
+ // mouse
+ for cmd in cmdlist do cmd.helpmark := false;
+
+ //maxkeylen := 0;
for bind in msbinds do
begin
if (Length(bind.key) = 0) then continue;
if (Length(cmd.help) > 0) then
begin
cmd.helpmark := true;
- if (maxkeylen < Length(bind.key)) then maxkeylen := Length(bind.key);
+ //if (maxkeylen < Length(bind.key)) then maxkeylen := Length(bind.key);
end;
end;
end;
- llb.appendItem('');
- llb.appendItem('mouse', true, true);
+ //llb.appendItem('');
+ //llb.appendItem('mouse', true, true);
+ if (f > 0) then addHelpEmptyLine();
+ addHelpCaptionLine('MOUSE');
for bind in msbinds do
begin
if (Length(bind.key) = 0) then continue;
begin
if (Length(cmd.help) > 0) then
begin
- s := bind.key;
- while (Length(s) < maxkeylen) do s += ' ';
- s := ' '+s+' -- '+cmd.help;
- llb.appendItem(s);
+ //s := bind.key;
+ //while (Length(s) < maxkeylen) do s += ' ';
+ //s := ' '+s+' -- '+cmd.help;
+ //llb.appendItem(s);
+ addHelpKey(bind.key, cmd.help);
end;
end;
end;
- winHelp := TUITopWindow.Create('Holmes Help', 10, 10);
- winHelp.escClose := true;
- winHelp.appendChild(llb);
+ //winHelp.appendChild(llb);
+
+ winHelp.flMaxSize := TLaySize.Create(trunc(getScrWdt/gh_ui_scale), trunc(getScrHgt/gh_ui_scale));
+ uiLayoutCtl(winHelp);
winHelp.centerInScreen();
end;
diff --git a/src/gx/gh_flexlay.pas b/src/gx/gh_flexlay.pas
index 5f237f521de9df680b5b00e9f4e81aacc1817321..c6da6b316ce79d9f6b24c891a667cc4beff1f2eb 100644 (file)
--- a/src/gx/gh_flexlay.pas
+++ b/src/gx/gh_flexlay.pas
*)
{$INCLUDE ../shared/a_modes.inc}
unit gh_flexlay;
-
-(* WARNING! OUT OF DATE! will be fixed later.
-
-first pass:
- set all 'temp-flex' flags for controls to 'flex'
- reset all 'laywrap' flags for controls
- build group arrays; for each group: find max size for group, adjust 'startsize' controls to group max size
- call 'calc max size' for top-level control
- flags set:
- 'firsttime'
-
-second pass:
- calcluate desired sizes (process flexes) using 'startsize', set 'desiredsize' and 'desiredpos'
- if control has children, call 'second pass' recursively with this control as parent
- flags set:
- 'group-element-changed', if any group element size was changed
- 'wrapping-changed', if not 'firsttime', and wrapping was changed (i.e. first pass will not set the flag)
-
-third pass:
- if 'group-element-changed':
- for each group: adjust controls to max desired size (startsize), set 'temp-flex' flags to 0 for 'em, set 'second-again' flag
- for other controls: if 'desiredsize' > 'maxsize', set 'startsize' to 'maxsize', set 'temp-flex' flag to 0, set 'second-again' flag
- if 'second-again' or 'wrapping-changed':
- reset 'second-again'
- reset 'wrapping-changed'
- reset 'firsttime'
- goto second pass
-
-fourth pass:
- set 'actualsize' and 'actualpos' to 'desiredsize' and 'desiredpos'
- return
-
-calc max size:
- set 'startsize' to max(size, maxsize, 0)
- if 'size' is negative:
- set 'temp-flex' flag to 0
- if has children:
- call 'calc max size' for each child
- set 'desiredmax' to 'startsize'
- do lines, don't distribute space (i.e. calc only wrapping),
- for each complete line, set 'desiredmax' to max(desiredmax, linesize)
- if 'maxsize' >= 0:
- set 'desiredmax' to min(desiredmax, maxsize)
- set 'startsize' to 'desiredmax'
- return
-
-
-wrapping lines:
- try to stuff controls in line until line width is less or equal to maxsize
- distribute flex for filled line
- continue until we still has something to stuff
-
-
-for wrapping:
- we'll hold 'laywrap' flag for each control; it will be set if this control
- starts a new line (even if this is the first control in line, as it is obviously
- starts a new line)
-
- on redoing second pass, if 'laywrap' flag changed, set 'wrapping-changed' flag
-*)
-
-
(*
control default size will be increased by margins
negative margins are ignored
private
type LayControlIdx = Integer;
- private
- class function nminX (a, b: Integer): Integer; inline;
-
private
// flags
const
utils;
-// ////////////////////////////////////////////////////////////////////////// //
-class function TFlexLayouterBase.nminX (a, b: Integer): Integer; inline;
-begin
- if (a < 0) then begin if (b < 0) then result := 0 else result := b; end
- else if (b < 0) or (a < b) then result := a
- else result := b;
-end;
-
-
// ////////////////////////////////////////////////////////////////////////// //
procedure TFlexLayouterBase.TLayControl.initialize (); inline;
begin
end;
if (lc.startsize.w < 0) then lc.startsize.w := 0;
if (lc.startsize.h < 0) then lc.startsize.h := 0;
+ {
lc.maxsize := msz;
if (lc.maxsize.w < lc.startsize.w) then begin if (lc.maxsize.w >= 0) then lc.maxsize.w := lc.startsize.w; end;
if (lc.maxsize.h < lc.startsize.h) then begin if (lc.maxsize.h >= 0) then lc.maxsize.h := lc.startsize.h; end;
+ }
+ if (msz.w < 0) then msz.w := lc.startsize.w;
+ if (msz.h < 0) then msz.h := lc.startsize.h;
+ lc.maxsize := msz;
end;
end;
end;
// expand or align
- if (lc.expand) then lc.desiredsize.h := nminX(lc.maxsize.h, lineh) // expand
+ if (lc.expand) then lc.desiredsize.h := nmax(1, lineh) // expand
else if (lc.alignBottom) then lc.desiredpos.y := cury+(lineh-lc.desiredsize.h) // bottom align
else if (lc.alignCenter) then lc.desiredpos.y := cury+(lineh-lc.desiredsize.h) div 2; // center
if (not osz.equals(lc.desiredsize)) then
me := @ctlist[boxidx];
// if we have no children, there's nothing to do
- if (me.firstChild = -1) then exit;
-
- // first, layout all children
- for lc in forChildren(boxidx) do layBox(lc.myidx);
-
- // second, layout lines, distribute flex data
- if (me.horizBox) then
+ if (me.firstChild <> -1) then
begin
- // horizontal boxes
- cury := me.margins.top;
+ // first, layout all children
+ for lc in forChildren(boxidx) do layBox(lc.myidx);
- fixLine(me, -1, -1, cury, spaceLeft); //HACK!
-
- lineStartIdx := me.firstChild;
- for lc in forChildren(boxidx) do
+ // second, layout lines, distribute flex data
+ if (me.horizBox) then
begin
- // new line?
- doWrap := (not lc.firstInLine) and (lc.lineStart);
- // need to wrap?
- if (not doWrap) and (lc.canWrap) and (lc.canWrap) and (lc.desiredsize.w > 0) and (spaceLeft < lc.desiredsize.w) then doWrap := true;
- if (doWrap) then
- begin
- // new line, fix this one
- if (not lc.didWrap) then begin wrappingChanged := true; lc.didWrap := true; end;
- fixLine(me, lineStartIdx, lc.myidx, cury, spaceLeft);
- lineStartIdx := lc.myidx;
- end
- else
- begin
- if (lc.didWrap) then begin wrappingChanged := true; lc.didWrap := false; end;
- end;
- spaceLeft -= lc.desiredsize.w;
- //if (maxhgt < lc.desiredsize.h) then maxhgt := lc.desiredsize.h;
- //if (lc.tempFlex > 0) then begin flexTotal += lc.tempFlex; flexBoxCount += 1; end;
- end;
- // fix last line
- fixLine(me, lineStartIdx, -1, cury, spaceLeft);
- end
- else
- begin
- // vertical boxes
- maxwdt := 0;
- flexTotal := 0;
- flexBoxCount := 0;
- spaceLeft := me.desiredsize.h-me.margins.vert;
+ // horizontal boxes
+ cury := me.margins.top;
- // calc flex
- for lc in forChildren(boxidx) do
- begin
- spaceLeft -= lc.desiredsize.h;
- if (maxwdt < lc.desiredsize.w) then maxwdt := lc.desiredsize.w;
- if (lc.tempFlex > 0) then begin flexTotal += lc.tempFlex; flexBoxCount += 1; end;
- end;
+ fixLine(me, -1, -1, cury, spaceLeft); //HACK!
- // distribute space
- cury := me.margins.top;
- //writeln('me: ', boxidx, '; margins: ', me.margins.toString);
- for lc in forChildren(boxidx) do
- begin
- osz := lc.desiredsize;
- lc.desiredsize := lc.startsize;
- lc.desiredpos.x := me.margins.left;
- lc.desiredpos.y := cury;
- cury += lc.desiredsize.h;
- // fix flexbox size
- if (lc.tempFlex > 0) and (spaceLeft > 0) then
+ lineStartIdx := me.firstChild;
+ for lc in forChildren(boxidx) do
begin
- toadd := trunc(spaceLeft*lc.tempFlex/flexTotal+0.5);
- if (toadd > 0) then
+ // new line?
+ doWrap := (not lc.firstInLine) and (lc.lineStart);
+ // need to wrap?
+ if (not doWrap) and (lc.canWrap) and (lc.canWrap) and (lc.desiredsize.w > 0) and (spaceLeft < lc.desiredsize.w) then doWrap := true;
+ if (doWrap) then
begin
- // size changed
- lc.desiredsize.h += toadd;
- cury += toadd;
- // compensate (crudely) rounding errors
- if (cury > me.desiredsize.h-me.margins.vert) then begin lc.desiredsize.h -= 1; cury -= 1; end;
+ // new line, fix this one
+ if (not lc.didWrap) then begin wrappingChanged := true; lc.didWrap := true; end;
+ fixLine(me, lineStartIdx, lc.myidx, cury, spaceLeft);
+ lineStartIdx := lc.myidx;
+ end
+ else
+ begin
+ if (lc.didWrap) then begin wrappingChanged := true; lc.didWrap := false; end;
end;
+ spaceLeft -= lc.desiredsize.w;
+ //if (maxhgt < lc.desiredsize.h) then maxhgt := lc.desiredsize.h;
+ //if (lc.tempFlex > 0) then begin flexTotal += lc.tempFlex; flexBoxCount += 1; end;
end;
- // expand or align
- if (lc.expand) then lc.desiredsize.w := nminX(lc.maxsize.w, me.desiredsize.w-me.margins.vert) // expand
- else if (lc.alignRight) then lc.desiredpos.x := me.desiredsize.w-me.margins.right-lc.desiredsize.w // right align
- else if (lc.alignCenter) then lc.desiredpos.x := (me.desiredsize.w-lc.desiredsize.w) div 2; // center
- if (not osz.equals(lc.desiredsize)) then
+ // fix last line
+ fixLine(me, lineStartIdx, -1, cury, spaceLeft);
+ end
+ else
+ begin
+ // vertical boxes
+ maxwdt := 0;
+ flexTotal := 0;
+ flexBoxCount := 0;
+ spaceLeft := me.desiredsize.h-me.margins.vert;
+
+ // calc flex
+ for lc in forChildren(boxidx) do
begin
- if (lc.inGroup) then groupElementChanged := true;
- // relayout children
- layBox(lc.firstChild);
+ spaceLeft -= lc.desiredsize.h;
+ if (maxwdt < lc.desiredsize.w) then maxwdt := lc.desiredsize.w;
+ if (lc.tempFlex > 0) then begin flexTotal += lc.tempFlex; flexBoxCount += 1; end;
+ end;
+
+ // distribute space
+ cury := me.margins.top;
+ //writeln('me: ', boxidx, '; margins: ', me.margins.toString);
+ for lc in forChildren(boxidx) do
+ begin
+ osz := lc.desiredsize;
+ lc.desiredsize := lc.startsize;
+ lc.desiredpos.x := me.margins.left;
+ lc.desiredpos.y := cury;
+ cury += lc.desiredsize.h;
+ // fix flexbox size
+ if (lc.tempFlex > 0) and (spaceLeft > 0) then
+ begin
+ toadd := trunc(spaceLeft*lc.tempFlex/flexTotal+0.5);
+ if (toadd > 0) then
+ begin
+ // size changed
+ lc.desiredsize.h += toadd;
+ cury += toadd;
+ // compensate (crudely) rounding errors
+ if (cury > me.desiredsize.h-me.margins.vert) then begin lc.desiredsize.h -= 1; cury -= 1; end;
+ end;
+ end;
+ // expand or align
+ if (lc.expand) then lc.desiredsize.w := nmax(1, me.desiredsize.w-me.margins.vert) // expand
+ else if (lc.alignRight) then lc.desiredpos.x := me.desiredsize.w-me.margins.right-lc.desiredsize.w // right align
+ else if (lc.alignCenter) then lc.desiredpos.x := (me.desiredsize.w-lc.desiredsize.w) div 2; // center
+ if (not osz.equals(lc.desiredsize)) then
+ begin
+ if (lc.inGroup) then groupElementChanged := true;
+ // relayout children
+ layBox(lc.firstChild);
+ end;
end;
end;
end;
+
+ if (me.maxsize.w >= 0) and (me.desiredsize.w > me.maxsize.w) then me.desiredsize.w := me.maxsize.w;
+ if (me.maxsize.h >= 0) and (me.desiredsize.h > me.maxsize.h) then me.desiredsize.h := me.maxsize.h;
end;
-(*
-second pass:
- calcluate desired sizes (process flexes) using 'startsize', set 'desiredsize' and 'desiredpos'
- if control has children, call 'second pass' recursively with this control as parent
- flags set:
- 'group-element-changed', if any group element size was changed
- 'wrapping-changed', if not 'firsttime', and wrapping was changed (i.e. first pass will not set the flag)
-*)
procedure TFlexLayouterBase.secondPass ();
begin
// reset flags
end;
-(*
-third pass:
- if 'group-element-changed':
- for each group: adjust controls to max desired size (startsize), set 'temp-flex' flags to 0 for 'em, set 'second-again' flag
- for other controls: if 'desiredsize' > 'maxsize', set 'startsize' to 'maxsize', set 'temp-flex' flag to 0, set 'second-again' flag
- if 'second-again' or 'wrapping-changed':
- reset 'second-again'
- reset 'wrapping-changed'
- reset 'firsttime'
- goto second pass
-*)
procedure TFlexLayouterBase.thirdPass ();
var
secondAgain: Boolean;
ct.expand := false; // don't expand grouped controls anymore
ct.tempFlex := 0; // don't change control size anymore
end;
+ (*
for c := 0 to 1 do
begin
if (ct.maxsize[c] < 0) then continue;
secondAgain := true;
end;
end;
+ *)
end;
end;
if (not secondAgain) and (not wrappingChanged) then break;
diff --git a/src/gx/gh_ui.pas b/src/gx/gh_ui.pas
index b23362bdb35207813803c6fc5682483ac94fd6de..ef68af5fe5efd3c7a710faa5336bab7c0beb97e8 100644 (file)
--- a/src/gx/gh_ui.pas
+++ b/src/gx/gh_ui.pas
uses
SysUtils, Classes,
- GL, GLExt, SDL2,
+ SDL2,
gh_ui_common,
gh_ui_style,
sdlcarcass, glgfx,
type TActionCB = procedure (me: TUIControl; uinfo: Integer);
type TCloseRequestCB = function (me: TUIControl): Boolean; // top-level windows will call this before closing with icon/keyboard
+ // return `true` to stop
+ type TCtlEnumCB = function (ctl: TUIControl): Boolean is nested;
+
public
const ClrIdxActive = 0;
const ClrIdxDisabled = 1;
mX, mY: Integer;
mWidth, mHeight: Integer;
mFrameWidth, mFrameHeight: Integer;
+ mScrollX, mScrollY: Integer;
mEnabled: Boolean;
mCanFocus: Boolean;
mChildren: array of TUIControl;
mFocused: TUIControl; // valid only for top-level controls
mEscClose: Boolean; // valid only for top-level controls
- mEatKeys: Boolean;
mDrawShadow: Boolean;
mCancel: Boolean;
mDefault: Boolean;
function getFocused (): Boolean; inline;
procedure setFocused (v: Boolean); inline;
+ function getActive (): Boolean; inline;
+
function getCanFocus (): Boolean; inline;
function isMyChild (ctl: TUIControl): Boolean;
procedure activated (); virtual;
procedure blurred (); virtual;
+ procedure calcFullClientSize ();
+
//WARNING! do not call scissor functions outside `.draw*()` API!
// set scissor to this rect (in local coords)
procedure setScissor (lx, ly, lw, lh: Integer);
mExpand: Boolean;
mLayDefSize: TLaySize;
mLayMaxSize: TLaySize;
+ mFullSize: TLaySize;
public
// layouter interface
property flExpand: Boolean read getExpand write setExpand;
property flHGroup: AnsiString read getHGroup write setHGroup;
property flVGroup: AnsiString read getVGroup write setVGroup;
+ property fullSize: TLaySize read mFullSize;
protected
function parsePos (par: TTextParser): TLayPos;
procedure toGlobal (var x, y: Integer);
procedure toGlobal (lx, ly: Integer; out x, y: Integer); inline;
+ procedure getDrawRect (out gx, gy, wdt, hgt: Integer);
+
// x and y are global coords
function controlAtXY (x, y: Integer; allowDisabled: Boolean=false): TUIControl;
- procedure doAction ();
+ function parentScrollX (): Integer; inline;
+ function parentScrollY (): Integer; inline;
+
+ procedure doAction (); virtual; // so user controls can override it
procedure mouseEvent (var ev: THMouseEvent); virtual; // returns `true` if event was eaten
procedure keyEvent (var ev: THKeyEvent); virtual; // returns `true` if event was eaten
+ procedure keyEventPre (var ev: THKeyEvent); virtual; // will be called before dispatching the event
+ procedure keyEventPost (var ev: THKeyEvent); virtual; // will be called after if nobody processed the event
function prevSibling (): TUIControl;
function nextSibling (): TUIControl;
procedure appendChild (ctl: TUIControl); virtual;
+ function setActionCBFor (const aid: AnsiString; cb: TActionCB): TActionCB; // returns previous cb
+
+ function forEachChildren (cb: TCtlEnumCB): TUIControl; // doesn't recurse
+ function forEachControl (cb: TCtlEnumCB; includeSelf: Boolean=true): TUIControl;
+
procedure close (); // this closes *top-level* control
public
property id: AnsiString read mId;
property styleId: AnsiString read mStyleId;
+ property scrollX: Integer read mScrollX write mScrollX;
+ property scrollY: Integer read mScrollY write mScrollY;
property x0: Integer read mX;
property y0: Integer read mY;
property height: Integer read mHeight;
property enabled: Boolean read getEnabled write setEnabled;
property parent: TUIControl read mParent;
property focused: Boolean read getFocused write setFocused;
+ property active: Boolean read getActive;
property escClose: Boolean read mEscClose write mEscClose;
- property eatKeys: Boolean read mEatKeys write mEatKeys;
property cancel: Boolean read mCancel write mCancel;
property defctl: Boolean read mDefault write mDefault;
property canFocus: Boolean read getCanFocus write mCanFocus;
TUITopWindow = class(TUIControl)
+ private
+ type TXMode = (None, Drag, Scroll);
+
private
mTitle: AnsiString;
- mDragging: Boolean;
+ mDragScroll: TXMode;
mDragStartX, mDragStartY: Integer;
mWaitingClose: Boolean;
mInClose: Boolean;
property freeOnClose: Boolean read mFreeOnClose write mFreeOnClose;
end;
-
+ // ////////////////////////////////////////////////////////////////////// //
TUISimpleText = class(TUIControl)
private
type
centered: Boolean;
hline: Boolean;
end;
+
private
mItems: array of TItem;
constructor Create (ax, ay: Integer);
destructor Destroy (); override;
+ procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
+
procedure appendItem (const atext: AnsiString; acentered: Boolean=false; ahline: Boolean=false);
procedure drawControl (gx, gy: Integer); override;
procedure mouseEvent (var ev: THMouseEvent); override;
end;
-
TUICBListBox = class(TUIControl)
private
type
varp: PBoolean;
actionCB: TActionCB;
end;
+
private
mItems: array of TItem;
mCurIndex: Integer;
+ mCurItemBack: array[0..ClrIdxMax] of TGxRGBA;
+
+ protected
+ procedure cacheStyle (root: TUIStyle); override;
public
constructor Create (ax, ay: Integer);
destructor Destroy (); override;
+ procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
+
procedure appendItem (const atext: AnsiString; bv: PBoolean; aaction: TActionCB=nil);
procedure drawControl (gx, gy: Integer); override;
procedure mouseEvent (var ev: THMouseEvent); override;
procedure keyEvent (var ev: THKeyEvent); override;
+
+ public
+ property caption: AnsiString read mCaption write mCaption;
+ property hasFrame: Boolean read mHasFrame write mHasFrame;
end;
TUIHBox = class(TUIBox)
public
+ constructor Create ();
+
procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
end;
TUIVBox = class(TUIBox)
public
+ constructor Create ();
+
procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
end;
end;
// ////////////////////////////////////////////////////////////////////// //
- TUITextLabel = class(TUIControl)
+ TUIStaticText = class(TUIControl)
private
mText: AnsiString;
mHAlign: Integer; // -1: left; 0: center; 1: right; default: left
mVAlign: Integer; // -1: top; 0: center; 1: bottom; default: center
+ mHeader: Boolean; // true: draw with frame text color
+ mLine: Boolean; // true: draw horizontal line
+
+ private
+ procedure setText (const atext: AnsiString);
+
+ public
+ procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
+
+ function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override;
+
+ procedure drawControl (gx, gy: Integer); override;
public
- constructor Create (const atext: AnsiString);
+ property text: AnsiString read mText write setText;
+ property halign: Integer read mHAlign write mHAlign;
+ property valign: Integer read mVAlign write mVAlign;
+ property header: Boolean read mHeader write mHeader;
+ property line: Boolean read mLine write mLine;
+ end;
+
+ // ////////////////////////////////////////////////////////////////////// //
+ TUITextLabel = class(TUIControl)
+ private
+ mText: AnsiString;
+ mHAlign: Integer; // -1: left; 0: center; 1: right; default: left
+ mVAlign: Integer; // -1: top; 0: center; 1: bottom; default: center
+ mHotChar: AnsiChar;
+ mHotOfs: Integer; // from text start, in pixels
+ mHotColor: array[0..ClrIdxMax] of TGxRGBA;
+ mLinkId: AnsiString; // linked control
+
+ protected
+ procedure cacheStyle (root: TUIStyle); override;
+ procedure setText (const s: AnsiString);
+
+ public
procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override;
procedure drawControl (gx, gy: Integer); override;
procedure mouseEvent (var ev: THMouseEvent); override;
+ procedure keyEventPost (var ev: THKeyEvent); override;
+
+ public
+ property text: AnsiString read mText write setText;
+ property halign: Integer read mHAlign write mHAlign;
+ property valign: Integer read mVAlign write mVAlign;
end;
// ////////////////////////////////////////////////////////////////////// //
TUIButton = class(TUITextLabel)
public
- constructor Create (const atext: AnsiString);
-
procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override;
procedure mouseEvent (var ev: THMouseEvent); override;
procedure keyEvent (var ev: THKeyEvent); override;
+ procedure keyEventPost (var ev: THKeyEvent); override;
end;
TUITopWindow(ctl).centerInScreen();
end;
+ // calculate full size
+ ctl.calcFullClientSize();
+
finally
FreeAndNil(lay);
end;
if (uiGrabCtl <> nil) then
begin
uiGrabCtl.mouseEvent(ev);
- if (ev.release) then uiGrabCtl := nil;
+ if (ev.release) and ((ev.bstate and (not ev.but)) = 0) then uiGrabCtl := nil;
ev.eat();
exit;
end;
ctl: TUIControl;
begin
processKills();
- glMatrixMode(GL_MODELVIEW);
- glPushMatrix();
+ gxBeginUIDraw(gh_ui_scale);
try
- glLoadIdentity();
- glScalef(gh_ui_scale, gh_ui_scale, 1);
for f := 0 to High(uiTopList) do
begin
ctl := uiTopList[f];
if (ctl.mDarken[cidx] > 0) then darkenRect(ctl.x0, ctl.y0, ctl.width, ctl.height, ctl.mDarken[cidx]);
end;
finally
- glMatrixMode(GL_MODELVIEW);
- glPopMatrix();
+ gxEndUIDraw();
end;
end;
mChildren := nil;
mFocused := nil;
mEscClose := false;
- mEatKeys := false;
scallowed := false;
mDrawShadow := false;
actionCB := nil;
function TUIControl.getColorIndex (): Integer; inline;
begin
if (not mEnabled) then begin result := ClrIdxDisabled; exit; end;
- if (getFocused) then begin result := ClrIdxActive; exit; end;
+ // if control cannot be focused, take "active" color scheme for it (it is easier this way)
+ if (not canFocus) or (getActive) then begin result := ClrIdxActive; exit; end;
result := ClrIdxInactive;
end;
procedure TUIControl.cacheStyle (root: TUIStyle);
var
- cst: AnsiString = '';
+ cst: AnsiString;
begin
//writeln('caching style for <', className, '> (', mCtl4Style, ')...');
- if (Length(mCtl4Style) > 0) then
- begin
- cst := mCtl4Style;
- if (cst[1] <> '@') then cst := '@'+cst;
- end;
+ cst := mCtl4Style;
// active
- mBackColor[ClrIdxActive] := root['back-color'+cst].asRGBADef(TGxRGBA.Create(0, 0, 128));
- mTextColor[ClrIdxActive] := root['text-color'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255));
- mFrameColor[ClrIdxActive] := root['frame-color'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255));
- mFrameTextColor[ClrIdxActive] := root['frame-text-color'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255));
- mFrameIconColor[ClrIdxActive] := root['frame-icon-color'+cst].asRGBADef(TGxRGBA.Create(0, 255, 0));
- mDarken[ClrIdxActive] := root['darken'+cst].asIntDef(-1);
+ mBackColor[ClrIdxActive] := root.get('back-color', 'active', cst).asRGBADef(TGxRGBA.Create(0, 0, 128));
+ mTextColor[ClrIdxActive] := root.get('text-color', 'active', cst).asRGBADef(TGxRGBA.Create(255, 255, 255));
+ mFrameColor[ClrIdxActive] := root.get('frame-color', 'active', cst).asRGBADef(TGxRGBA.Create(255, 255, 255));
+ mFrameTextColor[ClrIdxActive] := root.get('frame-text-color', 'active', cst).asRGBADef(TGxRGBA.Create(255, 255, 255));
+ mFrameIconColor[ClrIdxActive] := root.get('frame-icon-color', 'active', cst).asRGBADef(TGxRGBA.Create(0, 255, 0));
+ mDarken[ClrIdxActive] := root.get('darken', 'active', cst).asInt(-1);
// disabled
- mBackColor[ClrIdxDisabled] := root['back-color#disabled'+cst].asRGBADef(TGxRGBA.Create(0, 0, 128));
- mTextColor[ClrIdxDisabled] := root['text-color#disabled'+cst].asRGBADef(TGxRGBA.Create(127, 127, 127));
- mFrameColor[ClrIdxDisabled] := root['frame-color#disabled'+cst].asRGBADef(TGxRGBA.Create(127, 127, 127));
- mFrameTextColor[ClrIdxDisabled] := root['frame-text-color#disabled'+cst].asRGBADef(TGxRGBA.Create(127, 127, 127));
- mFrameIconColor[ClrIdxDisabled] := root['frame-icon-color#disabled'+cst].asRGBADef(TGxRGBA.Create(0, 127, 0));
- mDarken[ClrIdxDisabled] := root['darken#disabled'+cst].asIntDef(128);
+ mBackColor[ClrIdxDisabled] := root.get('back-color', 'disabled', cst).asRGBADef(TGxRGBA.Create(0, 0, 128));
+ mTextColor[ClrIdxDisabled] := root.get('text-color', 'disabled', cst).asRGBADef(TGxRGBA.Create(127, 127, 127));
+ mFrameColor[ClrIdxDisabled] := root.get('frame-color', 'disabled', cst).asRGBADef(TGxRGBA.Create(127, 127, 127));
+ mFrameTextColor[ClrIdxDisabled] := root.get('frame-text-color', 'disabled', cst).asRGBADef(TGxRGBA.Create(127, 127, 127));
+ mFrameIconColor[ClrIdxDisabled] := root.get('frame-icon-color', 'disabled', cst).asRGBADef(TGxRGBA.Create(0, 127, 0));
+ mDarken[ClrIdxDisabled] := root.get('darken', 'disabled', cst).asInt(-1);
// inactive
- mBackColor[ClrIdxInactive] := root['back-color#inactive'+cst].asRGBADef(TGxRGBA.Create(0, 0, 128));
- mTextColor[ClrIdxInactive] := root['text-color#inactive'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255));
- mFrameColor[ClrIdxInactive] := root['frame-color#inactive'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255));
- mFrameTextColor[ClrIdxInactive] := root['frame-text-color#inactive'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255));
- mFrameIconColor[ClrIdxInactive] := root['frame-icon-color#inactive'+cst].asRGBADef(TGxRGBA.Create(0, 255, 0));
- mDarken[ClrIdxInactive] := root['darken#inactive'+cst].asIntDef(128);
+ mBackColor[ClrIdxInactive] := root.get('back-color', 'inactive', cst).asRGBADef(TGxRGBA.Create(0, 0, 128));
+ mTextColor[ClrIdxInactive] := root.get('text-color', 'inactive', cst).asRGBADef(TGxRGBA.Create(255, 255, 255));
+ mFrameColor[ClrIdxInactive] := root.get('frame-color', 'inactive', cst).asRGBADef(TGxRGBA.Create(255, 255, 255));
+ mFrameTextColor[ClrIdxInactive] := root.get('frame-text-color', 'inactive', cst).asRGBADef(TGxRGBA.Create(255, 255, 255));
+ mFrameIconColor[ClrIdxInactive] := root.get('frame-icon-color', 'inactive', cst).asRGBADef(TGxRGBA.Create(0, 255, 0));
+ mDarken[ClrIdxInactive] := root.get('darken', 'inactive', cst).asInt(-1);
end;
result := TLayMargins.Create(mFrameHeight, mFrameWidth, mFrameHeight, mFrameWidth);
end;
-procedure TUIControl.setActualSizePos (constref apos: TLayPos; constref asize: TLaySize); inline; begin
+procedure TUIControl.setActualSizePos (constref apos: TLayPos; constref asize: TLaySize); inline;
+begin
//writeln(self.className, '; pos=', apos.toString, '; size=', asize.toString);
if (mParent <> nil) then
begin
if (strEquCI1251(prname, 'hgroup')) then begin mHGroup := par.expectIdOrStr(true); exit; end; // allow empty strings
if (strEquCI1251(prname, 'vgroup')) then begin mVGroup := par.expectIdOrStr(true); exit; end; // allow empty strings
// other
- if (strEquCI1251(prname, 'canfocus')) then begin mCanFocus := parseBool(par); exit; end;
- if (strEquCI1251(prname, 'enabled')) then begin mEnabled := parseBool(par); exit; end;
- if (strEquCI1251(prname, 'disabled')) then begin mEnabled := not parseBool(par); exit; end;
+ if (strEquCI1251(prname, 'canfocus')) then begin mCanFocus := true; exit; end;
+ if (strEquCI1251(prname, 'nofocus')) then begin mCanFocus := false; exit; end;
+ if (strEquCI1251(prname, 'disabled')) then begin mEnabled := false; exit; end;
+ if (strEquCI1251(prname, 'enabled')) then begin mEnabled := true; exit; end;
if (strEquCI1251(prname, 'escclose')) then begin mEscClose := not parseBool(par); exit; end;
- if (strEquCI1251(prname, 'eatkeys')) then begin mEatKeys := not parseBool(par); exit; end;
if (strEquCI1251(prname, 'default')) then begin mDefault := true; exit; end;
if (strEquCI1251(prname, 'cancel')) then begin mCancel := true; exit; end;
result := false;
end;
+procedure TUIControl.calcFullClientSize ();
+var
+ ctl: TUIControl;
+begin
+ mFullSize := TLaySize.Create(0, 0);
+ if (mWidth < 1) or (mHeight < 1) then exit;
+ for ctl in mChildren do
+ begin
+ ctl.calcFullClientSize();
+ mFullSize.w := nmax(mFullSize.w, ctl.mX-mFrameWidth+ctl.mFullSize.w);
+ mFullSize.h := nmax(mFullSize.h, ctl.mY-mFrameHeight+ctl.mFullSize.h);
+ end;
+ mFullSize.w := nmax(mFullSize.w, mWidth-mFrameWidth*2);
+ mFullSize.h := nmax(mFullSize.h, mHeight-mFrameHeight*2);
+end;
+
+
function TUIControl.topLevel (): TUIControl; inline;
begin
result := self;
end;
+function TUIControl.getActive (): Boolean; inline;
+var
+ ctl: TUIControl;
+begin
+ if (mParent = nil) then
+ begin
+ result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = self);
+ end
+ else
+ begin
+ ctl := topLevel.mFocused;
+ while (ctl <> nil) and (ctl <> self) do ctl := ctl.mParent;
+ result := (ctl = self);
+ if (result) then result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = topLevel);
+ end;
+end;
+
+
procedure TUIControl.setFocused (v: Boolean); inline;
var
tl: TUIControl;
// returns `true` if global coords are inside this control
function TUIControl.toLocal (var x, y: Integer): Boolean;
-var
- ctl: TUIControl;
begin
- ctl := self;
- while (ctl <> nil) do
+ if (mParent = nil) then
begin
- Dec(x, ctl.mX);
- Dec(y, ctl.mY);
- ctl := ctl.mParent;
+ Dec(x, mX);
+ Dec(y, mY);
+ result := (x >= 0) and (y >= 0) and (x < mWidth) and (y < mHeight);
+ end
+ else
+ begin
+ result := mParent.toLocal(x, y);
+ if result then
+ begin
+ Inc(x, mParent.mScrollX);
+ Inc(y, mParent.mScrollY);
+ result := (x >= 0) and (y >= 0) and (x < mParent.mWidth) and (y < mParent.mHeight);
+ Dec(x, mX);
+ Dec(y, mY);
+ end
+ else
+ begin
+ Inc(x, mParent.mScrollX);
+ Inc(y, mParent.mScrollY);
+ Dec(x, mX);
+ Dec(y, mY);
+ end;
end;
- result := (x >= 0) and (y >= 0) and (x < mWidth) and (y < mHeight);
end;
function TUIControl.toLocal (gx, gy: Integer; out x, y: Integer): Boolean; inline;
result := toLocal(x, y);
end;
+
procedure TUIControl.toGlobal (var x, y: Integer);
-var
- ctl: TUIControl;
begin
- ctl := self;
- while (ctl <> nil) do
+ Inc(x, mX);
+ Inc(y, mY);
+ if (mParent <> nil) then
begin
- Inc(x, ctl.mX);
- Inc(y, ctl.mY);
- ctl := ctl.mParent;
+ Dec(x, mParent.mScrollX);
+ Dec(y, mParent.mScrollY);
+ mParent.toGlobal(x, y);
end;
end;
toGlobal(x, y);
end;
+procedure TUIControl.getDrawRect (out gx, gy, wdt, hgt: Integer);
+var
+ cgx, cgy: Integer;
+begin
+ if (mParent = nil) then
+ begin
+ gx := mX;
+ gy := mY;
+ wdt := mWidth;
+ hgt := mHeight;
+ end
+ else
+ begin
+ toGlobal(0, 0, cgx, cgy);
+ mParent.getDrawRect(gx, gy, wdt, hgt);
+ if (wdt > 0) and (hgt > 0) then
+ begin
+ if not intersectRect(gx, gy, wdt, hgt, cgx, cgy, mWidth, mHeight) then
+ begin
+ wdt := 0;
+ hgt := 0;
+ end;
+ end;
+ end;
+end;
+
// x and y are global coords
function TUIControl.controlAtXY (x, y: Integer; allowDisabled: Boolean=false): TUIControl;
end;
+function TUIControl.parentScrollX (): Integer; inline; begin if (mParent <> nil) then result := mParent.mScrollX else result := 0; end;
+function TUIControl.parentScrollY (): Integer; inline; begin if (mParent <> nil) then result := mParent.mScrollY else result := 0; end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
function TUIControl.prevSibling (): TUIControl;
var
f: Integer;
var
ctl: TUIControl;
begin
- if mDefault then begin result := self; exit; end;
- for ctl in mChildren do
+ if (mEnabled) then
begin
- result := ctl.findDefaulControl();
- if (result <> nil) then exit;
+ if (mDefault) then begin result := self; exit; end;
+ for ctl in mChildren do
+ begin
+ result := ctl.findDefaulControl();
+ if (result <> nil) then exit;
+ end;
end;
result := nil;
end;
var
ctl: TUIControl;
begin
- if mCancel then begin result := self; exit; end;
- for ctl in mChildren do
+ if (mEnabled) then
begin
- result := ctl.findCancelControl();
- if (result <> nil) then exit;
+ if (mCancel) then begin result := self; exit; end;
+ for ctl in mChildren do
+ begin
+ result := ctl.findCancelControl();
+ if (result <> nil) then exit;
+ end;
end;
result := nil;
end;
end;
+function TUIControl.setActionCBFor (const aid: AnsiString; cb: TActionCB): TActionCB;
+var
+ ctl: TUIControl;
+begin
+ ctl := self[aid];
+ if (ctl <> nil) then
+ begin
+ result := ctl.actionCB;
+ ctl.actionCB := cb;
+ end
+ else
+ begin
+ result := nil;
+ end;
+end;
+
+
+function TUIControl.forEachChildren (cb: TCtlEnumCB): TUIControl;
+var
+ ctl: TUIControl;
+begin
+ result := nil;
+ if (not assigned(cb)) then exit;
+ for ctl in mChildren do
+ begin
+ if cb(ctl) then begin result := ctl; exit; end;
+ end;
+end;
+
+
+function TUIControl.forEachControl (cb: TCtlEnumCB; includeSelf: Boolean=true): TUIControl;
+
+ function forChildren (p: TUIControl; incSelf: Boolean): TUIControl;
+ var
+ ctl: TUIControl;
+ begin
+ result := nil;
+ if (p = nil) then exit;
+ if (incSelf) and (cb(p)) then begin result := p; exit; end;
+ for ctl in p.mChildren do
+ begin
+ result := forChildren(ctl, true);
+ if (result <> nil) then break;
+ end;
+ end;
+
+begin
+ result := nil;
+ if (not assigned(cb)) then exit;
+ result := forChildren(self, includeSelf);
+end;
+
+
procedure TUIControl.close (); // this closes *top-level* control
var
ctl: TUIControl;
procedure TUIControl.setScissor (lx, ly, lw, lh: Integer);
var
- gx, gy: Integer;
- //ox, oy, ow, oh: Integer;
+ gx, gy, wdt, hgt, cgx, cgy: Integer;
begin
if not scallowed then exit;
- //ox := lx; oy := ly; ow := lw; oh := lh;
+
if not intersectRect(lx, ly, lw, lh, 0, 0, mWidth, mHeight) then
begin
- //writeln('oops: <', self.className, '>: old=(', ox, ',', oy, ')-[', ow, ',', oh, ']');
- glScissor(0, 0, 0, 0);
+ scis.combineRect(0, 0, 0, 0);
+ exit;
+ end;
+
+ getDrawRect(gx, gy, wdt, hgt);
+ toGlobal(lx, ly, cgx, cgy);
+ if not intersectRect(gx, gy, wdt, hgt, cgx, cgy, lw, lh) then
+ begin
+ scis.combineRect(0, 0, 0, 0);
exit;
end;
- toGlobal(lx, ly, gx, gy);
- setScissorGLInternal(gx, gy, lw, lh);
+
+ setScissorGLInternal(gx, gy, wdt, hgt);
end;
procedure TUIControl.resetScissor (fullArea: Boolean); inline;
begin
if (mWidth < 1) or (mHeight < 1) then exit;
toGlobal(0, 0, gx, gy);
- //conwritefln('[%s]: (%d,%d)-(%d,%d) (%d,%d)', [ClassName, mX, mY, mWidth, mHeight, x, y]);
scis.save(true); // scissoring enabled
try
procedure TUIControl.keyEvent (var ev: THKeyEvent);
+
+ function doPreKey (ctl: TUIControl): Boolean;
+ begin
+ if (not ctl.mEnabled) then begin result := false; exit; end;
+ ctl.keyEventPre(ev);
+ result := (ev.eaten) or (ev.cancelled); // stop if event was consumed
+ end;
+
+ function doPostKey (ctl: TUIControl): Boolean;
+ begin
+ if (not ctl.mEnabled) then begin result := false; exit; end;
+ ctl.keyEventPost(ev);
+ result := (ev.eaten) or (ev.cancelled); // stop if event was consumed
+ end;
+
var
ctl: TUIControl;
begin
if (not mEnabled) then exit;
+ if (ev.eaten) or (ev.cancelled) then exit;
+ // call pre-key
+ if (mParent = nil) then
+ begin
+ forEachControl(doPreKey);
+ if (ev.eaten) or (ev.cancelled) then exit;
+ end;
// focused control should process keyboard first
if (topLevel.mFocused <> self) and isMyChild(topLevel.mFocused) and (topLevel.mFocused.mEnabled) then
begin
- topLevel.mFocused.keyEvent(ev);
+ ctl := topLevel.mFocused;
+ while (ctl <> nil) and (ctl <> self) do
+ begin
+ ctl.keyEvent(ev);
+ if (ev.eaten) or (ev.cancelled) then exit;
+ ctl := ctl.mParent;
+ end;
end;
// for top-level controls
- if (mParent = nil) and (not ev.eaten) and (not ev.cancelled) then
+ if (mParent = nil) then
begin
if (ev = 'S-Tab') then
begin
ev.eat();
exit;
end;
+ // call post-keys
+ if (ev.eaten) or (ev.cancelled) then exit;
+ forEachControl(doPostKey);
end;
- if mEatKeys then ev.eat();
+end;
+
+
+procedure TUIControl.keyEventPre (var ev: THKeyEvent);
+begin
+end;
+
+
+procedure TUIControl.keyEventPost (var ev: THKeyEvent);
+begin
end;
mTitle := atitle;
end;
+
procedure TUITopWindow.AfterConstruction ();
begin
inherited AfterConstruction();
begin
if (mWidth < Length(mTitle)*8+mFrameWidth*2+3*8) then mWidth := Length(mTitle)*8+mFrameWidth*2+3*8;
end;
- mDragging := false;
+ mDragScroll := TXMode.None;
mDrawShadow := true;
mWaitingClose := false;
mInClose := false;
closeCB := nil;
- mCtl4Style := '';
+ mCtl4Style := 'window';
end;
procedure TUITopWindow.drawControlPost (gx, gy: Integer);
var
cidx: Integer;
- tx: Integer;
+ tx, hgt, sbhgt: Integer;
begin
cidx := getColorIndex;
- if mDragging then
+ if (mDragScroll = TXMode.Drag) then
begin
- drawRectUI(mX+4, mY+4, mWidth-8, mHeight-8, mFrameColor[cidx]);
+ drawRectUI(gx+4, gy+4, mWidth-8, mHeight-8, mFrameColor[cidx]);
end
else
begin
- drawRectUI(mX+3, mY+3, mWidth-6, mHeight-6, mFrameColor[cidx]);
- drawRectUI(mX+5, mY+5, mWidth-10, mHeight-10, mFrameColor[cidx]);
+ drawRectUI(gx+3, gy+3, mWidth-6, mHeight-6, mFrameColor[cidx]);
+ drawRectUI(gx+5, gy+5, mWidth-10, mHeight-10, mFrameColor[cidx]);
+ // vertical scroll bar
+ hgt := mHeight-mFrameHeight*2;
+ if (hgt > 0) and (mFullSize.h > hgt) then
+ begin
+ //writeln(mTitle, ': height=', mHeight-mFrameHeight*2, '; fullsize=', mFullSize.toString);
+ sbhgt := mHeight-mFrameHeight*2+2;
+ fillRect(gx+mWidth-mFrameWidth+1, gy+7, mFrameWidth-3, sbhgt, mFrameColor[cidx]);
+ hgt += mScrollY;
+ if (hgt > mFullSize.h) then hgt := mFullSize.h;
+ hgt := sbhgt*hgt div mFullSize.h;
+ if (hgt > 0) then
+ begin
+ setScissor(mWidth-mFrameWidth+1, 7, mFrameWidth-3, sbhgt);
+ darkenRect(gx+mWidth-mFrameWidth+1, gy+7+hgt, mFrameWidth-3, sbhgt, 128);
+ end;
+ end;
+ // frame icon
setScissor(mFrameWidth, 0, 3*8, 8);
- fillRect(mX+mFrameWidth, mY, 3*8, 8, mBackColor[cidx]);
- drawText8(mX+mFrameWidth, mY, '[ ]', mFrameColor[cidx]);
- if mInClose then drawText8(mX+mFrameWidth+7, mY, '#', mFrameIconColor[cidx])
- else drawText8(mX+mFrameWidth+7, mY, '*', mFrameIconColor[cidx]);
+ fillRect(gx+mFrameWidth, gy, 3*8, 8, mBackColor[cidx]);
+ drawText8(gx+mFrameWidth, gy, '[ ]', mFrameColor[cidx]);
+ if mInClose then drawText8(gx+mFrameWidth+7, gy, '#', mFrameIconColor[cidx])
+ else drawText8(gx+mFrameWidth+7, gy, '*', mFrameIconColor[cidx]);
end;
+ // title
if (Length(mTitle) > 0) then
begin
setScissor(mFrameWidth+3*8, 0, mWidth-mFrameWidth*2-3*8, 8);
- tx := (mX+3*8)+((mWidth-3*8)-Length(mTitle)*8) div 2;
- fillRect(tx-3, mY, Length(mTitle)*8+3+2, 8, mBackColor[cidx]);
- drawText8(tx, mY, mTitle, mFrameTextColor[cidx]);
+ tx := (gx+3*8)+((mWidth-3*8)-Length(mTitle)*8) div 2;
+ fillRect(tx-3, gy, Length(mTitle)*8+3+2, 8, mBackColor[cidx]);
+ drawText8(tx, gy, mTitle, mFrameTextColor[cidx]);
end;
+ // shadow
inherited drawControlPost(gx, gy);
end;
procedure TUITopWindow.blurred ();
begin
- mDragging := false;
+ mDragScroll := TXMode.None;
mWaitingClose := false;
mInClose := false;
inherited;
procedure TUITopWindow.keyEvent (var ev: THKeyEvent);
begin
inherited keyEvent(ev);
- if (ev.eaten) or (ev.cancelled) or (not mEnabled) or (not getFocused) then exit;
+ if (ev.eaten) or (ev.cancelled) or (not mEnabled) {or (not getFocused)} then exit;
if (ev = 'M-F3') then
begin
if (not assigned(closeRequestCB)) or (closeRequestCB(self)) then
procedure TUITopWindow.mouseEvent (var ev: THMouseEvent);
var
lx, ly: Integer;
+ hgt, sbhgt: Integer;
begin
if (not mEnabled) then exit;
if (mWidth < 1) or (mHeight < 1) then exit;
- if mDragging then
+ if (mDragScroll = TXMode.Drag) then
begin
mX += ev.x-mDragStartX;
mY += ev.y-mDragStartY;
mDragStartX := ev.x;
mDragStartY := ev.y;
- if (ev.release) then mDragging := false;
+ if (ev.release) and (ev.but = ev.Left) then mDragScroll := TXMode.None;
+ ev.eat();
+ exit;
+ end;
+
+ if (mDragScroll = TXMode.Scroll) then
+ begin
+ // check for vertical scrollbar
+ ly := ev.y-mY;
+ if (ly < 7) then
+ begin
+ mScrollY := 0;
+ end
+ else
+ begin
+ sbhgt := mHeight-mFrameHeight*2+2;
+ hgt := mHeight-mFrameHeight*2;
+ if (hgt > 0) and (mFullSize.h > hgt) then
+ begin
+ hgt := (mFullSize.h*(ly-7) div (sbhgt-1))-(mHeight-mFrameHeight*2);
+ mScrollY := nmax(0, hgt);
+ hgt := mHeight-mFrameHeight*2;
+ if (mScrollY+hgt > mFullSize.h) then mScrollY := nmax(0, mFullSize.h-hgt);
+ end;
+ end;
+ if (ev.release) and (ev.but = ev.Left) then mDragScroll := TXMode.None;
ev.eat();
exit;
end;
end
else
begin
- mDragging := true;
+ mDragScroll := TXMode.Drag;
mDragStartX := ev.x;
mDragStartY := ev.y;
end;
ev.eat();
exit;
end;
+ // check for vertical scrollbar
+ if (lx >= mWidth-mFrameWidth+1) and (ly >= 7) and (ly < mHeight-mFrameHeight+1) then
+ begin
+ sbhgt := mHeight-mFrameHeight*2+2;
+ hgt := mHeight-mFrameHeight*2;
+ if (hgt > 0) and (mFullSize.h > hgt) then
+ begin
+ hgt := (mFullSize.h*(ly-7) div (sbhgt-1))-(mHeight-mFrameHeight*2);
+ mScrollY := nmax(0, hgt);
+ uiGrabCtl := self;
+ mDragScroll := TXMode.Scroll;
+ ev.eat();
+ exit;
+ end;
+ end;
+ // drag
if (lx < mFrameWidth) or (lx >= mWidth-mFrameWidth) or (ly >= mHeight-mFrameHeight) then
begin
uiGrabCtl := self;
- mDragging := true;
+ mDragScroll := TXMode.Drag;
mDragStartX := ev.x;
mDragStartY := ev.y;
ev.eat();
begin
mItems := nil;
inherited Create(ax, ay, 4, 4);
+ mDefSize := TLaySize.Create(mWidth, mHeight);
end;
end;
+procedure TUISimpleText.AfterConstruction ();
+begin
+ inherited;
+ mCanFocus := false;
+ mCtl4Style := 'simple_text';
+end;
+
+
procedure TUISimpleText.appendItem (const atext: AnsiString; acentered: Boolean=false; ahline: Boolean=false);
var
it: PItem;
it.centered := acentered;
it.hline := ahline;
if (Length(mItems)*8 > mHeight) then mHeight := Length(mItems)*8;
+ mDefSize := TLaySize.Create(mWidth, mHeight);
end;
procedure TUISimpleText.drawControl (gx, gy: Integer);
var
- f, tx: Integer;
+ cidx: Integer;
+ f, xofs: Integer;
it: PItem;
- r, g, b: Integer;
begin
+ cidx := getColorIndex;
for f := 0 to High(mItems) do
begin
it := @mItems[f];
- tx := gx;
- r := 255;
- g := 255;
- b := 0;
- if it.centered then begin b := 255; tx := gx+(mWidth-Length(it.title)*8) div 2; end;
+ xofs := 0;
+ if it.centered then begin xofs := (mWidth-Length(it.title)*8) div 2; end;
if it.hline then
begin
- b := 255;
if (Length(it.title) = 0) then
begin
- drawHLine(gx+4, gy+3, mWidth-8, TGxRGBA.Create(r, g, b));
+ drawHLine(gx+4, gy+3, mWidth-8, mFrameColor[cidx]);
end
- else if (tx-3 > gx+4) then
+ else
begin
- drawHLine(gx+4, gy+3, tx-3-(gx+3), TGxRGBA.Create(r, g, b));
- drawHLine(tx+Length(it.title)*8, gy+3, mWidth-4, TGxRGBA.Create(r, g, b));
+ drawHLine(gx+4, gy+3, gx+xofs-3-(gx+3), mFrameColor[cidx]);
+ drawHLine(gx+xofs+Length(it.title)*8, gy+3, mWidth-(xofs+Length(it.title)*8)-4, mFrameColor[cidx]);
+ drawText8(gx+xofs, gy, it.title, mFrameTextColor[cidx]);
end;
+ end
+ else
+ begin
+ drawText8(gx+xofs, gy, it.title, mTextColor[cidx]);
end;
- drawText8(tx, gy, it.title, TGxRGBA.Create(r, g, b));
Inc(gy, 8);
end;
end;
// ////////////////////////////////////////////////////////////////////////// //
constructor TUICBListBox.Create (ax, ay: Integer);
begin
- mItems := nil;
- mCurIndex := -1;
inherited Create(ax, ay, 4, 4);
+ mDefSize := TLaySize.Create(mWidth, mHeight);
end;
end;
+procedure TUICBListBox.AfterConstruction ();
+begin
+ inherited;
+ mItems := nil;
+ mCurIndex := -1;
+ mCtl4Style := 'cb_listbox';
+end;
+
+
+procedure TUICBListBox.cacheStyle (root: TUIStyle);
+begin
+ inherited cacheStyle(root);
+ // active
+ mCurItemBack[ClrIdxActive] := root.get('current-item-back-color', 'active', mCtl4Style).asRGBADef(TGxRGBA.Create(0, 128, 0));
+ // disabled
+ mCurItemBack[ClrIdxDisabled] := root.get('current-item-back-color', 'disabled', mCtl4Style).asRGBADef(TGxRGBA.Create(0, 64, 0));
+ // inactive
+ mCurItemBack[ClrIdxInactive] := root.get('current-item-back-color', 'inactive', mCtl4Style).asRGBADef(TGxRGBA.Create(0, 64, 0));
+end;
+
+
procedure TUICBListBox.appendItem (const atext: AnsiString; bv: PBoolean; aaction: TActionCB=nil);
var
it: PItem;
it.actionCB := aaction;
if (Length(mItems)*8 > mHeight) then mHeight := Length(mItems)*8;
if (mCurIndex < 0) then mCurIndex := 0;
+ mDefSize := TLaySize.Create(mWidth, mHeight);
end;
procedure TUICBListBox.drawControl (gx, gy: Integer);
var
+ cidx: Integer;
f, tx: Integer;
it: PItem;
begin
+ cidx := getColorIndex;
for f := 0 to High(mItems) do
begin
it := @mItems[f];
- if (mCurIndex = f) then fillRect(gx, gy, mWidth, 8, TGxRGBA.Create(0, 128, 0));
+ if (mCurIndex = f) then fillRect(gx, gy, mWidth, 8, mCurItemBack[cidx]);
if (it.varp <> nil) then
begin
- if it.varp^ then drawText8(gx, gy, '[x]', TGxRGBA.Create(255, 255, 255)) else drawText8(gx, gy, '[ ]', TGxRGBA.Create(255, 255, 255));
- drawText8(gx+3*8+2, gy, it.title, TGxRGBA.Create(255, 255, 0));
+ if it.varp^ then drawText8(gx, gy, '[x]', mFrameTextColor[cidx]) else drawText8(gx, gy, '[ ]', mFrameTextColor[cidx]);
+ drawText8(gx+3*8+2, gy, it.title, mTextColor[cidx]);
end
else if (Length(it.title) > 0) then
begin
tx := gx+(mWidth-Length(it.title)*8) div 2;
if (tx-3 > gx+4) then
begin
- drawHLine(gx+4, gy+3, tx-3-(gx+3), TGxRGBA.Create(255, 255, 255));
- drawHLine(tx+Length(it.title)*8, gy+3, mWidth-4, TGxRGBA.Create(255, 255, 255));
+ drawHLine(gx+4, gy+3, tx-3-(gx+3), mFrameColor[cidx]);
+ drawHLine(tx+Length(it.title)*8, gy+3, mWidth-4, mFrameColor[cidx]);
end;
- drawText8(tx, gy, it.title, TGxRGBA.Create(255, 255, 255));
+ drawText8(tx, gy, it.title, mFrameTextColor[cidx]);
end
else
begin
- drawHLine(gx+4, gy+3, mWidth-8, TGxRGBA.Create(255, 255, 255));
+ drawHLine(gx+4, gy+3, mWidth-8, mFrameColor[cidx]);
end;
Inc(gy, 8);
end;
//TODO: navigation with arrow keys, according to box orientation
procedure TUIBox.keyEvent (var ev: THKeyEvent);
+var
+ dir: Integer = 0;
+ cur, ctl: TUIControl;
begin
inherited keyEvent(ev);
- if (ev.eaten) or (ev.cancelled) or (not mEnabled) or (not getFocused) then exit;
+ if (ev.eaten) or (ev.cancelled) or (not ev.press) or (not mEnabled) or (not getActive) then exit;
+ if (Length(mChildren) = 0) then exit;
+ if (mHoriz) and (ev = 'Left') then dir := -1
+ else if (mHoriz) and (ev = 'Right') then dir := 1
+ else if (not mHoriz) and (ev = 'Up') then dir := -1
+ else if (not mHoriz) and (ev = 'Down') then dir := 1;
+ if (dir = 0) then exit;
+ ev.eat();
+ cur := topLevel.mFocused;
+ while (cur <> nil) and (cur.mParent <> self) do cur := cur.mParent;
+ //if (cur = nil) then writeln('CUR: nil') else writeln('CUR: ', cur.className, '#', cur.id);
+ if (dir < 0) then ctl := findPrevFocus(cur) else ctl := findNextFocus(cur);
+ //if (ctl = nil) then writeln('CTL: nil') else writeln('CTL: ', ctl.className, '#', ctl.id);
+ if (ctl <> nil) and (ctl <> self) then
+ begin
+ ctl.focused := true;
+ end;
end;
// ////////////////////////////////////////////////////////////////////////// //
+constructor TUIHBox.Create ();
+begin
+end;
+
+
procedure TUIHBox.AfterConstruction ();
begin
inherited AfterConstruction();
// ////////////////////////////////////////////////////////////////////////// //
+constructor TUIVBox.Create ();
+begin
+end;
+
+
procedure TUIVBox.AfterConstruction ();
begin
inherited AfterConstruction();
procedure TUILine.AfterConstruction ();
begin
inherited AfterConstruction();
+ mCanFocus := false;
mExpand := true;
mCanFocus := false;
mCtl4Style := 'line';
begin
inherited AfterConstruction();
mHoriz := true;
- mDefSize.h := 1;
+ mDefSize.h := 7;
end;
begin
inherited AfterConstruction();
mHoriz := false;
- mDefSize.w := 1;
+ mDefSize.w := 7;
end;
// ////////////////////////////////////////////////////////////////////////// //
-constructor TUITextLabel.Create (const atext: AnsiString);
+procedure TUIStaticText.AfterConstruction ();
+begin
+ inherited;
+ mCanFocus := false;
+ mHAlign := -1;
+ mVAlign := 0;
+ mHoriz := true; // nobody cares
+ mHeader := false;
+ mLine := false;
+ mDefSize.h := 8;
+ mCtl4Style := 'static';
+end;
+
+
+procedure TUIStaticText.setText (const atext: AnsiString);
begin
- inherited Create();
mText := atext;
- mDefSize := TLaySize.Create(Length(atext)*8, 8);
+ mDefSize := TLaySize.Create(Length(mText)*8, 8);
end;
+function TUIStaticText.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
+begin
+ if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) or (strEquCI1251(prname, 'text')) then
+ begin
+ setText(par.expectIdOrStr(true));
+ result := true;
+ exit;
+ end;
+ if (strEquCI1251(prname, 'textalign')) then
+ begin
+ parseTextAlign(par, mHAlign, mVAlign);
+ result := true;
+ exit;
+ end;
+ if (strEquCI1251(prname, 'header')) then
+ begin
+ mHeader := true;
+ result := true;
+ exit;
+ end;
+ if (strEquCI1251(prname, 'line')) then
+ begin
+ mLine := true;
+ result := true;
+ exit;
+ end;
+ result := inherited parseProperty(prname, par);
+end;
+
+
+procedure TUIStaticText.drawControl (gx, gy: Integer);
+var
+ xpos, ypos: Integer;
+ cidx: Integer;
+ clr: TGxRGBA;
+begin
+ cidx := getColorIndex;
+ fillRect(gx, gy, mWidth, mHeight, mBackColor[cidx]);
+
+ if (mHAlign < 0) then xpos := 0
+ else if (mHAlign > 0) then xpos := mWidth-Length(mText)*8
+ else xpos := (mWidth-Length(mText)*8) div 2;
+
+ if (Length(mText) > 0) then
+ begin
+ if (mHeader) then clr := mFrameTextColor[cidx] else clr := mTextColor[cidx];
+
+ if (mVAlign < 0) then ypos := 0
+ else if (mVAlign > 0) then ypos := mHeight-8
+ else ypos := (mHeight-8) div 2;
+
+ drawText8(gx+xpos, gy+ypos, mText, clr);
+ end;
+
+ if (mLine) then
+ begin
+ if (mHeader) then clr := mFrameColor[cidx] else clr := mTextColor[cidx];
+
+ if (mVAlign < 0) then ypos := 0
+ else if (mVAlign > 0) then ypos := mHeight-1
+ else ypos := (mHeight div 2);
+ ypos += gy;
+
+ if (Length(mText) = 0) then
+ begin
+ drawHLine(gx, ypos, mWidth, clr);
+ end
+ else
+ begin
+ drawHLine(gx, ypos, xpos-1, clr);
+ drawHLine(gx+xpos+Length(mText)*8, ypos, mWidth, clr);
+ end;
+ end;
+end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
procedure TUITextLabel.AfterConstruction ();
begin
inherited AfterConstruction();
mHAlign := -1;
mVAlign := 0;
mCanFocus := false;
- if (mDefSize.h <= 0) then mDefSize.h := 8;
+ mDefSize := TLaySize.Create(Length(mText)*8, 8);
mCtl4Style := 'label';
+ mLinkId := '';
+end;
+
+
+procedure TUITextLabel.cacheStyle (root: TUIStyle);
+begin
+ inherited cacheStyle(root);
+ // active
+ mHotColor[ClrIdxActive] := root.get('hot-color', 'active', mCtl4Style).asRGBADef(TGxRGBA.Create(0, 128, 0));
+ // disabled
+ mHotColor[ClrIdxDisabled] := root.get('hot-color', 'disabled', mCtl4Style).asRGBADef(TGxRGBA.Create(0, 64, 0));
+ // inactive
+ mHotColor[ClrIdxInactive] := root.get('hot-color', 'inactive', mCtl4Style).asRGBADef(TGxRGBA.Create(0, 64, 0));
+end;
+
+
+procedure TUITextLabel.setText (const s: AnsiString);
+var
+ f: Integer;
+begin
+ mText := '';
+ mHotChar := #0;
+ mHotOfs := 0;
+ f := 1;
+ while (f <= Length(s)) do
+ begin
+ if (s[f] = '\\') then
+ begin
+ Inc(f);
+ if (f <= Length(s)) then mText += s[f];
+ Inc(f);
+ end
+ else if (s[f] = '~') then
+ begin
+ Inc(f);
+ if (f <= Length(s)) then
+ begin
+ if (mHotChar = #0) then
+ begin
+ mHotChar := s[f];
+ mHotOfs := Length(mText)*8;
+ end;
+ mText += s[f];
+ end;
+ Inc(f);
+ end
+ else
+ begin
+ mText += s[f];
+ Inc(f);
+ end;
+ end;
end;
function TUITextLabel.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
begin
- if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then
+ if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) or (strEquCI1251(prname, 'text')) then
begin
- mText := par.expectIdOrStr(true);
+ setText(par.expectIdOrStr(true));
mDefSize := TLaySize.Create(Length(mText)*8, 8);
result := true;
exit;
end;
+ if (strEquCI1251(prname, 'link')) then
+ begin
+ mLinkId := par.expectIdOrStr(true);
+ result := true;
+ exit;
+ end;
if (strEquCI1251(prname, 'textalign')) then
begin
parseTextAlign(par, mHAlign, mVAlign);
else ypos := (mHeight-8) div 2;
drawText8(gx+xpos, gy+ypos, mText, mTextColor[cidx]);
+
+ if (Length(mLinkId) > 0) and (mHotChar <> #0) and (mHotChar <> ' ') then
+ begin
+ drawText8(gx+xpos+8+mHotOfs, gy+ypos, mHotChar, mHotColor[cidx]);
+ end;
end;
end;
end;
-// ////////////////////////////////////////////////////////////////////////// //
-constructor TUIButton.Create (const atext: AnsiString);
+procedure TUITextLabel.keyEventPost (var ev: THKeyEvent);
+var
+ ctl: TUIControl;
begin
- inherited Create(atext);
+ if (not mEnabled) then exit;
+ if (mHotChar = #0) or (Length(mLinkId) = 0) then exit;
+ if (ev.eaten) or (ev.cancelled) or (not ev.press) then exit;
+ if (not ev.isHot(mHotChar)) then exit;
+ ctl := topLevel[mLinkId];
+ if (ctl <> nil) then
+ begin
+ ev.eat();
+ if (ctl.canFocus) then ctl.focused := true;
+ end;
end;
+// ////////////////////////////////////////////////////////////////////////// //
procedure TUIButton.AfterConstruction ();
begin
inherited AfterConstruction();
mHAlign := -1;
mVAlign := 0;
mCanFocus := true;
- mDefSize := TLaySize.Create(Length(mText)*8+8, 8);
+ mDefSize := TLaySize.Create(Length(mText)*8+8, 10);
mCtl4Style := 'button';
end;
function TUIButton.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
begin
- result := inherited parseProperty(prname, par);
- if result then
+ if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then
begin
- mDefSize := TLaySize.Create(Length(mText)*8+8*2, 8);
+ result := inherited parseProperty(prname, par);
+ if result then mDefSize := TLaySize.Create(Length(mText)*8+8*2, 10);
+ exit;
end;
+ result := inherited parseProperty(prname, par);
end;
var
xpos, ypos: Integer;
cidx: Integer;
- lch, rch: AnsiChar;
begin
cidx := getColorIndex;
- fillRect(gx, gy, mWidth, mHeight, mBackColor[cidx]);
-
- if (mDefault) then begin lch := '<'; rch := '>'; end
- else if (mCancel) then begin lch := '{'; rch := '}'; end
- else begin lch := '['; rch := ']'; end;
if (mVAlign < 0) then ypos := 0
else if (mVAlign > 0) then ypos := mHeight-8
else ypos := (mHeight-8) div 2;
- drawText8(gx, gy+ypos, lch, mTextColor[cidx]);
- drawText8(gx+mWidth-8, gy+ypos, rch, mTextColor[cidx]);
+ fillRect(gx+1, gy, mWidth-2, mHeight, mBackColor[cidx]);
+ fillRect(gx, gy+1, 1, mHeight-2, mBackColor[cidx]);
+ fillRect(gx+mWidth-1, gy+1, 1, mHeight-2, mBackColor[cidx]);
if (Length(mText) > 0) then
begin
setScissor(8, 0, mWidth-16, mHeight);
drawText8(gx+xpos+8, gy+ypos, mText, mTextColor[cidx]);
+
+ if (mHotChar <> #0) and (mHotChar <> ' ') then
+ begin
+ drawText8(gx+xpos+8+mHotOfs, gy+ypos, mHotChar, mHotColor[cidx]);
+ end;
end;
end;
end;
+procedure TUIButton.keyEventPost (var ev: THKeyEvent);
+begin
+ if (not mEnabled) then exit;
+ if (mHotChar = #0) then exit;
+ if (ev.eaten) or (ev.cancelled) or (not ev.press) then exit;
+ if (not ev.isHot(mHotChar)) then exit;
+ if (not canFocus) then exit;
+ ev.eat();
+ focused := true;
+ doAction();
+end;
+
+
initialization
registerCtlClass(TUIHBox, 'hbox');
registerCtlClass(TUIVBox, 'vbox');
registerCtlClass(TUIHLine, 'hline');
registerCtlClass(TUIVLine, 'vline');
registerCtlClass(TUITextLabel, 'label');
+ registerCtlClass(TUIStaticText, 'static');
registerCtlClass(TUIButton, 'button');
end.
index 034321ae5f99f062fa36e10339351ab39dc961bf..de719d9d0a16267a2bf642cad70ac1f3eb9d45d9 100644 (file)
--- a/src/gx/gh_ui_common.pas
+++ b/src/gx/gh_ui_common.pas
end;
-
implementation
uses
diff --git a/src/gx/gh_ui_style.pas b/src/gx/gh_ui_style.pas
index 5c77405710ece9e1d8440589004b650eba08ecfe..97dcb79eabf279a79678211762adc01faa8525c4 100644 (file)
--- a/src/gx/gh_ui_style.pas
+++ b/src/gx/gh_ui_style.pas
* along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
{$INCLUDE ../../shared/a_modes.inc}
+{.$DEFINE UI_STYLE_DEBUG_SEARCH}
unit gh_ui_style;
interface
type
+ TStyleSection = class;
+
TStyleValue = packed record
public
- type TType = (Empty, Bool, Int, Color);
+ type TType = (Empty, Bool, Int, Color, Str);
public
- constructor Create (v: Boolean; okToInherit: Boolean=true);
- constructor Create (v: Integer; okToInherit: Boolean=true);
- constructor Create (ar, ag, ab: Integer; okToInherit: Boolean=true);
- constructor Create (ar, ag, ab, aa: Integer; okToInherit: Boolean=true);
- constructor Create (const v: TGxRGBA; okToInherit: Boolean=true);
+ constructor Create (v: Boolean);
+ constructor Create (v: Integer);
+ constructor Create (ar, ag, ab: Integer; aa: Integer=255);
+ constructor Create (const v: TGxRGBA);
+ constructor Create (const v: AnsiString);
function isEmpty (): Boolean; inline;
- function canInherit (): Boolean; inline;
function toString (): AnsiString;
function asRGBA: TGxRGBA; inline;
function asRGBADef (const def: TGxRGBA): TGxRGBA; inline;
- function asIntDef (const def: Integer): Integer; inline;
- function asBoolDef (const def: Boolean): Boolean; inline;
+ function asInt (const def: Integer=0): Integer; inline;
+ function asBool (const def: Boolean=false): Boolean; inline;
+ function asStr (const def: AnsiString=''): AnsiString; inline;
public
vtype: TType;
- allowInherit: Boolean;
case TType of
TType.Bool: (bval: Boolean);
TType.Int: (ival: Integer);
TType.Color: (r, g, b, a: Byte);
+ TType.Str: (sval: Pointer); // AnsiString
end;
- TStyleSection = class;
-
THashStrStyleVal = specialize THashBase<AnsiString, TStyleValue, THashKeyStrAnsiCI>;
THashStrSection = specialize THashBase<AnsiString, TStyleSection, THashKeyStrAnsiCI>;
TStyleSection = class
private
+ mParent: TStyleSection; // for inheritance
+ mInherits: AnsiString;
+ mHashName: AnsiString; // for this section
+ mCtlName: AnsiString; // for this section
mVals: THashStrStyleVal;
- mHashVals: THashStrSection; // "#..."
- mCtlVals: THashStrSection;
+ mHashes: THashStrSection;
+ mCtls: THashStrSection;
private
+ function getTopLevel (): TStyleSection; inline;
// "text-color#inactive@label"
function getValue (const path: AnsiString): TStyleValue;
- procedure setValue (const path: AnsiString; const val: TStyleValue);
public
constructor Create ();
destructor Destroy (); override;
+ function get (name, hash, ctl: AnsiString): TStyleValue;
+
public
- property value[const path: AnsiString]: TStyleValue read getValue write setValue; default;
+ property value[const path: AnsiString]: TStyleValue read getValue; default;
+ property topLevel: TStyleSection read getTopLevel;
end;
TUIStyle = class
mMain: TStyleSection;
private
+ procedure createMain ();
+
procedure parse (par: TTextParser);
function getValue (const path: AnsiString): TStyleValue; inline;
- procedure setValue (const path: AnsiString; const val: TStyleValue); inline;
public
constructor Create (const aid: AnsiString);
constructor CreateFromFile (const fname: AnsiString);
destructor Destroy (); override;
+ function get (name, hash, ctl: AnsiString): TStyleValue;
+
public
property id: AnsiString read mId;
- property value[const path: AnsiString]: TStyleValue read getValue write setValue; default;
+ property value[const path: AnsiString]: TStyleValue read getValue; default;
end;
// ////////////////////////////////////////////////////////////////////////// //
+const
+ defaultStyleStr =
+ 'default {'#10+
+ ' back-color: #008;'#10+
+ ' #active: { text-color: #fff; frame-color: #fff; frame-text-color: #fff; frame-icon-color: #0f0; }'#10+
+ ' #inactive: { text-color: #aaa; frame-color: #aaa; frame-text-color: #aaa; frame-icon-color: #0a0; }'#10+
+ ' #disabled: { text-color: #666; frame-color: #888; frame-text-color: #888; frame-icon-color: #080; }'#10+
+ ' @simple_text: { text-color: #ff0; #inactive(#active); }'#10+
+ ' @cb_listbox: { current-item-back-color: #080; text-color: #ff0; #inactive(#active) { current-item-back-color: #000; } }'#10+
+ ' @window: { #inactive(#active): { darken: 128; } }'#10+
+ ' @button: { back-color: #999; text-color: #000; hot-color: #600; #active: { back-color: #fff; hot-color: #c00; } #disabled: { back-color: #444; text-color: #333; hot-color: #333; } }'#10+
+ ' @label: { #active: {back-color: #440;} #inactive(#active); }'#10+
+ ' @static: { text-color: #ff0; #inactive(#active); }'#10+
+ ' @box: { #inactive(#active); }'#10+
+ '}'#10+
+ '';
var
styles: array of TUIStyle = nil;
function createDefaultStyle (): TUIStyle;
+var
+ st: TStream;
begin
- result := TUIStyle.Create('default');
-
- result['back-color'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 128));
- result['text-color'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
- result['frame-color'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
- result['frame-text-color'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
- result['frame-icon-color'] := TStyleValue.Create(TGxRGBA.Create(0, 255, 0));
-
- // disabled is always inactive too
-
- // main colors
- result['back-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 127));
- result['text-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
- result['frame-text-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
- result['frame-icon-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(0, 127, 0));
- result['darken#disabled'] := TStyleValue.Create(128, false); // darken inactive windows, no-inherit
- result['darken#inactive'] := TStyleValue.Create(128, false); // darken inactive windows, no-inherit
-
- // label
- result['text-color@label'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
- result['text-color#disabled@label'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
-
- // box
- result['frame-color@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 0));
- result['frame-text-color@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 0));
- result['frame-icon-color@box'] := TStyleValue.Create(TGxRGBA.Create(0, 255, 0));
-
- result['frame-color#inactive@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
- result['frame-text-color#inactive@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
- result['frame-icon-color#inactive@box'] := TStyleValue.Create(TGxRGBA.Create(0, 255, 0));
-
- result['frame-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
- result['frame-text-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
- result['frame-icon-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
-
- // button
- result['back-color@button'] := TStyleValue.Create(TGxRGBA.Create(0, 96, 255));
- result['text-color@button'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
-
- result['back-color#inactive@button'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 127));
- result['text-color#inactive@button'] := TStyleValue.Create(TGxRGBA.Create(196, 196, 196));
-
- result['back-color#disabled@button'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 127));
- result['text-color#disabled@button'] := TStyleValue.Create(TGxRGBA.Create(96, 96, 96));
+ result := nil;
+ st := TStringStream.Create(defaultStyleStr);
+ st.position := 0;
+ try
+ result := TUIStyle.Create(st);
+ finally
+ FreeAndNil(st);
+ end;
end;
f: Integer;
begin
if (st = nil) then raise Exception.Create('cannot load UI styles from nil stream');
- par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]);
+ par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId, par.TOption.HtmlColors]);
styles := nil;
try
while (not par.isEOF) do
// ////////////////////////////////////////////////////////////////////////// //
-constructor TStyleValue.Create (v: Boolean; okToInherit: Boolean=true); begin vtype := TType.Bool; allowInherit := okToInherit; bval := v; end;
-constructor TStyleValue.Create (v: Integer; okToInherit: Boolean=true); begin vtype := TType.Int; allowInherit := okToInherit; ival := v; end;
-
-constructor TStyleValue.Create (ar, ag, ab: Integer; okToInherit: Boolean=true);
-begin
- vtype := TType.Color;
- allowInherit := okToInherit;
- r := nmax(0, nmin(ar, 255));
- g := nmax(0, nmin(ag, 255));
- b := nmax(0, nmin(ab, 255));
- a := 255;
+procedure freeValueCB (var v: TStyleValue); begin
+ if (v.vtype = v.TType.Str) then
+ begin
+ AnsiString(v.sval) := '';
+ end;
+ v.vtype := v.TType.Empty;
end;
-constructor TStyleValue.Create (ar, ag, ab, aa: Integer; okToInherit: Boolean=true);
+constructor TStyleValue.Create (v: Boolean); begin vtype := TType.Bool; bval := v; end;
+constructor TStyleValue.Create (v: Integer); begin vtype := TType.Int; ival := v; end;
+constructor TStyleValue.Create (const v: AnsiString); begin vtype := TType.Str; sval := Pointer(v); end;
+
+constructor TStyleValue.Create (ar, ag, ab: Integer; aa: Integer=255);
begin
vtype := TType.Color;
- allowInherit := okToInherit;
r := nmax(0, nmin(ar, 255));
g := nmax(0, nmin(ag, 255));
b := nmax(0, nmin(ab, 255));
a := nmax(0, nmin(aa, 255));
end;
-constructor TStyleValue.Create (const v: TGxRGBA; okToInherit: Boolean=true);
+constructor TStyleValue.Create (const v: TGxRGBA);
begin
vtype := TType.Color;
- allowInherit := okToInherit;
r := v.r;
g := v.g;
b := v.b;
end;
function TStyleValue.isEmpty (): Boolean; inline; begin result := (vtype = TType.Empty); end;
-function TStyleValue.canInherit (): Boolean; inline; begin result := allowInherit; end;
function TStyleValue.asRGBA: TGxRGBA; inline; begin if (vtype = TType.Color) then result := TGxRGBA.Create(r, g, b, a) else result := TGxRGBA.Create(0, 0, 0, 0); end;
function TStyleValue.asRGBADef (const def: TGxRGBA): TGxRGBA; inline; begin if (vtype = TType.Color) then result := TGxRGBA.Create(r, g, b, a) else result := def; end;
-function TStyleValue.asIntDef (const def: Integer): Integer; inline; begin if (vtype = TType.Int) then result := ival else if (vtype = TType.Bool) then begin if (bval) then result := 1 else result := 0; end else result := def; end;
-function TStyleValue.asBoolDef (const def: Boolean): Boolean; inline; begin if (vtype = TType.Bool) then result := bval else if (vtype = TType.Int) then result := (ival <> 0) else result := def; end;
-
+function TStyleValue.asInt (const def: Integer=0): Integer; inline; begin if (vtype = TType.Int) then result := ival else if (vtype = TType.Bool) then begin if (bval) then result := 1 else result := 0; end else result := def; end;
+function TStyleValue.asBool (const def: Boolean=false): Boolean; inline; begin if (vtype = TType.Bool) then result := bval else if (vtype = TType.Int) then result := (ival <> 0) else result := def; end;
+function TStyleValue.asStr (const def: AnsiString=''): AnsiString; inline; begin if (vtype = TType.Str) then result := AnsiString(sval) else result := def; end;
function TStyleValue.toString (): AnsiString;
begin
if (hashPos > 0) then
begin
// has ctl and hash
- if (atPos < hashPos) then exit; // alas
- if (hashPos > 1) then name := Copy(path, 1, hashPos-1);
- Inc(hashPos); // skip hash
- if (hashPos < atPos) then hash := Copy(path, hashPos, atPos-hashPos);
+ if (atPos < hashPos) then
+ begin
+ // @ctl#hash
+ if (atPos > 1) then name := Copy(path, 1, atPos-1);
+ Inc(atPos); // skip "at"
+ if (atPos < hashPos) then ctl := Copy(path, atPos, hashPos-atPos);
+ Inc(hashPos); // skip hash
+ if (hashPos <= Length(path)) then hash := Copy(path, hashPos, Length(path)-hashPos+1);
+ end
+ else
+ begin
+ // #hash@ctl
+ if (hashPos > 1) then name := Copy(path, 1, hashPos-1);
+ Inc(hashPos); // skip hash
+ if (hashPos < atPos) then hash := Copy(path, hashPos, atPos-hashPos);
+ Inc(atPos); // skip "at"
+ if (atPos <= Length(path)) then ctl := Copy(path, atPos, Length(path)-atPos+1);
+ end;
end
else
begin
// has only ctl
if (atPos > 1) then name := Copy(path, 1, atPos-1);
+ Inc(atPos); // skip "at"
+ if (atPos <= Length(path)) then ctl := Copy(path, atPos, Length(path)-atPos+1);
end;
- Inc(atPos); // skip "at"
- if (atPos <= Length(path)) then ctl := Copy(path, atPos, Length(path)-atPos+1);
end
else if (hashPos > 0) then
begin
// ////////////////////////////////////////////////////////////////////////// //
constructor TStyleSection.Create ();
begin
- mVals := THashStrStyleVal.Create();
- mHashVals := THashStrSection.Create();
- mCtlVals := THashStrSection.Create(freeSectionCB);
+ mParent := nil;
+ mInherits := '';
+ mHashName := '';
+ mCtlName := '';
+ mVals := THashStrStyleVal.Create(freeValueCB);
+ mHashes := THashStrSection.Create(freeSectionCB);
+ mCtls := THashStrSection.Create(freeSectionCB);
end;
destructor TStyleSection.Destroy ();
begin
FreeAndNil(mVals);
- FreeAndNil(mHashVals);
- FreeAndNil(mCtlVals);
+ FreeAndNil(mHashes);
+ FreeAndNil(mCtls);
+ mParent := nil;
+ mInherits := '';
+ mHashName := '';
+ mCtlName := '';
inherited;
end;
-// "text-color#inactive@label"
-function TStyleSection.getValue (const path: AnsiString): TStyleValue;
+function TStyleSection.getTopLevel (): TStyleSection; inline;
+begin
+ result := self;
+ while (result.mParent <> nil) do result := result.mParent;
+end;
+
+
+function TStyleSection.get (name, hash, ctl: AnsiString): TStyleValue;
var
- name, hash, ctl: AnsiString;
- sect: TStyleSection = nil;
- s1: TStyleSection = nil;
- checkInheritance: Boolean = false;
+ tmp: AnsiString;
+ sect, s1, so: TStyleSection;
+ jumpsLeft: Integer = 32; // max inheritance level
+ skipInherits: Boolean = false;
begin
result.vtype := result.TType.Empty;
- if (not splitPath(path, name, hash, ctl)) then exit; // alas
- //writeln('name:<', name, '>; hash:<', hash, '>; ctl:<', ctl, '>');
if (Length(name) = 0) then exit; // alas
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('***GET: <', name, '#', hash, '@', ctl, '>');{$ENDIF}
// try control
+ sect := self;
if (Length(ctl) > 0) then
begin
- // has ctl section?
- if not mCtlVals.get(ctl, sect) then
+ if (not strEquCI1251(ctl, mCtlName)) then
begin
- sect := self;
- checkInheritance := true;
+ // has ctl section?
+ if (not topLevel.mCtls.get(ctl, sect)) then sect := topLevel;
end;
- end
- else
- begin
- sect := self;
end;
// has hash?
if (Length(hash) > 0) then
begin
- if sect.mHashVals.get(hash, s1) then
+ if (not strEquCI1251(hash, sect.mHashName)) then
begin
- if s1.mVals.get(name, result) then
- begin
- //writeln('hash: <', hash, '>: val=', result.toString);
- if (not result.isEmpty) and ((not checkInheritance) or (result.canInherit)) then exit;
- end;
+ if (sect.mHashes.get(hash, s1)) then sect := s1;
end;
- //writeln('NO hash: <', hash, '>: val=', result.toString);
- checkInheritance := true;
end;
- // try just a name
- if sect.mVals.get(name, result) then
+ // try name, go up with inheritance
+ while (jumpsLeft > 0) do
begin
- if (not result.isEmpty) and ((not checkInheritance) or (result.canInherit)) then exit;
+ if (sect.mVals.get(name, result)) then
+ begin
+ if (not result.isEmpty) then exit; // i found her!
+ end;
+ // go up
+ if (skipInherits) or (Length(sect.mInherits) = 0) then
+ begin
+ skipInherits := false;
+ // for hash section: try parent section first
+ if (Length(sect.mHashName) > 0) then
+ begin
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('search for <#', hash, '@', ctl, '> at <#', sect.mHashName, '@', sect.mCtlName, '>: hash up');{$ENDIF}
+ sect := sect.mParent;
+ if (sect = nil) then break; // alas
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' hash up: trying <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
+ if (sect.mVals.get(name, result)) then
+ begin
+ if (not result.isEmpty) then exit; // i found her!
+ end;
+ // move another parent up
+ sect := sect.mParent;
+ if (sect = nil) then break; // alas
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' hash up: jumped up twice to <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
+ end
+ else
+ begin
+ // one parent up
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('search for <#', hash, '@', ctl, '> at <#', sect.mHashName, '@', sect.mCtlName, '>: jump up');{$ENDIF}
+ sect := sect.mParent;
+ if (sect = nil) then break; // alas
+ end;
+ // here, we should have non-hash section
+ assert(Length(sect.mHashName) = 0);
+ // if we want hash, try to find it, otherwise do nothing
+ if (Length(hash) > 0) then
+ begin
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' search for <#', hash, '@', ctl, '> at <#', sect.mHashName, '@', sect.mCtlName, '>: hash down');{$ENDIF}
+ if (sect.mHashes.get(hash, s1)) then
+ begin
+ sect := s1;
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' found <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
+ end;
+ end;
+ end
+ else
+ begin
+ // inheritance
+ Dec(jumpsLeft);
+ if (jumpsLeft < 1) then break; // alas
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('inherits: <', sect.mInherits, '>');{$ENDIF}
+ // parse inherit string
+ if (not splitPath(sect.mInherits, tmp, hash, ctl)) then exit; // alas
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('inherits: <', hash, '>:<', ctl, '>');{$ENDIF}
+ // find section
+ if (Length(ctl) > 0) then
+ begin
+ // ctl
+ if (strEquCI1251(ctl, '$main$')) then sect := topLevel
+ else if (strEquCI1251(ctl, '$up$')) then begin if (Length(sect.mHashName) <> 0) then sect := sect.mParent.mParent else sect := sect.mParent; end
+ else if (not topLevel.mCtls.get(ctl, sect)) then sect := topLevel;
+ if (sect = nil) then break; // alas
+ if (Length(hash) > 0) then
+ begin
+ if (sect.mHashes.get(hash, s1)) then sect := s1;
+ end;
+ end
+ else
+ begin
+ // hash
+ assert(Length(hash) > 0);
+ // dummy loop, so i can use `break`
+ repeat
+ // get out of hash section
+ if (Length(sect.mHashName) > 0) then
+ begin
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('hash-jump-up: <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
+ sect := sect.mParent;
+ if (sect = nil) then break; // alas
+ // check for hash section in parent; use parent if there is no such hash section
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' checking parent: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
+ so := sect;
+ if (sect.mHashes.get(hash, s1)) then
+ begin
+ if (s1 <> sect) and (s1 <> so) then
+ begin
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' found in parent: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
+ sect := s1;
+ end;
+ end;
+ end
+ else
+ begin
+ // we're in parent, try to find hash section
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' checking: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
+ if (sect.mHashes.get(hash, s1)) then
+ begin
+ {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' found: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
+ sect := s1;
+ end
+ else
+ begin
+ // reuse current parent, but don't follow inheritance for it
+ skipInherits := true;
+ end;
+ end;
+ until true;
+ if (sect = nil) then break;
+ end;
+ end;
end;
// alas
result.vtype := result.TType.Empty;
end;
-procedure TStyleSection.setValue (const path: AnsiString; const val: TStyleValue);
+// "text-color#inactive@label"
+function TStyleSection.getValue (const path: AnsiString): TStyleValue;
var
name, hash, ctl: AnsiString;
- sect: TStyleSection = nil;
- s1: TStyleSection = nil;
begin
+ result.vtype := result.TType.Empty;
if (not splitPath(path, name, hash, ctl)) then exit; // alas
- // has name?
- if (Length(name) = 0) then exit; // no name -> nothing to do
- // has ctl?
- if (Length(ctl) > 0) then
- begin
- if not mCtlVals.get(ctl, sect) then
- begin
- // create new section
- sect := TStyleSection.Create();
- mCtlVals.put(ctl, sect);
- end;
- end
- else
- begin
- // no ctl, use default section
- sect := self;
- end;
- // has hash?
- if (Length(hash) > 0) then
- begin
- if not sect.mHashVals.get(hash, s1) then
- begin
- // create new section
- s1 := TStyleSection.Create();
- sect.mHashVals.put(hash, s1);
- end;
- end
- else
- begin
- // no hash, use default section
- s1 := sect;
- end;
- s1.mVals.put(name, val);
+ //writeln('name:<', name, '>; hash:<', hash, '>; ctl:<', ctl, '>');
+ result := get(name, hash, ctl);
end;
constructor TUIStyle.Create (const aid: AnsiString);
begin
mId := aid;
- mMain := TStyleSection.Create();
+ createMain();
end;
par: TTextParser;
begin
mId := '';
- mMain := TStyleSection.Create();
+ createMain();
if (st = nil) then exit;
- par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]);
+ par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId, par.TOption.HtmlColors]);
try
parse(par);
finally
constructor TUIStyle.CreateFromFile (const fname: AnsiString);
var
- par: TTextParser;
st: TStream;
begin
- mId := '';
- mMain := TStyleSection.Create();
st := openDiskFileRO(fname);
try
- par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]);
- try
- parse(par);
- finally
- par.Free();
- end;
+ Create(st);
finally
st.Free();
end;
end;
+procedure TUIStyle.createMain ();
+begin
+ mMain := TStyleSection.Create();
+ mMain.mCtlName := '$main$';
+end;
+
+
function TUIStyle.getValue (const path: AnsiString): TStyleValue; inline;
begin
result := mMain[path];
end;
-procedure TUIStyle.setValue (const path: AnsiString; const val: TStyleValue); inline;
+function TUIStyle.get (name, hash, ctl: AnsiString): TStyleValue;
begin
- mMain.setValue(path, val);
+ result := mMain.get(name, hash, ctl);
end;
procedure parseSection (sect: TStyleSection; ctlAllowed: Boolean; hashAllowed: Boolean);
var
- s: AnsiString;
+ s, inh: AnsiString;
sc: TStyleSection = nil;
v: TStyleValue;
+
+ procedure parseInherit ();
+ begin
+ inh := '';
+ if (par.eatDelim('(')) then
+ begin
+ if (par.eatDelim(')')) then par.error('empty inheritance is not allowed');
+ if (par.eatDelim('#')) then
+ begin
+ inh := '#';
+ inh += par.expectId();
+ end;
+ if (par.eatDelim('@')) then
+ begin
+ inh += '#';
+ inh += par.expectId();
+ end;
+ par.expectDelim(')');
+ end;
+ end;
+
+ function nib2c (n: Integer): Byte; inline;
+ begin
+ if (n < 0) then result := 0
+ else if (n > 15) then result := 255
+ else result := Byte(255*n div 15);
+ end;
+
begin
+ s := '';
+ inh := '';
par.expectDelim('{');
while (not par.isDelim('}')) do
begin
while (par.eatDelim(';')) do begin end;
- // hash
- if hashAllowed and (par.eatDelim('#')) then
+ // ctl
+ if ctlAllowed and (par.eatDelim('@')) then
begin
- s := par.expectIdOrStr();
- //writeln('hash: <', s, '>');
+ s := par.expectId();
+ parseInherit();
par.eatDelim(':'); // optional
- if not sect.mHashVals.get(s, sc) then
+ if (not sect.mCtls.get(s, sc)) then
begin
// create new section
sc := TStyleSection.Create();
- sect.mHashVals.put(s, sc);
+ sc.mParent := sect;
+ sc.mInherits := inh;
+ sc.mHashName := '';
+ sc.mCtlName := s;
+ sect.mCtls.put(s, sc);
+ end
+ else
+ begin
+ assert(sc.mParent = sect);
+ assert(sc.mHashName = '');
+ assert(sc.mCtlName = s);
+ if (Length(sc.mInherits) <> 0) and (Length(inh) <> 0) then par.error('double inheritance');
+ sc.mInherits := inh;
end;
- parseSection(sc, false, false);
+ if (not par.eatDelim(';')) then parseSection(sc, false, true);
continue;
end;
- // ctl
- if ctlAllowed and (par.eatDelim('@')) then
+ // hash
+ if hashAllowed and (par.eatDelim('#')) then
begin
- s := par.expectIdOrStr();
- //writeln('ctl: <', s, '>');
+ s := par.expectId();
+ parseInherit();
par.eatDelim(':'); // optional
- if not sect.mCtlVals.get(s, sc) then
+ if (not sect.mHashes.get(s, sc)) then
begin
// create new section
sc := TStyleSection.Create();
- sect.mCtlVals.put(s, sc);
+ sc.mParent := sect;
+ sc.mInherits := inh;
+ sc.mHashName := s;
+ sc.mCtlName := '';
+ sect.mHashes.put(s, sc);
+ end
+ else
+ begin
+ assert(sc.mParent = sect);
+ assert(sc.mHashName = s);
+ assert(sc.mCtlName = '');
+ if (Length(sc.mInherits) <> 0) and (Length(inh) <> 0) then par.error('double inheritance');
+ sc.mInherits := inh;
end;
- parseSection(sc, false, true);
+ if (not par.eatDelim(';')) then parseSection(sc, false, false);
continue;
end;
// name
- s := par.expectIdOrStr();
- //writeln('name: <', s, '>');
- v.allowInherit := true;
+ s := par.expectId();
par.expectDelim(':');
if (par.eatId('rgb')) or (par.eatId('rgba')) then
begin
end;
par.expectDelim(')');
end
+ else if (par.isId) and (par.tokStr[1] = '#') then
+ begin
+ // html color
+ assert((Length(par.tokStr) = 4) or (Length(par.tokStr) = 7));
+ //writeln('<', par.tokStr, '>; {', par.curChar, '}');
+ v.vtype := v.TType.Color;
+ if (Length(par.tokStr) = 4) then
+ begin
+ // #rgb
+ v.r := nib2c(digitInBase(par.tokStr[2], 16));
+ v.g := nib2c(digitInBase(par.tokStr[3], 16));
+ v.b := nib2c(digitInBase(par.tokStr[4], 16));
+ end
+ else
+ begin
+ // #rrggbb
+ v.r := Byte(digitInBase(par.tokStr[2], 16)*16+digitInBase(par.tokStr[3], 16));
+ v.g := Byte(digitInBase(par.tokStr[4], 16)*16+digitInBase(par.tokStr[5], 16));
+ v.b := Byte(digitInBase(par.tokStr[6], 16)*16+digitInBase(par.tokStr[7], 16));
+ end;
+ v.a := 255;
+ //writeln(' r=', v.r, '; g=', v.g, '; b=', v.b);
+ par.skipToken();
+ end
else if (par.eatId('true')) or (par.eatId('tan')) then
begin
v.vtype := v.TType.Bool;
v.vtype := v.TType.Bool;
v.bval := false;
end
+ else if (par.isStr) then
+ begin
+ // string value
+ v := TStyleValue.Create(par.tokStr);
+ par.skipToken();
+ end
+ else if (par.eatId('inherit')) then
+ begin
+ v.vtype := v.TType.Empty;
+ end
else
begin
// should be int
v.vtype := v.TType.Int;
v.ival := par.expectInt();
end;
- // '!' flags
- while (par.eatDelim('!')) do
- begin
- if (par.eatId('no-inherit')) then v.allowInherit := false
- else par.error('unknown flag');
- end;
par.expectDelim(';');
sect.mVals.put(s, v);
end;
end;
if (Length(mId) = 0) then mId := 'default';
par.skipToken();
- parseSection(mMain, true, true);
+ if (not par.eatDelim(';')) then parseSection(mMain, true, true);
end;
diff --git a/src/gx/glgfx.pas b/src/gx/glgfx.pas
index d39d2f087bfd1863693c7685aca40a64a243c09f..2aaec4431e3a83b669ddcfdeedf043715d0359e9 100644 (file)
--- a/src/gx/glgfx.pas
+++ b/src/gx/glgfx.pas
procedure eat (); inline;
procedure cancel (); inline;
+ function isHot (ch: AnsiChar): Boolean;
+
public
property eaten: Boolean read mEaten;
property cancelled: Boolean read mCancelled;
// setup 2D OpenGL mode; will be called automatically in `glInit()`
procedure oglSetup2D (winWidth, winHeight: Integer; upsideDown: Boolean=false);
+// the following calls MUST be paired AT ALL COSTS!
+procedure gxBeginUIDraw (scale: Single=1.0);
+procedure gxEndUIDraw ();
+
+
type
TScissorSave = record
public
@@ -271,6 +278,69 @@ function THKeyEvent.release (): Boolean; inline; begin result := (kind = TKind.R
procedure THKeyEvent.eat (); inline; begin mEaten := true; end;
procedure THKeyEvent.cancel (); inline; begin mCancelled := true; end;
+function THKeyEvent.isHot (ch: AnsiChar): Boolean;
+begin
+ case scan of
+ SDL_SCANCODE_A: result := (ch = 'A') or (ch = 'a') or (ch = 'Ô') or (ch = 'ô');
+ SDL_SCANCODE_B: result := (ch = 'B') or (ch = 'b') or (ch = 'È') or (ch = 'è');
+ SDL_SCANCODE_C: result := (ch = 'C') or (ch = 'c') or (ch = 'Ñ') or (ch = 'ñ');
+ SDL_SCANCODE_D: result := (ch = 'D') or (ch = 'd') or (ch = 'Â') or (ch = 'â');
+ SDL_SCANCODE_E: result := (ch = 'E') or (ch = 'e') or (ch = 'Ó') or (ch = 'ó');
+ SDL_SCANCODE_F: result := (ch = 'F') or (ch = 'f') or (ch = 'À') or (ch = 'à');
+ SDL_SCANCODE_G: result := (ch = 'G') or (ch = 'g') or (ch = 'Ï') or (ch = 'ï');
+ SDL_SCANCODE_H: result := (ch = 'H') or (ch = 'h') or (ch = 'Ð') or (ch = 'ð');
+ SDL_SCANCODE_I: result := (ch = 'I') or (ch = 'i') or (ch = 'Ø') or (ch = 'ø');
+ SDL_SCANCODE_J: result := (ch = 'J') or (ch = 'j') or (ch = 'Î') or (ch = 'î');
+ SDL_SCANCODE_K: result := (ch = 'K') or (ch = 'k') or (ch = 'Ë') or (ch = 'ë');
+ SDL_SCANCODE_L: result := (ch = 'L') or (ch = 'l') or (ch = 'Ä') or (ch = 'ä');
+ SDL_SCANCODE_M: result := (ch = 'M') or (ch = 'm') or (ch = 'Ü') or (ch = 'ü');
+ SDL_SCANCODE_N: result := (ch = 'N') or (ch = 'n') or (ch = 'Ò') or (ch = 'ò');
+ SDL_SCANCODE_O: result := (ch = 'O') or (ch = 'o') or (ch = 'Ù') or (ch = 'ù');
+ SDL_SCANCODE_P: result := (ch = 'P') or (ch = 'p') or (ch = 'Ç') or (ch = 'ç');
+ SDL_SCANCODE_Q: result := (ch = 'Q') or (ch = 'q') or (ch = 'É') or (ch = 'é');
+ SDL_SCANCODE_R: result := (ch = 'R') or (ch = 'r') or (ch = 'Ê') or (ch = 'ê');
+ SDL_SCANCODE_S: result := (ch = 'S') or (ch = 's') or (ch = 'Û') or (ch = 'û');
+ SDL_SCANCODE_T: result := (ch = 'T') or (ch = 't') or (ch = 'Å') or (ch = 'å');
+ SDL_SCANCODE_U: result := (ch = 'U') or (ch = 'u') or (ch = 'Ã') or (ch = 'ã');
+ SDL_SCANCODE_V: result := (ch = 'V') or (ch = 'v') or (ch = 'Ì') or (ch = 'ì');
+ SDL_SCANCODE_W: result := (ch = 'W') or (ch = 'w') or (ch = 'Ö') or (ch = 'ö');
+ SDL_SCANCODE_X: result := (ch = 'X') or (ch = 'x') or (ch = '×') or (ch = '÷');
+ SDL_SCANCODE_Y: result := (ch = 'Y') or (ch = 'y') or (ch = 'Í') or (ch = 'í');
+ SDL_SCANCODE_Z: result := (ch = 'Z') or (ch = 'z') or (ch = 'ß') or (ch = 'ÿ');
+
+ SDL_SCANCODE_1: result := (ch = '1') or (ch = '!');
+ SDL_SCANCODE_2: result := (ch = '2') or (ch = '@');
+ SDL_SCANCODE_3: result := (ch = '3') or (ch = '#');
+ SDL_SCANCODE_4: result := (ch = '4') or (ch = '$');
+ SDL_SCANCODE_5: result := (ch = '5') or (ch = '%');
+ SDL_SCANCODE_6: result := (ch = '6') or (ch = '^');
+ SDL_SCANCODE_7: result := (ch = '7') or (ch = '&');
+ SDL_SCANCODE_8: result := (ch = '8') or (ch = '*');
+ SDL_SCANCODE_9: result := (ch = '9') or (ch = '(');
+ SDL_SCANCODE_0: result := (ch = '0') or (ch = ')');
+
+ SDL_SCANCODE_RETURN: result := (ch = #13) or (ch = #10);
+ SDL_SCANCODE_ESCAPE: result := (ch = #27);
+ SDL_SCANCODE_BACKSPACE: result := (ch = #8);
+ SDL_SCANCODE_TAB: result := (ch = #9);
+ SDL_SCANCODE_SPACE: result := (ch = ' ');
+
+ SDL_SCANCODE_MINUS: result := (ch = '-');
+ SDL_SCANCODE_EQUALS: result := (ch = '=');
+ SDL_SCANCODE_LEFTBRACKET: result := (ch = '[') or (ch = '{');
+ SDL_SCANCODE_RIGHTBRACKET: result := (ch = ']') or (ch = '}');
+ SDL_SCANCODE_BACKSLASH, SDL_SCANCODE_NONUSHASH: result := (ch = '\') or (ch = '|');
+ SDL_SCANCODE_SEMICOLON: result := (ch = ';') or (ch = ':');
+ SDL_SCANCODE_APOSTROPHE: result := (ch = '''') or (ch = '"');
+ SDL_SCANCODE_GRAVE: result := (ch = '`') or (ch = '~');
+ SDL_SCANCODE_COMMA: result := (ch = ',') or (ch = '<');
+ SDL_SCANCODE_PERIOD: result := (ch = '.') or (ch = '>');
+ SDL_SCANCODE_SLASH: result := (ch = '/') or (ch = '?');
+
+ else result := false;
+ end;
+end;
+
// ////////////////////////////////////////////////////////////////////////// //
constructor TGxRGBA.Create (ar, ag, ab: Integer; aa: Integer=255);
end;
+procedure gxBeginUIDraw (scale: Single=1.0);
+begin
+ glMatrixMode(GL_MODELVIEW);
+ glPushMatrix();
+ glLoadIdentity();
+ glScalef(scale, scale, 1);
+end;
+
+procedure gxEndUIDraw ();
+begin
+ glMatrixMode(GL_MODELVIEW);
+ glPopMatrix();
+end;
+
+
// ////////////////////////////////////////////////////////////////////////// //
// cursor (hi, Death Track!)
const curTexWidth = 32;
diff --git a/src/shared/xparser.pas b/src/shared/xparser.pas
index 5332f0afe7c4af022019799a6d2eb4ce796f40c0..de2dfb38a379ac52872a91caaffd71ac61a11db2 100644 (file)
--- a/src/shared/xparser.pas
+++ b/src/shared/xparser.pas
DollarIsId, // allow dollar in identifiers; otherwise dollar will be TTDelim
DotIsId, // allow dot in identifiers; otherwise dot will be TTDelim
DashIsId, // '-' can be part of identifier (but identifier cannot start with '-')
+ HtmlColors, // #rgb or #rrggbb colors
PascalComments // allow `{}` pascal comments
);
TOptions = set of TOption;
private
type
TAnsiCharSet = set of AnsiChar;
+ const
+ CharBufSize = 8;
private
mLine, mCol: Integer;
- mCurChar, mNextChar: AnsiChar;
+ // chars for 'unget'
+ mCharBuf: packed array [0..CharBufSize-1] of AnsiChar;
+ mCharBufUsed: Integer;
+ mCharBufPos: Integer;
+ mEofHit: Boolean; // no more chars to load into mCharBuf
mOptions: TOptions;
mTokChar: AnsiChar; // for delimiters
mTokInt: Integer;
+ private
+ procedure fillCharBuf ();
+ function popFrontChar (): AnsiChar; inline; // never drains char buffer (except on "total EOF")
+ function peekCurChar (): AnsiChar; inline;
+ function peekNextChar (): AnsiChar; inline;
+ function peekChar (dest: Integer): AnsiChar; inline;
+
protected
- procedure warmup (); // called in constructor to warm up the system
- procedure loadNextChar (); virtual; abstract; // loads next char into mNextChar; #0 means 'eof'
+ function loadChar (): AnsiChar; virtual; abstract; // loads next char; #0 means 'eof'
+
+ public
+ function isIdStartChar (ch: AnsiChar): Boolean; inline;
+ function isIdMidChar (ch: AnsiChar): Boolean; inline;
public
constructor Create (aopts: TOptions=[TOption.SignedNumbers]);
procedure error (const amsg: AnsiString); noreturn;
procedure errorfmt (const afmt: AnsiString; const args: array of const); noreturn;
- function isEOF (): Boolean; inline;
-
function skipChar (): Boolean; // returns `false` on eof
function skipBlanks (): Boolean; // ...and comments; returns `false` on eof
function skipToken1 (): Boolean;
{$ENDIF}
+ function isEOF (): Boolean; inline;
+ function isId (): Boolean; inline;
+ function isInt (): Boolean; inline;
+ function isStr (): Boolean; inline;
+ function isDelim (): Boolean; inline;
function isIdOrStr (): Boolean; inline;
function expectId (): AnsiString;
property col: Integer read mCol;
property line: Integer read mLine;
- property curChar: AnsiChar read mCurChar;
- property nextChar: AnsiChar read mNextChar;
+ property curChar: AnsiChar read peekCurChar;
+ property nextChar: AnsiChar read peekNextChar;
// token start
property tokCol: Integer read mTokCol;
mBufPos: Integer;
protected
- procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
+ function loadChar (): AnsiChar; override; // loads next char; #0 means 'eof'
public
constructor Create (const fname: AnsiString; aopts: TOptions=[TOption.SignedNumbers]);
mPos: Integer;
protected
- procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
+ function loadChar (): AnsiChar; override; // loads next char; #0 means 'eof'
public
constructor Create (const astr: AnsiString; aopts: TOptions=[TOption.SignedNumbers]);
begin
mLine := 1;
mCol := 1;
- mCurChar := #0;
- mNextChar := #0;
+ mCharBufUsed := 0;
+ mCharBufPos := 0;
+ mEofHit := false;
mTokType := TTNone;
mTokStr := '';
mTokChar := #0;
mTokInt := 0;
mOptions := aopts;
- warmup();
skipToken();
end;
end;
-function TTextParser.isEOF (): Boolean; inline; begin {result := (mCurChar = #0);} result := (mTokType = TTEOF); end;
-
+function TTextParser.isIdStartChar (ch: AnsiChar): Boolean; inline;
+begin
+ result :=
+ (ch = '_') or
+ ((ch >= 'A') and (ch <= 'Z')) or
+ ((ch >= 'a') and (ch <= 'z')) or
+ (ch >= #128) or
+ ((ch = '$') and (TOption.DollarIsId in mOptions)) or
+ ((ch = '.') and (TOption.DotIsId in mOptions));
+end;
-procedure TTextParser.warmup ();
+function TTextParser.isIdMidChar (ch: AnsiChar): Boolean; inline;
begin
- mNextChar := ' ';
- loadNextChar();
- mCurChar := mNextChar;
- if (mNextChar <> #0) then loadNextChar();
+ result :=
+ ((ch >= '0') and (ch <= '9')) or
+ ((ch = '-') and (TOption.DashIsId in mOptions)) or
+ isIdStartChar(ch);
end;
-function TTextParser.skipChar (): Boolean;
+procedure TTextParser.fillCharBuf ();
+var
+ ch: AnsiChar;
begin
- if (mCurChar = #0) then begin result := false; exit; end;
- if (mCurChar = #10) then begin mCol := 1; Inc(mLine); end else Inc(mCol);
- mCurChar := mNextChar;
- if (mCurChar = #0) then begin result := false; exit; end;
- loadNextChar();
- // skip CR in CR/LF
- if (mCurChar = #13) then
+ if (mEofHit) then begin mCharBuf[mCharBufPos] := #0; exit; end;
+ while (not mEofHit) and (mCharBufUsed < CharBufSize) do
begin
- if (mNextChar = #10) then loadNextChar();
- mCurChar := #10;
+ ch := loadChar();
+ mCharBuf[(mCharBufPos+mCharBufUsed) mod CharBufSize] := ch;
+ if (ch = #0) then begin mEofHit := true; break; end;
+ Inc(mCharBufUsed);
end;
+end;
+
+
+// never drains char buffer (except on "total EOF")
+function TTextParser.popFrontChar (): AnsiChar; inline;
+begin
+ if (mEofHit) and (mCharBufUsed = 0) then begin result := #0; exit; end;
+ assert(mCharBufUsed > 0);
+ result := mCharBuf[mCharBufPos];
+ mCharBufPos := (mCharBufPos+1) mod CharBufSize;
+ Dec(mCharBufUsed);
+ if (not mEofHit) and (mCharBufUsed = 0) then fillCharBuf();
+end;
+
+function TTextParser.peekCurChar (): AnsiChar; inline;
+begin
+ if (mCharBufUsed = 0) and (not mEofHit) then fillCharBuf();
+ result := mCharBuf[mCharBufPos]; // it is safe, 'cause `fillCharBuf()` will put #0 on "total EOF"
+end;
+
+function TTextParser.peekNextChar (): AnsiChar; inline;
+begin
+ if (mCharBufUsed < 2) and (not mEofHit) then fillCharBuf();
+ if (mCharBufUsed < 2) then result := #0 else result := mCharBuf[(mCharBufPos+1) mod CharBufSize];
+end;
+
+function TTextParser.peekChar (dest: Integer): AnsiChar; inline;
+begin
+ if (dest < 0) or (dest >= CharBufSize) then error('internal text parser error');
+ if (mCharBufUsed < dest+1) then fillCharBuf();
+ if (mCharBufUsed < dest+1) then result := #0 else result := mCharBuf[(mCharBufPos+dest) mod CharBufSize];
+end;
+
+
+function TTextParser.skipChar (): Boolean;
+var
+ ch: AnsiChar;
+begin
+ ch := popFrontChar();
+ if (ch = #0) then begin result := false; exit; end;
result := true;
+ // CR?
+ case ch of
+ #10:
+ begin
+ mCol := 1;
+ Inc(mLine);
+ end;
+ #13:
+ begin
+ mCol := 1;
+ Inc(mLine);
+ if (mCharBufUsed > 0) and (mCharBuf[0] = #10) then
+ begin
+ if (popFrontChar() = #0) then result := false;
+ end;
+ end;
+ else
+ Inc(mCol);
+ end;
end;
var
level: Integer;
begin
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- if (mCurChar = '/') then
+ if (curChar = '/') then
begin
// single-line comment
- if (mNextChar = '/') then
+ if (nextChar = '/') then
begin
- while (mCurChar <> #0) and (mCurChar <> #10) do skipChar();
+ //writeln('spos=(', mLine, ',', mCol, ')');
+ while (curChar <> #0) and (curChar <> #10) and (curChar <> #13) do skipChar();
skipChar(); // skip EOL
+ //writeln('{', curChar, '}');
+ //writeln('epos=(', mLine, ',', mCol, ')');
continue;
end;
// multline comment
- if (mNextChar = '*') then
+ if (nextChar = '*') then
begin
// skip comment start
skipChar();
skipChar();
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- if (mCurChar = '*') and (mNextChar = '/') then
+ if (curChar = '*') and (nextChar = '/') then
begin
// skip comment end
skipChar();
continue;
end;
// nesting multline comment
- if (mNextChar = '+') then
+ if (nextChar = '+') then
begin
// skip comment start
skipChar();
skipChar();
level := 1;
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- if (mCurChar = '+') and (mNextChar = '/') then
+ if (curChar = '+') and (nextChar = '/') then
begin
// skip comment end
skipChar();
if (level = 0) then break;
continue;
end;
- if (mCurChar = '/') and (mNextChar = '+') then
+ if (curChar = '/') and (nextChar = '+') then
begin
// skip comment start
skipChar();
continue;
end;
end
- else if (mCurChar = '(') and (mNextChar = '*') then
+ else if (curChar = '(') and (nextChar = '*') then
begin
// pascal comment; skip comment start
skipChar();
skipChar();
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- if (mCurChar = '*') and (mNextChar = ')') then
+ if (curChar = '*') and (nextChar = ')') then
begin
// skip comment end
skipChar();
end;
continue;
end
- else if (mCurChar = '{') and (TOption.PascalComments in mOptions) then
+ else if (curChar = '{') and (TOption.PascalComments in mOptions) then
begin
// pascal comment; skip comment start
skipChar();
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- if (mCurChar = '}') then
+ if (curChar = '}') then
begin
// skip comment end
skipChar();
end;
continue;
end;
- if (mCurChar > ' ') then break;
+ if (curChar > ' ') then break;
skipChar(); // skip blank
end;
- result := (mCurChar <> #0);
+ result := (curChar <> #0);
end;
begin
if (TOption.SignedNumbers in mOptions) then
begin
- if (mCurChar = '+') or (mCurChar = '-') then
+ if (curChar = '+') or (curChar = '-') then
begin
- neg := (mCurChar = '-');
+ neg := (curChar = '-');
skipChar();
- if (mCurChar < '0') or (mCurChar > '9') then
+ if (curChar < '0') or (curChar > '9') then
begin
mTokType := TTDelim;
if (neg) then mTokChar := '-' else mTokChar := '+';
end;
end;
end;
- if (mCurChar = '0') then
+ if (curChar = '0') then
begin
- case mNextChar of
+ case nextChar of
'b','B': base := 2;
'o','O': base := 8;
'd','D': base := 10;
end;
// default base
if (base < 0) then base := 10;
- if (digitInBase(mCurChar, base) < 0) then raise Exception.Create('invalid number');
+ if (digitInBase(curChar, base) < 0) then error('invalid number');
mTokType := TTInt;
mTokInt := 0; // just in case
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- n := digitInBase(mCurChar, base);
+ if (curChar = '_') then
+ begin
+ skipChar();
+ if (curChar = #0) then break;
+ end;
+ n := digitInBase(curChar, base);
if (n < 0) then break;
n := mTokInt*10+n;
- if (n < 0) or (n < mTokInt) then raise Exception.Create('integer overflow');
+ if (n < 0) or (n < mTokInt) then error('integer overflow');
mTokInt := n;
skipChar();
end;
// check for valid number end
- if (mCurChar <> #0) then
+ if (curChar <> #0) then
begin
- if (mCurChar = '.') then raise Exception.Create('floating numbers aren''t supported yet');
- if (mCurChar = '_') or ((mCurChar >= 'A') and (mCurChar <= 'Z')) or ((mCurChar >= 'a') and (mCurChar <= 'z')) or (mCurChar >= #128) then
- begin
- raise Exception.Create('invalid number');
- end;
+ if (curChar = '.') then error('floating numbers aren''t supported yet');
+ if (isIdMidChar(curChar)) then error('invalid number');
end;
if neg then mTokInt := -mTokInt;
end;
begin
mTokType := TTStr;
mTokStr := ''; // just in case
- qch := mCurChar;
+ qch := curChar;
skipChar(); // skip starting quote
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
// escape
- if (qch = '"') and (mCurChar = '\') then
+ if (qch = '"') and (curChar = '\') then
begin
- if (mNextChar = #0) then raise Exception.Create('unterminated string escape');
- ch := mNextChar;
+ if (nextChar = #0) then error('unterminated string escape');
+ ch := nextChar;
// skip backslash and escape type
skipChar();
skipChar();
'e': mTokStr += #27;
'x', 'X': // hex escape
begin
- n := digitInBase(mCurChar, 16);
- if (n < 0) then raise Exception.Create('invalid hexstr escape');
+ n := digitInBase(curChar, 16);
+ if (n < 0) then error('invalid hexstr escape');
skipChar();
- if (digitInBase(mCurChar, 16) > 0) then
+ if (digitInBase(curChar, 16) > 0) then
begin
- n := n*16+digitInBase(mCurChar, 16);
+ n := n*16+digitInBase(curChar, 16);
skipChar();
end;
mTokStr += AnsiChar(n);
continue;
end;
// duplicate single quote (pascal style)
- if (qch = '''') and (mCurChar = '''') and (mNextChar = '''') then
+ if (qch = '''') and (curChar = '''') and (nextChar = '''') then
begin
// skip both quotes
skipChar();
mTokStr += '''';
continue;
end;
- if (mCurChar = qch) then
+ if (curChar = qch) then
begin
skipChar(); // skip ending quote
break;
end;
- mTokStr += mCurChar;
+ mTokStr += curChar;
skipChar();
end;
end;
begin
mTokType := TTId;
mTokStr := ''; // just in case
- while (mCurChar = '_') or ((mCurChar >= '0') and (mCurChar <= '9')) or
- ((mCurChar >= 'A') and (mCurChar <= 'Z')) or
- ((mCurChar >= 'a') and (mCurChar <= 'z')) or
- (mCurChar >= #128) or
- ((TOption.DollarIsId in mOptions) and (mCurChar = '$')) or
- ((TOption.DotIsId in mOptions) and (mCurChar = '.') and (mNextChar <> '.')) or
- ((TOption.DashIsId in mOptions) and (mCurChar = '-')) do
+ while (isIdMidChar(curChar)) do
begin
- mTokStr += mCurChar;
+ if (curChar = '.') and (nextChar = '.') then break; // dotdot is a token by itself
+ mTokStr += curChar;
skipChar();
end;
end;
+var
+ xpos: Integer;
begin
mTokType := TTNone;
mTokStr := '';
result := true;
// number?
- if (TOption.SignedNumbers in mOptions) and ((mCurChar = '+') or (mCurChar = '-')) then begin parseInt(); exit; end;
- if (mCurChar >= '0') and (mCurChar <= '9') then begin parseInt(); exit; end;
+ if (TOption.SignedNumbers in mOptions) and ((curChar = '+') or (curChar = '-')) then begin parseInt(); exit; end;
+ if (curChar >= '0') and (curChar <= '9') then begin parseInt(); exit; end;
// string?
- if (mCurChar = '"') or (mCurChar = '''') then begin parseString(); exit; end;
+ if (curChar = '"') or (curChar = '''') or (curChar = '`') then begin parseString(); exit; end;
+
+ // html color?
+ if (curChar = '#') and (TOption.HtmlColors in mOptions) then
+ begin
+ if (digitInBase(peekChar(1), 16) >= 0) and (digitInBase(peekChar(2), 16) >= 0) and (digitInBase(peekChar(3), 16) >= 0) then
+ begin
+ if (digitInBase(peekChar(4), 16) >= 0) and (digitInBase(peekChar(5), 16) >= 0) and (digitInBase(peekChar(6), 16) >= 0) then xpos := 7 else xpos := 4;
+ if (not isIdMidChar(peekChar(xpos))) then
+ begin
+ mTokType := TTId;
+ mTokStr := '';
+ while (xpos > 0) do
+ begin
+ mTokStr += curChar;
+ skipChar();
+ Dec(xpos);
+ end;
+ exit;
+ end;
+ end;
+ end;
// identifier?
- if (mCurChar = '_') or ((mCurChar >= 'A') and (mCurChar <= 'Z')) or ((mCurChar >= 'a') and (mCurChar <= 'z')) or (mCurChar >= #128) then begin parseId(); exit; end;
- if (TOption.DollarIsId in mOptions) and (mCurChar = '$') then begin parseId(); exit; end;
- if (TOption.DotIsId in mOptions) and (mCurChar = '.') and (mNextChar <> '.') then begin parseId(); exit; end;
+ if (isIdStartChar(curChar)) then
+ begin
+ if (curChar = '.') and (nextChar = '.') then
+ begin
+ // nothing to do here, as dotdot is a token by itself
+ end
+ else
+ begin
+ parseId();
+ exit;
+ end;
+ end;
// known delimiters?
- mTokChar := mCurChar;
+ mTokChar := curChar;
mTokType := TTDelim;
skipChar();
- if (mCurChar = '=') then
+ if (curChar = '=') then
begin
case mTokChar of
'<': begin mTokType := TTLessEqu; mTokStr := '<='; skipChar(); exit; end;
':': begin mTokType := TTAss; mTokStr := ':='; skipChar(); exit; end;
end;
end
- else if (mTokChar = mCurChar) then
+ else if (mTokChar = curChar) then
begin
case mTokChar of
'<': begin mTokType := TTShl; mTokStr := '<<'; skipChar(); exit; end;
else
begin
case mTokChar of
- '<': if (mCurChar = '>') then begin mTokType := TTNotEqu; mTokStr := '<>'; skipChar(); exit; end;
- '.': if (mCurChar = '.') then begin mTokType := TTDotDot; mTokStr := '..'; skipChar(); exit; end;
+ '<': if (curChar = '>') then begin mTokType := TTNotEqu; mTokStr := '<>'; skipChar(); exit; end;
+ '.': if (curChar = '.') then begin mTokType := TTDotDot; mTokStr := '..'; skipChar(); exit; end;
end;
end;
end;
-function TTextParser.isIdOrStr (): Boolean; inline;
-begin
- result := (mTokType = TTId) or (mTokType = TTStr);
-end;
+function TTextParser.isEOF (): Boolean; inline; begin result := (mTokType = TTEOF); end;
+function TTextParser.isId (): Boolean; inline; begin result := (mTokType = TTId); end;
+function TTextParser.isInt (): Boolean; inline; begin result := (mTokType = TTInt); end;
+function TTextParser.isStr (): Boolean; inline; begin result := (mTokType = TTStr); end;
+function TTextParser.isDelim (): Boolean; inline; begin result := (mTokType = TTDelim); end;
+function TTextParser.isIdOrStr (): Boolean; inline; begin result := (mTokType = TTId) or (mTokType = TTStr); end;
function TTextParser.expectId (): AnsiString;
begin
- if (mTokType <> TTId) then raise Exception.Create('identifier expected');
+ if (mTokType <> TTId) then error('identifier expected');
result := mTokStr;
skipToken();
end;
@@ -675,11 +795,11 @@ procedure TTextParser.expectId (const aid: AnsiString; caseSens: Boolean=true);
begin
if caseSens then
begin
- if (mTokType <> TTId) or (mTokStr <> aid) then raise Exception.Create('identifier '''+aid+''' expected');
+ if (mTokType <> TTId) or (mTokStr <> aid) then error('identifier '''+aid+''' expected');
end
else
begin
- if (mTokType <> TTId) or (not strEquCI1251(mTokStr, aid)) then raise Exception.Create('identifier '''+aid+''' expected');
+ if (mTokType <> TTId) or (not strEquCI1251(mTokStr, aid)) then error('identifier '''+aid+''' expected');
end;
skipToken();
end;
function TTextParser.expectStr (allowEmpty: Boolean=false): AnsiString;
begin
- if (mTokType <> TTStr) then raise Exception.Create('string expected');
- if (not allowEmpty) and (Length(mTokStr) = 0) then raise Exception.Create('non-empty string expected');
+ if (mTokType <> TTStr) then error('string expected');
+ if (not allowEmpty) and (Length(mTokStr) = 0) then error('non-empty string expected');
result := mTokStr;
skipToken();
end;
begin
case mTokType of
TTStr:
- if (not allowEmpty) and (Length(mTokStr) = 0) then raise Exception.Create('non-empty string expected');
+ if (not allowEmpty) and (Length(mTokStr) = 0) then error('non-empty string expected');
TTId:
begin end;
else
- raise Exception.Create('string or identifier expected');
+ error('string or identifier expected');
end;
result := mTokStr;
skipToken();
function TTextParser.expectInt (): Integer;
begin
- if (mTokType <> TTInt) then raise Exception.Create('string expected');
+ if (mTokType <> TTInt) then error('string expected');
result := mTokInt;
skipToken();
end;
procedure TTextParser.expectTT (ttype: Integer);
begin
- if (mTokType <> ttype) then raise Exception.Create('unexpected token');
+ if (mTokType <> ttype) then error('unexpected token');
skipToken();
end;
procedure TTextParser.expectDelim (const ch: AnsiChar);
begin
- if (mTokType <> TTDelim) or (mTokChar <> ch) then raise Exception.CreateFmt('delimiter ''%s'' expected', [ch]);
+ if (mTokType <> TTDelim) or (mTokChar <> ch) then errorfmt('delimiter ''%s'' expected', [ch]);
skipToken();
end;
function TTextParser.expectDelims (const ch: TAnsiCharSet): AnsiChar;
begin
- if (mTokType <> TTDelim) then raise Exception.Create('delimiter expected');
- if not (mTokChar in ch) then raise Exception.Create('delimiter expected');
+ if (mTokType <> TTDelim) then error('delimiter expected');
+ if not (mTokChar in ch) then error('delimiter expected');
result := mTokChar;
skipToken();
end;
GetMem(mBuffer, BufSize);
mBufPos := 0;
mBufLen := mFile.Read(mBuffer^, BufSize);
- if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
+ if (mBufLen < 0) then error('TFileTextParser: read error');
inherited Create(aopts);
end;
constructor TFileTextParser.Create (st: TStream; astOwned: Boolean=true; aopts: TOptions=[TOption.SignedNumbers]);
begin
- if (st = nil) then raise Exception.Create('cannot create parser for nil stream');
+ if (st = nil) then error('cannot create parser for nil stream');
mFile := st;
mStreamOwned := astOwned;
GetMem(mBuffer, BufSize);
mBufPos := 0;
mBufLen := mFile.Read(mBuffer^, BufSize);
- if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
+ if (mBufLen < 0) then error('TFileTextParser: read error');
inherited Create(aopts);
end;
mBuffer := nil;
mBufPos := 0;
mBufLen := 0;
- if mStreamOwned then mFile.Free();
- mFile := nil;
+ if (mStreamOwned) then FreeAndNil(mFile) else mFile := nil;
inherited;
end;
-procedure TFileTextParser.loadNextChar ();
+function TFileTextParser.loadChar (): AnsiChar;
begin
- if (mBufLen = 0) then begin mNextChar := #0; exit; end;
+ if (mBufLen = 0) then begin result := #0; exit; end;
if (mBufPos >= mBufLen) then
begin
mBufLen := mFile.Read(mBuffer^, BufSize);
- if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
- if (mBufLen = 0) then begin mNextChar := #0; exit; end;
+ if (mBufLen < 0) then error('TFileTextParser: read error');
+ if (mBufLen = 0) then begin result := #0; exit; end;
mBufPos := 0;
end;
assert(mBufPos < mBufLen);
- mNextChar := mBuffer[mBufPos];
+ result := mBuffer[mBufPos];
Inc(mBufPos);
- if (mNextChar = #0) then mNextChar := ' ';
+ if (result = #0) then result := ' ';
end;
end;
-procedure TStrTextParser.loadNextChar ();
+function TStrTextParser.loadChar (): AnsiChar;
begin
- mNextChar := #0;
+ result := #0;
if (mPos > Length(mStr)) then exit;
- mNextChar := mStr[mPos]; Inc(mPos);
- if (mNextChar = #0) then mNextChar := ' ';
+ result := mStr[mPos];
+ Inc(mPos);
+ if (result = #0) then result := ' ';
end;