From 34282db2f0936591a3686dc3cea00618be20e11f Mon Sep 17 00:00:00 2001 From: Ketmar Dark Date: Sat, 30 Sep 2017 21:35:15 +0300 Subject: [PATCH] FlexUI: alot of fixes; Holmes help window now using new FlexUI controls and layouter --- src/game/g_holmes.pas | 144 +++++-- src/gx/gh_flexlay.pas | 258 ++++-------- src/gx/gh_ui.pas | 867 +++++++++++++++++++++++++++++++++------- src/gx/gh_ui_common.pas | 1 - src/gx/gh_ui_style.pas | 552 ++++++++++++++++--------- src/gx/glgfx.pas | 85 ++++ src/shared/xparser.pas | 370 +++++++++++------ 7 files changed, 1613 insertions(+), 664 deletions(-) diff --git a/src/game/g_holmes.pas b/src/game/g_holmes.pas index 79c4349..b47011a 100644 --- a/src/game/g_holmes.pas +++ b/src/game/g_holmes.pas @@ -24,7 +24,7 @@ uses 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 (); @@ -137,17 +137,102 @@ end; 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; @@ -156,7 +241,7 @@ begin 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; @@ -164,7 +249,7 @@ begin 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 @@ -174,11 +259,14 @@ begin 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; @@ -188,16 +276,20 @@ begin 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; @@ -206,13 +298,15 @@ begin 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; @@ -220,17 +314,19 @@ begin 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 5f237f5..c6da6b3 100644 --- a/src/gx/gh_flexlay.pas +++ b/src/gx/gh_flexlay.pas @@ -16,68 +16,6 @@ *) {$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 @@ -114,9 +52,6 @@ type private type LayControlIdx = Integer; - private - class function nminX (a, b: Integer): Integer; inline; - private // flags const @@ -252,15 +187,6 @@ uses 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 @@ -533,9 +459,14 @@ 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; @@ -647,7 +578,7 @@ begin 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 @@ -684,106 +615,102 @@ begin 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 @@ -801,17 +728,6 @@ begin 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; @@ -864,6 +780,7 @@ begin 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; @@ -876,6 +793,7 @@ begin 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 b23362b..ef68af5 100644 --- a/src/gx/gh_ui.pas +++ b/src/gx/gh_ui.pas @@ -22,7 +22,7 @@ interface uses SysUtils, Classes, - GL, GLExt, SDL2, + SDL2, gh_ui_common, gh_ui_style, sdlcarcass, glgfx, @@ -38,6 +38,9 @@ type 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; @@ -51,12 +54,12 @@ type 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; @@ -85,6 +88,8 @@ type function getFocused (): Boolean; inline; procedure setFocused (v: Boolean); inline; + function getActive (): Boolean; inline; + function getCanFocus (): Boolean; inline; function isMyChild (ctl: TUIControl): Boolean; @@ -103,6 +108,8 @@ type 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); @@ -130,6 +137,7 @@ type mExpand: Boolean; mLayDefSize: TLaySize; mLayMaxSize: TLaySize; + mFullSize: TLaySize; public // layouter interface @@ -169,6 +177,7 @@ type 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; @@ -213,13 +222,20 @@ type 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; @@ -228,11 +244,18 @@ type 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; @@ -240,8 +263,8 @@ type 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; @@ -250,9 +273,12 @@ type TUITopWindow = class(TUIControl) + private + type TXMode = (None, Drag, Scroll); + private mTitle: AnsiString; - mDragging: Boolean; + mDragScroll: TXMode; mDragStartX, mDragStartY: Integer; mWaitingClose: Boolean; mInClose: Boolean; @@ -289,7 +315,7 @@ type property freeOnClose: Boolean read mFreeOnClose write mFreeOnClose; end; - + // ////////////////////////////////////////////////////////////////////// // TUISimpleText = class(TUIControl) private type @@ -299,6 +325,7 @@ type centered: Boolean; hline: Boolean; end; + private mItems: array of TItem; @@ -306,6 +333,8 @@ type 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; @@ -313,7 +342,6 @@ type procedure mouseEvent (var ev: THMouseEvent); override; end; - TUICBListBox = class(TUIControl) private type @@ -323,14 +351,21 @@ 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; @@ -356,15 +391,23 @@ type 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; @@ -399,15 +442,49 @@ type 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; @@ -415,13 +492,17 @@ type 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; @@ -430,6 +511,7 @@ type procedure mouseEvent (var ev: THMouseEvent); override; procedure keyEvent (var ev: THKeyEvent); override; + procedure keyEventPost (var ev: THKeyEvent); override; end; @@ -572,6 +654,9 @@ begin TUITopWindow(ctl).centerInScreen(); end; + // calculate full size + ctl.calcFullClientSize(); + finally FreeAndNil(lay); end; @@ -610,7 +695,7 @@ begin 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; @@ -668,11 +753,8 @@ var 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]; @@ -682,8 +764,7 @@ begin 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; @@ -776,7 +857,6 @@ begin mChildren := nil; mFocused := nil; mEscClose := false; - mEatKeys := false; scallowed := false; mDrawShadow := false; actionCB := nil; @@ -835,7 +915,8 @@ end; 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; @@ -857,35 +938,31 @@ 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; @@ -913,7 +990,8 @@ begin 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 @@ -1144,11 +1222,11 @@ 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; @@ -1167,6 +1245,23 @@ begin 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; @@ -1212,6 +1307,24 @@ begin 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; @@ -1258,17 +1371,32 @@ end; // 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; @@ -1278,16 +1406,16 @@ begin 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; @@ -1298,6 +1426,32 @@ begin 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; @@ -1318,6 +1472,11 @@ begin 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; @@ -1438,11 +1597,14 @@ function TUIControl.findDefaulControl (): TUIControl; 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; @@ -1451,11 +1613,14 @@ function TUIControl.findCancelControl (): TUIControl; 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; @@ -1493,6 +1658,59 @@ begin 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; @@ -1522,19 +1740,25 @@ end; 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; @@ -1559,7 +1783,6 @@ var 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 @@ -1613,17 +1836,45 @@ end; 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 @@ -1668,8 +1919,20 @@ 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; @@ -1682,6 +1945,7 @@ begin mTitle := atitle; end; + procedure TUITopWindow.AfterConstruction (); begin inherited AfterConstruction(); @@ -1691,12 +1955,12 @@ begin 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; @@ -1752,30 +2016,49 @@ 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; @@ -1793,7 +2076,7 @@ end; procedure TUITopWindow.blurred (); begin - mDragging := false; + mDragScroll := TXMode.None; mWaitingClose := false; mInClose := false; inherited; @@ -1803,7 +2086,7 @@ end; 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 @@ -1819,17 +2102,43 @@ end; 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; @@ -1849,17 +2158,33 @@ begin 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(); @@ -1910,6 +2235,7 @@ constructor TUISimpleText.Create (ax, ay: Integer); begin mItems := nil; inherited Create(ax, ay, 4, 4); + mDefSize := TLaySize.Create(mWidth, mHeight); end; @@ -1920,6 +2246,14 @@ begin 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; @@ -1931,37 +2265,39 @@ begin 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; @@ -1982,9 +2318,8 @@ end; // ////////////////////////////////////////////////////////////////////////// // constructor TUICBListBox.Create (ax, ay: Integer); begin - mItems := nil; - mCurIndex := -1; inherited Create(ax, ay, 4, 4); + mDefSize := TLaySize.Create(mWidth, mHeight); end; @@ -1995,6 +2330,27 @@ begin 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; @@ -2007,36 +2363,39 @@ begin 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; @@ -2216,13 +2575,37 @@ 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(); @@ -2231,6 +2614,11 @@ end; // ////////////////////////////////////////////////////////////////////////// // +constructor TUIVBox.Create (); +begin +end; + + procedure TUIVBox.AfterConstruction (); begin inherited AfterConstruction(); @@ -2264,6 +2652,7 @@ end; procedure TUILine.AfterConstruction (); begin inherited AfterConstruction(); + mCanFocus := false; mExpand := true; mCanFocus := false; mCtl4Style := 'line'; @@ -2298,7 +2687,7 @@ procedure TUIHLine.AfterConstruction (); begin inherited AfterConstruction(); mHoriz := true; - mDefSize.h := 1; + mDefSize.h := 7; end; @@ -2307,39 +2696,187 @@ procedure TUIVLine.AfterConstruction (); 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); @@ -2368,6 +2905,11 @@ begin 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; @@ -2384,31 +2926,44 @@ begin 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; @@ -2416,21 +2971,16 @@ procedure TUIButton.drawControl (gx, gy: Integer); 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 @@ -2440,6 +2990,11 @@ 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; @@ -2478,6 +3033,19 @@ begin 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'); @@ -2485,5 +3053,6 @@ initialization registerCtlClass(TUIHLine, 'hline'); registerCtlClass(TUIVLine, 'vline'); registerCtlClass(TUITextLabel, 'label'); + registerCtlClass(TUIStaticText, 'static'); registerCtlClass(TUIButton, 'button'); end. diff --git a/src/gx/gh_ui_common.pas b/src/gx/gh_ui_common.pas index 034321a..de719d9 100644 --- a/src/gx/gh_ui_common.pas +++ b/src/gx/gh_ui_common.pas @@ -73,7 +73,6 @@ type end; - implementation uses diff --git a/src/gx/gh_ui_style.pas b/src/gx/gh_ui_style.pas index 5c77405..97dcb79 100644 --- a/src/gx/gh_ui_style.pas +++ b/src/gx/gh_ui_style.pas @@ -15,6 +15,7 @@ * along with this program. If not, see . *) {$INCLUDE ../../shared/a_modes.inc} +{.$DEFINE UI_STYLE_DEBUG_SEARCH} unit gh_ui_style; interface @@ -26,57 +27,64 @@ uses 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; THashStrSection = specialize THashBase; 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 @@ -85,10 +93,11 @@ type 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); @@ -96,9 +105,11 @@ type 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; @@ -113,56 +124,38 @@ implementation // ////////////////////////////////////////////////////////////////////////// // +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; @@ -202,7 +195,7 @@ var 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 @@ -237,33 +230,30 @@ end; // ////////////////////////////////////////////////////////////////////////// // -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; @@ -271,12 +261,11 @@ begin 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 @@ -311,18 +300,32 @@ 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 @@ -343,111 +346,191 @@ end; // ////////////////////////////////////////////////////////////////////////// // 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; @@ -455,7 +538,7 @@ end; constructor TUIStyle.Create (const aid: AnsiString); begin mId := aid; - mMain := TStyleSection.Create(); + createMain(); end; @@ -464,9 +547,9 @@ var 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 @@ -477,19 +560,11 @@ end; 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; @@ -503,14 +578,21 @@ begin 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; @@ -525,48 +607,100 @@ procedure TUIStyle.parse (par: TTextParser); 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 @@ -586,6 +720,30 @@ procedure TUIStyle.parse (par: TTextParser); 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; @@ -596,18 +754,22 @@ procedure TUIStyle.parse (par: TTextParser); 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; @@ -626,7 +788,7 @@ begin 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 d39d2f0..2aaec44 100644 --- a/src/gx/glgfx.pas +++ b/src/gx/glgfx.pas @@ -121,6 +121,8 @@ type procedure eat (); inline; procedure cancel (); inline; + function isHot (ch: AnsiChar): Boolean; + public property eaten: Boolean read mEaten; property cancelled: Boolean read mCancelled; @@ -132,6 +134,11 @@ type // 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); @@ -676,6 +746,21 @@ begin 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 5332f0a..de2dfb3 100644 --- a/src/shared/xparser.pas +++ b/src/shared/xparser.pas @@ -66,6 +66,7 @@ type 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; @@ -73,10 +74,16 @@ type 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; @@ -86,9 +93,19 @@ type 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]); @@ -97,8 +114,6 @@ type 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 @@ -108,6 +123,11 @@ type 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; @@ -137,8 +157,8 @@ type 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; @@ -165,7 +185,7 @@ type 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]); @@ -179,7 +199,7 @@ type 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]); @@ -277,14 +297,14 @@ constructor TTextParser.Create (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; @@ -307,32 +327,98 @@ begin 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; @@ -340,26 +426,29 @@ function TTextParser.skipBlanks (): Boolean; 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(); @@ -371,15 +460,15 @@ begin 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(); @@ -388,7 +477,7 @@ begin if (level = 0) then break; continue; end; - if (mCurChar = '/') and (mNextChar = '+') then + if (curChar = '/') and (nextChar = '+') then begin // skip comment start skipChar(); @@ -401,14 +490,14 @@ begin 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(); @@ -419,13 +508,13 @@ begin 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(); @@ -435,10 +524,10 @@ begin end; continue; end; - if (mCurChar > ' ') then break; + if (curChar > ' ') then break; skipChar(); // skip blank end; - result := (mCurChar <> #0); + result := (curChar <> #0); end; @@ -462,11 +551,11 @@ function TTextParser.skipToken (): Boolean; 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 := '+'; @@ -474,9 +563,9 @@ function TTextParser.skipToken (): Boolean; 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; @@ -491,26 +580,28 @@ function TTextParser.skipToken (): Boolean; 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; @@ -522,15 +613,15 @@ function TTextParser.skipToken (): Boolean; 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(); @@ -542,12 +633,12 @@ function TTextParser.skipToken (): Boolean; '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); @@ -557,7 +648,7 @@ function TTextParser.skipToken (): Boolean; 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(); @@ -565,12 +656,12 @@ function TTextParser.skipToken (): Boolean; 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; @@ -579,19 +670,16 @@ function TTextParser.skipToken (): Boolean; 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 := ''; @@ -613,22 +701,52 @@ begin 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; @@ -638,7 +756,7 @@ begin ':': 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; @@ -650,22 +768,24 @@ begin 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; @@ -723,8 +843,8 @@ 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; @@ -734,11 +854,11 @@ function TTextParser.expectIdOrStr (allowEmpty: Boolean=false): AnsiString; 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(); @@ -747,7 +867,7 @@ end; 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; @@ -755,7 +875,7 @@ 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; @@ -769,15 +889,15 @@ 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; @@ -805,20 +925,20 @@ begin 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; @@ -829,26 +949,25 @@ begin 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; @@ -868,12 +987,13 @@ begin 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; -- 2.29.2