From: Ketmar Dark Date: Mon, 2 Oct 2017 23:35:41 +0000 (+0300) Subject: Merge branch 'master' of ssh://repo.or.cz/d2df-sdl X-Git-Url: https://deadsoftware.ru/gitweb?p=d2df-sdl.git;a=commitdiff_plain;h=6880f8a491a247a34d6afb5508d0a64196a3d26d;hp=6cfc4749e77a32dc356f8dc4b4f26788626bbb4e Merge branch 'master' of ssh://repo.or.cz/d2df-sdl --- diff --git a/src/flexui/fui_common.pas b/src/flexui/fui_common.pas new file mode 100644 index 0000000..744ddff --- /dev/null +++ b/src/flexui/fui_common.pas @@ -0,0 +1,251 @@ +(* coded by Ketmar // Invisible Vector + * Understanding is not required. Only obedience. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +{$INCLUDE ../shared/a_modes.inc} +unit fui_common; + +interface + + +// ////////////////////////////////////////////////////////////////////////// // +type + TLaySize = record + public + w, h: Integer; + + private + function getIdx (idx: Integer): Integer; inline; + procedure setIdx (idx, v: Integer); inline; + + public + constructor Create (aw, ah: Integer); + + function toString (): AnsiString; + + function equals (constref a: TLaySize): Boolean; inline; + public + property item[idx: Integer]: Integer read getIdx write setIdx; default; + end; + + TLayPos = record + public + x, y: Integer; + + private + function getIdx (idx: Integer): Integer; inline; + procedure setIdx (idx, v: Integer); inline; + + public + constructor Create (ax, ay: Integer); + + function toString (): AnsiString; + + function equals (constref a: TLayPos): Boolean; inline; + + public + property item[idx: Integer]: Integer read getIdx write setIdx; default; + end; + + TLayMargins = record + public + top, right, bottom, left: Integer; + + public + constructor Create (atop, aright, abottom, aleft: Integer); + + function toString (): AnsiString; + + function horiz (): Integer; inline; + function vert (): Integer; inline; + end; + + +// ////////////////////////////////////////////////////////////////////////// // +type + TGxRGBA = packed record + public + r, g, b, a: Byte; + + public + constructor Create (ar, ag, ab: Integer; aa: Integer=255); + + function asUInt (): LongWord; inline; + function isOpaque (): Boolean; inline; + function isTransparent (): Boolean; inline; + + // WARNING! This function does blending in RGB space, and RGB space is not linear! + // alpha value of `self` doesn't matter + // `aa` means: 255 for replace color, 0 for keep `self` + function blend (ar, ag, ab, aa: Integer): TGxRGBA; inline; + end; + + TGxRect = packed record + public + x, y, w, h: Integer; + + public + constructor Create (ax, ay, aw, ah: Integer); + + function empty (): Boolean; inline; // invalid rects are empty too + function valid (): Boolean; inline; + + // modifies this rect, so it won't be bigger than `r` + // returns `false` if this rect becomes empty + function intersect (constref r: TGxRect): Boolean; inline; + end; + + TGxOfs = packed record + public + xofs, yofs: Integer; + + public + constructor Create (axofs, ayofs: Integer); + end; + + +// ////////////////////////////////////////////////////////////////////////// // +// return `false` if destination rect is empty +// modifies rect0 +function intersectRect (var x0, y0, w0, h0: Integer; const x1, y1, w1, h1: Integer): Boolean; inline; +procedure normRGBA (var r, g, b, a: Integer); inline; + + +implementation + +uses + utils; + +// ////////////////////////////////////////////////////////////////////////// // +constructor TLaySize.Create (aw, ah: Integer); begin w := aw; h := ah; end; +function TLaySize.getIdx (idx: Integer): Integer; inline; begin if (idx = 0) then result := w else if (idx = 1) then result := h else result := -1; end; +procedure TLaySize.setIdx (idx, v: Integer); inline; begin if (idx = 0) then w := v else if (idx = 1) then h := v; end; +function TLaySize.toString (): AnsiString; begin result := formatstrf('[%d,%d]', [w, h]); end; +function TLaySize.equals (constref a: TLaySize): Boolean; inline; begin result := (w = a.w) and (h = a.h); end; + +constructor TLayPos.Create (ax, ay: Integer); begin x := ax; y := ay; end; +function TLayPos.getIdx (idx: Integer): Integer; inline; begin if (idx = 0) then result := x else if (idx = 1) then result := y else result := -1; end; +procedure TLayPos.setIdx (idx, v: Integer); inline; begin if (idx = 0) then x := v else if (idx = 1) then y := v; end; +function TLayPos.toString (): AnsiString; begin result := formatstrf('(%d,%d)', [x, y]); end; +function TLayPos.equals (constref a: TLayPos): Boolean; inline; begin result := (x = a.x) and (y = a.y); end; + +constructor TLayMargins.Create (atop, aright, abottom, aleft: Integer); +begin + if (atop < 0) then atop := 0; + if (aright < 0) then aright := 0; + if (abottom < 0) then abottom := 0; + if (aleft < 0) then aleft := 0; + left := aleft; + right := aright; + top := atop; + bottom := abottom; +end; +function TLayMargins.toString (): AnsiString; begin result := formatstrf('(%s,%s,%s,%s)', [top, right, bottom, left]); end; +function TLayMargins.horiz (): Integer; inline; begin result := left+right; end; +function TLayMargins.vert (): Integer; inline; begin result := top+bottom; end; + + +// ////////////////////////////////////////////////////////////////////////// // +constructor TGxRGBA.Create (ar, ag, ab: Integer; aa: Integer=255); +begin + if (ar < 0) then r := 0 else if (ar > 255) then r := 255 else r := Byte(ar); + if (ag < 0) then g := 0 else if (ag > 255) then g := 255 else g := Byte(ag); + if (ab < 0) then b := 0 else if (ab > 255) then b := 255 else b := Byte(ab); + if (aa < 0) then a := 0 else if (aa > 255) then a := 255 else a := Byte(aa); +end; + +function TGxRGBA.asUInt (): LongWord; inline; begin result := LongWord(r) or (LongWord(g) shl 8) or (LongWord(b) shl 16) or (LongWord(a) shl 24); end; + +function TGxRGBA.isOpaque (): Boolean; inline; begin result := (a = 255); end; +function TGxRGBA.isTransparent (): Boolean; inline; begin result := (a = 0); end; + +function TGxRGBA.blend (ar, ag, ab, aa: Integer): TGxRGBA; inline; +var + me, it, a_tmp_, dc_tmp_, srb_tmp_, sg_tmp_, drb_tmp_, dg_tmp_, orb_tmp_, og_tmp_: LongWord; +begin + if (aa <= 0) then begin result := self; exit; end; + result := TGxRGBA.Create(ar, ag, ab, aa); + if (aa >= 255) then begin result.a := a; exit; end; + me := asUInt; + it := result.asUInt; + a_tmp_ := (256-(255-(it shr 24))) and (-(1-(((255-(it shr 24))+1) shr 8))); // to not loose bits, but 255 should become 0 + dc_tmp_ := me and $ffffff; + srb_tmp_ := (it and $ff00ff); + sg_tmp_ := (it and $00ff00); + drb_tmp_ := (dc_tmp_ and $ff00ff); + dg_tmp_ := (dc_tmp_ and $00ff00); + orb_tmp_ := (drb_tmp_+(((srb_tmp_-drb_tmp_)*a_tmp_+$800080) shr 8)) and $ff00ff; + og_tmp_ := (dg_tmp_+(((sg_tmp_-dg_tmp_)*a_tmp_+$008000) shr 8)) and $00ff00; + me := (orb_tmp_ or og_tmp_); // or $ff000000; /* and $ffffff;*/ + result.r := Byte(me and $ff); + result.g := Byte((me shr 8) and $ff); + result.b := Byte((me shr 16) and $ff); + result.a := a; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +constructor TGxRect.Create (ax, ay, aw, ah: Integer); begin x := ax; y := ay; w := aw; h := ah; end; + +function TGxRect.empty (): Boolean; inline; begin result := (w <= 0) or (h <= 0); end; +function TGxRect.valid (): Boolean; inline; begin result := (w < 0) or (h < 0); end; + +function TGxRect.intersect (constref r: TGxRect): Boolean; inline; +begin + result := intersectRect(x, y, w, h, r.x, r.y, r.w, r.h); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +constructor TGxOfs.Create (axofs, ayofs: Integer); begin xofs := axofs; yofs := ayofs; end; + + +// ////////////////////////////////////////////////////////////////////////// // +//TODO: overflow checks +function intersectRect (var x0, y0, w0, h0: Integer; const x1, y1, w1, h1: Integer): Boolean; inline; +var + ex0, ey0: Integer; + ex1, ey1: Integer; +begin + result := false; + if (w0 < 1) or (h0 < 1) or (w1 < 1) or (h1 < 1) then exit; // at least one rect is null + // check for intersection + ex0 := x0+w0; + ey0 := y0+h0; + ex1 := x1+w1; + ey1 := y1+h1; + if (ex0 <= x1) or (ey0 <= y1) or (ex1 <= x0) or (ey1 <= y0) then exit; + if (x0 >= ex1) or (y0 >= ey1) or (x1 >= ex0) or (y1 >= ey0) then exit; + // ok, intersects + if (x0 < x1) then x0 := x1; + if (y0 < y1) then y0 := y1; + if (ex0 > ex1) then ex0 := ex1; + if (ey0 > ey1) then ey0 := ey1; + w0 := ex0-x0; + h0 := ey0-y0; + result := (w0 > 0) and (h0 > 0); +end; + + +procedure normRGBA (var r, g, b, a: Integer); inline; +begin + if (a < 0) then a := 0 else if (a > 255) then a := 255; + if (r < 0) then r := 0 else if (r > 255) then r := 255; + if (g < 0) then g := 0 else if (g > 255) then g := 255; + if (b < 0) then b := 0 else if (b > 255) then b := 255; +end; + + +end. diff --git a/src/gx/gh_ui.pas b/src/flexui/fui_ctls.pas similarity index 55% rename from src/gx/gh_ui.pas rename to src/flexui/fui_ctls.pas index b23362b..7969a26 100644 --- a/src/gx/gh_ui.pas +++ b/src/flexui/fui_ctls.pas @@ -16,16 +16,16 @@ *) {$INCLUDE ../shared/a_modes.inc} {$M+} -unit gh_ui; +unit fui_ctls; interface uses SysUtils, Classes, - GL, GLExt, SDL2, - gh_ui_common, - gh_ui_style, - sdlcarcass, glgfx, + SDL2, + sdlcarcass, + fui_common, fui_events, fui_style, + fui_gfx_gl, xparser; @@ -35,9 +35,12 @@ type TUIControl = class public - type TActionCB = procedure (me: TUIControl; uinfo: Integer); + type TActionCB = procedure (me: TUIControl); 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; @@ -67,11 +70,7 @@ type mFrameColor: array[0..ClrIdxMax] of TGxRGBA; mFrameTextColor: array[0..ClrIdxMax] of TGxRGBA; mFrameIconColor: array[0..ClrIdxMax] of TGxRGBA; - mDarken: array[0..ClrIdxMax] of Integer; // -1: none - - private - scis: TScissorSave; - scallowed: Boolean; + mDarken: array[0..ClrIdxMax] of Integer; // >255: none protected procedure updateStyle (); virtual; @@ -85,6 +84,8 @@ type function getFocused (): Boolean; inline; procedure setFocused (v: Boolean); inline; + function getActive (): Boolean; inline; + function getCanFocus (): Boolean; inline; function isMyChild (ctl: TUIControl): Boolean; @@ -92,8 +93,8 @@ type function findFirstFocus (): TUIControl; function findLastFocus (): TUIControl; - function findNextFocus (cur: TUIControl): TUIControl; - function findPrevFocus (cur: TUIControl): TUIControl; + function findNextFocus (cur: TUIControl; wrap: Boolean): TUIControl; + function findPrevFocus (cur: TUIControl; wrap: Boolean): TUIControl; function findCancelControl (): TUIControl; function findDefaulControl (): TUIControl; @@ -103,15 +104,13 @@ type procedure activated (); virtual; procedure blurred (); virtual; + procedure calcFullClientSize (); + + protected + var savedClip: TGxRect; // valid only in `draw*()` calls //WARNING! do not call scissor functions outside `.draw*()` API! // set scissor to this rect (in local coords) - procedure setScissor (lx, ly, lw, lh: Integer); - // reset scissor to whole control - procedure resetScissor (fullArea: Boolean); inline; // "full area" means "with frame" - - // DO NOT USE! - // set scissor to this rect (in global coords) - procedure setScissorGLInternal (x, y, w, h: Integer); + procedure setScissor (lx, ly, lw, lh: Integer); // valid only in `draw*()` calls public actionCB: TActionCB; @@ -130,29 +129,27 @@ type mExpand: Boolean; mLayDefSize: TLaySize; mLayMaxSize: TLaySize; + mFullSize: TLaySize; + mNoPad: Boolean; + mPadding: TLaySize; public // layouter interface function getDefSize (): TLaySize; inline; // default size; <0: use max size //procedure setDefSize (const sz: TLaySize); inline; // default size; <0: use max size function getMargins (): TLayMargins; inline; + function getPadding (): TLaySize; inline; // children padding (each non-first child will get this on left/top) function getMaxSize (): TLaySize; inline; // max size; <0: set to some huge value //procedure setMaxSize (const sz: TLaySize); inline; // max size; <0: set to some huge value function getFlex (): Integer; inline; // <=0: not flexible function isHorizBox (): Boolean; inline; // horizontal layout for children? - procedure setHorizBox (v: Boolean); inline; // horizontal layout for children? function canWrap (): Boolean; inline; // for horizontal boxes: can wrap children? for child: `false` means 'nonbreakable at *next* ctl' - procedure setCanWrap (v: Boolean); inline; // for horizontal boxes: can wrap children? for child: `false` means 'nonbreakable at *next* ctl' + function noPad (): Boolean; inline; // ignore padding in box direction for this control function isLineStart (): Boolean; inline; // `true` if this ctl should start a new line; ignored for vertical boxes - procedure setLineStart (v: Boolean); inline; // `true` if this ctl should start a new line; ignored for vertical boxes function getAlign (): Integer; inline; // aligning in non-main direction: <0: left/up; 0: center; >0: right/down - procedure setAlign (v: Integer); inline; // aligning in non-main direction: <0: left/up; 0: center; >0: right/down function getExpand (): Boolean; inline; // expanding in non-main direction: `true` will ignore align and eat all available space - procedure setExpand (v: Boolean); inline; // expanding in non-main direction: `true` will ignore align and eat all available space function getHGroup (): AnsiString; inline; // empty: not grouped - procedure setHGroup (const v: AnsiString); inline; // empty: not grouped function getVGroup (): AnsiString; inline; // empty: not grouped - procedure setVGroup (const v: AnsiString); inline; // empty: not grouped procedure setActualSizePos (constref apos: TLayPos; constref asize: TLaySize); inline; @@ -162,17 +159,23 @@ type property flex: Integer read mFlex write mFlex; property flDefaultSize: TLaySize read mDefSize write mDefSize; property flMaxSize: TLaySize read mMaxSize write mMaxSize; - property flHoriz: Boolean read isHorizBox write setHorizBox; - property flCanWrap: Boolean read canWrap write setCanWrap; - property flLineStart: Boolean read isLineStart write setLineStart; - property flAlign: Integer read getAlign write setAlign; - property flExpand: Boolean read getExpand write setExpand; - property flHGroup: AnsiString read getHGroup write setHGroup; - property flVGroup: AnsiString read getVGroup write setVGroup; + property flPadding: TLaySize read mPadding write mPadding; + property flHoriz: Boolean read mHoriz write mHoriz; + property flCanWrap: Boolean read mCanWrap write mCanWrap; + property flLineStart: Boolean read mLineStart write mLineStart; + property flAlign: Integer read mAlign write mAlign; + property flExpand: Boolean read mExpand write mExpand; + property flHGroup: AnsiString read mHGroup write mHGroup; + property flVGroup: AnsiString read mVGroup write mVGroup; + property flNoPad: Boolean read mNoPad write mNoPad; + property fullSize: TLaySize read mFullSize; protected function parsePos (par: TTextParser): TLayPos; function parseSize (par: TTextParser): TLaySize; + function parsePadding (par: TTextParser): TLaySize; + function parseHPadding (par: TTextParser; def: Integer): TLaySize; + function parseVPadding (par: TTextParser; def: Integer): TLaySize; function parseBool (par: TTextParser): Boolean; function parseAnyAlign (par: TTextParser): Integer; function parseHAlign (par: TTextParser): Integer; @@ -194,9 +197,10 @@ type public constructor Create (); - constructor Create (ax, ay, aw, ah: Integer); destructor Destroy (); override; + procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser + // `sx` and `sy` are screen coordinates procedure drawControl (gx, gy: Integer); virtual; @@ -213,13 +217,22 @@ 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 makeVisibleInParent (); + + 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,20 +241,27 @@ 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 id: AnsiString read mId write mId; property styleId: AnsiString read mStyleId; - property x0: Integer read mX; - property y0: Integer read mY; - property height: Integer read mHeight; - property width: Integer read mWidth; + property scrollX: Integer read mScrollX write mScrollX; + property scrollY: Integer read mScrollY write mScrollY; + property x0: Integer read mX write mX; + property y0: Integer read mY write mY; + property width: Integer read mWidth write mWidth; + property height: Integer read mHeight write mHeight; property enabled: Boolean read getEnabled write setEnabled; property parent: TUIControl read mParent; property focused: Boolean read getFocused write setFocused; + property active: Boolean read getActive; property escClose: Boolean read mEscClose write mEscClose; - property eatKeys: Boolean read mEatKeys write mEatKeys; property cancel: Boolean read mCancel write mCancel; property defctl: Boolean read mDefault write mDefault; property canFocus: Boolean read getCanFocus write mCanFocus; @@ -250,17 +270,18 @@ type TUITopWindow = class(TUIControl) + private + type TXMode = (None, Drag, Scroll); + private mTitle: AnsiString; - mDragging: Boolean; + mDragScroll: TXMode; mDragStartX, mDragStartY: Integer; mWaitingClose: Boolean; mInClose: Boolean; mFreeOnClose: Boolean; // default: false mDoCenter: Boolean; // after layouting - - protected - procedure cacheStyle (root: TUIStyle); override; + mFitToScreen: Boolean; protected procedure activated (); override; @@ -270,12 +291,14 @@ type closeCB: TActionCB; // called after window was removed from ui window list public - constructor Create (const atitle: AnsiString; ax, ay: Integer; aw: Integer=-1; ah: Integer=-1); + constructor Create (const atitle: AnsiString); procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override; + procedure flFitToScreen (); // call this before layouting + procedure centerInScreen (); // `sx` and `sy` are screen coordinates @@ -287,56 +310,7 @@ type public property freeOnClose: Boolean read mFreeOnClose write mFreeOnClose; - end; - - - TUISimpleText = class(TUIControl) - private - type - PItem = ^TItem; - TItem = record - title: AnsiString; - centered: Boolean; - hline: Boolean; - end; - private - mItems: array of TItem; - - public - constructor Create (ax, ay: Integer); - destructor Destroy (); override; - - procedure appendItem (const atext: AnsiString; acentered: Boolean=false; ahline: Boolean=false); - - procedure drawControl (gx, gy: Integer); override; - - procedure mouseEvent (var ev: THMouseEvent); override; - end; - - - TUICBListBox = class(TUIControl) - private - type - PItem = ^TItem; - TItem = record - title: AnsiString; - varp: PBoolean; - actionCB: TActionCB; - end; - private - mItems: array of TItem; - mCurIndex: Integer; - - public - constructor Create (ax, ay: Integer); - destructor Destroy (); override; - - procedure appendItem (const atext: AnsiString; bv: PBoolean; aaction: TActionCB=nil); - - procedure drawControl (gx, gy: Integer); override; - - procedure mouseEvent (var ev: THMouseEvent); override; - procedure keyEvent (var ev: THKeyEvent); override; + property fitToScreen: Boolean read mFitToScreen write mFitToScreen; end; // ////////////////////////////////////////////////////////////////////// // @@ -344,6 +318,11 @@ type private mHasFrame: Boolean; mCaption: AnsiString; + mHAlign: Integer; // -1: left; 0: center; 1: right; default: left + + protected + procedure setCaption (const acap: AnsiString); + procedure setHasFrame (v: Boolean); public constructor Create (ahoriz: Boolean); @@ -356,15 +335,24 @@ type procedure mouseEvent (var ev: THMouseEvent); override; procedure keyEvent (var ev: THKeyEvent); override; + + public + property caption: AnsiString read mCaption write setCaption; + property hasFrame: Boolean read mHasFrame write setHasFrame; + property captionAlign: Integer read mHAlign write mHAlign; 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,29 +387,97 @@ 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); virtual; + public procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override; + procedure doAction (); override; + procedure drawControl (gx, gy: Integer); override; procedure mouseEvent (var ev: THMouseEvent); override; + procedure keyEventPost (var ev: THKeyEvent); override; + + public + property text: AnsiString read mText write setText; + property halign: Integer read mHAlign write mHAlign; + property valign: Integer read mVAlign write mVAlign; end; // ////////////////////////////////////////////////////////////////////// // TUIButton = class(TUITextLabel) + protected + procedure setText (const s: AnsiString); override; + public - constructor Create (const atext: AnsiString); + procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser + + procedure drawControl (gx, gy: Integer); override; + + procedure mouseEvent (var ev: THMouseEvent); override; + procedure keyEvent (var ev: THKeyEvent); override; + end; + + // ////////////////////////////////////////////////////////////////////// // + TUISwitchBox = class(TUITextLabel) + protected + mBoolVar: PBoolean; + mChecked: Boolean; + mIcon: TGxContext.TMarkIcon; + mSwitchColor: array[0..ClrIdxMax] of TGxRGBA; + protected + procedure cacheStyle (root: TUIStyle); override; + + procedure setText (const s: AnsiString); override; + + function getChecked (): Boolean; virtual; + procedure setChecked (v: Boolean); virtual; abstract; + + public procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override; @@ -430,6 +486,39 @@ type procedure mouseEvent (var ev: THMouseEvent); override; procedure keyEvent (var ev: THKeyEvent); override; + + procedure setVar (pvar: PBoolean); + + public + property checked: Boolean read getChecked write setChecked; + end; + + TUICheckBox = class(TUISwitchBox) + protected + procedure setChecked (v: Boolean); override; + + public + procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser + + procedure doAction (); override; + end; + + TUIRadioBox = class(TUISwitchBox) + private + mRadioGroup: AnsiString; + + protected + procedure setChecked (v: Boolean); override; + + public + procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser + + function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override; + + procedure doAction (); override; + + public + property radioGroup: AnsiString read mRadioGroup write mRadioGroup; //FIXME end; @@ -454,13 +543,14 @@ procedure uiLayoutCtl (ctl: TUIControl); // ////////////////////////////////////////////////////////////////////////// // var - gh_ui_scale: Single = 1.0; + fuiRenderScale: Single = 1.0; + uiContext: TGxContext = nil; implementation uses - gh_flexlay, + fui_flexlay, utils; @@ -546,6 +636,8 @@ begin if (ctl = nil) then exit; lay := TFlexLayouter.Create(); try + if (ctl is TUITopWindow) and (TUITopWindow(ctl).fitToScreen) then TUITopWindow(ctl).flFitToScreen(); + lay.setup(ctl); //lay.layout(); @@ -572,6 +664,18 @@ begin TUITopWindow(ctl).centerInScreen(); end; + // calculate full size + ctl.calcFullClientSize(); + + // fix focus + if (ctl.mParent = nil) then + begin + if (ctl.mFocused = nil) or (ctl.mFocused = ctl) or (not ctl.mFocused.enabled) then + begin + ctl.mFocused := ctl.findFirstFocus(); + end; + end; + finally FreeAndNil(lay); end; @@ -602,26 +706,26 @@ begin processKills(); if (evt.eaten) or (evt.cancelled) then exit; ev := evt; - ev.x := trunc(ev.x/gh_ui_scale); - ev.y := trunc(ev.y/gh_ui_scale); - ev.dx := trunc(ev.dx/gh_ui_scale); //FIXME - ev.dy := trunc(ev.dy/gh_ui_scale); //FIXME + ev.x := trunc(ev.x/fuiRenderScale); + ev.y := trunc(ev.y/fuiRenderScale); + ev.dx := trunc(ev.dx/fuiRenderScale); //FIXME + ev.dy := trunc(ev.dy/fuiRenderScale); //FIXME try 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; - if (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)].mEnabled) then uiTopList[High(uiTopList)].mouseEvent(ev); + if (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)].enabled) then uiTopList[High(uiTopList)].mouseEvent(ev); if (not ev.eaten) and (not ev.cancelled) and (ev.press) then begin for f := High(uiTopList) downto 0 do begin if uiTopList[f].toLocal(ev.x, ev.y, lx, ly) then begin - if (uiTopList[f].mEnabled) and (f <> High(uiTopList)) then + if (uiTopList[f].enabled) and (f <> High(uiTopList)) then begin uiTopList[High(uiTopList)].blurred(); ctmp := uiTopList[f]; @@ -650,10 +754,10 @@ begin processKills(); if (evt.eaten) or (evt.cancelled) then exit; ev := evt; - ev.x := trunc(ev.x/gh_ui_scale); - ev.y := trunc(ev.y/gh_ui_scale); + ev.x := trunc(ev.x/fuiRenderScale); + ev.y := trunc(ev.y/fuiRenderScale); try - if (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)].mEnabled) then uiTopList[High(uiTopList)].keyEvent(ev); + if (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)].enabled) then uiTopList[High(uiTopList)].keyEvent(ev); //if (ev.release) then begin ev.eat(); exit; end; finally if (ev.eaten) then evt.eat(); @@ -668,22 +772,22 @@ var ctl: TUIControl; begin processKills(); - glMatrixMode(GL_MODELVIEW); - glPushMatrix(); + //if (uiContext = nil) then uiContext := TGxContext.Create(); + gxSetContext(uiContext, fuiRenderScale); + uiContext.resetClip(); try - glLoadIdentity(); - glScalef(gh_ui_scale, gh_ui_scale, 1); for f := 0 to High(uiTopList) do begin ctl := uiTopList[f]; ctl.draw(); - cidx := ctl.getColorIndex; - //if (f <> High(uiTopList)) then darkenRect(ctl.x0, ctl.y0, ctl.width, ctl.height, 128); - if (ctl.mDarken[cidx] > 0) then darkenRect(ctl.x0, ctl.y0, ctl.width, ctl.height, ctl.mDarken[cidx]); + if (f <> High(uiTopList)) then + begin + cidx := ctl.getColorIndex; + uiContext.darkenRect(ctl.x0, ctl.y0, ctl.width, ctl.height, ctl.mDarken[cidx]); + end; end; finally - glMatrixMode(GL_MODELVIEW); - glPopMatrix(); + gxSetContext(nil); end; end; @@ -734,7 +838,7 @@ begin if (ctl is TUITopWindow) then begin try - if assigned(TUITopWindow(ctl).closeCB) then TUITopWindow(ctl).closeCB(ctl, 0); + if assigned(TUITopWindow(ctl).closeCB) then TUITopWindow(ctl).closeCB(ctl); finally if (TUITopWindow(ctl).mFreeOnClose) then scheduleKill(ctl); end; @@ -763,12 +867,18 @@ end; // ////////////////////////////////////////////////////////////////////////// // constructor TUIControl.Create (); begin +end; + + +procedure TUIControl.AfterConstruction (); +begin + inherited; mParent := nil; mId := ''; mX := 0; mY := 0; mWidth := 64; - mHeight := 8; + mHeight := uiContext.charHeight(' '); mFrameWidth := 0; mFrameHeight := 0; mEnabled := true; @@ -776,14 +886,14 @@ begin mChildren := nil; mFocused := nil; mEscClose := false; - mEatKeys := false; - scallowed := false; mDrawShadow := false; actionCB := nil; // layouter interface - //mDefSize := TLaySize.Create(64, 8); // default size + //mDefSize := TLaySize.Create(64, uiContext.charHeight(' ')); // default size mDefSize := TLaySize.Create(0, 0); // default size mMaxSize := TLaySize.Create(-1, -1); // maximum size + mPadding := TLaySize.Create(0, 0); + mNoPad := false; mFlex := 0; mHoriz := true; mCanWrap := false; @@ -797,16 +907,6 @@ begin end; -constructor TUIControl.Create (ax, ay, aw, ah: Integer); -begin - Create(); - mX := ax; - mY := ay; - mWidth := aw; - mHeight := ah; -end; - - destructor TUIControl.Destroy (); var f, c: Integer; @@ -834,8 +934,17 @@ 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 (not enabled) then begin result := ClrIdxDisabled; exit; end; + // top windows: no focus hack + if (self is TUITopWindow) then + begin + if (getActive) then begin result := ClrIdxActive; exit; end; + end + else + begin + // 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; + end; result := ClrIdxInactive; end; @@ -857,63 +966,51 @@ 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(666); // 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(666); // 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(666); end; // ////////////////////////////////////////////////////////////////////////// // function TUIControl.getDefSize (): TLaySize; inline; begin result := mLayDefSize; end; function TUIControl.getMaxSize (): TLaySize; inline; begin result := mLayMaxSize; end; +function TUIControl.getPadding (): TLaySize; inline; begin result := mPadding; end; function TUIControl.getFlex (): Integer; inline; begin result := mFlex; end; function TUIControl.isHorizBox (): Boolean; inline; begin result := mHoriz; end; -procedure TUIControl.setHorizBox (v: Boolean); inline; begin mHoriz := v; end; function TUIControl.canWrap (): Boolean; inline; begin result := mCanWrap; end; -procedure TUIControl.setCanWrap (v: Boolean); inline; begin mCanWrap := v; end; +function TUIControl.noPad (): Boolean; inline; begin result := mNoPad; end; function TUIControl.isLineStart (): Boolean; inline; begin result := mLineStart; end; -procedure TUIControl.setLineStart (v: Boolean); inline; begin mLineStart := v; end; function TUIControl.getAlign (): Integer; inline; begin result := mAlign; end; -procedure TUIControl.setAlign (v: Integer); inline; begin mAlign := v; end; function TUIControl.getExpand (): Boolean; inline; begin result := mExpand; end; -procedure TUIControl.setExpand (v: Boolean); inline; begin mExpand := v; end; function TUIControl.getHGroup (): AnsiString; inline; begin result := mHGroup; end; -procedure TUIControl.setHGroup (const v: AnsiString); inline; begin mHGroup := v; end; function TUIControl.getVGroup (): AnsiString; inline; begin result := mVGroup; end; -procedure TUIControl.setVGroup (const v: AnsiString); inline; begin mVGroup := v; end; +function TUIControl.getMargins (): TLayMargins; inline; begin result := TLayMargins.Create(mFrameHeight, mFrameWidth, mFrameHeight, mFrameWidth); end; -function TUIControl.getMargins (): TLayMargins; inline; +procedure TUIControl.setActualSizePos (constref apos: TLayPos; constref asize: TLaySize); inline; begin - result := TLayMargins.Create(mFrameHeight, mFrameWidth, mFrameHeight, mFrameWidth); -end; - -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 @@ -958,6 +1055,37 @@ begin par.expectDelim(ech); end; +function TUIControl.parsePadding (par: TTextParser): TLaySize; +begin + result := parseSize(par); +end; + +function TUIControl.parseHPadding (par: TTextParser; def: Integer): TLaySize; +begin + if (par.isInt) then + begin + result.h := def; + result.w := par.expectInt(); + end + else + begin + result := parsePadding(par); + end; +end; + +function TUIControl.parseVPadding (par: TTextParser; def: Integer): TLaySize; +begin + if (par.isInt) then + begin + result.w := def; + result.h := par.expectInt(); + end + else + begin + result := parsePadding(par); + end; +end; + function TUIControl.parseBool (par: TTextParser): Boolean; begin result := @@ -1135,6 +1263,9 @@ begin if (strEquCI1251(prname, 'defheight')) or (strEquCI1251(prname, 'height')) then begin mDefSize.h := par.expectInt(); exit; end; if (strEquCI1251(prname, 'maxwidth')) then begin mMaxSize.w := par.expectInt(); exit; end; if (strEquCI1251(prname, 'maxheight')) then begin mMaxSize.h := par.expectInt(); exit; end; + // padding + if (strEquCI1251(prname, 'padding')) then begin mPadding := parsePadding(par); exit; end; + if (strEquCI1251(prname, 'nopad')) then begin mNoPad := true; exit; end; // flags if (strEquCI1251(prname, 'wrap')) then begin mCanWrap := parseBool(par); exit; end; if (strEquCI1251(prname, 'linestart')) then begin mLineStart := parseBool(par); exit; end; @@ -1144,11 +1275,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; @@ -1158,6 +1289,7 @@ end; // ////////////////////////////////////////////////////////////////////////// // procedure TUIControl.activated (); begin + makeVisibleInParent(); end; @@ -1167,6 +1299,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,25 +1361,45 @@ 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; begin tl := topLevel; - if not v then + if (not v) then begin if (tl.mFocused = self) then begin - tl.blurred(); - tl.mFocused := tl.findNextFocus(self); + blurred(); // this will reset grab, but still... + if (uiGrabCtl = self) then uiGrabCtl := nil; + tl.mFocused := tl.findNextFocus(self, true); if (tl.mFocused = self) then tl.mFocused := nil; + if (tl.mFocused <> nil) then tl.mFocused.activated(); end; exit; end; - if (not mEnabled) or (not canFocus) then exit; + if (not canFocus) then exit; if (tl.mFocused <> self) then begin - if (tl.mFocused <> nil) and (tl.mFocused <> nil) then tl.mFocused.blurred(); + if (tl.mFocused <> nil) then tl.mFocused.blurred(); tl.mFocused := self; if (uiGrabCtl <> self) then uiGrabCtl := nil; activated(); @@ -1240,7 +1409,7 @@ end; function TUIControl.getCanFocus (): Boolean; inline; begin - result := (mCanFocus) and (mWidth > 0) and (mHeight > 0); + result := (getEnabled) and (mCanFocus) and (mWidth > 0) and (mHeight > 0); end; @@ -1258,17 +1427,23 @@ 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 := true; // hack + end + else + begin + result := mParent.toLocal(x, y); + Inc(x, mParent.mScrollX); + Inc(y, mParent.mScrollY); + Dec(x, mX); + Dec(y, mY); + if result then result := (x >= 0) and (y >= 0) and (x < mParent.mWidth) and (y < mParent.mHeight); end; - result := (x >= 0) and (y >= 0) and (x < mWidth) and (y < mHeight); + if result then 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 +1453,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 +1473,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; @@ -1306,7 +1507,7 @@ var f: Integer; begin result := nil; - if (not allowDisabled) and (not mEnabled) then exit; + if (not allowDisabled) and (not enabled) then exit; if (mWidth < 1) or (mHeight < 1) then exit; if not toLocal(x, y, lx, ly) then exit; for f := High(mChildren) downto 0 do @@ -1318,6 +1519,40 @@ 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; + + +procedure TUIControl.makeVisibleInParent (); +var + sy, ey, cy: Integer; + p: TUIControl; +begin + if (mWidth < 1) or (mHeight < 1) then exit; + p := mParent; + if (p = nil) then exit; + if (p.mFullSize.w < 1) or (p.mFullSize.h < 1) then + begin + p.mScrollX := 0; + p.mScrollY := 0; + exit; + end; + p.makeVisibleInParent(); + cy := mY-p.mFrameHeight; + sy := p.mScrollY; + ey := sy+(p.mHeight-p.mFrameHeight*2); + if (cy < sy) then + begin + p.mScrollY := nmax(0, cy); + end + else if (cy+mHeight > ey) then + begin + p.mScrollY := nmax(0, cy+mHeight-(p.mHeight-p.mFrameHeight*2)); + end; +end; + + +// ////////////////////////////////////////////////////////////////////////// // function TUIControl.prevSibling (): TUIControl; var f: Integer; @@ -1369,7 +1604,7 @@ begin result := mChildren[f].findFirstFocus(); if (result <> nil) then exit; end; - if canFocus then result := self; + if (canFocus) then result := self; end; end; @@ -1386,51 +1621,78 @@ begin result := mChildren[f].findLastFocus(); if (result <> nil) then exit; end; - if canFocus then result := self; + if (canFocus) then result := self; end; end; -function TUIControl.findNextFocus (cur: TUIControl): TUIControl; -begin - result := nil; - if enabled then +function TUIControl.findNextFocus (cur: TUIControl; wrap: Boolean): TUIControl; +var + curHit: Boolean = false; + + function checkFocus (ctl: TUIControl): Boolean; begin - if not isMyChild(cur) then cur := nil; - if (cur = nil) then begin result := findFirstFocus(); exit; end; - result := cur.findFirstFocus(); - if (result <> nil) and (result <> cur) then exit; - while true do + if curHit then begin - cur := cur.nextSibling; - if (cur = nil) then break; - result := cur.findFirstFocus(); - if (result <> nil) then exit; + result := (ctl.canFocus); + end + else + begin + curHit := (ctl = cur); + result := false; // don't stop end; - result := findFirstFocus(); end; -end; - -function TUIControl.findPrevFocus (cur: TUIControl): TUIControl; begin result := nil; if enabled then begin - if not isMyChild(cur) then cur := nil; - if (cur = nil) then begin result := findLastFocus(); exit; end; - //FIXME! - result := cur.findLastFocus(); - if (result <> nil) and (result <> cur) then exit; - while true do + if not isMyChild(cur) then begin - cur := cur.prevSibling; - if (cur = nil) then break; - result := cur.findLastFocus(); - if (result <> nil) then exit; - end; - result := findLastFocus(); - end; + result := findFirstFocus(); + end + else + begin + result := forEachControl(checkFocus); + if (result = nil) and (wrap) then result := findFirstFocus(); + end; + end; +end; + + +function TUIControl.findPrevFocus (cur: TUIControl; wrap: Boolean): TUIControl; +var + lastCtl: TUIControl = nil; + + function checkFocus (ctl: TUIControl): Boolean; + begin + if (ctl = cur) then + begin + result := true; + end + else + begin + result := false; + if (ctl.canFocus) then lastCtl := ctl; + end; + end; + +begin + result := nil; + if enabled then + begin + if not isMyChild(cur) then + begin + result := findLastFocus(); + end + else + begin + forEachControl(checkFocus); + if (lastCtl = nil) and (wrap) then lastCtl := findLastFocus(); + result := lastCtl; + //if (lastCtl <> nil) then writeln('ctl<', lastCtl.className, '>: {', lastCtl.id, '}'); + end; + end; end; @@ -1438,11 +1700,14 @@ function TUIControl.findDefaulControl (): TUIControl; var ctl: TUIControl; begin - if mDefault then begin result := self; exit; end; - for ctl in mChildren do + if (enabled) 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 +1716,14 @@ function TUIControl.findCancelControl (): TUIControl; var ctl: TUIControl; begin - if mCancel then begin result := self; exit; end; - for ctl in mChildren do + if (enabled) 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 +1761,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; @@ -1505,65 +1826,62 @@ end; procedure TUIControl.doAction (); begin - if assigned(actionCB) then actionCB(self, 0); + if assigned(actionCB) then actionCB(self); end; // ////////////////////////////////////////////////////////////////////////// // -procedure TUIControl.setScissorGLInternal (x, y, w, h: Integer); -begin - if not scallowed then exit; - x := trunc(x*gh_ui_scale); - y := trunc(y*gh_ui_scale); - w := trunc(w*gh_ui_scale); - h := trunc(h*gh_ui_scale); - scis.combineRect(x, y, w, h); -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 + 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); + uiContext.clip := TGxRect.Create(0, 0, 0, 0); exit; end; - toGlobal(lx, ly, gx, gy); - setScissorGLInternal(gx, gy, lw, lh); -end; -procedure TUIControl.resetScissor (fullArea: Boolean); inline; -begin - if not scallowed then exit; - if (fullArea) then - begin - setScissor(0, 0, mWidth, mHeight); - end - else + getDrawRect(gx, gy, wdt, hgt); + + toGlobal(lx, ly, cgx, cgy); + if (not intersectRect(gx, gy, wdt, hgt, cgx, cgy, lw, lh)) then begin - setScissor(mFrameWidth, mFrameHeight, mWidth-mFrameWidth*2, mHeight-mFrameHeight*2); + uiContext.clip := TGxRect.Create(0, 0, 0, 0); + exit; end; + + uiContext.clip := savedClip; + uiContext.combineClip(TGxRect.Create(gx, gy, wdt, hgt)); + //uiContext.clip := TGxRect.Create(gx, gy, wdt, hgt); end; + // ////////////////////////////////////////////////////////////////////////// // procedure TUIControl.draw (); var f: Integer; gx, gy: Integer; + + procedure resetScissor (fullArea: Boolean); inline; + begin + uiContext.clip := savedClip; + if (fullArea) then + begin + setScissor(0, 0, mWidth, mHeight); + end + else + begin + setScissor(mFrameWidth, mFrameHeight, mWidth-mFrameWidth*2, mHeight-mFrameHeight*2); + end; + end; + begin - if (mWidth < 1) or (mHeight < 1) then exit; + if (mWidth < 1) or (mHeight < 1) or (uiContext = nil) or (not uiContext.active) 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 + savedClip := uiContext.clip; try - scallowed := true; resetScissor(true); // full area drawControl(gx, gy); resetScissor(false); // client area @@ -1571,8 +1889,7 @@ begin resetScissor(true); // full area drawControlPost(gx, gy); finally - scis.restore(); - scallowed := false; + uiContext.clip := savedClip; end; end; @@ -1584,11 +1901,12 @@ end; procedure TUIControl.drawControlPost (gx, gy: Integer); begin // shadow - if mDrawShadow and (mWidth > 0) and (mHeight > 0) then + if (mParent = nil) and (mDrawShadow) and (mWidth > 0) and (mHeight > 0) then begin - setScissorGLInternal(gx+8, gy+8, mWidth, mHeight); - darkenRect(gx+mWidth, gy+8, 8, mHeight, 128); - darkenRect(gx+8, gy+mHeight, mWidth-8, 8, 128); + //setScissorGLInternal(gx+8, gy+8, mWidth, mHeight); + uiContext.resetClip(); + uiContext.darkenRect(gx+mWidth, gy+8, 8, mHeight, 128); + uiContext.darkenRect(gx+8, gy+mHeight, mWidth-8, 8, 128); end; end; @@ -1598,7 +1916,7 @@ procedure TUIControl.mouseEvent (var ev: THMouseEvent); var ctl: TUIControl; begin - if (not mEnabled) then exit; + if (not enabled) then exit; if (mWidth < 1) or (mHeight < 1) then exit; ctl := controlAtXY(ev.x, ev.y); if (ctl = nil) then exit; @@ -1613,29 +1931,58 @@ end; procedure TUIControl.keyEvent (var ev: THKeyEvent); + + function doPreKey (ctl: TUIControl): Boolean; + begin + if (not ctl.enabled) 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.enabled) 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 (not enabled) 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 + if (topLevel.mFocused <> self) and isMyChild(topLevel.mFocused) and (topLevel.mFocused.enabled) then begin - topLevel.mFocused.keyEvent(ev); + // bubble keyboard event + 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 - ctl := findPrevFocus(mFocused); - if (ctl <> mFocused) then ctl.setFocused(true); + ctl := findPrevFocus(mFocused, true); + if (ctl <> nil) and (ctl <> mFocused) then ctl.setFocused(true); ev.eat(); exit; end; if (ev = 'Tab') then begin - ctl := findNextFocus(mFocused); - if (ctl <> mFocused) then ctl.setFocused(true); + ctl := findNextFocus(mFocused, true); + if (ctl <> nil) and (ctl <> mFocused) then ctl.setFocused(true); ev.eat(); exit; end; @@ -1668,35 +2015,53 @@ 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; // ////////////////////////////////////////////////////////////////////////// // -constructor TUITopWindow.Create (const atitle: AnsiString; ax, ay: Integer; aw: Integer=-1; ah: Integer=-1); +constructor TUITopWindow.Create (const atitle: AnsiString); begin - inherited Create(ax, ay, aw, ah); - mFrameWidth := 8; - mFrameHeight := 8; + inherited Create(); mTitle := atitle; end; + procedure TUITopWindow.AfterConstruction (); begin - inherited AfterConstruction(); - if (mWidth < mFrameWidth*2+3*8) then mWidth := mFrameWidth*2+3*8; + inherited; + mFitToScreen := true; + mFrameWidth := 8; + mFrameHeight := 8; + if (mWidth < mFrameWidth*2+uiContext.iconWinWidth(TGxContext.TWinIcon.Close)) then mWidth := mFrameWidth*2+uiContext.iconWinWidth(TGxContext.TWinIcon.Close); if (mHeight < mFrameHeight*2) then mHeight := mFrameHeight*2; if (Length(mTitle) > 0) then begin - if (mWidth < Length(mTitle)*8+mFrameWidth*2+3*8) then mWidth := Length(mTitle)*8+mFrameWidth*2+3*8; + if (mWidth < uiContext.textWidth(mTitle)+mFrameWidth*2+uiContext.iconWinWidth(TGxContext.TWinIcon.Close)) then + begin + mWidth := uiContext.textWidth(mTitle)+mFrameWidth*2+uiContext.iconWinWidth(TGxContext.TWinIcon.Close); + end; end; - mDragging := false; + mCanFocus := false; + mDragScroll := TXMode.None; mDrawShadow := true; mWaitingClose := false; mInClose := false; closeCB := nil; - mCtl4Style := ''; + mCtl4Style := 'window'; end; @@ -1727,9 +2092,13 @@ begin end; -procedure TUITopWindow.cacheStyle (root: TUIStyle); +procedure TUITopWindow.flFitToScreen (); +var + nsz: TLaySize; begin - inherited cacheStyle(root); + nsz := TLaySize.Create(trunc(fuiScrWdt/fuiRenderScale)-mFrameWidth*2-6, trunc(fuiScrHgt/fuiRenderScale)-mFrameHeight*2-6); + if (mMaxSize.w < 1) then mMaxSize.w := nsz.w; + if (mMaxSize.h < 1) then mMaxSize.h := nsz.h; end; @@ -1737,45 +2106,71 @@ procedure TUITopWindow.centerInScreen (); begin if (mWidth > 0) and (mHeight > 0) then begin - mX := trunc((gScrWidth/gh_ui_scale-mWidth)/2); - mY := trunc((gScrHeight/gh_ui_scale-mHeight)/2); + mX := trunc((fuiScrWdt/fuiRenderScale-mWidth)/2); + mY := trunc((fuiScrHgt/fuiRenderScale-mHeight)/2); end; end; procedure TUITopWindow.drawControl (gx, gy: Integer); begin - fillRect(gx, gy, mWidth, mHeight, mBackColor[getColorIndex]); + uiContext.color := mBackColor[getColorIndex]; + uiContext.fillRect(gx, gy, mWidth, mHeight); end; procedure TUITopWindow.drawControlPost (gx, gy: Integer); var cidx: Integer; - tx: Integer; + tx, hgt, sbhgt, iwdt: Integer; begin cidx := getColorIndex; - if mDragging then + if (mDragScroll = TXMode.Drag) then begin - drawRectUI(mX+4, mY+4, mWidth-8, mHeight-8, mFrameColor[cidx]); + uiContext.color := mFrameColor[cidx]; + uiContext.rect(gx+4, gy+4, mWidth-8, mHeight-8); 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]); - 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]); - end; + uiContext.color := mFrameColor[cidx]; + uiContext.rect(gx+3, gy+3, mWidth-6, mHeight-6); + uiContext.rect(gx+5, gy+5, mWidth-10, mHeight-10); + // 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; + uiContext.fillRect(gx+mWidth-mFrameWidth+1, gy+7, mFrameWidth-3, sbhgt); + 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); + uiContext.darkenRect(gx+mWidth-mFrameWidth+1, gy+7+hgt, mFrameWidth-3, sbhgt, 128); + end; + end; + // frame icon + iwdt := uiContext.iconWinWidth(TGxContext.TWinIcon.Close); + setScissor(mFrameWidth, 0, iwdt, 8); + uiContext.color := mBackColor[cidx]; + uiContext.fillRect(gx+mFrameWidth, gy, iwdt, 8); + uiContext.color := mFrameIconColor[cidx]; + uiContext.drawIconWin(TGxContext.TWinIcon.Close, gx+mFrameWidth, gy, mInClose); + 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]); + iwdt := uiContext.iconWinWidth(TGxContext.TWinIcon.Close); + setScissor(mFrameWidth+iwdt, 0, mWidth-mFrameWidth*2-iwdt, 8); + tx := (gx+iwdt)+((mWidth-iwdt)-uiContext.textWidth(mTitle)) div 2; + uiContext.color := mBackColor[cidx]; + uiContext.fillRect(tx-3, gy, uiContext.textWidth(mTitle)+3+2, 8); + uiContext.color := mFrameTextColor[cidx]; + uiContext.drawText(tx, gy, mTitle); end; + // shadow inherited drawControlPost(gx, gy); end; @@ -1785,17 +2180,18 @@ begin if (mFocused = nil) or (mFocused = self) then begin mFocused := findFirstFocus(); - if (mFocused <> nil) and (mFocused <> self) then mFocused.activated(); end; + if (mFocused <> nil) and (mFocused <> self) then mFocused.activated(); inherited; end; procedure TUITopWindow.blurred (); begin - mDragging := false; + mDragScroll := TXMode.None; mWaitingClose := false; mInClose := false; + if (mFocused <> nil) and (mFocused <> self) then mFocused.blurred(); inherited; end; @@ -1803,7 +2199,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 enabled) {or (not getFocused)} then exit; if (ev = 'M-F3') then begin if (not assigned(closeRequestCB)) or (closeRequestCB(self)) then @@ -1819,17 +2215,43 @@ end; procedure TUITopWindow.mouseEvent (var ev: THMouseEvent); var lx, ly: Integer; + hgt, sbhgt: Integer; begin - if (not mEnabled) then exit; + if (not enabled) 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; @@ -1841,7 +2263,7 @@ begin if (ly < 8) then begin uiGrabCtl := self; - if (lx >= mFrameWidth) and (lx < mFrameWidth+3*8) then + if (lx >= mFrameWidth) and (lx < mFrameWidth+uiContext.iconWinWidth(TGxContext.TWinIcon.Close)) then begin //uiRemoveWindow(self); mWaitingClose := true; @@ -1849,17 +2271,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(); @@ -1871,7 +2309,7 @@ begin begin if mWaitingClose then begin - if (lx >= mFrameWidth) and (lx < mFrameWidth+3*8) then + if (lx >= mFrameWidth) and (lx < mFrameWidth+uiContext.iconWinWidth(TGxContext.TWinIcon.Close)) then begin if (not assigned(closeRequestCB)) or (closeRequestCB(self)) then begin @@ -1889,7 +2327,7 @@ begin begin if mWaitingClose then begin - mInClose := (lx >= mFrameWidth) and (lx < mFrameWidth+3*8); + mInClose := (lx >= mFrameWidth) and (lx < mFrameWidth+uiContext.iconWinWidth(TGxContext.TWinIcon.Close)); ev.eat(); exit; end; @@ -1906,441 +2344,426 @@ end; // ////////////////////////////////////////////////////////////////////////// // -constructor TUISimpleText.Create (ax, ay: Integer); +constructor TUIBox.Create (ahoriz: Boolean); begin - mItems := nil; - inherited Create(ax, ay, 4, 4); + inherited Create(); + mHoriz := ahoriz; end; -destructor TUISimpleText.Destroy (); +procedure TUIBox.AfterConstruction (); begin - mItems := nil; inherited; + mCanFocus := false; + mHAlign := -1; // left + mCtl4Style := 'box'; end; -procedure TUISimpleText.appendItem (const atext: AnsiString; acentered: Boolean=false; ahline: Boolean=false); -var - it: PItem; +procedure TUIBox.setCaption (const acap: AnsiString); +begin + mCaption := acap; + mDefSize := TLaySize.Create(uiContext.textWidth(mCaption)+3, uiContext.textHeight(mCaption)); +end; + + +procedure TUIBox.setHasFrame (v: Boolean); +begin + mHasFrame := v; + if (mHasFrame) then begin mFrameWidth := 8; mFrameHeight := 8; end else begin mFrameWidth := 0; mFrameHeight := 0; end; + if (mHasFrame) then mNoPad := true; +end; + + +function TUIBox.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; begin - if (Length(atext)*8+3*8+2 > mWidth) then mWidth := Length(atext)*8+3*8+2; - SetLength(mItems, Length(mItems)+1); - it := @mItems[High(mItems)]; - it.title := atext; - it.centered := acentered; - it.hline := ahline; - if (Length(mItems)*8 > mHeight) then mHeight := Length(mItems)*8; + if (parseOrientation(prname, par)) then begin result := true; exit; end; + if (strEquCI1251(prname, 'padding')) then + begin + if (mHoriz) then mPadding := parseHPadding(par, 0) else mPadding := parseVPadding(par, 0); + result := true; + exit; + end; + if (strEquCI1251(prname, 'frame')) then + begin + setHasFrame(parseBool(par)); + result := true; + exit; + end; + if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then + begin + setCaption(par.expectIdOrStr(true)); + result := true; + exit; + end; + if (strEquCI1251(prname, 'textalign')) or (strEquCI1251(prname, 'text-align')) then + begin + mHAlign := parseHAlign(par); + result := true; + exit; + end; + if (strEquCI1251(prname, 'children')) then + begin + parseChildren(par); + result := true; + exit; + end; + result := inherited parseProperty(prname, par); end; -procedure TUISimpleText.drawControl (gx, gy: Integer); +procedure TUIBox.drawControl (gx, gy: Integer); var - f, tx: Integer; - it: PItem; - r, g, b: Integer; -begin - 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; - 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)); - end - else if (tx-3 > gx+4) then - 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)); - end; + cidx: Integer; + xpos: Integer; +begin + cidx := getColorIndex; + uiContext.color := mBackColor[cidx]; + uiContext.fillRect(gx, gy, mWidth, mHeight); + if mHasFrame then + begin + // draw frame + uiContext.color := mFrameColor[cidx]; + uiContext.rect(gx+3, gy+3, mWidth-6, mHeight-6); + end; + // draw caption + if (Length(mCaption) > 0) then + begin + if (mHAlign < 0) then xpos := 3 + else if (mHAlign > 0) then xpos := mWidth-mFrameWidth*2-uiContext.textWidth(mCaption) + else xpos := (mWidth-mFrameWidth*2-uiContext.textWidth(mCaption)) div 2; + xpos += gx+mFrameWidth; + + setScissor(mFrameWidth+1, 0, mWidth-mFrameWidth-2, 8); + if mHasFrame then + begin + uiContext.color := mBackColor[cidx]; + uiContext.fillRect(xpos-3, gy, uiContext.textWidth(mCaption)+4, 8); end; - drawText8(tx, gy, it.title, TGxRGBA.Create(r, g, b)); - Inc(gy, 8); + uiContext.color := mFrameTextColor[cidx]; + uiContext.drawText(xpos, gy, mCaption); end; end; -procedure TUISimpleText.mouseEvent (var ev: THMouseEvent); +procedure TUIBox.mouseEvent (var ev: THMouseEvent); var lx, ly: Integer; begin inherited mouseEvent(ev); - if (not ev.eaten) and (not ev.cancelled) and (mEnabled) and toLocal(ev.x, ev.y, lx, ly) then + if (not ev.eaten) and (not ev.cancelled) and (enabled) and toLocal(ev.x, ev.y, lx, ly) then begin ev.eat(); end; end; -// ////////////////////////////////////////////////////////////////////////// // -constructor TUICBListBox.Create (ax, ay: Integer); +procedure TUIBox.keyEvent (var ev: THKeyEvent); +var + dir: Integer = 0; + cur, ctl: TUIControl; begin - mItems := nil; - mCurIndex := -1; - inherited Create(ax, ay, 4, 4); + inherited keyEvent(ev); + if (ev.eaten) or (ev.cancelled) or (not ev.press) or (not enabled) 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, true) else ctl := findNextFocus(cur, true); + //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; -destructor TUICBListBox.Destroy (); +// ////////////////////////////////////////////////////////////////////////// // +constructor TUIHBox.Create (); begin - mItems := nil; - inherited; end; -procedure TUICBListBox.appendItem (const atext: AnsiString; bv: PBoolean; aaction: TActionCB=nil); -var - it: PItem; +procedure TUIHBox.AfterConstruction (); begin - if (Length(atext)*8+3*8+2 > mWidth) then mWidth := Length(atext)*8+3*8+2; - SetLength(mItems, Length(mItems)+1); - it := @mItems[High(mItems)]; - it.title := atext; - it.varp := bv; - it.actionCB := aaction; - if (Length(mItems)*8 > mHeight) then mHeight := Length(mItems)*8; - if (mCurIndex < 0) then mCurIndex := 0; + inherited; + mHoriz := true; end; -procedure TUICBListBox.drawControl (gx, gy: Integer); -var - f, tx: Integer; - it: PItem; +// ////////////////////////////////////////////////////////////////////////// // +constructor TUIVBox.Create (); begin - 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 (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)); - 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)); - end; - drawText8(tx, gy, it.title, TGxRGBA.Create(255, 255, 255)); - end - else - begin - drawHLine(gx+4, gy+3, mWidth-8, TGxRGBA.Create(255, 255, 255)); - end; - Inc(gy, 8); - end; end; -procedure TUICBListBox.mouseEvent (var ev: THMouseEvent); -var - lx, ly: Integer; - it: PItem; +procedure TUIVBox.AfterConstruction (); begin - inherited mouseEvent(ev); - if (not ev.eaten) and (not ev.cancelled) and (mEnabled) and toLocal(ev.x, ev.y, lx, ly) then - begin - ev.eat(); - if (ev = 'lmb') then - begin - ly := ly div 8; - if (ly >= 0) and (ly < Length(mItems)) then - begin - it := @mItems[ly]; - if (it.varp <> nil) then - begin - mCurIndex := ly; - it.varp^ := not it.varp^; - if assigned(it.actionCB) then it.actionCB(self, Integer(it.varp^)); - if assigned(actionCB) then actionCB(self, ly); - end; - end; - end; - end; + inherited; + mHoriz := false; end; -procedure TUICBListBox.keyEvent (var ev: THKeyEvent); -var - it: PItem; +// ////////////////////////////////////////////////////////////////////////// // +procedure TUISpan.AfterConstruction (); begin - inherited keyEvent(ev); - if (ev.eaten) or (ev.cancelled) or (not mEnabled) or (not getFocused) then exit; - //result := true; - if (ev = 'Home') or (ev = 'PageUp') then - begin - ev.eat(); - mCurIndex := 0; - end; - if (ev = 'End') or (ev = 'PageDown') then - begin - ev.eat(); - mCurIndex := High(mItems); - end; - if (ev = 'Up') then - begin - ev.eat(); - if (Length(mItems) > 0) then - begin - if (mCurIndex < 0) then mCurIndex := Length(mItems); - while (mCurIndex > 0) do - begin - Dec(mCurIndex); - if (mItems[mCurIndex].varp <> nil) then break; - end; - end - else - begin - mCurIndex := -1; - end; - end; - if (ev = 'Down') then - begin - ev.eat(); - if (Length(mItems) > 0) then - begin - if (mCurIndex < 0) then mCurIndex := -1; - while (mCurIndex < High(mItems)) do - begin - Inc(mCurIndex); - if (mItems[mCurIndex].varp <> nil) then break; - end; - end - else - begin - mCurIndex := -1; - end; - end; - if (ev = 'Space') or (ev = 'Enter') then - begin - ev.eat(); - if (mCurIndex >= 0) and (mCurIndex < Length(mItems)) and (mItems[mCurIndex].varp <> nil) then - begin - it := @mItems[mCurIndex]; - it.varp^ := not it.varp^; - if assigned(it.actionCB) then it.actionCB(self, Integer(it.varp^)); - if assigned(actionCB) then actionCB(self, mCurIndex); - end; - end; + inherited; + mExpand := true; + mCanFocus := false; + mNoPad := true; + mCtl4Style := 'span'; end; -// ////////////////////////////////////////////////////////////////////////// // -constructor TUIBox.Create (ahoriz: Boolean); +function TUISpan.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; begin - inherited Create(); - mHoriz := ahoriz; + if (parseOrientation(prname, par)) then begin result := true; exit; end; + result := inherited parseProperty(prname, par); end; -procedure TUIBox.AfterConstruction (); +procedure TUISpan.drawControl (gx, gy: Integer); +begin +end; + + +// ////////////////////////////////////////////////////////////////////// // +procedure TUILine.AfterConstruction (); begin - inherited AfterConstruction(); + inherited; mCanFocus := false; - mCtl4Style := 'box'; + mExpand := true; + mCanFocus := false; + mCtl4Style := 'line'; end; -function TUIBox.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; +function TUILine.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; begin if (parseOrientation(prname, par)) then begin result := true; exit; end; - if (strEquCI1251(prname, 'frame')) then - begin - mHasFrame := parseBool(par); - if (mHasFrame) then begin mFrameWidth := 8; mFrameHeight := 8; end else begin mFrameWidth := 0; mFrameHeight := 0; end; - result := true; - exit; - end; - if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then - begin - mCaption := par.expectIdOrStr(true); - mDefSize := TLaySize.Create(Length(mCaption)*8+3, 8); - result := true; - exit; - end; - if (strEquCI1251(prname, 'children')) then - begin - parseChildren(par); - result := true; - exit; - end; result := inherited parseProperty(prname, par); end; -procedure TUIBox.drawControl (gx, gy: Integer); +procedure TUILine.drawControl (gx, gy: Integer); var cidx: Integer; - tx: Integer; begin cidx := getColorIndex; - fillRect(gx, gy, mWidth, mHeight, mBackColor[cidx]); - if mHasFrame then - begin - // draw frame - drawRectUI(gx+3, gy+3, mWidth-6, mHeight-6, mFrameColor[cidx]); - end; - // draw caption - if (Length(mCaption) > 0) then - begin - setScissor(mFrameWidth+1, 0, mWidth-mFrameWidth-2, 8); - tx := gx+((mWidth-Length(mCaption)*8) div 2); - if mHasFrame then fillRect(tx-2, gy, Length(mCaption)*8+3, 8, mBackColor[cidx]); - drawText8(tx, gy, mCaption, mFrameTextColor[cidx]); - end; -end; - - -procedure TUIBox.mouseEvent (var ev: THMouseEvent); -var - lx, ly: Integer; -begin - inherited mouseEvent(ev); - if (not ev.eaten) and (not ev.cancelled) and (mEnabled) and toLocal(ev.x, ev.y, lx, ly) then - begin - ev.eat(); - end; -end; - - -//TODO: navigation with arrow keys, according to box orientation -procedure TUIBox.keyEvent (var ev: THKeyEvent); -begin - inherited keyEvent(ev); - if (ev.eaten) or (ev.cancelled) or (not mEnabled) or (not getFocused) then exit; + uiContext.color := mTextColor[cidx]; + if mHoriz then uiContext.hline(gx, gy+(mHeight div 2), mWidth) + else uiContext.vline(gx+(mWidth div 2), gy, mHeight); end; // ////////////////////////////////////////////////////////////////////////// // -procedure TUIHBox.AfterConstruction (); +procedure TUIHLine.AfterConstruction (); begin - inherited AfterConstruction(); + inherited; mHoriz := true; + mDefSize.h := 7; end; // ////////////////////////////////////////////////////////////////////////// // -procedure TUIVBox.AfterConstruction (); +procedure TUIVLine.AfterConstruction (); begin - inherited AfterConstruction(); + inherited; mHoriz := false; + mDefSize.w := 7; end; // ////////////////////////////////////////////////////////////////////////// // -procedure TUISpan.AfterConstruction (); +procedure TUIStaticText.AfterConstruction (); begin - inherited AfterConstruction(); - mExpand := true; + inherited; mCanFocus := false; - mCtl4Style := 'span'; -end; - - -function TUISpan.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; -begin - if (parseOrientation(prname, par)) then begin result := true; exit; end; - result := inherited parseProperty(prname, par); -end; - - -procedure TUISpan.drawControl (gx, gy: Integer); -begin + mHAlign := -1; + mVAlign := 0; + mHoriz := true; // nobody cares + mHeader := false; + mLine := false; + mDefSize.h := uiContext.charHeight(' '); + mCtl4Style := 'static'; end; -// ////////////////////////////////////////////////////////////////////// // -procedure TUILine.AfterConstruction (); +procedure TUIStaticText.setText (const atext: AnsiString); begin - inherited AfterConstruction(); - mExpand := true; - mCanFocus := false; - mCtl4Style := 'line'; + mText := atext; + mDefSize := TLaySize.Create(uiContext.textWidth(mText), uiContext.textHeight(mText)); end; -function TUILine.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; +function TUIStaticText.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; begin - if (parseOrientation(prname, par)) then begin result := true; exit; end; + 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')) or (strEquCI1251(prname, 'text-align')) 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 TUILine.drawControl (gx, gy: Integer); +procedure TUIStaticText.drawControl (gx, gy: Integer); var + xpos, ypos: Integer; cidx: Integer; begin cidx := getColorIndex; - if mHoriz then - begin - drawHLine(gx, gy+(mHeight div 2), mWidth, mTextColor[cidx]); - end - else + uiContext.color := mBackColor[cidx]; + uiContext.fillRect(gx, gy, mWidth, mHeight); + + if (mHAlign < 0) then xpos := 0 + else if (mHAlign > 0) then xpos := mWidth-uiContext.textWidth(mText) + else xpos := (mWidth-uiContext.textWidth(mText)) div 2; + + if (Length(mText) > 0) then begin - drawVLine(gx+(mWidth div 2), gy, mHeight, mTextColor[cidx]); + if (mHeader) then uiContext.color := mFrameTextColor[cidx] else uiContext.color := mTextColor[cidx]; + + if (mVAlign < 0) then ypos := 0 + else if (mVAlign > 0) then ypos := mHeight-uiContext.textHeight(mText) + else ypos := (mHeight-uiContext.textHeight(mText)) div 2; + + uiContext.drawText(gx+xpos, gy+ypos, mText); end; -end; + if (mLine) then + begin + if (mHeader) then uiContext.color := mFrameColor[cidx] else uiContext.color := mTextColor[cidx]; -// ////////////////////////////////////////////////////////////////////////// // -procedure TUIHLine.AfterConstruction (); -begin - inherited AfterConstruction(); - mHoriz := true; - mDefSize.h := 1; + 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 + uiContext.hline(gx, ypos, mWidth); + end + else + begin + uiContext.hline(gx, ypos, xpos-1); + uiContext.hline(gx+xpos+uiContext.textWidth(mText), ypos, mWidth); + end; + end; end; // ////////////////////////////////////////////////////////////////////////// // -procedure TUIVLine.AfterConstruction (); +procedure TUITextLabel.AfterConstruction (); begin - inherited AfterConstruction(); - mHoriz := false; - mDefSize.w := 1; + inherited; + mHAlign := -1; + mVAlign := 0; + mCanFocus := false; + mDefSize := TLaySize.Create(uiContext.textWidth(mText), uiContext.textHeight(mText)); + mCtl4Style := 'label'; + mLinkId := ''; end; -// ////////////////////////////////////////////////////////////////////////// // -constructor TUITextLabel.Create (const atext: AnsiString); +procedure TUITextLabel.cacheStyle (root: TUIStyle); begin - inherited Create(); - mText := atext; - mDefSize := TLaySize.Create(Length(atext)*8, 8); + 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.AfterConstruction (); +procedure TUITextLabel.setText (const s: AnsiString); +var + f: Integer; begin - inherited AfterConstruction(); - mHAlign := -1; - mVAlign := 0; - mCanFocus := false; - if (mDefSize.h <= 0) then mDefSize.h := 8; - mCtl4Style := 'label'; + 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); + end; + mText += s[f]; + end; + Inc(f); + end + else + begin + mText += s[f]; + Inc(f); + end; + end; + // fix hotchar offset + if (mHotChar <> #0) and (mHotOfs > 0) then + begin + mHotOfs := uiContext.textWidth(Copy(mText, 1, mHotOfs+1))-uiContext.charWidth(mText[mHotOfs+1]); + end; + // fix size + mDefSize := TLaySize.Create(uiContext.textWidth(mText), uiContext.textHeight(mText)); 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 + setText(par.expectIdOrStr(true)); + result := true; + exit; + end; + if (strEquCI1251(prname, 'link')) then begin - mText := par.expectIdOrStr(true); - mDefSize := TLaySize.Create(Length(mText)*8, 8); + mLinkId := par.expectIdOrStr(true); result := true; exit; end; - if (strEquCI1251(prname, 'textalign')) then + if (strEquCI1251(prname, 'textalign')) or (strEquCI1251(prname, 'text-align')) then begin parseTextAlign(par, mHAlign, mVAlign); result := true; @@ -2356,18 +2779,26 @@ var cidx: Integer; begin cidx := getColorIndex; - fillRect(gx, gy, mWidth, mHeight, mBackColor[cidx]); + uiContext.color := mBackColor[cidx]; + uiContext.fillRect(gx, gy, mWidth, mHeight); if (Length(mText) > 0) then begin if (mHAlign < 0) then xpos := 0 - else if (mHAlign > 0) then xpos := mWidth-Length(mText)*8 - else xpos := (mWidth-Length(mText)*8) div 2; + else if (mHAlign > 0) then xpos := mWidth-uiContext.textWidth(mText) + else xpos := (mWidth-uiContext.textWidth(mText)) div 2; if (mVAlign < 0) then ypos := 0 - else if (mVAlign > 0) then ypos := mHeight-8 - else ypos := (mHeight-8) div 2; + else if (mVAlign > 0) then ypos := mHeight-uiContext.textHeight(mText) + else ypos := (mHeight-uiContext.textHeight(mText)) div 2; + + uiContext.color := mTextColor[cidx]; + uiContext.drawText(gx+xpos, gy+ypos, mText); - drawText8(gx+xpos, gy+ypos, mText, mTextColor[cidx]); + if (Length(mLinkId) > 0) and (mHotChar <> #0) and (mHotChar <> ' ') then + begin + uiContext.color := mHotColor[cidx]; + uiContext.drawChar(gx+xpos+mHotOfs, gy+ypos, mHotChar); + end; end; end; @@ -2377,38 +2808,61 @@ var lx, ly: Integer; begin inherited mouseEvent(ev); - if (not ev.eaten) and (not ev.cancelled) and (mEnabled) and toLocal(ev.x, ev.y, lx, ly) then + if (not ev.eaten) and (not ev.cancelled) and (enabled) and toLocal(ev.x, ev.y, lx, ly) then begin ev.eat(); end; end; -// ////////////////////////////////////////////////////////////////////////// // -constructor TUIButton.Create (const atext: AnsiString); +procedure TUITextLabel.doAction (); +var + ctl: TUIControl; begin - inherited Create(atext); + if (assigned(actionCB)) then + begin + actionCB(self); + end + else + begin + ctl := topLevel[mLinkId]; + if (ctl <> nil) then + begin + if (ctl.canFocus) then ctl.focused := true; + end; + end; +end; + + +procedure TUITextLabel.keyEventPost (var ev: THKeyEvent); +begin + if (not enabled) then exit; + if (mHotChar = #0) then exit; + if (ev.eaten) or (ev.cancelled) or (not ev.press) then exit; + if (ev.kstate <> ev.ModAlt) then exit; + if (not ev.isHot(mHotChar)) then exit; + ev.eat(); + if (canFocus) then focused := true; + doAction(); end; +// ////////////////////////////////////////////////////////////////////////// // procedure TUIButton.AfterConstruction (); begin - inherited AfterConstruction(); + inherited; mHAlign := -1; mVAlign := 0; mCanFocus := true; - mDefSize := TLaySize.Create(Length(mText)*8+8, 8); + mDefSize := TLaySize.Create(uiContext.textWidth(mText)+8*2, uiContext.textHeight(mText)+2); mCtl4Style := 'button'; end; -function TUIButton.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; +procedure TUIButton.setText (const s: AnsiString); begin - result := inherited parseProperty(prname, par); - if result then - begin - mDefSize := TLaySize.Create(Length(mText)*8+8*2, 8); - end; + inherited setText(s); + mDefSize := TLaySize.Create(uiContext.textWidth(mText)+8*2, uiContext.textHeight(mText)+2); end; @@ -2416,30 +2870,33 @@ 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]); + uiContext.color := mBackColor[cidx]; + uiContext.fillRect(gx+1, gy, mWidth-2, mHeight); + uiContext.fillRect(gx, gy+1, 1, mHeight-2); + uiContext.fillRect(gx+mWidth-1, gy+1, 1, mHeight-2); if (Length(mText) > 0) then begin if (mHAlign < 0) then xpos := 0 - else if (mHAlign > 0) then xpos := mWidth-Length(mText)*8 - else xpos := (mWidth-Length(mText)*8) div 2; + else if (mHAlign > 0) then xpos := mWidth-uiContext.textWidth(mText) + else xpos := (mWidth-uiContext.textWidth(mText)) div 2; + + if (mVAlign < 0) then ypos := 0 + else if (mVAlign > 0) then ypos := mHeight-uiContext.textHeight(mText) + else ypos := (mHeight-uiContext.textHeight(mText)) div 2; setScissor(8, 0, mWidth-16, mHeight); - drawText8(gx+xpos+8, gy+ypos, mText, mTextColor[cidx]); + uiContext.color := mTextColor[cidx]; + uiContext.drawText(gx+xpos+8, gy+ypos, mText); + + if (mHotChar <> #0) and (mHotChar <> ' ') then + begin + uiContext.color := mHotColor[cidx]; + uiContext.drawChar(gx+xpos+8+mHotOfs, gy+ypos, mHotChar); + end; end; end; @@ -2458,7 +2915,7 @@ begin end; exit; end; - if (ev.eaten) or (ev.cancelled) or (not mEnabled) or not focused then exit; + if (ev.eaten) or (ev.cancelled) or (not enabled) or not focused then exit; ev.eat(); end; @@ -2466,7 +2923,7 @@ end; procedure TUIButton.keyEvent (var ev: THKeyEvent); begin inherited keyEvent(ev); - if (not ev.eaten) and (not ev.cancelled) and (mEnabled) then + if (not ev.eaten) and (not ev.cancelled) and (enabled) then begin if (ev = 'Enter') or (ev = 'Space') then begin @@ -2478,6 +2935,231 @@ begin end; +// ////////////////////////////////////////////////////////////////////////// // +procedure TUISwitchBox.AfterConstruction (); +begin + inherited; + mHAlign := -1; + mVAlign := 0; + mCanFocus := true; + mIcon := TGxContext.TMarkIcon.Checkbox; + mDefSize := TLaySize.Create(uiContext.textWidth(mText)+3+uiContext.iconMarkWidth(mIcon), uiContext.iconMarkHeight(mIcon)); + mCtl4Style := 'switchbox'; + mChecked := false; + mBoolVar := @mChecked; +end; + + +procedure TUISwitchBox.cacheStyle (root: TUIStyle); +begin + inherited cacheStyle(root); + // active + mSwitchColor[ClrIdxActive] := root.get('switch-color', 'active', mCtl4Style).asRGBADef(TGxRGBA.Create(255, 255, 255)); + // disabled + mSwitchColor[ClrIdxDisabled] := root.get('switch-color', 'disabled', mCtl4Style).asRGBADef(TGxRGBA.Create(255, 255, 255)); + // inactive + mSwitchColor[ClrIdxInactive] := root.get('switch-color', 'inactive', mCtl4Style).asRGBADef(TGxRGBA.Create(255, 255, 255)); +end; + + +procedure TUISwitchBox.setText (const s: AnsiString); +begin + inherited setText(s); + mDefSize := TLaySize.Create(uiContext.textWidth(mText)+3+uiContext.iconMarkWidth(mIcon), uiContext.iconMarkHeight(mIcon)); +end; + + +function TUISwitchBox.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; +begin + if (strEquCI1251(prname, 'checked')) then + begin + result := true; + setChecked(true); + exit; + end; + result := inherited parseProperty(prname, par); +end; + + +function TUISwitchBox.getChecked (): Boolean; +begin + if (mBoolVar <> nil) then result := mBoolVar^ else result := false; +end; + + +procedure TUISwitchBox.setVar (pvar: PBoolean); +begin + if (pvar = nil) then pvar := @mChecked; + if (pvar <> mBoolVar) then + begin + mBoolVar := pvar; + setChecked(mBoolVar^); + end; +end; + + +procedure TUISwitchBox.drawControl (gx, gy: Integer); +var + xpos, ypos: Integer; + cidx: Integer; +begin + cidx := getColorIndex; + + if (mHAlign < 0) then xpos := 0 + else if (mHAlign > 0) then xpos := mWidth-(uiContext.textWidth(mText)+3+uiContext.iconMarkWidth(mIcon)) + else xpos := (mWidth-(uiContext.textWidth(mText)+3+uiContext.iconMarkWidth(mIcon))) div 2; + + if (mVAlign < 0) then ypos := 0 + else if (mVAlign > 0) then ypos := mHeight-uiContext.iconMarkHeight(mIcon) + else ypos := (mHeight-uiContext.iconMarkHeight(mIcon)) div 2; + + uiContext.color := mBackColor[cidx]; + uiContext.fillRect(gx, gy, mWidth, mHeight); + + uiContext.color := mSwitchColor[cidx]; + uiContext.drawIconMark(mIcon, gx, gy, checked); + + if (mVAlign < 0) then ypos := 0 + else if (mVAlign > 0) then ypos := mHeight-uiContext.textHeight(mText) + else ypos := (mHeight-uiContext.textHeight(mText)) div 2; + + uiContext.color := mTextColor[cidx]; + uiContext.drawText(gx+xpos+3+uiContext.iconMarkWidth(mIcon), gy+ypos, mText); + + if (mHotChar <> #0) and (mHotChar <> ' ') then + begin + uiContext.color := mHotColor[cidx]; + uiContext.drawChar(gx+xpos+3+uiContext.iconMarkWidth(mIcon)+mHotOfs, gy+ypos, mHotChar); + end; +end; + + +procedure TUISwitchBox.mouseEvent (var ev: THMouseEvent); +var + lx, ly: Integer; +begin + inherited mouseEvent(ev); + if (uiGrabCtl = self) then + begin + ev.eat(); + if (ev = '-lmb') and focused and toLocal(ev.x, ev.y, lx, ly) then + begin + doAction(); + end; + exit; + end; + if (ev.eaten) or (ev.cancelled) or (not enabled) or not focused then exit; + ev.eat(); +end; + + +procedure TUISwitchBox.keyEvent (var ev: THKeyEvent); +begin + inherited keyEvent(ev); + if (not ev.eaten) and (not ev.cancelled) and (enabled) then + begin + if (ev = 'Space') then + begin + ev.eat(); + doAction(); + exit; + end; + end; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +procedure TUICheckBox.AfterConstruction (); +begin + inherited; + mChecked := false; + mBoolVar := @mChecked; + mIcon := TGxContext.TMarkIcon.Checkbox; + setText(''); +end; + + +procedure TUICheckBox.setChecked (v: Boolean); +begin + mBoolVar^ := v; +end; + + +procedure TUICheckBox.doAction (); +begin + if (assigned(actionCB)) then + begin + actionCB(self); + end + else + begin + setChecked(not getChecked); + end; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +procedure TUIRadioBox.AfterConstruction (); +begin + inherited; + mChecked := false; + mBoolVar := @mChecked; + mRadioGroup := ''; + mIcon := TGxContext.TMarkIcon.Radiobox; + setText(''); +end; + + +function TUIRadioBox.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; +begin + if (strEquCI1251(prname, 'group')) then + begin + mRadioGroup := par.expectIdOrStr(true); + if (getChecked) then setChecked(true); + result := true; + exit; + end; + if (strEquCI1251(prname, 'checked')) then + begin + result := true; + setChecked(true); + exit; + end; + result := inherited parseProperty(prname, par); +end; + + +procedure TUIRadioBox.setChecked (v: Boolean); + + function resetGroup (ctl: TUIControl): Boolean; + begin + result := false; + if (ctl <> self) and (ctl is TUIRadioBox) and (TUIRadioBox(ctl).mRadioGroup = mRadioGroup) then + begin + TUIRadioBox(ctl).mBoolVar^ := false; + end; + end; + +begin + mBoolVar^ := v; + if v then topLevel.forEachControl(resetGroup); +end; + + +procedure TUIRadioBox.doAction (); +begin + if (assigned(actionCB)) then + begin + actionCB(self); + end + else + begin + setChecked(true); + end; +end; + + +// ////////////////////////////////////////////////////////////////////////// // initialization registerCtlClass(TUIHBox, 'hbox'); registerCtlClass(TUIVBox, 'vbox'); @@ -2485,5 +3167,10 @@ initialization registerCtlClass(TUIHLine, 'hline'); registerCtlClass(TUIVLine, 'vline'); registerCtlClass(TUITextLabel, 'label'); + registerCtlClass(TUIStaticText, 'static'); registerCtlClass(TUIButton, 'button'); + registerCtlClass(TUICheckBox, 'checkbox'); + registerCtlClass(TUIRadioBox, 'radiobox'); + + uiContext := TGxContext.Create(); end. diff --git a/src/flexui/fui_events.pas b/src/flexui/fui_events.pas new file mode 100644 index 0000000..919227a --- /dev/null +++ b/src/flexui/fui_events.pas @@ -0,0 +1,461 @@ +(* coded by Ketmar // Invisible Vector + * Understanding is not required. Only obedience. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +{$INCLUDE ../shared/a_modes.inc} +unit fui_events; + +interface + +uses + SysUtils, Classes, + SDL2; + + +// ////////////////////////////////////////////////////////////////////////// // +type + THMouseEvent = record + public + const + // both for but and for bstate + None = 0; + Left = $0001; + Right = $0002; + Middle = $0004; + WheelUp = $0008; + WheelDown = $0010; + + // event types + type + TKind = (Release, Press, Motion); + + private + mEaten: Boolean; + mCancelled: Boolean; + + public + kind: TKind; // motion, press, release + x, y: Integer; // current mouse position + dx, dy: Integer; // for wheel this is wheel motion, otherwise this is relative mouse motion + but: Word; // current pressed/released button, or 0 for motion + bstate: Word; // button state BEFORE event (i.e. press/release modifications aren't done yet) + kstate: Word; // keyboard state (see THKeyEvent); + + public + procedure intrInit (); inline; // init hidden fields + + function press (): Boolean; inline; + function release (): Boolean; inline; + function motion (): Boolean; inline; + procedure eat (); inline; + procedure cancel (); inline; + + public + property eaten: Boolean read mEaten; + property cancelled: Boolean read mCancelled; + end; + + THKeyEvent = record + public + const + // modifiers + ModCtrl = $0001; + ModAlt = $0002; + ModShift = $0004; + ModHyper = $0008; + + // event types + type + TKind = (Release, Press); + + private + mEaten: Boolean; + mCancelled: Boolean; + + public + kind: TKind; + scan: Word; // SDL_SCANCODE_XXX or 0 for character event + //sym: LongWord; // SDLK_XXX + ch: AnsiChar; // converted to 1251; can be #0 + x, y: Integer; // current mouse position + bstate: Word; // button state + kstate: Word; // keyboard state BEFORE event (i.e. press/release modifications aren't done yet) + + public + procedure intrInit (); inline; // init hidden fields + + function press (): Boolean; inline; + function release (): Boolean; inline; + procedure eat (); inline; + procedure cancel (); inline; + + function isHot (c: AnsiChar): Boolean; + + public + property eaten: Boolean read mEaten; + property cancelled: Boolean read mCancelled; + end; + + +// ////////////////////////////////////////////////////////////////////////// // +// call this on window deactivation, for example +procedure fuiResetKMState (sendEvents: Boolean=true); + + +// ////////////////////////////////////////////////////////////////////////// // +// event handlers +var + evMouseCB: procedure (var ev: THMouseEvent) = nil; + evKeyCB: procedure (var ev: THKeyEvent) = nil; + + +// ////////////////////////////////////////////////////////////////////////// // +function fuiMouseX (): Integer; inline; +function fuiMouseY (): Integer; inline; +function fuiButState (): Word; inline; +function fuiModState (): Word; inline; + +procedure fuiSetMouseX (v: Integer); inline; +procedure fuiSetMouseY (v: Integer); inline; +procedure fuiSetButState (v: Word); inline; +procedure fuiSetModState (v: Word); inline; + + +// ////////////////////////////////////////////////////////////////////////// // +// any mods = 255: nothing was defined +function parseModKeys (const s: AnsiString; out kmods: Byte; out mbuts: Byte): AnsiString; + +operator = (constref ev: THKeyEvent; const s: AnsiString): Boolean; +operator = (const s: AnsiString; constref ev: THKeyEvent): Boolean; + +operator = (constref ev: THMouseEvent; const s: AnsiString): Boolean; +operator = (const s: AnsiString; constref ev: THMouseEvent): Boolean; + + +implementation + +var + curButState: Word = 0; + curModState: Word = 0; + curMsX: Integer = 0; + curMsY: Integer = 0; + + +// ////////////////////////////////////////////////////////////////////////// // +function strEquCI (const s0, s1: AnsiString): Boolean; +var + f: Integer; + c0, c1: AnsiChar; +begin + result := (Length(s0) = Length(s1)); + if result then + begin + for f := 1 to Length(s0) do + begin + c0 := s0[f]; + if (c0 >= 'a') and (c0 <= 'z') then Dec(c0, 32); // poor man's `toupper()` + c1 := s1[f]; + if (c1 >= 'a') and (c1 <= 'z') then Dec(c1, 32); // poor man's `toupper()` + if (c0 <> c1) then begin result := false; exit; end; + end; + end; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +function fuiMouseX (): Integer; inline; begin result := curMsX; end; +function fuiMouseY (): Integer; inline; begin result := curMsY; end; +function fuiButState (): Word; inline; begin result := curButState; end; +function fuiModState (): Word; inline; begin result := curModState; end; + +procedure fuiSetMouseX (v: Integer); inline; begin curMsX := v; end; +procedure fuiSetMouseY (v: Integer); inline; begin curMsY := v; end; +procedure fuiSetButState (v: Word); inline; begin curButState := v; end; +procedure fuiSetModState (v: Word); inline; begin curModState := v; end; + + +// ////////////////////////////////////////////////////////////////////////// // +procedure THMouseEvent.intrInit (); inline; begin mEaten := false; mCancelled := false; end; +function THMouseEvent.press (): Boolean; inline; begin result := (kind = TKind.Press); end; +function THMouseEvent.release (): Boolean; inline; begin result := (kind = TKind.Release); end; +function THMouseEvent.motion (): Boolean; inline; begin result := (kind = TKind.Motion); end; +procedure THMouseEvent.eat (); inline; begin mEaten := true; end; +procedure THMouseEvent.cancel (); inline; begin mCancelled := true; end; + +procedure THKeyEvent.intrInit (); inline; begin mEaten := false; mCancelled := false; ch := #0; scan := 0; end; +function THKeyEvent.press (): Boolean; inline; begin result := (kind = TKind.Press); end; +function THKeyEvent.release (): Boolean; inline; begin result := (kind = TKind.Release); end; +procedure THKeyEvent.eat (); inline; begin mEaten := true; end; +procedure THKeyEvent.cancel (); inline; begin mCancelled := true; end; + +function THKeyEvent.isHot (c: AnsiChar): Boolean; +begin + if (c = #0) or (scan = 0) or (scan = $FFFF) then begin result := false; exit; end; + case scan of + SDL_SCANCODE_A: result := (c = 'A') or (c = 'a') or (c = 'Ô') or (c = 'ô'); + SDL_SCANCODE_B: result := (c = 'B') or (c = 'b') or (c = 'È') or (c = 'è'); + SDL_SCANCODE_C: result := (c = 'C') or (c = 'c') or (c = 'Ñ') or (c = 'ñ'); + SDL_SCANCODE_D: result := (c = 'D') or (c = 'd') or (c = 'Â') or (c = 'â'); + SDL_SCANCODE_E: result := (c = 'E') or (c = 'e') or (c = 'Ó') or (c = 'ó'); + SDL_SCANCODE_F: result := (c = 'F') or (c = 'f') or (c = 'À') or (c = 'à'); + SDL_SCANCODE_G: result := (c = 'G') or (c = 'g') or (c = 'Ï') or (c = 'ï'); + SDL_SCANCODE_H: result := (c = 'H') or (c = 'h') or (c = 'Ð') or (c = 'ð'); + SDL_SCANCODE_I: result := (c = 'I') or (c = 'i') or (c = 'Ø') or (c = 'ø'); + SDL_SCANCODE_J: result := (c = 'J') or (c = 'j') or (c = 'Î') or (c = 'î'); + SDL_SCANCODE_K: result := (c = 'K') or (c = 'k') or (c = 'Ë') or (c = 'ë'); + SDL_SCANCODE_L: result := (c = 'L') or (c = 'l') or (c = 'Ä') or (c = 'ä'); + SDL_SCANCODE_M: result := (c = 'M') or (c = 'm') or (c = 'Ü') or (c = 'ü'); + SDL_SCANCODE_N: result := (c = 'N') or (c = 'n') or (c = 'Ò') or (c = 'ò'); + SDL_SCANCODE_O: result := (c = 'O') or (c = 'o') or (c = 'Ù') or (c = 'ù'); + SDL_SCANCODE_P: result := (c = 'P') or (c = 'p') or (c = 'Ç') or (c = 'ç'); + SDL_SCANCODE_Q: result := (c = 'Q') or (c = 'q') or (c = 'É') or (c = 'é'); + SDL_SCANCODE_R: result := (c = 'R') or (c = 'r') or (c = 'Ê') or (c = 'ê'); + SDL_SCANCODE_S: result := (c = 'S') or (c = 's') or (c = 'Û') or (c = 'û'); + SDL_SCANCODE_T: result := (c = 'T') or (c = 't') or (c = 'Å') or (c = 'å'); + SDL_SCANCODE_U: result := (c = 'U') or (c = 'u') or (c = 'Ã') or (c = 'ã'); + SDL_SCANCODE_V: result := (c = 'V') or (c = 'v') or (c = 'Ì') or (c = 'ì'); + SDL_SCANCODE_W: result := (c = 'W') or (c = 'w') or (c = 'Ö') or (c = 'ö'); + SDL_SCANCODE_X: result := (c = 'X') or (c = 'x') or (c = '×') or (c = '÷'); + SDL_SCANCODE_Y: result := (c = 'Y') or (c = 'y') or (c = 'Í') or (c = 'í'); + SDL_SCANCODE_Z: result := (c = 'Z') or (c = 'z') or (c = 'ß') or (c = 'ÿ'); + + SDL_SCANCODE_1: result := (c = '1') or (c = '!'); + SDL_SCANCODE_2: result := (c = '2') or (c = '@'); + SDL_SCANCODE_3: result := (c = '3') or (c = '#'); + SDL_SCANCODE_4: result := (c = '4') or (c = '$'); + SDL_SCANCODE_5: result := (c = '5') or (c = '%'); + SDL_SCANCODE_6: result := (c = '6') or (c = '^'); + SDL_SCANCODE_7: result := (c = '7') or (c = '&'); + SDL_SCANCODE_8: result := (c = '8') or (c = '*'); + SDL_SCANCODE_9: result := (c = '9') or (c = '('); + SDL_SCANCODE_0: result := (c = '0') or (c = ')'); + + SDL_SCANCODE_RETURN: result := (c = #13) or (c = #10); + SDL_SCANCODE_ESCAPE: result := (c = #27); + SDL_SCANCODE_BACKSPACE: result := (c = #8); + SDL_SCANCODE_TAB: result := (c = #9); + SDL_SCANCODE_SPACE: result := (c = ' '); + + SDL_SCANCODE_MINUS: result := (c = '-'); + SDL_SCANCODE_EQUALS: result := (c = '='); + SDL_SCANCODE_LEFTBRACKET: result := (c = '[') or (c = '{'); + SDL_SCANCODE_RIGHTBRACKET: result := (c = ']') or (c = '}'); + SDL_SCANCODE_BACKSLASH, SDL_SCANCODE_NONUSHASH: result := (c = '\') or (c = '|'); + SDL_SCANCODE_SEMICOLON: result := (c = ';') or (c = ':'); + SDL_SCANCODE_APOSTROPHE: result := (c = '''') or (c = '"'); + SDL_SCANCODE_GRAVE: result := (c = '`') or (c = '~'); + SDL_SCANCODE_COMMA: result := (c = ',') or (c = '<'); + SDL_SCANCODE_PERIOD: result := (c = '.') or (c = '>'); + SDL_SCANCODE_SLASH: result := (c = '/') or (c = '?'); + + else result := false; + end; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +// any mods = 255: nothing was defined +function parseModKeys (const s: AnsiString; out kmods: Byte; out mbuts: Byte): AnsiString; +var + pos, epos: Integer; +begin + kmods := 255; + mbuts := 255; + pos := 1; + //while (pos <= Length(s)) and (s[pos] <= ' ') do Inc(pos); + if (pos < Length(s)) and ((s[pos] = '+') or (s[pos] = '-') or (s[pos] = '*')) then Inc(pos); + while (pos <= Length(s)) do + begin + if (Length(s)-pos >= 1) and (s[pos+1] = '-') then + begin + case s[pos] of + 'C', 'c': begin if (kmods = 255) then kmods := 0; kmods := kmods or THKeyEvent.ModCtrl; Inc(pos, 2); continue; end; + 'M', 'm': begin if (kmods = 255) then kmods := 0; kmods := kmods or THKeyEvent.ModAlt; Inc(pos, 2); continue; end; + 'S', 's': begin if (kmods = 255) then kmods := 0; kmods := kmods or THKeyEvent.ModShift; Inc(pos, 2); continue; end; + end; + break; + end; + if (Length(s)-pos >= 3) and (s[pos+3] = '-') and ((s[pos+1] = 'M') or (s[pos+1] = 'm')) and ((s[pos+2] = 'B') or (s[pos+2] = 'b')) then + begin + case s[pos] of + 'L', 'l': begin if (mbuts = 255) then mbuts := 0; mbuts := mbuts or THMouseEvent.Left; Inc(pos, 4); continue; end; + 'R', 'r': begin if (mbuts = 255) then mbuts := 0; mbuts := mbuts or THMouseEvent.Right; Inc(pos, 4); continue; end; + 'M', 'm': begin if (mbuts = 255) then mbuts := 0; mbuts := mbuts or THMouseEvent.Middle; Inc(pos, 4); continue; end; + end; + break; + end; + break; + end; + epos := Length(s)+1; + while (epos > pos) and (s[epos-1] <= ' ') do Dec(epos); + if (epos > pos) then result := Copy(s, pos, epos-pos) else result := ''; +end; + + +operator = (constref ev: THKeyEvent; const s: AnsiString): Boolean; +var + f: Integer; + kmods: Byte = 255; + mbuts: Byte = 255; + kname: AnsiString; +begin + result := false; + if (Length(s) > 0) then + begin + if (s[1] = '+') then begin if (not ev.press) then exit; end + else if (s[1] = '-') then begin if (not ev.release) then exit; end + else if (s[1] = '*') then begin end + else if (not ev.press) then exit; + end; + kname := parseModKeys(s, kmods, mbuts); + if (kmods = 255) then kmods := 0; + if (ev.kstate <> kmods) then exit; + if (mbuts <> 255) and (ev.bstate <> mbuts) then exit; + + if (strEquCI(kname, 'Enter')) then kname := 'RETURN'; + + for f := 0 to SDL_NUM_SCANCODES-1 do + begin + if strEquCI(kname, SDL_GetScancodeName(f)) then + begin + result := (ev.scan = f); + exit; + end; + end; +end; + + +operator = (const s: AnsiString; constref ev: THKeyEvent): Boolean; +begin + result := (ev = s); +end; + + +operator = (constref ev: THMouseEvent; const s: AnsiString): Boolean; +var + kmods: Byte = 255; + mbuts: Byte = 255; + kname: AnsiString; + but: Integer = -1; + modch: AnsiChar = ' '; +begin + result := false; + + if (Length(s) > 0) then + begin + if (s[1] = '+') then begin if (not ev.press) then exit; modch := '+'; end + else if (s[1] = '-') then begin if (not ev.release) then exit; modch := '-'; end + else if (s[1] = '*') then begin if (not ev.motion) then exit; end + else if (not ev.press) then exit; + end; + + kname := parseModKeys(s, kmods, mbuts); + if strEquCI(kname, 'LMB') then but := THMouseEvent.Left + else if strEquCI(kname, 'RMB') then but := THMouseEvent.Right + else if strEquCI(kname, 'MMB') then but := THMouseEvent.Middle + else if strEquCI(kname, 'WheelUp') or strEquCI(kname, 'WUP') then but := THMouseEvent.WheelUp + else if strEquCI(kname, 'WheelDown') or strEquCI(kname, 'WDN') or strEquCI(kname, 'WDOWN') then but := THMouseEvent.WheelDown + else if strEquCI(kname, 'None') then but := 0 + else exit; + + if (mbuts = 255) then mbuts := 0; + if (kmods = 255) then kmods := 0; + if (ev.kstate <> kmods) then exit; + if (modch = '-') then mbuts := mbuts or but else if (modch = '+') then mbuts := mbuts and (not but); + + result := (ev.bstate = mbuts) and (ev.but = but); +end; + + +operator = (const s: AnsiString; constref ev: THMouseEvent): Boolean; +begin + result := (ev = s); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +procedure fuiResetKMState (sendEvents: Boolean=true); +var + mask: Word; + mev: THMouseEvent; + kev: THKeyEvent; +begin + // generate mouse release events + if (curButState <> 0) then + begin + if sendEvents then + begin + mask := 1; + while (mask <> 0) do + begin + // checked each time, 'cause `evMouseCB` can be changed from the handler + if ((curButState and mask) <> 0) and assigned(evMouseCB) then + begin + FillChar(mev, sizeof(mev), 0); + mev.intrInit(); + mev.kind := mev.TKind.Release; + mev.x := curMsX; + mev.y := curMsY; + mev.dx := 0; + mev.dy := 0; + mev.but := mask; + mev.bstate := curButState; + mev.kstate := curModState; + curButState := curButState and (not mask); + evMouseCB(mev); + end; + mask := mask shl 1; + end; + end; + curButState := 0; + end; + + // generate modifier release events + if (curModState <> 0) then + begin + if sendEvents then + begin + mask := 1; + while (mask <= 8) do + begin + // checked each time, 'cause `evMouseCB` can be changed from the handler + if ((curModState and mask) <> 0) and assigned(evKeyCB) then + begin + FillChar(kev, sizeof(kev), 0); + kev.intrInit(); + kev.kind := kev.TKind.Release; + case mask of + THKeyEvent.ModCtrl: begin kev.scan := SDL_SCANCODE_LCTRL; {kev.sym := SDLK_LCTRL;}{arbitrary} end; + THKeyEvent.ModAlt: begin kev.scan := SDL_SCANCODE_LALT; {kev.sym := SDLK_LALT;}{arbitrary} end; + THKeyEvent.ModShift: begin kev.scan := SDL_SCANCODE_LSHIFT; {kev.sym := SDLK_LSHIFT;}{arbitrary} end; + THKeyEvent.ModHyper: begin kev.scan := SDL_SCANCODE_LGUI; {kev.sym := SDLK_LGUI;}{arbitrary} end; + else assert(false); + end; + kev.x := curMsX; + kev.y := curMsY; + mev.bstate := 0{curMsButState}; // anyway + mev.kstate := curModState; + curModState := curModState and (not mask); + evKeyCB(kev); + end; + mask := mask shl 1; + end; + end; + curModState := 0; + end; +end; + + +end. diff --git a/src/gx/gh_flexlay.pas b/src/flexui/fui_flexlay.pas similarity index 76% rename from src/gx/gh_flexlay.pas rename to src/flexui/fui_flexlay.pas index 5f237f5..fb470c4 100644 --- a/src/gx/gh_flexlay.pas +++ b/src/flexui/fui_flexlay.pas @@ -15,69 +15,7 @@ * along with this program. If not, see . *) {$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 -*) - - +unit fui_flexlay; (* control default size will be increased by margins negative margins are ignored @@ -85,10 +23,12 @@ ControlT: procedure layPrepare (); // called before registering control in layouter function getDefSize (): TLaySize; // default size; <0: use max size function getMargins (): TLayMargins; + function getPadding (): TLaySize; // children padding (each non-first child will get this on left/top) function getMaxSize (): TLaySize; // max size; <0: set to some huge value function getFlex (): Integer; // <=0: not flexible function isHorizBox (): Boolean; // horizontal layout for children? function canWrap (): Boolean; // for horizontal boxes: can wrap children? for child: `false` means 'nonbreakable at *next* ctl' + function noPad (): Boolean; // ignore padding in box direction for this control function isLineStart (): Boolean; // `true` if this ctl should start a new line; ignored for vertical boxes function getAlign (): Integer; // aligning in non-main direction: <0: left/up; 0: center; >0: right/down function getExpand (): Boolean; // expanding in non-main direction: `true` will ignore align and eat all available space @@ -102,7 +42,7 @@ ControlT: interface uses - gh_ui_common; + fui_common; // ////////////////////////////////////////////////////////////////////////// // @@ -114,20 +54,18 @@ type private type LayControlIdx = Integer; - private - class function nminX (a, b: Integer): Integer; inline; - private // flags const FlagHorizBox = LongWord(1) shl 0; // horizontal layout for children FlagLineStart = LongWord(1) shl 1; FlagLineCanWrap = LongWord(1) shl 2; + FlagNoPad = LongWord(1) shl 3; // internal - FlagLineDidWrap = LongWord(1) shl 3; // will be set when line was wrapped - FlagInGroup = LongWord(1) shl 4; // set if this control is a member of any group - FlagExpand = LongWord(1) shl 5; - FlagLineFirst = LongWord(1) shl 6; + FlagLineDidWrap = LongWord(1) shl 8; // will be set when line was wrapped + FlagInGroup = LongWord(1) shl 9; // set if this control is a member of any group + FlagExpand = LongWord(1) shl 10; + FlagLineFirst = LongWord(1) shl 11; private type @@ -136,12 +74,13 @@ type public myidx: LayControlIdx; tempFlex: Integer; - flags: LongWord; // see below + flags: LongWord; // see above aligndir: Integer; startsize: TLaySize; // current desiredsize: TLaySize; maxsize: TLaySize; margins: TLayMargins; // can never be negative + padding: TLaySize; desiredpos: TLayPos; ctl: ControlT; parent: LayControlIdx; // = -1; @@ -160,6 +99,7 @@ type function canWrap (): Boolean; inline; function inGroup (): Boolean; inline; function firstInLine (): Boolean; inline; + function noPad (): Boolean; inline; function getExpand (): Boolean; inline; procedure setExpand (v: Boolean); inline; @@ -201,7 +141,7 @@ type // this also sets `tempFlex` procedure calcMaxSizeInternal (cidx: LayControlIdx); - procedure fixLine (me: PLayControl; i0, i1: LayControlIdx; var cury: Integer; var spaceLeft: Single); + procedure fixLine (me: PLayControl; i0, i1: LayControlIdx; ypad: Integer; var cury: Integer; var spaceLeft: Single); // do box layouting; call `layBox()` recursively if necessary procedure layBox (boxidx: LayControlIdx); @@ -252,15 +192,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 @@ -275,6 +206,7 @@ function TFlexLayouterBase.TLayControl.lineStart (): Boolean; inline; begin resu function TFlexLayouterBase.TLayControl.canWrap (): Boolean; inline; begin result := ((flags and FlagLineCanWrap) <> 0); end; function TFlexLayouterBase.TLayControl.inGroup (): Boolean; inline; begin result := ((flags and FlagInGroup) <> 0); end; function TFlexLayouterBase.TLayControl.firstInLine (): Boolean; inline; begin result := ((flags and FlagLineFirst) <> 0); end; +function TFlexLayouterBase.TLayControl.noPad (): Boolean; inline; begin result := ((flags and FlagNoPad) <> 0); end; function TFlexLayouterBase.TLayControl.getDidWrap (): Boolean; inline; begin result := ((flags and FlagLineDidWrap) <> 0); end; procedure TFlexLayouterBase.TLayControl.setDidWrap (v: Boolean); inline; begin if (v) then flags := flags or FlagLineDidWrap else flags := flags and (not FlagLineDidWrap); end; @@ -367,6 +299,7 @@ begin if (lc.ctl.isLineStart) then lc.flags := lc.flags or FlagLineStart; if (lc.ctl.canWrap) then lc.flags := lc.flags or FlagLineCanWrap; if (lc.ctl.getExpand) then lc.flags := lc.flags or FlagExpand; + if (lc.ctl.noPad) then lc.flags := lc.flags or FlagNoPad; lc.aligndir := lc.ctl.getAlign; end; @@ -477,6 +410,9 @@ var zerow: Boolean; curwdt, curhgt, totalhgt: Integer; doWrap: Boolean; + xpad, ypad: Integer; + realpad: Integer; + dopad: Boolean = false; begin if (cidx < 0) or (cidx >= Length(ctlist)) then exit; @@ -497,21 +433,27 @@ begin curwdt := lc.margins.horiz; curhgt := 0; totalhgt := lc.margins.vert; + xpad := nmax(0, lc.padding.w); + ypad := 0; for c in forChildren(cidx) do begin + if (dopad) then realpad := xpad else realpad := 0; // new line? doWrap := (not c.firstInLine) and (c.lineStart); // need to wrap? - if (not doWrap) and zerow and (lc.canWrap) and (c.canWrap) and (msz.w > 0) and (curwdt+c.startsize.w > lc.startsize.w) then doWrap := true; + if (not doWrap) and (not zerow) and (not negw) and (lc.canWrap) and (c.canWrap) and (msz.w > 0) and (curwdt+c.startsize.w+realpad > lc.startsize.w) then doWrap := true; if (doWrap) then begin totalhgt += curhgt; if (lc.startsize.w < curwdt) then lc.startsize.w := curwdt; curwdt := 0; curhgt := 0; + ypad := nmax(0, lc.padding.h); + realpad := 0; end; - curwdt += c.startsize.w; - if (curhgt < c.startsize.h) then curhgt := c.startsize.h; + curwdt += c.startsize.w+realpad; + if (curhgt < c.startsize.h+ypad) then curhgt := c.startsize.h+ypad; + dopad := (xpad > 0) and (not lc.noPad); end; //writeln('00: ', cidx, ': totalhgt=', totalhgt); totalhgt += curhgt; @@ -524,18 +466,26 @@ begin // vertical boxes if (negh) then lc.tempFlex := 0; // size is negative: don't expand curhgt := lc.margins.vert; + ypad := nmax(0, lc.padding.h); for c in forChildren(cidx) do begin if (lc.startsize.w < c.startsize.w+lc.margins.horiz) then lc.startsize.w := c.startsize.w+lc.margins.horiz; curhgt += c.startsize.h; + if (dopad) then curhgt += ypad; + dopad := (not c.noPad); end; if (lc.startsize.h < curhgt) then lc.startsize.h := curhgt; 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; @@ -548,17 +498,14 @@ var maxsz: Integer; cidx: LayControlIdx; ct: PLayControl; - mr: TLayMargins; begin // reset all 'laywrap' flags for controls, set initial 'startsize' for f := 0 to High(ctlist) do begin ctlist[f].didWrap := false; ctlist[f].startsize := ctlist[f].ctl.getDefSize; - mr := ctlist[f].ctl.getMargins; - ctlist[f].margins := mr; - //ctlist[f].startsize.w += mr.horiz; - //ctlist[f].startsize.h += mr.vert; + ctlist[f].margins := ctlist[f].ctl.getMargins; + ctlist[f].padding := ctlist[f].ctl.getPadding; end; // setup sizes calcMaxSizeInternal(0); // this also sets `tempFlex` @@ -599,7 +546,7 @@ begin end; -procedure TFlexLayouterBase.fixLine (me: PLayControl; i0, i1: LayControlIdx; var cury: Integer; var spaceLeft: Single); +procedure TFlexLayouterBase.fixLine (me: PLayControl; i0, i1: LayControlIdx; ypad: Integer; var cury: Integer; var spaceLeft: Single); var flexTotal: Integer = 0; // total sum of flex fields flexBoxCount: Integer = 0; // number of boxes @@ -609,7 +556,9 @@ var toadd: Integer; sti0: Integer; lineh: Integer; + xpad: Integer; begin + if (ypad < 0) then ypad := 0; curx := me.margins.left; sti0 := i0; // calc minimal line height, count flexboxes @@ -617,11 +566,12 @@ begin while (i0 <> i1) do begin lc := @ctlist[i0]; - lineh := nmax(lineh, lc.startsize.h); + lineh := nmax(lineh, lc.startsize.h+ypad); if (lc.tempFlex > 0) then begin flexTotal += lc.tempFlex; flexBoxCount += 1; end; i0 := lc.nextSibling; end; // distribute space, expand/align + xpad := nmax(0, me.padding.w); i0 := sti0; while (i0 <> i1) do begin @@ -631,6 +581,7 @@ begin lc.desiredpos.x := curx; lc.desiredpos.y := cury; curx += lc.desiredsize.w; + if (xpad > 0) and (not lc.noPad) then curx += xpad; // fix flexbox size if (lc.tempFlex > 0) and (spaceLeft > 0) then begin @@ -647,7 +598,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 @@ -679,111 +630,117 @@ var doWrap: Boolean; toadd: Integer; osz: TLaySize; + xpad, ypad, realpad: Integer; + dopad: Boolean = false; begin if (boxidx < 0) or (boxidx >= Length(ctlist)) then exit; 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; + xpad := nmax(0, me.padding.w); + ypad := 0; - // 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, 0, 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 + if (dopad) then realpad := xpad else realpad := 0; + // 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-realpad < 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, ypad, cury, spaceLeft); + lineStartIdx := lc.myidx; + ypad := nmax(0, me.padding.h); + realpad := 0; + end + else + begin + if (lc.didWrap) then begin wrappingChanged := true; lc.didWrap := false; end; end; + spaceLeft -= lc.desiredsize.w+realpad; + dopad := (xpad > 0) and (not lc.noPad); + //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, ypad, cury, spaceLeft); + end + else + begin + // vertical boxes + maxwdt := 0; + flexTotal := 0; + flexBoxCount := 0; + spaceLeft := me.desiredsize.h-me.margins.vert; + ypad := nmax(0, me.padding.h); + + // 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; + if (ypad > 0) and (not lc.noPad) then cury += ypad; + // 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 +758,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 +810,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 +823,7 @@ begin secondAgain := true; end; end; + *) end; end; if (not secondAgain) and (not wrappingChanged) then break; diff --git a/src/flexui/fui_gfx_gl.pas b/src/flexui/fui_gfx_gl.pas new file mode 100644 index 0000000..f70e789 --- /dev/null +++ b/src/flexui/fui_gfx_gl.pas @@ -0,0 +1,1113 @@ +(* coded by Ketmar // Invisible Vector + * Understanding is not required. Only obedience. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +{$INCLUDE ../shared/a_modes.inc} +unit fui_gfx_gl; + +interface + +uses + SysUtils, Classes, + GL, GLExt, SDL2, + sdlcarcass, + fui_common, fui_events; + + +// ////////////////////////////////////////////////////////////////////////// // +type + TGxFont = class + protected + mName: AnsiString; + mHeight: Integer; + mBaseLine: Integer; + + public + function charWidth (const ch: AnsiChar): Integer; virtual; abstract; + function textWidth (const s: AnsiString): Integer; virtual; abstract; + + public + property name: AnsiString read mName; + property height: Integer read mHeight; + property baseLine: Integer read mBaseLine; + end; + + TGxContext = class + public + type + TMarkIcon = ( + Checkbox, + Radiobox + ); + + type + TWinIcon = ( + Close + ); + + protected + mActive: Boolean; + mColor: TGxRGBA; + mFont: TGxFont; + // for active contexts + mScaled: Boolean; + mScale: Single; + mClipRect: TGxRect; + mClipOfs: TGxOfs; + + protected + function getFont (): AnsiString; + procedure setFont (const aname: AnsiString); + + procedure onActivate (); + procedure onDeactivate (); + + procedure setColor (const clr: TGxRGBA); + + procedure realizeClip (); // setup scissoring + + procedure setClipOfs (const aofs: TGxOfs); + procedure setClipRect (const aclip: TGxRect); + + public + constructor Create (); + destructor Destroy (); override; + + procedure line (x1, y1, x2, y2: Integer); + procedure hline (x, y, len: Integer); + procedure vline (x, y, len: Integer); + procedure rect (x, y, w, h: Integer); + procedure fillRect (x, y, w, h: Integer); + procedure darkenRect (x, y, w, h: Integer; a: Integer); + + function charWidth (const ch: AnsiChar): Integer; + function charHeight (const ch: AnsiChar): Integer; + function textWidth (const s: AnsiString): Integer; + function textHeight (const s: AnsiString): Integer; + function drawChar (x, y: Integer; const ch: AnsiChar): Integer; // returns char width + function drawText (x, y: Integer; const s: AnsiString): Integer; // returns text width + + function iconMarkWidth (ic: TMarkIcon): Integer; + function iconMarkHeight (ic: TMarkIcon): Integer; + procedure drawIconMark (ic: TMarkIcon; x, y: Integer; marked: Boolean); + + function iconWinWidth (ic: TWinIcon): Integer; + function iconWinHeight (ic: TWinIcon): Integer; + procedure drawIconWin (ic: TWinIcon; x, y: Integer; pressed: Boolean); + + procedure resetClip (); + + function setOffset (constref aofs: TGxOfs): TGxOfs; // returns previous offset + function setClip (constref aclip: TGxRect): TGxRect; // returns previous clip + + function combineClip (constref aclip: TGxRect): TGxRect; // returns previous clip + + public //HACK! + procedure glSetScale (ascale: Single); + procedure glSetTrans (ax, ay: Single); + procedure glSetScaleTrans (ascale, ax, ay: Single); + + public + property active: Boolean read mActive; + property color: TGxRGBA read mColor write setColor; + property font: AnsiString read getFont write setFont; + property offset: TGxOfs read mClipOfs write setClipOfs; + property clip: TGxRect read mClipRect write setClipRect; // clipping is unaffected by offset + end; + + +// set active context; `ctx` can be `nil` +procedure gxSetContext (ctx: TGxContext; ascale: Single=1.0); +procedure gxSetContextNoMatrix (ctx: TGxContext); + + +// setup 2D OpenGL mode; will be called automatically in `glInit()` +procedure oglSetup2D (winWidth, winHeight: Integer; upsideDown: Boolean=false); +procedure oglSetup2DState (); // don't modify viewports and matrices + +procedure oglDrawCursor (); +procedure oglDrawCursorAt (msX, msY: Integer); + + + +// ////////////////////////////////////////////////////////////////////////// // +var + gGfxDoClear: Boolean = true; + + +implementation + + +// ////////////////////////////////////////////////////////////////////////// // +// returns `false` if the color is transparent +// returns `false` if the color is transparent +function setupGLColor (constref clr: TGxRGBA): Boolean; +begin + if (clr.a < 255) then + begin + glEnable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + end + else + begin + glDisable(GL_BLEND); + end; + glColor4ub(clr.r, clr.g, clr.b, clr.a); + result := (clr.a <> 0); +end; + +function isScaled (): Boolean; +var + mt: packed array [0..15] of Double; +begin + glGetDoublev(GL_MODELVIEW_MATRIX, @mt[0]); + result := (mt[0] <> 1.0) or (mt[1*4+1] <> 1.0); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +//TODO: OpenGL framebuffers and shaders state +type + TSavedGLState = record + public + glmatmode: GLint; + gltextbinding: GLint; + //oldprg: GLint; + //oldfbr, oldfbw: GLint; + glvport: packed array [0..3] of GLint; + saved: Boolean; + + public + constructor Create (dosave: Boolean); + procedure save (); + procedure restore (); + end; + +constructor TSavedGLState.Create (dosave: Boolean); +begin + FillChar(self, sizeof(self), 0); + if (dosave) then save(); +end; + +procedure TSavedGLState.save (); +begin + if (saved) then raise Exception.Create('cannot save into already saved OpenGL state'); + glGetIntegerv(GL_MATRIX_MODE, @glmatmode); + glGetIntegerv(GL_TEXTURE_BINDING_2D, @gltextbinding); + glGetIntegerv(GL_VIEWPORT, @glvport[0]); + //glGetIntegerv(GL_CURRENT_PROGRAM, &oldprg); + //glGetIntegerv(GL_READ_FRAMEBUFFER_BINDING, &oldfbr); + //glGetIntegerv(GL_DRAW_FRAMEBUFFER_BINDING, &oldfbw); + glMatrixMode(GL_PROJECTION); glPushMatrix(); + glMatrixMode(GL_MODELVIEW); glPushMatrix(); + glMatrixMode(GL_TEXTURE); glPushMatrix(); + glMatrixMode(GL_COLOR); glPushMatrix(); + glPushAttrib({GL_ENABLE_BIT|GL_COLOR_BUFFER_BIT|GL_CURRENT_BIT}GL_ALL_ATTRIB_BITS); // let's play safe + saved := true; +end; + +procedure TSavedGLState.restore (); +begin + if (not saved) then raise Exception.Create('cannot restore unsaved OpenGL state'); + glPopAttrib({GL_ENABLE_BIT}); + glMatrixMode(GL_PROJECTION); glPopMatrix(); + glMatrixMode(GL_MODELVIEW); glPopMatrix(); + glMatrixMode(GL_TEXTURE); glPopMatrix(); + glMatrixMode(GL_COLOR); glPopMatrix(); + glMatrixMode(glmatmode); + //if (glHasFunc!"glBindFramebufferEXT") glBindFramebufferEXT(GL_READ_FRAMEBUFFER_EXT, oldfbr); + //if (glHasFunc!"glBindFramebufferEXT") glBindFramebufferEXT(GL_DRAW_FRAMEBUFFER_EXT, oldfbw); + glBindTexture(GL_TEXTURE_2D, gltextbinding); + //if (glHasFunc!"glUseProgram") glUseProgram(oldprg); + glViewport(glvport[0], glvport[1], glvport[2], glvport[3]); + saved := false; +end; + + +var + curCtx: TGxContext = nil; + savedGLState: TSavedGLState; + + +// ////////////////////////////////////////////////////////////////////////// // +// set active context; `ctx` can be `nil` +procedure gxSetContextInternal (ctx: TGxContext; ascale: Single; domatrix: Boolean); +var + mt: packed array [0..15] of Double; +begin + if (savedGLState.saved) then savedGLState.restore(); + + if (curCtx <> nil) then + begin + curCtx.onDeactivate(); + curCtx.mActive := false; + end; + + curCtx := ctx; + if (ctx <> nil) then + begin + ctx.mActive := true; + savedGLState.save(); + if (domatrix) then + begin + oglSetup2D(fuiScrWdt, fuiScrHgt); + glScalef(ascale, ascale, 1.0); + ctx.mScaled := (ascale <> 1.0); + ctx.mScale := ascale; + end + else + begin + // assume uniform scale + glGetDoublev(GL_MODELVIEW_MATRIX, @mt[0]); + ctx.mScaled := (mt[0] <> 1.0) or (mt[1*4+1] <> 1.0); + ctx.mScale := mt[0]; + oglSetup2DState(); + end; + ctx.onActivate(); + end; +end; + + +procedure gxSetContext (ctx: TGxContext; ascale: Single=1.0); begin gxSetContextInternal(ctx, ascale, true); end; +procedure gxSetContextNoMatrix (ctx: TGxContext); begin gxSetContextInternal(ctx, 1, false); end; + + +// ////////////////////////////////////////////////////////////////////////// // +type + TScissorSave = record + public + wassc: Boolean; + scxywh: packed array[0..3] of GLint; + + public + + public + procedure save (enableScissoring: Boolean); + procedure restore (); + + // set new scissor rect, bounded by the saved scissor rect + procedure combineRect (x, y, w, h: Integer); + end; + + +procedure TScissorSave.save (enableScissoring: Boolean); +begin + wassc := (glIsEnabled(GL_SCISSOR_TEST) <> 0); + if wassc then glGetIntegerv(GL_SCISSOR_BOX, @scxywh[0]) else glGetIntegerv(GL_VIEWPORT, @scxywh[0]); + //conwritefln('(%d,%d)-(%d,%d)', [scxywh[0], scxywh[1], scxywh[2], scxywh[3]]); + if enableScissoring and (not wassc) then glEnable(GL_SCISSOR_TEST); +end; + +procedure TScissorSave.restore (); +begin + glScissor(scxywh[0], scxywh[1], scxywh[2], scxywh[3]); + if wassc then glEnable(GL_SCISSOR_TEST) else glDisable(GL_SCISSOR_TEST); +end; + +procedure TScissorSave.combineRect (x, y, w, h: Integer); +//var ox, oy, ow, oh: Integer; +begin + if (w < 1) or (h < 1) then begin glScissor(0, 0, 0, 0); exit; end; + y := fuiScrHgt-(y+h); + //ox := x; oy := y; ow := w; oh := h; + if not intersectRect(x, y, w, h, scxywh[0], scxywh[1], scxywh[2], scxywh[3]) then + begin + //writeln('oops: COMBINE: old=(', ox, ',', oy, ')-(', ox+ow-1, ',', oy+oh-1, '); sci: (', scxywh[0], ',', scxywh[1], ')-(', scxywh[0]+scxywh[2]-1, ',', scxywh[1]+scxywh[3]-1, ')'); + //writeln('oops: COMBINE: oldx=<', ox, '-', ox+ow-1, '>; oldy=<', oy, ',', oy+oh-1, '> : scix=<', scxywh[0], '-', scxywh[0]+scxywh[2]-1, '>; sciy=<', scxywh[1], '-', scxywh[1]+scxywh[3]-1, '>'); + glScissor(0, 0, 0, 0); + end + else + begin + glScissor(x, y, w, h); + end; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +{$INCLUDE fui_gfx_gl_fonts.inc} + +type + TGxBmpFont = class(TGxFont) + private + mTexId: GLuint; // OpenGL texture id + mWidth: Integer; // <=0: proportional + mFontBmp: PByte; + mFontWdt: PByte; + mFreeFontWdt: Boolean; + + protected + procedure oglCreateTexture (); + procedure oglDestroyTexture (); + + function drawTextInternal (x, y: Integer; const s: AnsiString): Integer; // return width (not including last empty pixel) + + public + constructor Create (const aname: AnsiString; awdt, ahgt: Integer; const afont: PByte; const awdtable: PByte=nil); + destructor Destroy (); override; + + function charWidth (const ch: AnsiChar): Integer; override; + function textWidth (const s: AnsiString): Integer; override; + end; + + +constructor TGxBmpFont.Create (const aname: AnsiString; awdt, ahgt: Integer; const afont: PByte; const awdtable: PByte=nil); +var + c: Integer; +begin + if (afont = nil) then raise Exception.Create('internal error in font creation'); + if (ahgt < 1) then raise Exception.Create('internal error in font creation'); + if (awdt > 0) then + begin + //if (awdtable <> nil) then raise Exception.Create('internal error in font creation'); + mFreeFontWdt := true; + // create width table + GetMem(mFontWdt, 256); + for c := 0 to 255 do mFontWdt[c] := awdt-1; + end + else + begin + if (awdtable = nil) then raise Exception.Create('internal error in font creation'); + awdt := 0; + mFontWdt := awdtable; + end; + mName := aname; + mWidth := awdt; + mHeight := ahgt; + mBaseLine := ahgt-1; //FIXME + mFontBmp := afont; + mTexId := 0; +end; + + +destructor TGxBmpFont.Destroy (); +begin + if (mFreeFontWdt) and (mFontWdt <> nil) then FreeMem(mFontWdt); + mName := ''; + mWidth := 0; + mHeight := 0; + mBaseLine := 0; + mFontBmp := nil; + mFontWdt := nil; + mFreeFontWdt := false; + mTexId := 0; + inherited; +end; + + +procedure TGxBmpFont.oglCreateTexture (); +begin + mTexId := createFontTexture(mFontBmp, mFontWdt, (mWidth <= 0)); +end; + + +procedure TGxBmpFont.oglDestroyTexture (); +begin + if (mTexId <> 0) then + begin + glDeleteTextures(1, @mTexId); + mTexId := 0; + end; +end; + + +function TGxBmpFont.charWidth (const ch: AnsiChar): Integer; +begin + result := (mFontWdt[Byte(ch)] and $0f); +end; + + +function TGxBmpFont.textWidth (const s: AnsiString): Integer; +var + ch: AnsiChar; +begin + if (Length(s) > 0) then + begin + result := -1; + for ch in s do result += (mFontWdt[Byte(ch)] and $0f)+1; + end + else + begin + result := 0; + end; +end; + + +// return width (not including last empty pixel) +function TGxBmpFont.drawTextInternal (x, y: Integer; const s: AnsiString): Integer; +var + ch: AnsiChar; + tx, ty: Integer; +begin + if (Length(s) = 0) then begin result := 0; exit; end; + + result := -1; + + glEnable(GL_ALPHA_TEST); + glAlphaFunc(GL_NOTEQUAL, 0.0); + glEnable(GL_TEXTURE_2D); + glBindTexture(GL_TEXTURE_2D, mTexId); + + for ch in s do + begin + tx := (Integer(ch) mod 16)*8; + ty := (Integer(ch) div 16)*8; + glBegin(GL_QUADS); + glTexCoord2f((tx+0)/128.0, (ty+0)/128.0); glVertex2i(x+0, y+0); // top-left + glTexCoord2f((tx+8)/128.0, (ty+0)/128.0); glVertex2i(x+8, y+0); // top-right + glTexCoord2f((tx+8)/128.0, (ty+8)/128.0); glVertex2i(x+8, y+8); // bottom-right + glTexCoord2f((tx+0)/128.0, (ty+8)/128.0); glVertex2i(x+0, y+8); // bottom-left + glEnd(); + x += (mFontWdt[Byte(ch)] and $0f)+1; + result += (mFontWdt[Byte(ch)] and $0f)+1; + end; + + glDisable(GL_ALPHA_TEST); + glDisable(GL_TEXTURE_2D); + glBindTexture(GL_TEXTURE_2D, 0); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +var + fontList: array of TGxBmpFont = nil; + defaultFontName: AnsiString = 'dos'; + + +function strEquCI (const s0, s1: AnsiString): Boolean; +var + f: Integer; + c0, c1: AnsiChar; +begin + result := (Length(s0) = Length(s1)); + if (result) then + begin + for f := 1 to Length(s0) do + begin + c0 := s0[f]; + if (c0 >= 'a') and (c0 <= 'z') then Dec(c0, 32); // poor man's `toupper()` + c1 := s1[f]; + if (c1 >= 'a') and (c1 <= 'z') then Dec(c1, 32); // poor man's `toupper()` + if (c0 <> c1) then begin result := false; exit; end; + end; + end; +end; + + +function getFontByName (const aname: AnsiString): TGxBmpFont; +var + f: Integer; + fname: AnsiString; +begin + if (Length(fontList) = 0) then raise Exception.Create('font subsystem not initialized'); + if (Length(aname) = 0) or (strEquCI(aname, 'default')) then fname := defaultFontName else fname := aname; + for f := 0 to High(fontList) do + begin + result := fontList[f]; + if (result = nil) then continue; + if (strEquCI(result.name, fname)) then exit; + end; + if (fontList[0] = nil) then raise Exception.Create('font subsystem not properly initialized'); + result := fontList[0]; +end; + + +procedure deleteFonts (); +var + f: Integer; +begin + for f := 0 to High(fontList) do freeAndNil(fontList[f]); + fontList := nil; +end; + + +procedure createFonts (); +begin + deleteFonts(); + SetLength(fontList, 4); + fontList[0] := TGxBmpFont.Create('dos', 8, 8, @kgiFont8[0], @kgiFont8PropWidth[0]); + fontList[1] := TGxBmpFont.Create('dos-prop', 0, 8, @kgiFont8[0], @kgiFont8PropWidth[0]); + fontList[2] := TGxBmpFont.Create('msx', 6, 8, @kgiFont6[0], @kgiFont6PropWidth[0]); + fontList[3] := TGxBmpFont.Create('msx-prop', 0, 8, @kgiFont6[0], @kgiFont6PropWidth[0]); +end; + + +procedure oglInitFonts (); +var + f: Integer; +begin + for f := 0 to High(fontList) do if (fontList[f] <> nil) then fontList[f].oglCreateTexture(); +end; + + +procedure oglDeinitFonts (); +var + f: Integer; +begin + for f := 0 to High(fontList) do if (fontList[f] <> nil) then fontList[f].oglDestroyTexture(); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +procedure oglSetup2DState (); +begin + glDisable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + glDisable(GL_LINE_SMOOTH); + glDisable(GL_POLYGON_SMOOTH); + glDisable(GL_POINT_SMOOTH); + glDisable(GL_DEPTH_TEST); + glDisable(GL_TEXTURE_2D); + glDisable(GL_LIGHTING); + glDisable(GL_DITHER); + glDisable(GL_STENCIL_TEST); + glDisable(GL_SCISSOR_TEST); + glDisable(GL_CULL_FACE); + glDisable(GL_ALPHA_TEST); + + glClearColor(0, 0, 0, 0); + glColor4f(1, 1, 1, 1); +end; + + +procedure oglSetup2D (winWidth, winHeight: Integer; upsideDown: Boolean=false); +begin + glViewport(0, 0, winWidth, winHeight); + + oglSetup2DState(); + + glMatrixMode(GL_TEXTURE); + glLoadIdentity(); + + glMatrixMode(GL_COLOR); + glLoadIdentity(); + + glMatrixMode(GL_PROJECTION); + glLoadIdentity(); + if (upsideDown) then + begin + glOrtho(0, winWidth, 0, winHeight, -1, 1); // set origin to bottom left + end + else + begin + glOrtho(0, winWidth, winHeight, 0, -1, 1); // set origin to top left + end; + + glMatrixMode(GL_MODELVIEW); + glLoadIdentity(); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +{$INCLUDE fui_gfx_gl_cursor.inc} + +procedure oglDrawCursor (); begin oglDrawCursorAt(fuiMouseX, fuiMouseY); end; + + +// ////////////////////////////////////////////////////////////////////////// // +constructor TGxContext.Create (); +begin + mActive := false; + mColor := TGxRGBA.Create(255, 255, 255); + mFont := getFontByName('default'); + mScaled := false; + mScale := 1.0; + mClipRect := TGxRect.Create(0, 0, 8192, 8192); + mClipOfs := TGxOfs.Create(0, 0); +end; + + +destructor TGxContext.Destroy (); +begin + if (mActive) then gxSetContext(nil); + inherited; +end; + + +function TGxContext.getFont (): AnsiString; +begin + result := mFont.name; +end; + +procedure TGxContext.setFont (const aname: AnsiString); +begin + mFont := getFontByName(aname); +end; + + +procedure TGxContext.onActivate (); +begin + setupGLColor(mColor); + realizeClip(); +end; + +procedure TGxContext.onDeactivate (); +begin +end; + + +procedure TGxContext.setColor (const clr: TGxRGBA); +begin + mColor := clr; + if (mActive) then setupGLColor(mColor); +end; + + +procedure TGxContext.realizeClip (); +var + sx, sy, sw, sh: Integer; +begin + if (not mActive) then exit; // just in case + if (mClipRect.w <= 0) or (mClipRect.h <= 0) then + begin + glEnable(GL_SCISSOR_TEST); + glScissor(0, 0, 0, 0); + end + else + begin + if (mScaled) then + begin + sx := trunc(mClipRect.x*mScale); + sy := trunc(mClipRect.y*mScale); + sw := trunc(mClipRect.w*mScale); + sh := trunc(mClipRect.h*mScale); + end + else + begin + sx := mClipRect.x; + sy := mClipRect.y; + sw := mClipRect.w; + sh := mClipRect.h; + end; + if (not intersectRect(sx, sy, sw, sh, 0, 0, fuiScrWdt, fuiScrHgt)) then + begin + glEnable(GL_SCISSOR_TEST); + glScissor(0, 0, 0, 0); + end + else if (sx = 0) and (sy = 0) and (sw = fuiScrWdt) and (sh = fuiScrHgt) then + begin + glDisable(GL_SCISSOR_TEST); + end + else + begin + glEnable(GL_SCISSOR_TEST); + sy := fuiScrHgt-(sy+sh); + glScissor(sx, sy, sw, sh); + end; + end; +end; + + +procedure TGxContext.resetClip (); +begin + mClipRect := TGxRect.Create(0, 0, 8192, 8192); + if (mActive) then realizeClip(); +end; + + +procedure TGxContext.setClipOfs (const aofs: TGxOfs); +begin + mClipOfs := aofs; +end; + + +procedure TGxContext.setClipRect (const aclip: TGxRect); +begin + mClipRect := aclip; + if (mActive) then realizeClip(); +end; + + +function TGxContext.setOffset (constref aofs: TGxOfs): TGxOfs; +begin + result := mClipOfs; + mClipOfs := aofs; +end; + + +function TGxContext.setClip (constref aclip: TGxRect): TGxRect; +begin + result := mClipRect; + mClipRect := aclip; + if (mActive) then realizeClip(); +end; + + +function TGxContext.combineClip (constref aclip: TGxRect): TGxRect; +begin + result := mClipRect; + mClipRect.intersect(aclip); + if (mActive) then realizeClip(); +end; + + +procedure TGxContext.line (x1, y1, x2, y2: Integer); +begin + if (not mActive) or (mClipRect.w < 1) or (mClipRect.h < 1) or (mColor.a = 0) then exit; + + if (not mScaled) then + begin + glLineWidth(1); + glBegin(GL_LINES); + glVertex2f(x1+0.375, y1+0.375); + glVertex2f(x2+0.375, y2+0.375); + glEnd(); + + if (x1 <> x2) or (y1 <> y2) then + begin + glPointSize(1); + glBegin(GL_POINTS); + glVertex2f(x2+0.375, y2+0.375); + glEnd(); + end; + end + else + begin + glLineWidth(1); + glBegin(GL_LINES); + glVertex2i(x1, y1); + glVertex2i(x2, y2); + // draw last point + glVertex2i(x2, y2); + glVertex2i(x2+1, y2+1); + glEnd(); + end; +end; + + +procedure TGxContext.hline (x, y, len: Integer); +begin + if (not mActive) or (mClipRect.w < 1) or (mClipRect.h < 1) or (mColor.a = 0) then exit; + if (len < 1) then exit; + if (not mScaled) then + begin + glLineWidth(1); + glBegin(GL_LINES); + glVertex2f(x+0.375, y+0.375); + glVertex2f(x+len+0.375, y+0.375); + glEnd(); + end + else if (mScale > 1.0) then + begin + glBegin(GL_QUADS); + glVertex2i(x, y); + glVertex2i(x+len, y); + glVertex2i(x+len, y+1); + glVertex2i(x, y+1); + glEnd(); + end + else + begin + glPointSize(1); + glBegin(GL_POINTS); + while (len > 0) do begin glVertex2i(x, y); Inc(x); Dec(len); end; + glEnd(); + end; +end; + + +procedure TGxContext.vline (x, y, len: Integer); +begin + if (not mActive) or (mClipRect.w < 1) or (mClipRect.h < 1) or (mColor.a = 0) then exit; + if (len < 1) then exit; + if (not mScaled) then + begin + glLineWidth(1); + glBegin(GL_LINES); + glVertex2f(x+0.375, y+0.375); + glVertex2f(x+0.375, y+len+0.375); + glEnd(); + end + else if (mScale > 1.0) then + begin + glBegin(GL_QUADS); + glVertex2i(x, y); + glVertex2i(x, y+len); + glVertex2i(x+1, y+len); + glVertex2i(x+1, y); + glEnd(); + end + else + begin + glPointSize(1); + glBegin(GL_POINTS); + while (len > 0) do begin glVertex2i(x, y); Inc(y); Dec(len); end; + glEnd(); + end; +end; + + +procedure TGxContext.rect (x, y, w, h: Integer); +begin + if (not mActive) or (mClipRect.w < 1) or (mClipRect.h < 1) or (mColor.a = 0) then exit; + if (w < 0) or (h < 0) then exit; + if (w = 1) and (h = 1) then + begin + glPointSize(1); + glBegin(GL_POINTS); + if mScaled then glVertex2i(x, y) else glVertex2f(x+0.375, y+0.375); + glEnd(); + end + else + begin + if (not mScaled) then + begin + glLineWidth(1); + glBegin(GL_LINES); + glVertex2i(x, y); glVertex2i(x+w, y); // top + glVertex2i(x, y+h-1); glVertex2i(x+w, y+h-1); // bottom + glVertex2f(x+0.375, y+1); glVertex2f(x+0.375, y+h-1); // left + glVertex2f(x+w-1+0.375, y+1); glVertex2f(x+w-1+0.375, y+h-1); // right + glEnd(); + end + else + begin + hline(x, y, w); + hline(x, y+h-1, w); + vline(x, y+1, h-2); + vline(x+w-1, y+1, h-2); + end; + end; +end; + + +procedure TGxContext.fillRect (x, y, w, h: Integer); +begin + if (not mActive) or (mClipRect.w < 1) or (mClipRect.h < 1) or (mColor.a = 0) then exit; + if (w < 0) or (h < 0) then exit; + glBegin(GL_QUADS); + glVertex2f(x, y); + glVertex2f(x+w, y); + glVertex2f(x+w, y+h); + glVertex2f(x, y+h); + glEnd(); +end; + + +procedure TGxContext.darkenRect (x, y, w, h: Integer; a: Integer); +begin + if (not mActive) or (mClipRect.w < 1) or (mClipRect.h < 1) or (a >= 255) then exit; + if (w < 0) or (h < 0) then exit; + if (a < 0) then a := 0; + glEnable(GL_BLEND); + glBlendFunc(GL_ZERO, GL_SRC_ALPHA); + glColor4f(0.0, 0.0, 0.0, a/255.0); + glBegin(GL_QUADS); + glVertex2i(x, y); + glVertex2i(x+w, y); + glVertex2i(x+w, y+h); + glVertex2i(x, y+h); + glEnd(); + setupGLColor(mColor); +end; + + +function TGxContext.charWidth (const ch: AnsiChar): Integer; +begin + result := mFont.charWidth(ch); +end; + +function TGxContext.charHeight (const ch: AnsiChar): Integer; +begin + result := mFont.height; +end; + + +function TGxContext.textWidth (const s: AnsiString): Integer; +begin + result := mFont.textWidth(s); +end; + +function TGxContext.textHeight (const s: AnsiString): Integer; +begin + result := mFont.height; +end; + + +function TGxContext.drawChar (x, y: Integer; const ch: AnsiChar): Integer; // returns char width +begin + result := mFont.charWidth(ch); + if (not mActive) or (mClipRect.w < 1) or (mClipRect.h < 1) or (mColor.a = 0) then exit; + TGxBmpFont(mFont).drawTextInternal(x, y, ch); +end; + +function TGxContext.drawText (x, y: Integer; const s: AnsiString): Integer; // returns text width +begin + result := mFont.textWidth(s); + if (not mActive) or (mClipRect.w < 1) or (mClipRect.h < 1) or (mColor.a = 0) or (Length(s) = 0) then exit; + TGxBmpFont(mFont).drawTextInternal(x, y, s); +end; + + +function TGxContext.iconMarkWidth (ic: TMarkIcon): Integer; begin result := 11; end; +function TGxContext.iconMarkHeight (ic: TMarkIcon): Integer; begin result := 8; end; + +procedure TGxContext.drawIconMark (ic: TMarkIcon; x, y: Integer; marked: Boolean); +var + f: Integer; +begin + if (not mActive) or (mClipRect.w < 1) or (mClipRect.h < 1) or (mColor.a = 0) then exit; + if (ic = TMarkIcon.Checkbox) then + begin + vline(x, y, 7); + vline(x+10, y, 7); + hline(x+1, y, 1); + hline(x+1, y+6, 1); + hline(x+9, y, 1); + hline(x+9, y+6, 1); + end + else + begin + vline(x, y+1, 5); + vline(x+10, y+1, 5); + hline(x+1, y, 1); + hline(x+1, y+6, 1); + hline(x+9, y, 1); + hline(x+9, y+6, 1); + end; + if (not marked) then exit; + case ic of + TMarkIcon.Checkbox: + begin + for f := 0 to 4 do + begin + vline(x+3+f, y+1+f, 1); + vline(x+7-f, y+1+f, 1); + end; + end; + TMarkIcon.Radiobox: + begin + hline(x+4, y+1, 3); + hline(x+3, y+2, 5); + hline(x+3, y+3, 5); + hline(x+3, y+4, 5); + hline(x+4, y+5, 3); + end; + end; +end; + + +function TGxContext.iconWinWidth (ic: TWinIcon): Integer; begin result := 9; end; +function TGxContext.iconWinHeight (ic: TWinIcon): Integer; begin result := 8; end; + +procedure TGxContext.drawIconWin (ic: TWinIcon; x, y: Integer; pressed: Boolean); +var + f: Integer; +begin + if (not mActive) or (mClipRect.w < 1) or (mClipRect.h < 1) or (mColor.a = 0) then exit; + if pressed then rect(x, y, 9, 8); + for f := 1 to 5 do + begin + vline(x+1+f, y+f, 1); + vline(x+1+6-f, y+f, 1); + end; +end; + + +procedure TGxContext.glSetScale (ascale: Single); +begin + if (ascale < 0.01) then ascale := 0.01; + glLoadIdentity(); + glScalef(ascale, ascale, 1.0); + mScale := ascale; + mScaled := (ascale <> 1.0); +end; + +procedure TGxContext.glSetTrans (ax, ay: Single); +begin + glLoadIdentity(); + glScalef(mScale, mScale, 1.0); + glTranslatef(ax, ay, 0); +end; + + +procedure TGxContext.glSetScaleTrans (ascale, ax, ay: Single); +begin + glSetScale(ascale); + glTranslatef(ax, ay, 0); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +(* +procedure oglRestoreMode (doClear: Boolean); +begin + oglSetup2D(fuiScrWdt, fuiScrHgt); + glScissor(0, 0, fuiScrWdt, fuiScrHgt); + + glBindTexture(GL_TEXTURE_2D, 0); + glDisable(GL_BLEND); + glDisable(GL_TEXTURE_2D); + glDisable(GL_STENCIL_TEST); + glDisable(GL_SCISSOR_TEST); + glDisable(GL_LIGHTING); + glDisable(GL_DEPTH_TEST); + glDisable(GL_CULL_FACE); + glDisable(GL_LINE_SMOOTH); + glDisable(GL_POINT_SMOOTH); + glLineWidth(1); + glPointSize(1); + glColor4f(1, 1, 1, 1); + + if doClear then + begin + glClearColor(0, 0, 0, 0); + glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT or GL_ACCUM_BUFFER_BIT or GL_STENCIL_BUFFER_BIT); + end; + + // scale everything + glMatrixMode(GL_MODELVIEW); + glLoadIdentity(); + //glScalef(4, 4, 1); +end; +*) + + +//procedure onWinFocus (); begin end; +//procedure onWinBlur (); begin fuiResetKMState(true); end; + +//procedure onPreRender (); begin oglRestoreMode(gGfxDoClear); end; +procedure onPostRender (); begin oglDrawCursor(); end; + +procedure onInit (); +begin + //oglSetup2D(fuiScrWdt, fuiScrHgt); + createCursorTexture(); + oglInitFonts(); +end; + +procedure onDeinit (); +begin + fuiResetKMState(false); + if (curtexid <> 0) then glDeleteTextures(1, @curtexid); + curtexid := 0; + oglDeinitFonts(); + fuiSetButState(0); + fuiSetModState(0); + fuiSetMouseX(0); + fuiSetMouseY(0); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +initialization + savedGLState := TSavedGLState.Create(false); + createFonts(); + //winFocusCB := onWinFocus; + //winBlurCB := onWinBlur; + //prerenderFrameCB := onPreRender; + postrenderFrameCB := onPostRender; + oglInitCB := onInit; + oglDeinitCB := onDeinit; +end. diff --git a/src/flexui/fui_gfx_gl_cursor.inc b/src/flexui/fui_gfx_gl_cursor.inc new file mode 100644 index 0000000..1884c9f --- /dev/null +++ b/src/flexui/fui_gfx_gl_cursor.inc @@ -0,0 +1,171 @@ +(* coded by Ketmar // Invisible Vector + * Understanding is not required. Only obedience. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +// ////////////////////////////////////////////////////////////////////////// // +// cursor (hi, Death Track!) +const curTexWidth = 32; +const curTexHeight = 32; +const curWidth = 17; +const curHeight = 23; + +const cursorImg: array[0..curWidth*curHeight-1] of Byte = ( + 2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 3,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 3,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 3,3,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0, + 3,3,4,2,2,0,0,0,0,0,0,0,0,0,0,0,0, + 3,3,4,4,2,2,0,0,0,0,0,0,0,0,0,0,0, + 3,3,4,4,4,2,2,0,0,0,0,0,0,0,0,0,0, + 3,3,4,4,4,4,2,2,0,0,0,0,0,0,0,0,0, + 3,3,4,4,4,5,6,2,2,0,0,0,0,0,0,0,0, + 3,3,4,4,5,6,7,5,2,2,0,0,0,0,0,0,0, + 3,3,4,5,6,7,5,4,5,2,2,0,0,0,0,0,0, + 3,3,5,6,7,5,4,5,6,7,2,2,0,0,0,0,0, + 3,3,6,7,5,4,5,6,7,7,7,2,2,0,0,0,0, + 3,3,7,5,4,5,6,7,7,7,7,7,2,2,0,0,0, + 3,3,5,4,5,6,8,8,8,8,8,8,8,8,2,0,0, + 3,3,4,5,6,3,8,8,8,8,8,8,8,8,8,0,0, + 3,3,5,6,3,3,0,0,0,0,0,0,0,0,0,0,0, + 3,3,6,3,3,0,0,0,0,0,0,0,0,0,0,0,0, + 3,3,3,3,0,0,0,0,0,0,0,0,0,0,0,0,0, + 3,3,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 3,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +); +const cursorPal: array[0..9*4-1] of Byte = ( + 0, 0, 0, 0, + 0, 0, 0, 92, // shadow + 85,255,255,255, + 85, 85,255,255, + 255, 85, 85,255, + 170, 0,170,255, + 85, 85, 85,255, + 0, 0, 0,255, + 0, 0,170,255 +); + + +var + curtexid: GLuint = 0; + + +procedure createCursorTexture (); +var + tex, tpp: PByte; + c: Integer; + x, y: Integer; +begin + if (curtexid <> 0) then exit; //begin glDeleteTextures(1, @curtexid); curtexid := 0; end; + + GetMem(tex, curTexWidth*curTexHeight*4); + try + FillChar(tex^, curTexWidth*curTexHeight*4, 0); + + // draw shadow + for y := 0 to curHeight-1 do + begin + for x := 0 to curWidth-1 do + begin + if (cursorImg[y*curWidth+x] <> 0) then + begin + c := 1*4; + tpp := tex+((y+1)*(curTexWidth*4)+(x+3)*4); + tpp^ := cursorPal[c+0]; Inc(tpp); + tpp^ := cursorPal[c+1]; Inc(tpp); + tpp^ := cursorPal[c+2]; Inc(tpp); + tpp^ := cursorPal[c+3]; Inc(tpp); + tpp^ := cursorPal[c+0]; Inc(tpp); + tpp^ := cursorPal[c+1]; Inc(tpp); + tpp^ := cursorPal[c+2]; Inc(tpp); + tpp^ := cursorPal[c+3]; Inc(tpp); + end; + end; + end; + + // draw cursor + for y := 0 to curHeight-1 do + begin + for x := 0 to curWidth-1 do + begin + c := cursorImg[y*curWidth+x]*4; + if (c <> 0) then + begin + tpp := tex+(y*(curTexWidth*4)+x*4); + tpp^ := cursorPal[c+0]; Inc(tpp); + tpp^ := cursorPal[c+1]; Inc(tpp); + tpp^ := cursorPal[c+2]; Inc(tpp); + tpp^ := cursorPal[c+3]; Inc(tpp); + end; + end; + end; + + glGenTextures(1, @curtexid); + if (curtexid = 0) then raise Exception.Create('can''t create cursor texture'); + + glBindTexture(GL_TEXTURE_2D, curtexid); + glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT); + glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST); + + //GLfloat[4] bclr = 0.0; + //glTexParameterfv(GL_TEXTURE_2D, GL_TEXTURE_BORDER_COLOR, bclr.ptr); + + glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, curTexWidth, curTexHeight, 0, GL_RGBA{gltt}, GL_UNSIGNED_BYTE, tex); + glFlush(); + finally + FreeMem(tex); + end; +end; + + +procedure oglDrawCursorAt (msX, msY: Integer); +var + sst: TSavedGLState; +begin + //if (curtexid = 0) then createCursorTexture() else glBindTexture(GL_TEXTURE_2D, curtexid); + sst := TSavedGLState.Create(true); + try + oglSetup2D(fuiScrWdt, fuiScrHgt); + glBindTexture(GL_TEXTURE_2D, curtexid); + // blend it + glEnable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + glEnable(GL_TEXTURE_2D); + glDisable(GL_STENCIL_TEST); + glDisable(GL_SCISSOR_TEST); + glDisable(GL_LIGHTING); + glDisable(GL_DEPTH_TEST); + glDisable(GL_CULL_FACE); + // color and opacity + glColor4f(1, 1, 1, 1.0); + //Dec(msX, 2); + glBegin(GL_QUADS); + glTexCoord2f(0.0, 0.0); glVertex2i(msX, msY); // top-left + glTexCoord2f(1.0, 0.0); glVertex2i(msX+curTexWidth, msY); // top-right + glTexCoord2f(1.0, 1.0); glVertex2i(msX+curTexWidth, msY+curTexHeight); // bottom-right + glTexCoord2f(0.0, 1.0); glVertex2i(msX, msY+curTexHeight); // bottom-left + glEnd(); + //Inc(msX, 2); + //glDisable(GL_BLEND); + //glDisable(GL_TEXTURE_2D); + //glColor4f(1, 1, 1, 1); + //glBindTexture(GL_TEXTURE_2D, 0); + finally + sst.restore(); + end; +end; diff --git a/src/flexui/fui_gfx_gl_fonts.inc b/src/flexui/fui_gfx_gl_fonts.inc new file mode 100644 index 0000000..c3372e2 --- /dev/null +++ b/src/flexui/fui_gfx_gl_fonts.inc @@ -0,0 +1,311 @@ +(* coded by Ketmar // Invisible Vector + * Understanding is not required. Only obedience. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +// ////////////////////////////////////////////////////////////////////////// // +// fonts +const kgiFont6: array[0..256*8-1] of Byte = ( +$00,$00,$00,$00,$00,$00,$00,$00,$3c,$42,$a5,$81,$a5,$99,$42,$3c,$3c,$7e,$db,$ff,$ff,$db,$66,$3c,$6c,$fe, +$fe,$fe,$7c,$38,$10,$00,$10,$38,$7c,$fe,$7c,$38,$10,$00,$10,$38,$54,$fe,$54,$10,$38,$00,$10,$38,$7c,$fe, +$fe,$10,$38,$00,$00,$00,$00,$30,$30,$00,$00,$00,$ff,$ff,$ff,$e7,$e7,$ff,$ff,$ff,$38,$44,$82,$82,$82,$44, +$38,$00,$c7,$bb,$7d,$7d,$7d,$bb,$c7,$ff,$0f,$03,$05,$79,$88,$88,$88,$70,$38,$44,$44,$44,$38,$10,$7c,$10, +$30,$28,$24,$24,$28,$20,$e0,$c0,$3c,$24,$3c,$24,$24,$e4,$dc,$18,$10,$54,$38,$ee,$38,$54,$10,$00,$10,$10, +$10,$7c,$10,$10,$10,$10,$10,$10,$10,$ff,$00,$00,$00,$00,$00,$00,$00,$ff,$10,$10,$10,$10,$10,$10,$10,$f0, +$10,$10,$10,$10,$10,$10,$10,$1f,$10,$10,$10,$10,$10,$10,$10,$ff,$10,$10,$10,$10,$10,$10,$10,$10,$10,$10, +$10,$10,$00,$00,$00,$ff,$00,$00,$00,$00,$00,$00,$00,$1f,$10,$10,$10,$10,$00,$00,$00,$f0,$10,$10,$10,$10, +$10,$10,$10,$1f,$00,$00,$00,$00,$10,$10,$10,$f0,$00,$00,$00,$00,$81,$42,$24,$18,$18,$24,$42,$81,$01,$02, +$04,$08,$10,$20,$40,$80,$80,$40,$20,$10,$08,$04,$02,$01,$00,$10,$10,$ff,$10,$10,$00,$00,$00,$00,$00,$00, +$00,$00,$00,$00,$20,$20,$20,$20,$00,$00,$20,$00,$50,$50,$50,$00,$00,$00,$00,$00,$50,$50,$f8,$50,$f8,$50, +$50,$00,$20,$78,$a0,$70,$28,$f0,$20,$00,$c0,$c8,$10,$20,$40,$98,$18,$00,$40,$a0,$40,$a8,$90,$98,$60,$00, +$10,$20,$40,$00,$00,$00,$00,$00,$10,$20,$40,$40,$40,$20,$10,$00,$40,$20,$10,$10,$10,$20,$40,$00,$88,$50, +$20,$f8,$20,$50,$88,$00,$00,$20,$20,$f8,$20,$20,$00,$00,$00,$00,$00,$00,$00,$20,$20,$40,$00,$00,$00,$78, +$00,$00,$00,$00,$00,$00,$00,$00,$00,$60,$60,$00,$00,$00,$08,$10,$20,$40,$80,$00,$70,$88,$98,$a8,$c8,$88, +$70,$00,$20,$60,$a0,$20,$20,$20,$f8,$00,$70,$88,$08,$10,$60,$80,$f8,$00,$70,$88,$08,$30,$08,$88,$70,$00, +$10,$30,$50,$90,$f8,$10,$10,$00,$f8,$80,$e0,$10,$08,$10,$e0,$00,$30,$40,$80,$f0,$88,$88,$70,$00,$f8,$88, +$10,$20,$20,$20,$20,$00,$70,$88,$88,$70,$88,$88,$70,$00,$70,$88,$88,$78,$08,$10,$60,$00,$00,$00,$20,$00, +$00,$20,$00,$00,$00,$00,$20,$00,$00,$20,$20,$40,$18,$30,$60,$c0,$60,$30,$18,$00,$00,$00,$f8,$00,$f8,$00, +$00,$00,$c0,$60,$30,$18,$30,$60,$c0,$00,$70,$88,$08,$10,$20,$00,$20,$00,$70,$88,$08,$68,$a8,$a8,$70,$00, +$20,$50,$88,$88,$f8,$88,$88,$00,$f0,$48,$48,$70,$48,$48,$f0,$00,$30,$48,$80,$80,$80,$48,$30,$00,$e0,$50, +$48,$48,$48,$50,$e0,$00,$f8,$80,$80,$f0,$80,$80,$f8,$00,$f8,$80,$80,$f0,$80,$80,$80,$00,$70,$88,$80,$b8, +$88,$88,$70,$00,$88,$88,$88,$f8,$88,$88,$88,$00,$70,$20,$20,$20,$20,$20,$70,$00,$38,$10,$10,$10,$90,$90, +$60,$00,$88,$90,$a0,$c0,$a0,$90,$88,$00,$80,$80,$80,$80,$80,$80,$f8,$00,$88,$d8,$a8,$a8,$88,$88,$88,$00, +$88,$c8,$c8,$a8,$98,$98,$88,$00,$70,$88,$88,$88,$88,$88,$70,$00,$f0,$88,$88,$f0,$80,$80,$80,$00,$70,$88, +$88,$88,$a8,$90,$68,$00,$f0,$88,$88,$f0,$a0,$90,$88,$00,$70,$88,$80,$70,$08,$88,$70,$00,$f8,$20,$20,$20, +$20,$20,$20,$00,$88,$88,$88,$88,$88,$88,$70,$00,$88,$88,$88,$88,$50,$50,$20,$00,$88,$88,$88,$a8,$a8,$d8, +$88,$00,$88,$88,$50,$20,$50,$88,$88,$00,$88,$88,$88,$70,$20,$20,$20,$00,$f8,$08,$10,$20,$40,$80,$f8,$00, +$70,$40,$40,$40,$40,$40,$70,$00,$00,$00,$80,$40,$20,$10,$08,$00,$70,$10,$10,$10,$10,$10,$70,$00,$20,$50, +$88,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$f8,$00,$40,$20,$10,$00,$00,$00,$00,$00,$00,$00,$70,$08, +$78,$88,$78,$00,$80,$80,$b0,$c8,$88,$c8,$b0,$00,$00,$00,$70,$88,$80,$88,$70,$00,$08,$08,$68,$98,$88,$98, +$68,$00,$00,$00,$70,$88,$f8,$80,$70,$00,$10,$28,$20,$f8,$20,$20,$20,$00,$00,$00,$68,$98,$98,$68,$08,$70, +$80,$80,$f0,$88,$88,$88,$88,$00,$20,$00,$60,$20,$20,$20,$70,$00,$10,$00,$30,$10,$10,$10,$90,$60,$40,$40, +$48,$50,$60,$50,$48,$00,$60,$20,$20,$20,$20,$20,$70,$00,$00,$00,$d0,$a8,$a8,$a8,$a8,$00,$00,$00,$b0,$c8, +$88,$88,$88,$00,$00,$00,$70,$88,$88,$88,$70,$00,$00,$00,$b0,$c8,$c8,$b0,$80,$80,$00,$00,$68,$98,$98,$68, +$08,$08,$00,$00,$b0,$c8,$80,$80,$80,$00,$00,$00,$78,$80,$f0,$08,$f0,$00,$40,$40,$f0,$40,$40,$48,$30,$00, +$00,$00,$90,$90,$90,$90,$68,$00,$00,$00,$88,$88,$88,$50,$20,$00,$00,$00,$88,$a8,$a8,$a8,$50,$00,$00,$00, +$88,$50,$20,$50,$88,$00,$00,$00,$88,$88,$98,$68,$08,$70,$00,$00,$f8,$10,$20,$40,$f8,$00,$18,$20,$20,$40, +$20,$20,$18,$00,$20,$20,$20,$00,$20,$20,$20,$00,$c0,$20,$20,$10,$20,$20,$c0,$00,$40,$a8,$10,$00,$00,$00, +$00,$00,$00,$00,$20,$50,$f8,$00,$00,$00,$00,$00,$00,$00,$00,$00,$ff,$ff,$f0,$f0,$f0,$f0,$0f,$0f,$0f,$0f, +$00,$00,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$00,$00,$00,$00,$00,$00,$00,$00,$00,$3c,$3c,$00,$00,$00,$ff,$ff, +$ff,$ff,$ff,$ff,$00,$00,$c0,$c0,$c0,$c0,$c0,$c0,$c0,$c0,$0f,$0f,$0f,$0f,$f0,$f0,$f0,$f0,$fc,$fc,$fc,$fc, +$fc,$fc,$fc,$fc,$03,$03,$03,$03,$03,$03,$03,$03,$3f,$3f,$3f,$3f,$3f,$3f,$3f,$3f,$11,$22,$44,$88,$11,$22, +$44,$88,$88,$44,$22,$11,$88,$44,$22,$11,$fe,$7c,$38,$10,$00,$00,$00,$00,$00,$00,$00,$00,$10,$38,$7c,$fe, +$80,$c0,$e0,$f0,$e0,$c0,$80,$00,$01,$03,$07,$0f,$07,$03,$01,$00,$ff,$7e,$3c,$18,$18,$3c,$7e,$ff,$81,$c3, +$e7,$ff,$ff,$e7,$c3,$81,$f0,$f0,$f0,$f0,$00,$00,$00,$00,$00,$00,$00,$00,$0f,$0f,$0f,$0f,$0f,$0f,$0f,$0f, +$00,$00,$00,$00,$00,$00,$00,$00,$f0,$f0,$f0,$f0,$33,$33,$cc,$cc,$33,$33,$cc,$cc,$00,$20,$20,$50,$50,$88, +$f8,$00,$20,$20,$70,$20,$70,$20,$20,$00,$00,$00,$00,$50,$88,$a8,$50,$00,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff, +$00,$00,$00,$00,$ff,$ff,$ff,$ff,$f0,$f0,$f0,$f0,$f0,$f0,$f0,$f0,$0f,$0f,$0f,$0f,$0f,$0f,$0f,$0f,$ff,$ff, +$ff,$ff,$00,$00,$00,$00,$00,$00,$68,$90,$90,$90,$68,$00,$30,$48,$48,$70,$48,$48,$70,$c0,$f8,$88,$80,$80, +$80,$80,$80,$00,$00,$50,$70,$88,$f8,$80,$70,$00,$00,$00,$78,$80,$f0,$80,$78,$00,$00,$00,$78,$90,$90,$90, +$60,$00,$20,$00,$60,$20,$20,$20,$70,$00,$50,$00,$70,$20,$20,$20,$70,$00,$f8,$20,$70,$a8,$a8,$70,$20,$f8, +$20,$50,$88,$f8,$88,$50,$20,$00,$70,$88,$88,$88,$50,$50,$d8,$00,$30,$40,$40,$20,$50,$50,$50,$20,$00,$00, +$00,$50,$a8,$a8,$50,$00,$08,$70,$a8,$a8,$a8,$70,$80,$00,$38,$40,$80,$f8,$80,$40,$38,$00,$70,$88,$88,$88, +$88,$88,$88,$00,$00,$f8,$00,$f8,$00,$f8,$00,$00,$20,$20,$f8,$20,$20,$00,$f8,$00,$c0,$30,$08,$30,$c0,$00, +$f8,$00,$50,$f8,$80,$f0,$80,$80,$f8,$00,$78,$80,$80,$f0,$80,$80,$78,$00,$20,$20,$20,$20,$20,$20,$a0,$40, +$70,$20,$20,$20,$20,$20,$70,$00,$50,$70,$20,$20,$20,$20,$70,$00,$00,$18,$24,$24,$18,$00,$00,$00,$00,$30, +$78,$78,$30,$00,$00,$00,$00,$00,$00,$00,$30,$00,$00,$00,$3e,$20,$20,$20,$a0,$60,$20,$00,$a0,$50,$50,$50, +$00,$00,$00,$00,$40,$a0,$20,$40,$e0,$00,$00,$00,$00,$38,$38,$38,$38,$38,$38,$00,$3c,$42,$99,$a1,$a1,$99, +$42,$3c,$00,$00,$90,$a8,$e8,$a8,$90,$00,$00,$00,$60,$10,$70,$90,$68,$00,$00,$00,$f0,$80,$f0,$88,$f0,$00, +$00,$00,$90,$90,$90,$f8,$08,$00,$00,$00,$30,$50,$50,$70,$88,$00,$00,$00,$70,$88,$f8,$80,$70,$00,$00,$20, +$70,$a8,$a8,$70,$20,$00,$00,$00,$78,$48,$40,$40,$40,$00,$00,$00,$88,$50,$20,$50,$88,$00,$00,$00,$88,$98, +$a8,$c8,$88,$00,$00,$50,$20,$00,$98,$a8,$c8,$00,$00,$00,$90,$a0,$c0,$a0,$90,$00,$00,$00,$38,$28,$28,$48, +$88,$00,$00,$00,$88,$d8,$a8,$88,$88,$00,$00,$00,$88,$88,$f8,$88,$88,$00,$00,$00,$70,$88,$88,$88,$70,$00, +$00,$00,$78,$48,$48,$48,$48,$00,$00,$00,$78,$88,$78,$28,$48,$00,$00,$00,$f0,$88,$f0,$80,$80,$00,$00,$00, +$78,$80,$80,$80,$78,$00,$00,$00,$f8,$20,$20,$20,$20,$00,$00,$00,$88,$50,$20,$40,$80,$00,$00,$00,$a8,$70, +$20,$70,$a8,$00,$00,$00,$f0,$48,$70,$48,$f0,$00,$00,$00,$40,$40,$70,$48,$70,$00,$00,$00,$88,$88,$c8,$a8, +$c8,$00,$00,$00,$f0,$08,$70,$08,$f0,$00,$00,$00,$a8,$a8,$a8,$a8,$f8,$00,$00,$00,$70,$88,$38,$88,$70,$00, +$00,$00,$a8,$a8,$a8,$f8,$08,$00,$00,$00,$48,$48,$78,$08,$08,$00,$00,$00,$c0,$40,$70,$48,$70,$00,$90,$a8, +$a8,$e8,$a8,$a8,$90,$00,$20,$50,$88,$88,$f8,$88,$88,$00,$f8,$88,$80,$f0,$88,$88,$f0,$00,$90,$90,$90,$90, +$90,$f8,$08,$00,$38,$28,$28,$48,$48,$f8,$88,$00,$f8,$80,$80,$f0,$80,$80,$f8,$00,$20,$70,$a8,$a8,$a8,$70, +$20,$00,$f8,$88,$88,$80,$80,$80,$80,$00,$88,$88,$50,$20,$50,$88,$88,$00,$88,$88,$98,$a8,$c8,$88,$88,$00, +$50,$20,$88,$98,$a8,$c8,$88,$00,$88,$90,$a0,$c0,$a0,$90,$88,$00,$18,$28,$48,$48,$48,$48,$88,$00,$88,$d8, +$a8,$a8,$88,$88,$88,$00,$88,$88,$88,$f8,$88,$88,$88,$00,$70,$88,$88,$88,$88,$88,$70,$00,$f8,$88,$88,$88, +$88,$88,$88,$00,$78,$88,$88,$78,$28,$48,$88,$00,$f0,$88,$88,$f0,$80,$80,$80,$00,$70,$88,$80,$80,$80,$88, +$70,$00,$f8,$20,$20,$20,$20,$20,$20,$00,$88,$88,$88,$50,$20,$40,$80,$00,$a8,$a8,$70,$20,$70,$a8,$a8,$00, +$f0,$48,$48,$70,$48,$48,$f0,$00,$80,$80,$80,$f0,$88,$88,$f0,$00,$88,$88,$88,$c8,$a8,$a8,$c8,$00,$f0,$08, +$08,$30,$08,$08,$f0,$00,$a8,$a8,$a8,$a8,$a8,$a8,$f8,$00,$70,$88,$08,$78,$08,$88,$70,$00,$a8,$a8,$a8,$a8, +$a8,$f8,$08,$00,$88,$88,$88,$88,$78,$08,$08,$00,$c0,$40,$40,$70,$48,$48,$70,$00 +); + +const kgiFont8: array[0..256*8-1] of Byte = ( +$00,$00,$00,$00,$00,$00,$00,$00,$7e,$81,$a5,$81,$bd,$99,$81,$7e,$7e,$ff,$db,$ff,$c3,$e7,$ff,$7e,$6c,$fe, +$fe,$fe,$7c,$38,$10,$00,$10,$38,$7c,$fe,$7c,$38,$10,$00,$38,$7c,$38,$fe,$fe,$d6,$10,$38,$10,$10,$38,$7c, +$fe,$7c,$10,$38,$00,$00,$18,$3c,$3c,$18,$00,$00,$ff,$ff,$e7,$c3,$c3,$e7,$ff,$ff,$00,$3c,$66,$42,$42,$66, +$3c,$00,$ff,$c3,$99,$bd,$bd,$99,$c3,$ff,$0f,$07,$0f,$7d,$cc,$cc,$cc,$78,$3c,$66,$66,$66,$3c,$18,$7e,$18, +$3f,$33,$3f,$30,$30,$70,$f0,$e0,$7f,$63,$7f,$63,$63,$67,$e6,$c0,$99,$5a,$3c,$e7,$e7,$3c,$5a,$99,$80,$e0, +$f8,$fe,$f8,$e0,$80,$00,$02,$0e,$3e,$fe,$3e,$0e,$02,$00,$18,$3c,$7e,$18,$18,$7e,$3c,$18,$66,$66,$66,$66, +$66,$00,$66,$00,$7f,$db,$db,$7b,$1b,$1b,$1b,$00,$7e,$c3,$78,$cc,$cc,$78,$8c,$f8,$00,$00,$00,$00,$7e,$7e, +$7e,$00,$18,$3c,$7e,$18,$7e,$3c,$18,$ff,$18,$3c,$7e,$18,$18,$18,$18,$00,$18,$18,$18,$18,$7e,$3c,$18,$00, +$00,$18,$0c,$fe,$0c,$18,$00,$00,$00,$30,$60,$fe,$60,$30,$00,$00,$00,$00,$c0,$c0,$c0,$fe,$00,$00,$00,$24, +$66,$ff,$66,$24,$00,$00,$00,$18,$3c,$7e,$ff,$ff,$00,$00,$00,$ff,$ff,$7e,$3c,$18,$00,$00,$00,$00,$00,$00, +$00,$00,$00,$00,$30,$78,$78,$30,$30,$00,$30,$00,$6c,$6c,$6c,$00,$00,$00,$00,$00,$6c,$6c,$fe,$6c,$fe,$6c, +$6c,$00,$30,$7c,$c0,$78,$0c,$f8,$30,$00,$00,$c6,$cc,$18,$30,$66,$c6,$00,$38,$6c,$38,$76,$dc,$cc,$76,$00, +$60,$60,$c0,$00,$00,$00,$00,$00,$18,$30,$60,$60,$60,$30,$18,$00,$60,$30,$18,$18,$18,$30,$60,$00,$00,$66, +$3c,$ff,$3c,$66,$00,$00,$00,$30,$30,$fc,$30,$30,$00,$00,$00,$00,$00,$00,$00,$70,$30,$60,$00,$00,$00,$fc, +$00,$00,$00,$00,$00,$00,$00,$00,$00,$30,$30,$00,$06,$0c,$18,$30,$60,$c0,$80,$00,$78,$cc,$dc,$fc,$ec,$cc, +$78,$00,$30,$f0,$30,$30,$30,$30,$fc,$00,$78,$cc,$0c,$38,$60,$cc,$fc,$00,$78,$cc,$0c,$38,$0c,$cc,$78,$00, +$1c,$3c,$6c,$cc,$fe,$0c,$0c,$00,$fc,$c0,$f8,$0c,$0c,$cc,$78,$00,$38,$60,$c0,$f8,$cc,$cc,$78,$00,$fc,$cc, +$0c,$18,$30,$60,$60,$00,$78,$cc,$cc,$78,$cc,$cc,$78,$00,$78,$cc,$cc,$7c,$0c,$18,$70,$00,$00,$00,$30,$30, +$00,$30,$30,$00,$00,$00,$30,$30,$00,$70,$30,$60,$18,$30,$60,$c0,$60,$30,$18,$00,$00,$00,$fc,$00,$fc,$00, +$00,$00,$60,$30,$18,$0c,$18,$30,$60,$00,$78,$cc,$0c,$18,$30,$00,$30,$00,$7c,$c6,$de,$de,$de,$c0,$78,$00, +$30,$78,$cc,$cc,$fc,$cc,$cc,$00,$fc,$66,$66,$7c,$66,$66,$fc,$00,$3c,$66,$c0,$c0,$c0,$66,$3c,$00,$fc,$6c, +$66,$66,$66,$6c,$fc,$00,$fe,$62,$68,$78,$68,$62,$fe,$00,$fe,$62,$68,$78,$68,$60,$f0,$00,$3c,$66,$c0,$c0, +$ce,$66,$3e,$00,$cc,$cc,$cc,$fc,$cc,$cc,$cc,$00,$78,$30,$30,$30,$30,$30,$78,$00,$1e,$0c,$0c,$0c,$cc,$cc, +$78,$00,$e6,$66,$6c,$78,$6c,$66,$e6,$00,$f0,$60,$60,$60,$62,$66,$fe,$00,$c6,$ee,$fe,$d6,$c6,$c6,$c6,$00, +$c6,$e6,$f6,$de,$ce,$c6,$c6,$00,$38,$6c,$c6,$c6,$c6,$6c,$38,$00,$fc,$66,$66,$7c,$60,$60,$f0,$00,$78,$cc, +$cc,$cc,$dc,$78,$1c,$00,$fc,$66,$66,$7c,$78,$6c,$e6,$00,$78,$cc,$e0,$38,$1c,$cc,$78,$00,$fc,$b4,$30,$30, +$30,$30,$78,$00,$cc,$cc,$cc,$cc,$cc,$cc,$fc,$00,$cc,$cc,$cc,$cc,$cc,$78,$30,$00,$c6,$c6,$c6,$d6,$fe,$ee, +$c6,$00,$c6,$c6,$6c,$38,$6c,$c6,$c6,$00,$cc,$cc,$cc,$78,$30,$30,$78,$00,$fe,$cc,$98,$30,$62,$c6,$fe,$00, +$78,$60,$60,$60,$60,$60,$78,$00,$c0,$60,$30,$18,$0c,$06,$02,$00,$78,$18,$18,$18,$18,$18,$78,$00,$10,$38, +$6c,$c6,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$ff,$30,$30,$18,$00,$00,$00,$00,$00,$00,$00,$78,$0c, +$7c,$cc,$76,$00,$e0,$60,$7c,$66,$66,$66,$bc,$00,$00,$00,$78,$cc,$c0,$cc,$78,$00,$1c,$0c,$0c,$7c,$cc,$cc, +$76,$00,$00,$00,$78,$cc,$fc,$c0,$78,$00,$38,$6c,$60,$f0,$60,$60,$f0,$00,$00,$00,$76,$cc,$cc,$7c,$0c,$f8, +$e0,$60,$6c,$76,$66,$66,$e6,$00,$30,$00,$70,$30,$30,$30,$78,$00,$18,$00,$78,$18,$18,$18,$d8,$70,$e0,$60, +$66,$6c,$78,$6c,$e6,$00,$70,$30,$30,$30,$30,$30,$78,$00,$00,$00,$ec,$fe,$d6,$c6,$c6,$00,$00,$00,$f8,$cc, +$cc,$cc,$cc,$00,$00,$00,$78,$cc,$cc,$cc,$78,$00,$00,$00,$dc,$66,$66,$7c,$60,$f0,$00,$00,$76,$cc,$cc,$7c, +$0c,$1e,$00,$00,$d8,$6c,$6c,$60,$f0,$00,$00,$00,$7c,$c0,$78,$0c,$f8,$00,$10,$30,$7c,$30,$30,$34,$18,$00, +$00,$00,$cc,$cc,$cc,$cc,$76,$00,$00,$00,$cc,$cc,$cc,$78,$30,$00,$00,$00,$c6,$c6,$d6,$fe,$6c,$00,$00,$00, +$c6,$6c,$38,$6c,$c6,$00,$00,$00,$cc,$cc,$cc,$7c,$0c,$f8,$00,$00,$fc,$98,$30,$64,$fc,$00,$1c,$30,$30,$e0, +$30,$30,$1c,$00,$18,$18,$18,$00,$18,$18,$18,$00,$e0,$30,$30,$1c,$30,$30,$e0,$00,$76,$dc,$00,$00,$00,$00, +$00,$00,$10,$38,$6c,$c6,$c6,$c6,$fe,$00,$78,$cc,$c0,$cc,$78,$18,$0c,$78,$00,$cc,$00,$cc,$cc,$cc,$7e,$00, +$1c,$00,$78,$cc,$fc,$c0,$78,$00,$7e,$c3,$3c,$06,$3e,$66,$3f,$00,$cc,$00,$78,$0c,$7c,$cc,$7e,$00,$e0,$00, +$78,$0c,$7c,$cc,$7e,$00,$30,$30,$78,$0c,$7c,$cc,$7e,$00,$00,$00,$7c,$c0,$c0,$7c,$06,$3c,$7e,$c3,$3c,$66, +$7e,$60,$3c,$00,$cc,$00,$78,$cc,$fc,$c0,$78,$00,$e0,$00,$78,$cc,$fc,$c0,$78,$00,$cc,$00,$70,$30,$30,$30, +$78,$00,$7c,$c6,$38,$18,$18,$18,$3c,$00,$e0,$00,$70,$30,$30,$30,$78,$00,$cc,$30,$78,$cc,$cc,$fc,$cc,$00, +$30,$30,$00,$78,$cc,$fc,$cc,$00,$1c,$00,$fc,$60,$78,$60,$fc,$00,$00,$00,$7f,$0c,$7f,$cc,$7f,$00,$3e,$6c, +$cc,$fe,$cc,$cc,$ce,$00,$78,$cc,$00,$78,$cc,$cc,$78,$00,$00,$cc,$00,$78,$cc,$cc,$78,$00,$00,$e0,$00,$78, +$cc,$cc,$78,$00,$78,$cc,$00,$cc,$cc,$cc,$7e,$00,$00,$e0,$00,$cc,$cc,$cc,$7e,$00,$00,$cc,$00,$cc,$cc,$fc, +$0c,$f8,$c6,$38,$7c,$c6,$c6,$7c,$38,$00,$cc,$00,$cc,$cc,$cc,$cc,$78,$00,$18,$18,$7e,$c0,$c0,$7e,$18,$18, +$38,$6c,$64,$f0,$60,$e6,$fc,$00,$cc,$cc,$78,$fc,$30,$fc,$30,$00,$f0,$d8,$d8,$f4,$cc,$de,$cc,$0e,$0e,$1b, +$18,$7e,$18,$18,$d8,$70,$1c,$00,$78,$0c,$7c,$cc,$7e,$00,$38,$00,$70,$30,$30,$30,$78,$00,$00,$1c,$00,$78, +$cc,$cc,$78,$00,$00,$1c,$00,$cc,$cc,$cc,$7e,$00,$00,$f8,$00,$f8,$cc,$cc,$cc,$00,$fc,$00,$cc,$ec,$fc,$dc, +$cc,$00,$3c,$6c,$6c,$3e,$00,$7e,$00,$00,$3c,$66,$66,$3c,$00,$7e,$00,$00,$30,$00,$30,$60,$c0,$cc,$78,$00, +$00,$00,$00,$fc,$c0,$c0,$00,$00,$00,$00,$00,$fc,$0c,$0c,$00,$00,$c6,$cc,$d8,$3e,$63,$ce,$98,$1f,$c6,$cc, +$d8,$f3,$67,$cf,$9f,$03,$00,$18,$00,$18,$18,$3c,$3c,$18,$00,$33,$66,$cc,$66,$33,$00,$00,$00,$cc,$66,$33, +$66,$cc,$00,$00,$22,$88,$22,$88,$22,$88,$22,$88,$55,$aa,$55,$aa,$55,$aa,$55,$aa,$dc,$76,$dc,$76,$dc,$76, +$dc,$76,$18,$18,$18,$18,$18,$18,$18,$18,$18,$18,$18,$18,$f8,$18,$18,$18,$18,$18,$f8,$18,$f8,$18,$18,$18, +$36,$36,$36,$36,$f6,$36,$36,$36,$00,$00,$00,$00,$fe,$36,$36,$36,$00,$00,$f8,$18,$f8,$18,$18,$18,$36,$36, +$f6,$06,$f6,$36,$36,$36,$36,$36,$36,$36,$36,$36,$36,$36,$00,$00,$fe,$06,$f6,$36,$36,$36,$36,$36,$f6,$06, +$fe,$00,$00,$00,$36,$36,$36,$36,$fe,$00,$00,$00,$18,$18,$f8,$18,$f8,$00,$00,$00,$00,$00,$00,$00,$f8,$18, +$18,$18,$18,$18,$18,$18,$1f,$00,$00,$00,$18,$18,$18,$18,$ff,$00,$00,$00,$00,$00,$00,$00,$ff,$18,$18,$18, +$18,$18,$18,$18,$1f,$18,$18,$18,$00,$00,$00,$00,$ff,$00,$00,$00,$18,$18,$18,$18,$ff,$18,$18,$18,$18,$18, +$1f,$18,$1f,$18,$18,$18,$36,$36,$36,$36,$37,$36,$36,$36,$36,$36,$37,$30,$3f,$00,$00,$00,$00,$00,$3f,$30, +$37,$36,$36,$36,$36,$36,$f7,$00,$ff,$00,$00,$00,$00,$00,$ff,$00,$f7,$36,$36,$36,$36,$36,$37,$30,$37,$36, +$36,$36,$00,$00,$ff,$00,$ff,$00,$00,$00,$36,$36,$f7,$00,$f7,$36,$36,$36,$18,$18,$ff,$00,$ff,$00,$00,$00, +$36,$36,$36,$36,$ff,$00,$00,$00,$00,$00,$ff,$00,$ff,$18,$18,$18,$00,$00,$00,$00,$ff,$36,$36,$36,$36,$36, +$36,$36,$3f,$00,$00,$00,$18,$18,$1f,$18,$1f,$00,$00,$00,$00,$00,$1f,$18,$1f,$18,$18,$18,$00,$00,$00,$00, +$3f,$36,$36,$36,$36,$36,$36,$36,$f7,$36,$36,$36,$18,$18,$ff,$00,$ff,$18,$18,$18,$18,$18,$18,$18,$f8,$00, +$00,$00,$00,$00,$00,$00,$1f,$18,$18,$18,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$00,$00,$00,$00,$ff,$ff,$ff,$ff, +$f0,$f0,$f0,$f0,$f0,$f0,$f0,$f0,$0f,$0f,$0f,$0f,$0f,$0f,$0f,$0f,$ff,$ff,$ff,$ff,$00,$00,$00,$00,$00,$00, +$76,$dc,$c8,$dc,$76,$00,$00,$78,$cc,$f8,$cc,$f8,$c0,$c0,$00,$fe,$c6,$c0,$c0,$c0,$c0,$00,$00,$fe,$6c,$6c, +$6c,$6c,$6c,$00,$fe,$66,$30,$18,$30,$66,$fe,$00,$00,$00,$7e,$cc,$cc,$cc,$78,$00,$00,$66,$66,$66,$66,$7c, +$60,$c0,$00,$76,$dc,$18,$18,$18,$18,$00,$fc,$30,$78,$cc,$cc,$78,$30,$fc,$38,$6c,$c6,$fe,$c6,$6c,$38,$00, +$38,$6c,$c6,$c6,$6c,$6c,$ee,$00,$1c,$30,$18,$7c,$cc,$cc,$78,$00,$00,$00,$7e,$db,$db,$7e,$00,$00,$06,$0c, +$7e,$db,$db,$7e,$60,$c0,$3c,$60,$c0,$fc,$c0,$60,$3c,$00,$78,$cc,$cc,$cc,$cc,$cc,$cc,$00,$00,$fc,$00,$fc, +$00,$fc,$00,$00,$30,$30,$fc,$30,$30,$00,$fc,$00,$60,$30,$18,$30,$60,$00,$fc,$00,$18,$30,$60,$30,$18,$00, +$fc,$00,$0e,$1b,$1b,$18,$18,$18,$18,$18,$18,$18,$18,$18,$18,$d8,$d8,$70,$30,$30,$00,$fc,$00,$30,$30,$00, +$00,$72,$9c,$00,$72,$9c,$00,$00,$38,$6c,$6c,$38,$00,$00,$00,$00,$00,$00,$00,$18,$18,$00,$00,$00,$00,$00, +$00,$00,$18,$00,$00,$00,$0f,$0c,$0c,$0c,$ec,$6c,$3c,$1c,$78,$6c,$6c,$6c,$6c,$00,$00,$00,$78,$0c,$38,$60, +$7c,$00,$00,$00,$00,$00,$3c,$3c,$3c,$3c,$00,$00,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff +); + +const kgiFont6PropWidth: array[0..256-1] of Byte = ( + $08,$08,$08,$07,$07,$07,$07,$04,$08,$07,$08,$08,$06,$06,$06,$07, + $06,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08, + $85,$21,$13,$05,$05,$05,$05,$13,$13,$13,$05,$05,$12,$14,$12,$05, + $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$21,$12,$05,$05,$05,$05, + $05,$05,$05,$05,$05,$05,$05,$05,$05,$13,$05,$05,$05,$05,$05,$05, + $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$13,$05,$13,$05,$05, + $13,$05,$05,$05,$05,$05,$05,$05,$05,$13,$04,$14,$13,$05,$05,$05, + $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$14,$21,$04,$05,$08, + $08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$04, + $44,$08,$08,$08,$08,$08,$08,$08,$05,$04,$05,$08,$08,$08,$08,$08, + $05,$05,$05,$05,$05,$05,$13,$13,$05,$05,$05,$04,$05,$05,$05,$05, + $05,$05,$05,$05,$05,$03,$04,$04,$06,$05,$04,$07,$04,$03,$05,$08, + $05,$05,$05,$05,$05,$05,$05,$14,$05,$05,$05,$04,$05,$05,$05,$05, + $14,$05,$05,$05,$05,$05,$05,$05,$14,$05,$05,$05,$05,$05,$14,$05, + $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05, + $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05 +); + +const kgiFont8PropWidth: array[0..256-1] of Byte = ( + $08,$08,$08,$07,$07,$07,$07,$06,$08,$07,$08,$08,$07,$08,$08,$08, + $07,$07,$07,$07,$08,$08,$07,$08,$07,$07,$07,$07,$07,$08,$08,$08, + $85,$14,$15,$07,$06,$07,$07,$03,$14,$14,$08,$06,$13,$06,$22,$07, + $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$22,$13,$05,$06,$15,$06, + $07,$06,$07,$07,$07,$07,$07,$07,$06,$14,$07,$07,$07,$07,$07,$07, + $07,$06,$07,$06,$06,$06,$06,$07,$07,$06,$07,$14,$07,$14,$07,$08, + $23,$07,$07,$06,$07,$06,$06,$07,$07,$14,$05,$07,$14,$07,$06,$06, + $07,$07,$06,$06,$15,$07,$06,$07,$07,$06,$06,$06,$32,$06,$07,$07, + $06,$07,$06,$08,$07,$07,$07,$07,$08,$06,$06,$06,$07,$05,$06,$06, + $06,$08,$07,$06,$06,$06,$07,$07,$06,$07,$06,$07,$07,$06,$07,$08, + $07,$05,$06,$07,$06,$06,$16,$16,$06,$06,$06,$08,$08,$06,$08,$08, + $08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08, + $38,$08,$08,$38,$08,$08,$38,$28,$28,$28,$08,$08,$28,$08,$08,$08, + $08,$08,$08,$28,$38,$38,$28,$08,$08,$08,$38,$08,$08,$08,$48,$08, + $07,$06,$07,$07,$07,$07,$07,$07,$06,$07,$07,$06,$08,$08,$06,$06, + $06,$06,$06,$06,$35,$05,$06,$07,$15,$32,$32,$08,$15,$15,$24,$08 +); + + +function createFontTexture (const font: PByte; const fontwdt: PByte; prop: Boolean): GLuint; +const + Width = 16*8; + Height = 16*8; +var + tex, tpp: PByte; + b: Byte; + cc: Integer; + x, y, dx, dy: Integer; +begin + GetMem(tex, Width*Height*4); + + for cc := 0 to 255 do + begin + x := (cc mod 16)*8; + y := (cc div 16)*8; + for dy := 0 to 7 do + begin + b := font[cc*8+dy]; + if prop then b := b shl (fontwdt[cc] shr 4); + tpp := tex+((y+dy)*(Width*4))+x*4; + for dx := 0 to 7 do + begin + if ((b and $80) <> 0) then + begin + tpp^ := 255; Inc(tpp); + tpp^ := 255; Inc(tpp); + tpp^ := 255; Inc(tpp); + tpp^ := 255; Inc(tpp); + end + else + begin + tpp^ := 0; Inc(tpp); + tpp^ := 0; Inc(tpp); + tpp^ := 0; Inc(tpp); + tpp^ := 0; Inc(tpp); + end; + b := (b and $7f) shl 1; + end; + end; + end; + + glGenTextures(1, @result); + if (result = 0) then raise Exception.Create('can''t create Holmes font texture'); + + glBindTexture(GL_TEXTURE_2D, result); + glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT); + glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST); + + //GLfloat[4] bclr = 0.0; + //glTexParameterfv(GL_TEXTURE_2D, GL_TEXTURE_BORDER_COLOR, bclr.ptr); + + glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, Width, Height, 0, GL_RGBA{gltt}, GL_UNSIGNED_BYTE, tex); + glFlush(); + + //FreeMem(tex); +end; + + +{ +var + font6texid: GLuint = 0; + font8texid: GLuint = 0; + prfont6texid: GLuint = 0; + prfont8texid: GLuint = 0; + + +procedure deleteFonts (); +begin + if (font6texid <> 0) then glDeleteTextures(1, @font6texid); + if (font8texid <> 0) then glDeleteTextures(1, @font8texid); + if (prfont6texid <> 0) then glDeleteTextures(1, @prfont6texid); + if (prfont8texid <> 0) then glDeleteTextures(1, @prfont8texid); + font6texid := 0; + font8texid := 0; + prfont6texid := 0; + prfont8texid := 0; +end; + + +procedure createFonts (); +begin + if (font6texid = 0) then font6texid := createFontTexture(kgiFont6, kgiFont6PropWidth, false); + if (font8texid = 0) then font8texid := createFontTexture(kgiFont8, kgiFont8PropWidth, false); + if (prfont6texid = 0) then prfont6texid := createFontTexture(kgiFont6, kgiFont6PropWidth, true); + if (prfont8texid = 0) then prfont8texid := createFontTexture(kgiFont8, kgiFont8PropWidth, true); +end; +} diff --git a/src/flexui/fui_style.pas b/src/flexui/fui_style.pas new file mode 100644 index 0000000..31bbf21 --- /dev/null +++ b/src/flexui/fui_style.pas @@ -0,0 +1,796 @@ +(* coded by Ketmar // Invisible Vector + * Understanding is not required. Only obedience. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +{$INCLUDE ../../shared/a_modes.inc} +{.$DEFINE UI_STYLE_DEBUG_SEARCH} +unit fui_style; + +interface + +uses + SysUtils, Classes, + fui_common, // for TGxRGBA + xstreams, xparser, utils, hashtable; + + +type + TStyleSection = class; + + TStyleValue = packed record + public + type TType = (Empty, Bool, Int, Color, Str); + + public + 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 toString (): AnsiString; + function asRGBA: TGxRGBA; inline; + function asRGBADef (const def: TGxRGBA): TGxRGBA; 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; + case TType of + TType.Bool: (bval: Boolean); + TType.Int: (ival: Integer); + TType.Color: (r, g, b, a: Byte); + TType.Str: (sval: Pointer); // AnsiString + end; + + 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; + mHashes: THashStrSection; + mCtls: THashStrSection; + + private + function getTopLevel (): TStyleSection; inline; + // "text-color#inactive@label" + function getValue (const path: AnsiString): TStyleValue; + + public + constructor Create (); + destructor Destroy (); override; + + function get (name, hash, ctl: AnsiString): TStyleValue; + + public + property value[const path: AnsiString]: TStyleValue read getValue; default; + property topLevel: TStyleSection read getTopLevel; + end; + + TUIStyle = class + private + mId: AnsiString; // style name ('default', for example) + mMain: TStyleSection; + + private + procedure createMain (); + + procedure parse (par: TTextParser); + + function getValue (const path: AnsiString): TStyleValue; inline; + + public + constructor Create (const aid: AnsiString); + constructor Create (st: TStream); // parse from stream + 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; default; + end; + + +procedure uiLoadStyles (const fname: AnsiString); +procedure uiLoadStyles (st: TStream); + +// will return "default" (or raise an exception if there is no "default") +function uiFindStyle (const stname: AnsiString): TUIStyle; + + +implementation + + +// ////////////////////////////////////////////////////////////////////////// // +const + defaultStyleStr = + 'default {'#10+ + ' back-color: #008;'#10+ + ' #active: { text-color: #fff; hot-color: #f00; switch-color: #fff; frame-color: #fff; frame-text-color: #fff; frame-icon-color: #0f0; }'#10+ + ' #inactive: { text-color: #aaa; hot-color: #a00; switch-color: #aaa; frame-color: #aaa; frame-text-color: #aaa; frame-icon-color: #0a0; }'#10+ + ' #disabled: { text-color: #666; hot-color: #600; switch-color: #666; frame-color: #888; frame-text-color: #888; frame-icon-color: #080; }'#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: { #inactive(#active); }'#10+ + ' @static: { text-color: #ff0; #inactive(#active); }'#10+ + ' @box: { #inactive(#active); }'#10+ + ' @switchbox: { #active: { back-color: #080; } #inactive: { switch-color: #fff; } }'#10+ + ' @checkbox(@switchbox): {}'#10+ + ' @radiobox(@switchbox): {}'#10+ + '}'#10+ + ''; +var + styles: array of TUIStyle = nil; + + +function createDefaultStyle (): TUIStyle; +var + st: TStream; +begin + result := nil; + st := TStringStream.Create(defaultStyleStr); + st.position := 0; + try + result := TUIStyle.Create(st); + finally + FreeAndNil(st); + end; +end; + + +function uiFindStyle (const stname: AnsiString): TUIStyle; +var + stl: TUIStyle; +begin + if (Length(stname) > 0) then + begin + for stl in styles do if (strEquCI1251(stl.mId, stname)) then begin result := stl; exit; end; + end; + for stl in styles do if (strEquCI1251(stl.mId, 'default')) then begin result := stl; exit; end; + stl := createDefaultStyle(); + SetLength(styles, Length(styles)+1); + styles[High(styles)] := stl; + result := stl; +end; + + +procedure uiLoadStyles (const fname: AnsiString); +var + st: TStream; +begin + st := openDiskFileRO(fname); + try + uiLoadStyles(st); + finally + st.Free(); + end; +end; + + +procedure uiLoadStyles (st: TStream); +var + par: TTextParser; + stl: TUIStyle = nil; + 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.TOption.HtmlColors]); + styles := nil; + try + while (not par.isEOF) do + begin + stl := TUIStyle.Create(''); + stl.parse(par); + //writeln('new style: <', stl.mId, '>'); + f := 0; + while (f < Length(styles)) do begin if (strEquCI1251(styles[f].mId, stl.mId)) then break; Inc(f); end; + if (f < Length(styles)) then + begin + FreeAndNil(styles[f]); + end + else + begin + f := Length(styles); + SetLength(styles, f+1); + end; + styles[f] := stl; + stl := nil; + end; + finally + stl.Free(); + par.Free(); + end; + // we should have "default" style + for f := 0 to High(styles) do if (strEquCI1251(styles[f].mId, 'default')) then exit; + stl := createDefaultStyle(); + SetLength(styles, Length(styles)+1); + styles[High(styles)] := stl; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +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 (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; + 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); +begin + vtype := TType.Color; + r := v.r; + g := v.g; + b := v.b; + a := v.a; +end; + +function TStyleValue.isEmpty (): Boolean; inline; begin result := (vtype = TType.Empty); 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.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 + case vtype of + TType.Empty: result := ''; + TType.Bool: if bval then result := 'true' else result := 'false'; + TType.Int: result := formatstrf('%s', [ival]); + TType.Color: if (a = 255) then result := formatstrf('rgb(%s,%s,%s)', [r, g, b]) else result := formatstrf('rgba(%s,%s,%s)', [r, g, b, a]); + else result := ''; + end; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +procedure freeSectionCB (var v: TStyleSection); begin FreeAndNil(v); end; + + +function splitPath (const path: AnsiString; out name, hash, ctl: AnsiString): Boolean; +var + hashPos, atPos: Integer; +begin + result := false; + name := ''; + hash := ''; + ctl := ''; + hashPos := pos('#', path); + atPos := pos('@', path); + // split + if (atPos > 0) then + begin + // has ctl, and (possible) hash + if (hashPos > 0) then + begin + // has ctl and hash + 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; + end + else if (hashPos > 0) then + begin + // has hash + if (hashPos > 1) then name := Copy(path, 1, hashPos-1); + Inc(hashPos); // skip hash + if (hashPos <= Length(path)) then hash := Copy(path, hashPos, Length(path)-hashPos+1); + end + else + begin + // only name + name := path; + end; + result := true; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +constructor TStyleSection.Create (); +begin + 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(mHashes); + FreeAndNil(mCtls); + mParent := nil; + mInherits := ''; + mHashName := ''; + mCtlName := ''; + inherited; +end; + + +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 + tmp: AnsiString; + sect, s1, so: TStyleSection; + jumpsLeft: Integer = 32; // max inheritance level + skipInherits: Boolean = false; +begin + result.vtype := result.TType.Empty; + 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 + if (not strEquCI1251(ctl, mCtlName)) then + begin + // has ctl section? + if (not topLevel.mCtls.get(ctl, sect)) then sect := topLevel; + end; + end; + // has hash? + if (Length(hash) > 0) then + begin + if (not strEquCI1251(hash, sect.mHashName)) then + begin + if (sect.mHashes.get(hash, s1)) then sect := s1; + end; + end; + // try name, go up with inheritance + while (jumpsLeft > 0) do + begin + 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; + + +// "text-color#inactive@label" +function TStyleSection.getValue (const path: AnsiString): TStyleValue; +var + name, hash, ctl: AnsiString; +begin + result.vtype := result.TType.Empty; + if (not splitPath(path, name, hash, ctl)) then exit; // alas + //writeln('name:<', name, '>; hash:<', hash, '>; ctl:<', ctl, '>'); + result := get(name, hash, ctl); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +constructor TUIStyle.Create (const aid: AnsiString); +begin + mId := aid; + createMain(); +end; + + +constructor TUIStyle.Create (st: TStream); // parse from stream +var + par: TTextParser; +begin + mId := ''; + createMain(); + if (st = nil) then exit; + par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId, par.TOption.HtmlColors]); + try + parse(par); + finally + par.Free(); + end; +end; + + +constructor TUIStyle.CreateFromFile (const fname: AnsiString); +var + st: TStream; +begin + st := openDiskFileRO(fname); + try + Create(st); + finally + st.Free(); + end; +end; + + +destructor TUIStyle.Destroy (); +begin + mId := ''; + FreeAndNil(mMain); +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; + +function TUIStyle.get (name, hash, ctl: AnsiString): TStyleValue; +begin + result := mMain.get(name, hash, ctl); +end; + + +procedure TUIStyle.parse (par: TTextParser); + function getByte (): Byte; + begin + if (par.tokType <> par.TTInt) then par.expectInt(); + if (par.tokInt < 0) or (par.tokInt > 255) then par.error('invalid byte value'); + result := Byte(par.tokInt); + par.skipToken(); + end; + + procedure parseSection (sect: TStyleSection; ctlAllowed: Boolean; hashAllowed: Boolean); + var + 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; + // ctl + if ctlAllowed and (par.eatDelim('@')) then + begin + s := par.expectId(); + parseInherit(); + par.eatDelim(':'); // optional + if (not sect.mCtls.get(s, sc)) then + begin + // create new section + sc := TStyleSection.Create(); + 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; + if (not par.eatDelim(';')) then parseSection(sc, false, true); + continue; + end; + // hash + if hashAllowed and (par.eatDelim('#')) then + begin + s := par.expectId(); + parseInherit(); + par.eatDelim(':'); // optional + if (not sect.mHashes.get(s, sc)) then + begin + // create new section + sc := TStyleSection.Create(); + 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; + if (not par.eatDelim(';')) then parseSection(sc, false, false); + continue; + end; + // name + s := par.expectId(); + par.expectDelim(':'); + if (par.eatId('rgb')) or (par.eatId('rgba')) then + begin + // color + par.expectDelim('('); + v.vtype := v.TType.Color; + v.r := getByte(); par.eatDelim(','); // optional + v.g := getByte(); par.eatDelim(','); // optional + v.b := getByte(); par.eatDelim(','); // optional + if (par.tokType = par.TTInt) then + begin + v.a := getByte(); par.eatDelim(','); // optional + end + else + begin + v.a := 255; // opaque + end; + par.expectDelim(')'); + end + else if (par.isId) and (par.tokStr[1] = '#') then + begin + // html color + assert((Length(par.tokStr) = 4) or (Length(par.tokStr) = 7)); + //writeln('<', par.tokStr, '>; {', par.curChar, '}'); + v.vtype := v.TType.Color; + if (Length(par.tokStr) = 4) then + begin + // #rgb + v.r := nib2c(digitInBase(par.tokStr[2], 16)); + v.g := nib2c(digitInBase(par.tokStr[3], 16)); + v.b := nib2c(digitInBase(par.tokStr[4], 16)); + end + else + begin + // #rrggbb + v.r := Byte(digitInBase(par.tokStr[2], 16)*16+digitInBase(par.tokStr[3], 16)); + v.g := Byte(digitInBase(par.tokStr[4], 16)*16+digitInBase(par.tokStr[5], 16)); + v.b := Byte(digitInBase(par.tokStr[6], 16)*16+digitInBase(par.tokStr[7], 16)); + end; + v.a := 255; + //writeln(' r=', v.r, '; g=', v.g, '; b=', v.b); + par.skipToken(); + end + else if (par.eatId('true')) or (par.eatId('tan')) then + begin + v.vtype := v.TType.Bool; + v.bval := true; + end + else if (par.eatId('false')) or (par.eatId('ona')) then + begin + 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; + par.expectDelim(';'); + sect.mVals.put(s, v); + end; + par.expectDelim('}'); + end; + +begin + // style name + if (not par.isIdOrStr) then + begin + if (Length(mId) = 0) then par.error('style name expected'); + end + else + begin + mId := par.tokStr; + end; + if (Length(mId) = 0) then mId := 'default'; + par.skipToken(); + if (not par.eatDelim(';')) then parseSection(mMain, true, true); +end; + + +end. diff --git a/src/flexui/sdlcarcass.pas b/src/flexui/sdlcarcass.pas new file mode 100644 index 0000000..33a4664 --- /dev/null +++ b/src/flexui/sdlcarcass.pas @@ -0,0 +1,362 @@ +(* Copyright (C) DooM 2D:Forever Developers + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +{$INCLUDE ../shared/a_modes.inc} +unit sdlcarcass; + +interface + +uses + SDL2, fui_events; + + +// ////////////////////////////////////////////////////////////////////////// // +// call this with SDL2 event; returns `true` if event was eaten +function fuiOnSDLEvent (var ev: TSDL_Event): Boolean; + + +// ////////////////////////////////////////////////////////////////////////// // +// event handlers +var + winFocusCB: procedure () = nil; // this will be called when window got focus; `fuiWinActive` already set + winBlurCB: procedure () = nil; // this will be called when window lost focus; `fuiWinActive` already set + // for standalone + buildFrameCB: procedure () = nil; // don't do any rendering here, do it in `renderFrameCB()` + renderFrameCB: procedure () = nil; // no need to call `glSwap()` here + exposeFrameCB: procedure () = nil; // call `glSwap()` here instead; automatically set by standalone + // + prerenderFrameCB: procedure () = nil; + postrenderFrameCB: procedure () = nil; + fuiResizeCB: procedure () = nil; // `fuiScrWdt` and `fuiScrHgt` are already set + oglInitCB: procedure () = nil; // `fuiScrWdt` and `fuiScrHgt` are already set + oglDeinitCB: procedure () = nil; + + +var + // default size + fuiScrWdt: Integer = 1024; + fuiScrHgt: Integer = 768; + fuiWinActive: Boolean = false; + fuiQuitReceived: Boolean = false; + + +// ////////////////////////////////////////////////////////////////////////// // +function fuiTimeMicro (): UInt64; inline; +function fuiTimeMilli (): UInt64; inline; + + +// ////////////////////////////////////////////////////////////////////////// // +// only for standalone mode +function getFUIFPS (): Integer; inline; +procedure setFUIFPS (v: Integer); inline; + +property fuiFPS: Integer read getFUIFPS write setFUIFPS; // default: 30 + + +implementation + +uses + SysUtils, Classes, + GL, GLExt, + {$IF DEFINED(LINUX)} + unixtype, linux + {$ELSEIF DEFINED(WINDOWS)} + Windows + {$ELSE} + {$WARNING You suck!} + {$ENDIF} + ; + + +// ////////////////////////////////////////////////////////////////////////// // +var + gEffFPS: Integer = 30; + +function getFUIFPS (): Integer; inline; begin result := gEffFPS; end; +procedure setFUIFPS (v: Integer); inline; begin if (v < 1) then v := 1 else if (v > 60*4) then v := 60*4; gEffFPS := v; end; + + +// ////////////////////////////////////////////////////////////////////////// // +{$IF DEFINED(LINUX)} +type THPTimeType = TTimeSpec; +{$ELSE} +type THPTimeType = Int64; +{$ENDIF} + +var + mFrequency: Int64 = 0; + mHasHPTimer: Boolean = false; + +procedure initTimerIntr (); +var + r: THPTimeType; +begin + if (mFrequency = 0) then + begin +{$IF DEFINED(LINUX)} + if (clock_getres(CLOCK_MONOTONIC, @r) <> 0) then raise Exception.Create('profiler error: cannot get timer resolution'); + mHasHPTimer := (r.tv_nsec <> 0); + if not mHasHPTimer then raise Exception.Create('profiler error: hires timer is not available'); + mFrequency := 1; // just a flag + if (r.tv_nsec <> 0) then mFrequency := 1000000000000000000 div r.tv_nsec; +{$ELSE} + mHasHPTimer := QueryPerformanceFrequency(r); + if not mHasHPTimer then raise Exception.Create('profiler error: hires timer is not available'); + mFrequency := r; +{$ENDIF} + end; +end; + + +function fuiTimeMicro (): UInt64; inline; +var + r: THPTimeType; +begin + //if (mFrequency = 0) then initTimerIntr(); + {$IF DEFINED(LINUX)} + clock_gettime(CLOCK_MONOTONIC, @r); + result := UInt64(r.tv_sec)*1000000+UInt64(r.tv_nsec) div 1000; // microseconds + {$ELSE} + QueryPerformanceCounter(r); + result := UInt64(r)*1000000 div mFrequency; + {$ENDIF} +end; + + +function fuiTimeMilli (): UInt64; inline; +begin + result := fuiTimeMicro() div 1000; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +var + wc2shitmap: array[0..65535] of AnsiChar; + wc2shitmapInited: Boolean = false; + + +// ////////////////////////////////////////////////////////////////////////// // +const + cp1251: array[0..127] of Word = ( + $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F, + $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F, + $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407, + $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457, + $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F, + $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F, + $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F, + $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F + ); + + +procedure initShitMap (); +var + f: Integer; +begin + for f := 0 to High(wc2shitmap) do wc2shitmap[f] := '?'; + for f := 0 to 127 do wc2shitmap[f] := AnsiChar(f); + for f := 0 to 127 do wc2shitmap[cp1251[f]] := AnsiChar(f+128); + wc2shitmapInited := true; +end; + + +function wchar2win (wc: WideChar): AnsiChar; inline; +begin + if not wc2shitmapInited then initShitMap(); + if (LongWord(wc) > 65535) then result := '?' else result := wc2shitmap[LongWord(wc)]; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +function fuiOnSDLEvent (var ev: TSDL_Event): Boolean; +var + mev: THMouseEvent; + kev: THKeyEvent; + uc: UnicodeChar; + keychr: Word; + + function buildBut (b: Byte): Word; + begin + result := 0; + case b of + SDL_BUTTON_LEFT: result := result or THMouseEvent.Left; + SDL_BUTTON_MIDDLE: result := result or THMouseEvent.Middle; + SDL_BUTTON_RIGHT: result := result or THMouseEvent.Right; + end; + end; + + procedure windowEventHandler (constref ev: TSDL_WindowEvent); + begin + case ev.event of + SDL_WINDOWEVENT_MINIMIZED: if fuiWinActive then begin fuiResetKMState(true); fuiWinActive := false; if assigned(winBlurCB) then winBlurCB(); end; + SDL_WINDOWEVENT_RESIZED, SDL_WINDOWEVENT_SIZE_CHANGED: + begin + if (ev.data1 <> fuiScrWdt) or (ev.data2 <> fuiScrHgt) then + begin + fuiScrWdt := ev.data1; + fuiScrHgt := ev.data2; + if assigned(fuiResizeCB) then fuiResizeCB(); + end; + end; + SDL_WINDOWEVENT_EXPOSED: if assigned(exposeFrameCB) then exposeFrameCB(); + SDL_WINDOWEVENT_FOCUS_GAINED: if not fuiWinActive then begin fuiWinActive := true; if assigned(winFocusCB) then winFocusCB(); end; + SDL_WINDOWEVENT_FOCUS_LOST: if fuiWinActive then begin fuiResetKMState(true); fuiWinActive := false; if assigned(winBlurCB) then winBlurCB(); end; + end; + end; + +begin + result := false; + + case ev.type_ of + SDL_WINDOWEVENT: windowEventHandler(ev.window); + SDL_QUITEV: fuiQuitReceived := true; + + SDL_KEYDOWN, SDL_KEYUP: + begin + // fix left/right modifiers + FillChar(kev, sizeof(kev), 0); + kev.intrInit(); + if (ev.type_ = SDL_KEYDOWN) then kev.kind := THKeyEvent.TKind.Press else kev.kind := THKeyEvent.TKind.Release; + kev.scan := ev.key.keysym.scancode; + //kev.sym := ev.key.keysym.sym; + + if (kev.scan = SDL_SCANCODE_RCTRL) then kev.scan := SDL_SCANCODE_LCTRL; + if (kev.scan = SDL_SCANCODE_RALT) then kev.scan := SDL_SCANCODE_LALT; + if (kev.scan = SDL_SCANCODE_RSHIFT) then kev.scan := SDL_SCANCODE_LSHIFT; + if (kev.scan = SDL_SCANCODE_RGUI) then kev.scan := SDL_SCANCODE_LGUI; + + { + if (kev.sym = SDLK_RCTRL) then kev.sym := SDLK_LCTRL; + if (kev.sym = SDLK_RALT) then kev.sym := SDLK_LALT; + if (kev.sym = SDLK_RSHIFT) then kev.sym := SDLK_LSHIFT; + if (kev.sym = SDLK_RGUI) then kev.sym := SDLK_LGUI; + } + + kev.x := fuiMouseX; + kev.y := fuiMouseY; + kev.bstate := fuiButState; + kev.kstate := fuiModState; + + case kev.scan of + SDL_SCANCODE_LCTRL: if (kev.press) then fuiSetModState(fuiModState or THKeyEvent.ModCtrl) else fuiSetModState(fuiModState and (not THKeyEvent.ModCtrl)); + SDL_SCANCODE_LALT: if (kev.press) then fuiSetModState(fuiModState or THKeyEvent.ModAlt) else fuiSetModState(fuiModState and (not THKeyEvent.ModAlt)); + SDL_SCANCODE_LSHIFT: if (kev.press) then fuiSetModState(fuiModState or THKeyEvent.ModShift) else fuiSetModState(fuiModState and (not THKeyEvent.ModShift)); + end; + + if assigned(evKeyCB) then + begin + evKeyCB(kev); + result := kev.eaten; + end; + end; + + SDL_MOUSEBUTTONDOWN, SDL_MOUSEBUTTONUP: + begin + FillChar(mev, sizeof(mev), 0); + mev.intrInit(); + if (ev.type_ = SDL_MOUSEBUTTONDOWN) then mev.kind := THMouseEvent.TKind.Press else mev.kind := THMouseEvent.TKind.Release; + mev.dx := ev.button.x-fuiMouseX; + mev.dy := ev.button.y-fuiMouseY; + fuiSetMouseX(ev.button.x); + fuiSetMouseY(ev.button.y); + mev.but := buildBut(ev.button.button); + mev.x := fuiMouseX; + mev.y := fuiMouseY; + mev.bstate := fuiButState; + mev.kstate := fuiModState; + if (mev.but <> 0) then + begin + // ev.button.clicks: Byte + if (ev.type_ = SDL_MOUSEBUTTONDOWN) then fuiSetButState(fuiButState or mev.but) else fuiSetButState(fuiButState and (not mev.but)); + if assigned(evMouseCB) then + begin + evMouseCB(mev); + result := mev.eaten; + end; + end; + end; + SDL_MOUSEWHEEL: + begin + if (ev.wheel.y <> 0) then + begin + FillChar(mev, sizeof(mev), 0); + mev.intrInit(); + mev.kind := THMouseEvent.TKind.Press; + mev.dx := 0; + mev.dy := ev.wheel.y; + if (ev.wheel.y < 0) then mev.but := THMouseEvent.WheelUp else mev.but := THMouseEvent.WheelDown; + mev.x := fuiMouseX; + mev.y := fuiMouseY; + mev.bstate := fuiButState; + mev.kstate := fuiModState; + if assigned(evMouseCB) then + begin + evMouseCB(mev); + result := mev.eaten; + end; + end; + end; + SDL_MOUSEMOTION: + begin + FillChar(mev, sizeof(mev), 0); + mev.intrInit(); + mev.kind := THMouseEvent.TKind.Motion; + mev.dx := ev.button.x-fuiMouseX; + mev.dy := ev.button.y-fuiMouseY; + fuiSetMouseX(ev.button.x); + fuiSetMouseY(ev.button.y); + mev.but := 0; + mev.x := fuiMouseX; + mev.y := fuiMouseY; + mev.bstate := fuiButState; + mev.kstate := fuiModState; + if assigned(evMouseCB) then + begin + evMouseCB(mev); + result := mev.eaten; + end; + end; + + SDL_TEXTINPUT: + if ((fuiModState and (not THKeyEvent.ModShift)) = 0) then + begin + Utf8ToUnicode(@uc, PChar(ev.text.text), 1); + keychr := Word(uc); + if (keychr > 127) then keychr := Word(wchar2win(WideChar(keychr))); + if (keychr > 0) and assigned(evKeyCB) then + begin + FillChar(kev, sizeof(kev), 0); + kev.intrInit(); + kev.kind := THKeyEvent.TKind.Press; + kev.scan := 0; + kev.ch := AnsiChar(keychr); + kev.x := fuiMouseX; + kev.y := fuiMouseY; + kev.bstate := fuiButState; + kev.kstate := fuiModState; + evKeyCB(kev); + result := kev.eaten; + end; + end; + end; +end; + + +begin + initTimerIntr(); + fuiWinActive := fuiWinActive; + fuiScrWdt := fuiScrWdt; + fuiScrHgt := fuiScrHgt; +end. diff --git a/src/flexui/sdlstandalone.pas b/src/flexui/sdlstandalone.pas new file mode 100644 index 0000000..3959b2a --- /dev/null +++ b/src/flexui/sdlstandalone.pas @@ -0,0 +1,232 @@ +(* Copyright (C) DooM 2D:Forever Developers + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +{$INCLUDE ../shared/a_modes.inc} +unit sdlstandalone; + +interface + +uses + SDL2, + sdlcarcass; + + +// ////////////////////////////////////////////////////////////////////////// // +// initialize OpenGL; set `gScreenWidth` and `gScreenHeight` before calling this +function glInit (const winTitle: AnsiString='SDL TEST'): Boolean; +procedure glDeinit (); +// call this to show built frame +procedure glSwap (); +// call this to push "quit" event into queue +procedure pushQuitEvent (); +// call this to process queued messages; result is `true` if quit event was received +function processMessages (): Boolean; + +// run main loop, call `buildFrameCB()` and `renderFrameCB()`, maintain the given FPS +procedure mainLoop (); + + +implementation + +uses + SysUtils; + + +var + gWinH: PSDL_Window = nil; + gGLContext: TSDL_GLContext = nil; + lastFrameTime: UInt64 = 0; + + +// ////////////////////////////////////////////////////////////////////////// // +procedure onExposeFrame (); +begin + glSwap(); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +function sdlInit (): Boolean; +var + sdlflags: LongWord; +begin + result := false; + + sdlflags := SDL_INIT_TIMER or SDL_INIT_VIDEO; + if SDL_Init(sdlflags) < 0 then exit; //raise Exception.Create('SDL: Init failed: ' + SDL_GetError()); + + //SDL_Quit(); + result := true; + fuiWinActive := fuiWinActive; + SDL_StartTextInput(); +end; + + +procedure glSwap (); +begin + if (gWinH = nil) then exit; + SDL_GL_SwapWindow(gWinH); +end; + + +procedure killGLWindow (); +begin + if (gWinH <> nil) then SDL_DestroyWindow(gWinH); + if (gGLContext <> nil) then SDL_GL_DeleteContext(gGLContext); + gWinH := nil; + gGLContext := nil; +end; + + +procedure pushQuitEvent (); +var + ev: TSDL_Event; +begin + ev.type_ := SDL_QUITEV; + SDL_PushEvent(@ev); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +// true: quit +function processMessages (): Boolean; +var + ev: TSDL_Event; +begin + result := false; + FillChar(ev, sizeof(ev), 0); + while (SDL_PollEvent(@ev) > 0) do + begin + fuiOnSDLEvent(ev); + //if (ev.type_ = SDL_QUITEV) then exit; + end; + if fuiQuitReceived then result := true; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +procedure glDeinit (); +begin + if (gWinH <> nil) and assigned(oglDeinitCB) then oglDeinitCB(); + killGLWindow(); +end; + + +function glInit (const winTitle: AnsiString='SDL TEST'): Boolean; +var + wFlags: LongWord = 0; + v: Byte = 0; +begin + result := false; + + wFlags := SDL_WINDOW_OPENGL or SDL_WINDOW_RESIZABLE; + //if gFullscreen then wFlags := wFlags or SDL_WINDOW_FULLSCREEN; + //if gWinMaximized then wFlags := wFlags or SDL_WINDOW_MAXIMIZED; + + glDeinit(); + + //if VSync then v := 1 else v := 0; + SDL_GL_SetAttribute(SDL_GL_CONTEXT_MAJOR_VERSION, 2); + SDL_GL_SetAttribute(SDL_GL_CONTEXT_MINOR_VERSION, 1); + SDL_GL_SetAttribute(SDL_GL_RED_SIZE, 8); + SDL_GL_SetAttribute(SDL_GL_GREEN_SIZE, 8); + SDL_GL_SetAttribute(SDL_GL_BLUE_SIZE, 8); + SDL_GL_SetAttribute(SDL_GL_DEPTH_SIZE, 16); + SDL_GL_SetAttribute(SDL_GL_DOUBLEBUFFER, 1); + SDL_GL_SetAttribute(SDL_GL_STENCIL_SIZE, 1); // lights; it is enough to have 1-bit stencil buffer for lighting + SDL_GL_SetSwapInterval(v); + + { + if gFullscreen then + begin + mode.w := gScreenWidth; + mode.h := gScreenHeight; + mode.format := 0; + mode.refresh_rate := 0; + mode.driverdata := nil; + if SDL_GetClosestDisplayMode(0, @mode, @cmode) = nil then + begin + gScreenWidth := 800; + gScreenHeight := 600; + end + else + begin + gScreenWidth := cmode.w; + gScreenHeight := cmode.h; + end; + end; + } + + gWinH := SDL_CreateWindow(PAnsiChar(winTitle), -1, -1, fuiScrWdt, fuiScrHgt, wFlags); + if (gWinH = nil) then exit; + + gGLContext := SDL_GL_CreateContext(gWinH); + if (gGLContext = nil) then begin SDL_DestroyWindow(gWinH); gWinH := nil; exit; end; + + SDL_GL_MakeCurrent(gWinH, gGLContext); + SDL_ShowCursor(SDL_DISABLE); + + if assigned(oglInitCB) then oglInitCB(); + + result := true; +end; + + +// run main loop, call `buildFrameCB()` and `renderFrameCB()`, maintain the given FPS +procedure mainLoop (); +var + nft, ctt: UInt64; + wt: Integer; +begin + if assigned(buildFrameCB) then buildFrameCB(); + if assigned(prerenderFrameCB) then prerenderFrameCB(); + if assigned(renderFrameCB) then renderFrameCB(); + if assigned(postrenderFrameCB) then postrenderFrameCB(); + glSwap(); + lastFrameTime := fuiTimeMilli(); + while true do + begin + // calculate time to build and render next frame + nft := lastFrameTime+(1000 div fuiFPS); + ctt := fuiTimeMilli(); + if (ctt >= nft) then + begin + // time to build next frame + if assigned(buildFrameCB) then buildFrameCB(); + if assigned(prerenderFrameCB) then prerenderFrameCB(); + if assigned(renderFrameCB) then renderFrameCB(); + if assigned(postrenderFrameCB) then postrenderFrameCB(); + glSwap(); + lastFrameTime := ctt; // ignore frame processing time + end + else + begin + // has to wait for some time + if (nft-ctt > 1000) then wt := 1000 else wt := Integer(nft-ctt); + SDL_WaitEventTimeout(nil, wt); + end; + if processMessages() then break; // just in case + end; +end; + + +initialization + exposeFrameCB := onExposeFrame(); + + if not sdlInit() then raise Exception.Create('cannot initialize SDL'); +finalization + glDeinit(); + SDL_Quit(); +end. diff --git a/src/game/Doom2DF.lpr b/src/game/Doom2DF.lpr index e95d623..5162d93 100644 --- a/src/game/Doom2DF.lpr +++ b/src/game/Doom2DF.lpr @@ -108,15 +108,20 @@ uses envvars in '../shared/envvars.pas', g_panel in 'g_panel.pas', g_language in 'g_language.pas', + + sdlcarcass in '../flexui/sdlcarcass.pas', + //sdlstandalone in '../flexui/sdlstandalone.pas', + + fui_common in '../flexui/fui_common.pas', + fui_gfx_gl in '../flexui/fui_gfx_gl.pas', + fui_events in '../flexui/fui_events.pas', + fui_style in '../flexui/fui_style.pas', + fui_flexlay in '../flexui/fui_flexlay.pas', + fui_ctls in '../flexui/fui_ctls.pas', + ImagingTypes, Imaging, - ImagingUtility, - sdlcarcass in '../gx/sdlcarcass.pas', - glgfx in '../gx/glgfx.pas', - gh_ui_common in '../gx/gh_ui_common.pas', - gh_ui_style in '../gx/gh_ui_style.pas', - gh_ui in '../gx/gh_ui.pas', - gh_flexlay in '../gx/gh_flexlay.pas'; + ImagingUtility; {$IFDEF WINDOWS} {$R *.res} diff --git a/src/game/g_holmes.pas b/src/game/g_holmes.pas index 79c4349..bcb2cfa 100644 --- a/src/game/g_holmes.pas +++ b/src/game/g_holmes.pas @@ -24,7 +24,9 @@ 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, + fui_common, fui_events, fui_ctls, + fui_gfx_gl; procedure g_Holmes_Draw (); @@ -53,6 +55,7 @@ uses var + hlmContext: TGxContext = nil; //globalInited: Boolean = false; msX: Integer = -666; msY: Integer = -666; @@ -108,8 +111,9 @@ procedure createLayersWindow (); forward; procedure createOutlinesWindow (); forward; -procedure toggleLayersWindowCB (me: TUIControl; checked: Integer); +procedure toggleLayersWindowCB (me: TUIControl); begin + showLayersWindow := not showLayersWindow; if showLayersWindow then begin if (winLayers = nil) then createLayersWindow(); @@ -121,9 +125,9 @@ begin end; end; - -procedure toggleOutlineWindowCB (me: TUIControl; checked: Integer); +procedure toggleOutlineWindowCB (me: TUIControl); begin + showOutlineWindow := not showOutlineWindow; if showOutlineWindow then begin if (winOutlines = nil) then createOutlinesWindow(); @@ -137,17 +141,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'); + 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 +245,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 +253,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 +263,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 +280,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 +302,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,84 +318,155 @@ 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); + + uiLayoutCtl(winHelp); winHelp.centerInScreen(); end; -procedure winLayersClosed (me: TUIControl; dummy: Integer); begin showLayersWindow := false; end; -procedure winOutlinesClosed (me: TUIControl; dummy: Integer); begin showOutlineWindow := false; end; +procedure winLayersClosed (me: TUIControl); begin showLayersWindow := false; end; +procedure winOutlinesClosed (me: TUIControl); begin showOutlineWindow := false; end; + +procedure addCheckBox (parent: TUIControl; const text: AnsiString; pvar: PBoolean; const aid: AnsiString=''); +var + cb: TUICheckBox; +begin + cb := TUICheckBox.Create(); + cb.flExpand := true; + cb.setVar(pvar); + cb.text := text; + cb.id := aid; + parent.appendChild(cb); +end; + +procedure addButton (parent: TUIControl; const text: AnsiString; cb: TUIControl.TActionCB); +var + but: TUIButton; +begin + but := TUIButton.Create(); + //but.flExpand := true; + but.actionCB := cb; + but.text := text; + parent.appendChild(but); +end; + + +procedure actionFillWalls (cb: TUIControl); +begin + TUICheckBox(cb).checked := not TUICheckBox(cb).checked; + TUICheckBox(cb.topLevel['cbcontour']).enabled := not TUICheckBox(cb).checked; +end; procedure createLayersWindow (); var - llb: TUICBListBox; + box: TUIVBox; begin - llb := TUICBListBox.Create(0, 0); - llb.appendItem('background', @g_rlayer_back); - llb.appendItem('steps', @g_rlayer_step); - llb.appendItem('walls', @g_rlayer_wall); - llb.appendItem('doors', @g_rlayer_door); - llb.appendItem('acid1', @g_rlayer_acid1); - llb.appendItem('acid2', @g_rlayer_acid2); - llb.appendItem('water', @g_rlayer_water); - llb.appendItem('foreground', @g_rlayer_fore); - winLayers := TUITopWindow.Create('layers', 10, 10); + winLayers := TUITopWindow.Create('layers'); + winLayers.flHoriz := false; + winLayers.x0 := 10; + winLayers.y0 := 10; + winLayers.flHoriz := false; winLayers.escClose := true; - winLayers.appendChild(llb); winLayers.closeCB := winLayersClosed; + + box := TUIVBox.Create(); + addCheckBox(box, '~background', @g_rlayer_back); + addCheckBox(box, '~steps', @g_rlayer_step); + addCheckBox(box, '~walls', @g_rlayer_wall); + addCheckBox(box, '~doors', @g_rlayer_door); + addCheckBox(box, 'acid~1', @g_rlayer_acid1); + addCheckBox(box, 'acid~2', @g_rlayer_acid2); + addCheckBox(box, 'wate~r', @g_rlayer_water); + addCheckBox(box, '~foreground', @g_rlayer_fore); + winLayers.appendChild(box); + + uiLayoutCtl(winLayers); end; procedure createOutlinesWindow (); var - llb: TUICBListBox; + box: TUIVBox; begin - llb := TUICBListBox.Create(0, 0); - llb.appendItem('background', @g_ol_rlayer_back); - llb.appendItem('steps', @g_ol_rlayer_step); - llb.appendItem('walls', @g_ol_rlayer_wall); - llb.appendItem('doors', @g_ol_rlayer_door); - llb.appendItem('acid1', @g_ol_rlayer_acid1); - llb.appendItem('acid2', @g_ol_rlayer_acid2); - llb.appendItem('water', @g_ol_rlayer_water); - llb.appendItem('foreground', @g_ol_rlayer_fore); - llb.appendItem('OPTIONS', nil); - llb.appendItem('fill walls', @g_ol_fill_walls); - llb.appendItem('contours', @g_ol_nice); - winOutlines := TUITopWindow.Create('outlines', 100, 10); + winOutlines := TUITopWindow.Create('outlines'); + winOutlines.flHoriz := false; + winOutlines.x0 := 100; + winOutlines.y0 := 30; + winOutlines.flHoriz := false; winOutlines.escClose := true; - winOutlines.appendChild(llb); winOutlines.closeCB := winOutlinesClosed; + + box := TUIVBox.Create(); + box.hasFrame := true; + box.caption := 'layers'; + addCheckBox(box, '~background', @g_ol_rlayer_back); + addCheckBox(box, '~steps', @g_ol_rlayer_step); + addCheckBox(box, '~walls', @g_ol_rlayer_wall); + addCheckBox(box, '~doors', @g_ol_rlayer_door); + addCheckBox(box, 'acid~1', @g_ol_rlayer_acid1); + addCheckBox(box, 'acid~2', @g_ol_rlayer_acid2); + addCheckBox(box, 'wate~r', @g_ol_rlayer_water); + addCheckBox(box, '~foreground', @g_ol_rlayer_fore); + winOutlines.appendChild(box); + + box := TUIVBox.Create(); + box.hasFrame := true; + box.caption := 'options'; + addCheckBox(box, 'fi~ll walls', @g_ol_fill_walls, 'cbfill'); + addCheckBox(box, 'con~tours', @g_ol_nice, 'cbcontour'); + winOutlines.appendChild(box); + + winOutlines.setActionCBFor('cbfill', actionFillWalls); + + uiLayoutCtl(winOutlines); end; procedure createOptionsWindow (); var - llb: TUICBListBox; + box: TUIBox; + span: TUISpan; begin - llb := TUICBListBox.Create(0, 0); - llb.appendItem('map grid', @showGrid); - llb.appendItem('cursor position on map', @showMapCurPos); - llb.appendItem('monster info', @showMonsInfo); - llb.appendItem('monster LOS to player', @showMonsLOS2Plr); - llb.appendItem('monster cells (SLOW!)', @showAllMonsCells); - llb.appendItem('draw triggers (SLOW!)', @showTriggers); - llb.appendItem('WINDOWS', nil); - llb.appendItem('layers window', @showLayersWindow, toggleLayersWindowCB); - llb.appendItem('outline window', @showOutlineWindow, toggleOutlineWindowCB); - winOptions := TUITopWindow.Create('Holmes Options', 100, 100); + winOptions := TUITopWindow.Create('Holmes Options'); + winOptions.flHoriz := false; + winOptions.flHoriz := false; winOptions.escClose := true; - winOptions.appendChild(llb); + + box := TUIVBox.Create(); + box.hasFrame := true; + box.caption := 'visual'; + addCheckBox(box, 'map ~grid', @showGrid); + addCheckBox(box, 'cursor ~position on map', @showMapCurPos); + addCheckBox(box, '~monster info', @showMonsInfo); + addCheckBox(box, 'monster LO~S to player', @showMonsLOS2Plr); + addCheckBox(box, 'monster ~cells (SLOW!)', @showAllMonsCells); + addCheckBox(box, 'draw ~triggers (SLOW!)', @showTriggers); + winOptions.appendChild(box); + + box := TUIHBox.Create(); + box.hasFrame := true; + box.caption := 'windows'; + box.captionAlign := 0; + box.flAlign := 0; + addButton(box, '~layers', toggleLayersWindowCB); + span := TUISpan.Create(); + span.flExpand := true; + span.flDefaultSize := TLaySize.Create(4, 1); + box.appendChild(span); + addButton(box, '~outline', toggleOutlineWindowCB); + winOptions.appendChild(box); + + uiLayoutCtl(winOptions); winOptions.centerInScreen(); end; @@ -305,13 +474,15 @@ end; procedure toggleLayersWindow (arg: Integer=-1); begin if (arg < 0) then showLayersWindow := not showLayersWindow else showLayersWindow := (arg > 0); - toggleLayersWindowCB(nil, 0); + showLayersWindow := not showLayersWindow; // hack for callback + toggleLayersWindowCB(nil); end; procedure toggleOutlineWindow (arg: Integer=-1); begin if (arg < 0) then showOutlineWindow := not showOutlineWindow else showOutlineWindow := (arg > 0); - toggleOutlineWindowCB(nil, 0); + showOutlineWindow := not showOutlineWindow; // hack for callback + toggleOutlineWindowCB(nil); end; procedure toggleHelpWindow (arg: Integer=-1); @@ -688,6 +859,7 @@ var g := ag; b := ab; if g_ol_nice then clearOliner(); + hlmContext.color := TGxRGBA.Create(r, g, b); for f := 0 to High(parr) do begin pan := parr[f]; @@ -702,11 +874,11 @@ var end; if g_ol_fill_walls then begin - fillRect(pan.X, pan.Y, pan.Width, pan.Height, TGxRGBA.Create(r, g, b)); + hlmContext.fillRect(pan.X, pan.Y, pan.Width, pan.Height); end else if not g_ol_nice then begin - drawRect(pan.X, pan.Y, pan.Width, pan.Height, TGxRGBA.Create(r, g, b)); + hlmContext.rect(pan.X, pan.Y, pan.Width, pan.Height); end; end; if g_ol_nice then @@ -735,14 +907,16 @@ procedure plrDebugDraw (); var x, y: Integer; begin + hlmContext.color := TGxRGBA.Create(96, 96, 96); for y := 0 to (mapGrid.gridHeight div mapGrid.tileSize) do begin - drawLine(mapGrid.gridX0, mapGrid.gridY0+y*mapGrid.tileSize, mapGrid.gridX0+mapGrid.gridWidth, mapGrid.gridY0+y*mapGrid.tileSize, TGxRGBA.Create(96, 96, 96)); + hlmContext.line(mapGrid.gridX0, mapGrid.gridY0+y*mapGrid.tileSize, mapGrid.gridX0+mapGrid.gridWidth, mapGrid.gridY0+y*mapGrid.tileSize); end; + hlmContext.color := TGxRGBA.Create(96, 96, 96); for x := 0 to (mapGrid.gridWidth div mapGrid.tileSize) do begin - drawLine(mapGrid.gridX0+x*mapGrid.tileSize, mapGrid.gridY0, mapGrid.gridX0+x*mapGrid.tileSize, mapGrid.gridY0+y*mapGrid.gridHeight, TGxRGBA.Create(96, 96, 96)); + hlmContext.line(mapGrid.gridX0+x*mapGrid.tileSize, mapGrid.gridY0, mapGrid.gridX0+x*mapGrid.tileSize, mapGrid.gridY0+y*mapGrid.gridHeight); end; end; @@ -750,13 +924,14 @@ procedure plrDebugDraw (); var x, y: Integer; begin + hlmContext.color := TGxRGBA.Create(128, 0, 128, 64); for y := 0 to (mapGrid.gridHeight div mapGrid.tileSize) do begin for x := 0 to (mapGrid.gridWidth div mapGrid.tileSize) do begin if awmIsSetHolmes(x*mapGrid.tileSize+mapGrid.gridX0+1, y*mapGrid.tileSize++mapGrid.gridY0+1) then begin - fillRect(x*mapGrid.tileSize++mapGrid.gridX0, y*mapGrid.tileSize++mapGrid.gridY0, monsGrid.tileSize, monsGrid.tileSize, TGxRGBA.Create(128, 0, 128, 64)); + hlmContext.fillRect(x*mapGrid.tileSize++mapGrid.gridX0, y*mapGrid.tileSize++mapGrid.gridY0, monsGrid.tileSize, monsGrid.tileSize); end; end; end; @@ -774,25 +949,31 @@ procedure plrDebugDraw (); plr := gPlayers[0]; if (plr = nil) then exit; plr.getMapBox(px, py, pw, ph); - drawRect(px, py, pw, ph, TGxRGBA.Create(255, 0, 255, 200)); + hlmContext.color := TGxRGBA.Create(255, 0, 255, 200); + hlmContext.rect(px, py, pw, ph); pdx := pmsCurMapX-(px+pw div 2); pdy := pmsCurMapY-(py+ph div 2); - drawLine(px+pw div 2, py+ph div 2, px+pw div 2+pdx, py+ph div 2+pdy, TGxRGBA.Create(255, 0, 255, 200)); + hlmContext.color := TGxRGBA.Create(255, 0, 255, 200); + hlmContext.line(px+pw div 2, py+ph div 2, px+pw div 2+pdx, py+ph div 2+pdy); pan := mapGrid.traceBox(ex, ey, px, py, pw, ph, pdx, pdy, nil, GridTagObstacle); if (pan = nil) then begin - drawRect(px+pdx, py+pdy, pw, ph, TGxRGBA.Create(255, 255, 255, 180)); + hlmContext.color := TGxRGBA.Create(255, 255, 255, 180); + hlmContext.rect(px+pdx, py+pdy, pw, ph); end else begin - drawRect(px+pdx, py+pdy, pw, ph, TGxRGBA.Create(255, 255, 0, 180)); + hlmContext.color := TGxRGBA.Create(255, 255, 0, 180); + hlmContext.rect(px+pdx, py+pdy, pw, ph); end; - drawRect(ex, ey, pw, ph, TGxRGBA.Create(255, 127, 0, 180)); + hlmContext.color := TGxRGBA.Create(255, 127, 0, 180); + hlmContext.rect(ex, ey, pw, ph); end; procedure hilightCell (cx, cy: Integer); begin - fillRect(cx, cy, monsGrid.tileSize, monsGrid.tileSize, TGxRGBA.Create(0, 128, 0, 64)); + hlmContext.color := TGxRGBA.Create(0, 128, 0, 64); + hlmContext.fillRect(cx, cy, monsGrid.tileSize, monsGrid.tileSize); end; procedure hilightCell1 (cx, cy: Integer); @@ -800,7 +981,8 @@ procedure plrDebugDraw (); //e_WriteLog(Format('h1: (%d,%d)', [cx, cy]), MSG_NOTIFY); cx := cx and (not (monsGrid.tileSize-1)); cy := cy and (not (monsGrid.tileSize-1)); - fillRect(cx, cy, monsGrid.tileSize, monsGrid.tileSize, TGxRGBA.Create(255, 255, 0, 92)); + hlmContext.color := TGxRGBA.Create(255, 255, 0, 92); + hlmContext.fillRect(cx, cy, monsGrid.tileSize, monsGrid.tileSize); end; function hilightWallTrc (pan: TPanel; tag: Integer; x, y, prevx, prevy: Integer): Boolean; @@ -808,7 +990,8 @@ procedure plrDebugDraw (); result := false; // don't stop if (pan = nil) then exit; // cell completion, ignore //e_WriteLog(Format('h1: (%d,%d)', [cx, cy]), MSG_NOTIFY); - fillRect(pan.X, pan.Y, pan.Width, pan.Height, TGxRGBA.Create(0, 128, 128, 64)); + hlmContext.color := TGxRGBA.Create(0, 128, 128, 64); + hlmContext.fillRect(pan.X, pan.Y, pan.Width, pan.Height); end; function monsCollector (mon: TMonster; tag: Integer): Boolean; @@ -818,10 +1001,14 @@ procedure plrDebugDraw (); begin result := false; mon.getMapBox(mx, my, mw, mh); - e_DrawQuad(mx, my, mx+mw-1, my+mh-1, 255, 255, 0, 96); + hlmContext.color := TGxRGBA.Create(255, 255, 0, 160); + hlmContext.rect(mx, my, mw, mh); + //e_DrawQuad(mx, my, mx+mw-1, my+mh-1, 255, 255, 0, 96); if lineAABBIntersects(laserX0, laserY0, laserX1, laserY1, mx, my, mw, mh, ex, ey) then begin - e_DrawPoint(8, ex, ey, 0, 255, 0); + //e_DrawPoint(8, ex, ey, 0, 255, 0); + hlmContext.color := TGxRGBA.Create(0, 255, 0, 220); + hlmContext.fillRect(ex-2, ey-2, 7, 7); end; end; @@ -851,10 +1038,12 @@ procedure plrDebugDraw (); exit; end; mon.getMapBox(mx, my, mw, mh); - drawLine(mx+mw div 2, my+mh div 2, emx+emw div 2, emy+emh div 2, TGxRGBA.Create(255, 0, 0)); + hlmContext.color := TGxRGBA.Create(255, 0, 0); + hlmContext.line(mx+mw div 2, my+mh div 2, emx+emw div 2, emy+emh div 2); if (g_Map_traceToNearestWall(mx+mw div 2, my+mh div 2, emx+emw div 2, emy+emh div 2, @ex, @ey) <> nil) then begin - drawLine(mx+mw div 2, my+mh div 2, ex, ey, TGxRGBA.Create(0, 255, 0)); + hlmContext.color := TGxRGBA.Create(0, 255, 0); + hlmContext.line(mx+mw div 2, my+mh div 2, ex, ey); end; end; @@ -868,14 +1057,16 @@ procedure plrDebugDraw (); if (eplr = nil) then exit; eplr.getMapBox(emx, emy, emw, emh); mon.getMapBox(mx, my, mw, mh); - drawLine(mx+mw div 2, my+mh div 2, emx+emw div 2, emy+emh div 2, TGxRGBA.Create(255, 0, 0)); + hlmContext.color := TGxRGBA.Create(255, 0, 0); + hlmContext.line(mx+mw div 2, my+mh div 2, emx+emw div 2, emy+emh div 2); {$IF DEFINED(D2F_DEBUG)} mapGrid.dbgRayTraceTileHitCB := hilightCell1; {$ENDIF} if (g_Map_traceToNearestWall(mx+mw div 2, my+mh div 2, emx+emw div 2, emy+emh div 2, @ex, @ey) <> nil) then //if (mapGrid.traceRay(ex, ey, mx+mw div 2, my+mh div 2, emx+emw div 2, emy+emh div 2, hilightWallTrc, (GridTagWall or GridTagDoor)) <> nil) then begin - drawLine(mx+mw div 2, my+mh div 2, ex, ey, TGxRGBA.Create(0, 255, 0)); + hlmContext.color := TGxRGBA.Create(0, 255, 0); + hlmContext.line(mx+mw div 2, my+mh div 2, ex, ey); end; {$IF DEFINED(D2F_DEBUG)} mapGrid.dbgRayTraceTileHitCB := nil; @@ -892,23 +1083,26 @@ procedure plrDebugDraw (); if showMonsInfo then begin //fillRect(mx-4, my-7*8-6, 110, 7*8+6, 0, 0, 94, 250); - darkenRect(mx-4, my-7*8-6, 110, 7*8+6, 128); + hlmContext.font := 'msx'; + hlmContext.color := TGxRGBA.Create(255, 127, 0); + + hlmContext.darkenRect(mx-4, my-7*hlmContext.charWidth(' ')-6, 110, 7*hlmContext.charWidth(' ')+6, 128); my -= 8; my -= 2; // type - drawText6(mx, my, Format('%s(U:%u)', [monsTypeToString(mon.MonsterType), mon.UID]), TGxRGBA.Create(255, 127, 0)); my -= 8; + hlmContext.drawText(mx, my, Format('%s(U:%u)', [monsTypeToString(mon.MonsterType), mon.UID])); my -= hlmContext.charWidth(' '); // beh - drawText6(mx, my, Format('Beh: %s', [monsBehToString(mon.MonsterBehaviour)]), TGxRGBA.Create(255, 127, 0)); my -= 8; + hlmContext.drawText(mx, my, Format('Beh: %s', [monsBehToString(mon.MonsterBehaviour)])); my -= hlmContext.charWidth(' '); // state - drawText6(mx, my, Format('State:%s (%d)', [monsStateToString(mon.MonsterState), mon.MonsterSleep]), TGxRGBA.Create(255, 127, 0)); my -= 8; + hlmContext.drawText(mx, my, Format('State:%s (%d)', [monsStateToString(mon.MonsterState), mon.MonsterSleep])); my -= hlmContext.charWidth(' '); // health - drawText6(mx, my, Format('Health:%d', [mon.MonsterHealth]), TGxRGBA.Create(255, 127, 0)); my -= 8; + hlmContext.drawText(mx, my, Format('Health:%d', [mon.MonsterHealth])); my -= hlmContext.charWidth(' '); // ammo - drawText6(mx, my, Format('Ammo:%d', [mon.MonsterAmmo]), TGxRGBA.Create(255, 127, 0)); my -= 8; + hlmContext.drawText(mx, my, Format('Ammo:%d', [mon.MonsterAmmo])); my -= hlmContext.charWidth(' '); // target - drawText6(mx, my, Format('TgtUID:%u', [mon.MonsterTargetUID]), TGxRGBA.Create(255, 127, 0)); my -= 8; - drawText6(mx, my, Format('TgtTime:%d', [mon.MonsterTargetTime]), TGxRGBA.Create(255, 127, 0)); my -= 8; + hlmContext.drawText(mx, my, Format('TgtUID:%u', [mon.MonsterTargetUID])); my -= hlmContext.charWidth(' '); + hlmContext.drawText(mx, my, Format('TgtTime:%d', [mon.MonsterTargetTime])); my -= hlmContext.charWidth(' '); end; drawMonsterTargetLine(); @@ -934,7 +1128,8 @@ procedure plrDebugDraw (); pan := g_Map_PanelByGUID(platMarkedGUID); if (pan = nil) then exit; mapGrid.forEachBodyCell(pan.proxyId, hilightCell); - drawRect(pan.x, pan.y, pan.width, pan.height, TGxRGBA.Create(0, 200, 0, 200)); + hlmContext.color := TGxRGBA.Create(0, 200, 0, 200); + hlmContext.rect(pan.x, pan.y, pan.width, pan.height); end; procedure drawTrigger (var trig: TTrigger); @@ -945,24 +1140,26 @@ procedure plrDebugDraw (); begin pan := g_Map_PanelByGUID(pguid); if (pan = nil) then exit; - drawLine( - trig.trigCenter.x, trig.trigCenter.y, - pan.x+pan.width div 2, pan.y+pan.height div 2, - TGxRGBA.Create(255, 0, 255, 220)); + hlmContext.color := TGxRGBA.Create(255, 0, 255, 220); + hlmContext.line(trig.trigCenter.x, trig.trigCenter.y, pan.x+pan.width div 2, pan.y+pan.height div 2); end; var tts: AnsiString; tx: Integer; begin - fillRect(trig.x, trig.y, trig.width, trig.height, TGxRGBA.Create(255, 0, 255, 96)); + hlmContext.font := 'msx'; + hlmContext.color := TGxRGBA.Create(255, 0, 255, 96); + hlmContext.fillRect(trig.x, trig.y, trig.width, trig.height); tts := trigType2Str(trig.TriggerType); tx := trig.x+(trig.width-Length(tts)*6) div 2; - darkenRect(tx-2, trig.y-10, Length(tts)*6+4, 10, 64); - drawText6(tx, trig.y-9, tts, TGxRGBA.Create(255, 127, 0)); + hlmContext.darkenRect(tx-2, trig.y-10, Length(tts)*6+4, 10, 64); + hlmContext.color := TGxRGBA.Create(255, 127, 0); + hlmContext.drawText(tx, trig.y-9, tts); tx := trig.x+(trig.width-Length(trig.mapId)*6) div 2; - darkenRect(tx-2, trig.y-20, Length(trig.mapId)*6+4, 10, 64); - drawText6(tx, trig.y-19, trig.mapId, TGxRGBA.Create(255, 255, 0)); + hlmContext.darkenRect(tx-2, trig.y-20, Length(trig.mapId)*6+4, 10, 64); + hlmContext.color := TGxRGBA.Create(255, 255, 0); + hlmContext.drawText(tx, trig.y-19, trig.mapId); drawPanelDest(trig.trigPanelGUID); case trig.TriggerType of TRIGGER_NONE: begin end; @@ -983,15 +1180,15 @@ procedure plrDebugDraw (); begin if (trig.trigDataRec.trigTWidth > 0) and (trig.trigDataRec.trigTHeight > 0) then begin - fillRect( + hlmContext.color := TGxRGBA.Create(0, 255, 255, 42); + hlmContext.fillRect( trig.trigDataRec.trigTX, trig.trigDataRec.trigTY, - trig.trigDataRec.trigTWidth, trig.trigDataRec.trigTHeight, - TGxRGBA.Create(0, 255, 255, 42)); - drawLine( + trig.trigDataRec.trigTWidth, trig.trigDataRec.trigTHeight); + hlmContext.color := TGxRGBA.Create(255, 0, 255, 220); + hlmContext.line( trig.trigCenter.x, trig.trigCenter.y, trig.trigDataRec.trigTX+trig.trigDataRec.trigTWidth div 2, - trig.trigDataRec.trigTY+trig.trigDataRec.trigTHeight div 2, - TGxRGBA.Create(255, 0, 255, 220)); + trig.trigDataRec.trigTY+trig.trigDataRec.trigTHeight div 2); end; end; TRIGGER_SOUND: begin end; @@ -1030,13 +1227,13 @@ procedure plrDebugDraw (); if gib.alive then begin gib.getMapBox(px, py, pw, ph); - drawRect(px, py, pw, ph, TGxRGBA.Create(255, 0, 255)); + hlmContext.color := TGxRGBA.Create(255, 0, 255); + hlmContext.rect(px, py, pw, ph); end; end; end; var - scisave: TScissorSave; mon: TMonster; mx, my, mw, mh: Integer; //pan: TPanel; @@ -1044,14 +1241,20 @@ var begin if (gPlayer1 = nil) then exit; - scisave.save(true); // enable scissoring - glPushMatrix(); + if (hlmContext = nil) then hlmContext := TGxContext.Create(); + + gxSetContext(hlmContext); try //glScissor(0, gWinSizeY-gPlayerScreenSize.Y-1, vpw, vph); - glScissor(0, gScreenHeight-gPlayerScreenSize.Y-1, gPlayerScreenSize.X, gPlayerScreenSize.Y); + //hlmContext.clip := TGxRect.Create(0, gScreenHeight-gPlayerScreenSize.Y-1, gPlayerScreenSize.X, gPlayerScreenSize.Y); + { glScalef(g_dbg_scale, g_dbg_scale, 1.0); glTranslatef(-vpx, -vpy, 0); + } + hlmContext.glSetScaleTrans(g_dbg_scale, -vpx, -vpy); + glEnable(GL_SCISSOR_TEST); + glScissor(0, gScreenHeight-gPlayerScreenSize.Y-1, gPlayerScreenSize.X, gPlayerScreenSize.Y); if (showGrid) then drawTileGrid(); drawOutlines(); @@ -1064,7 +1267,9 @@ begin if (mon <> nil) then begin mon.getMapBox(mx, my, mw, mh); - e_DrawQuad(mx, my, mx+mw-1, my+mh-1, 255, 0, 0, 30); + //e_DrawQuad(mx, my, mx+mw-1, my+mh-1, 255, 0, 0, 30); + hlmContext.color := TGxRGBA.Create(255, 0, 0, 220); + hlmContext.rect(mx, my, mw, mh); drawMonsterInfo(mon); end; end; @@ -1096,11 +1301,17 @@ begin *) finally - glPopMatrix(); - scisave.restore(); + gxSetContext(nil); end; - if showMapCurPos then drawText8(4, gWinSizeY-10, Format('mappos:(%d,%d)', [pmsCurMapX, pmsCurMapY]), TGxRGBA.Create(255, 255, 0)); + if showMapCurPos then + begin + gxSetContext(hlmContext); + hlmContext.font := 'dos'; + hlmContext.color := TGxRGBA.Create(255, 255, 0); + hlmContext.drawText(4, gWinSizeY-10, Format('mappos:(%d,%d)', [pmsCurMapX, pmsCurMapY])); + gxSetContext(nil); + end; end; @@ -1517,5 +1728,5 @@ begin evMouseCB := onMouseEvent; evKeyCB := onKeyEvent; - conRegVar('hlm_ui_scale', @gh_ui_scale, 0.01, 5.0, 'Holmes UI scale', '', false); + conRegVar('hlm_ui_scale', @fuiRenderScale, 0.01, 5.0, 'Holmes UI scale', '', false); end. diff --git a/src/game/g_main.pas b/src/game/g_main.pas index 94762c9..57f12e9 100644 --- a/src/game/g_main.pas +++ b/src/game/g_main.pas @@ -95,7 +95,7 @@ begin if SDL_Init(sdlflags) < 0 then raise Exception.Create('SDL: Init failed: ' + SDL_GetError()); -{$IFDEF HEADLESS} +{$IFNDEF HEADLESS} SDL_StartTextInput(); {$ENDIF} diff --git a/src/game/g_window.pas b/src/game/g_window.pas index 1db0c63..258b489 100644 --- a/src/game/g_window.pas +++ b/src/game/g_window.pas @@ -57,7 +57,7 @@ uses g_console, e_input, g_options, g_game, g_basic, g_textures, e_sound, g_sound, g_menu, ENet, g_net, g_map, g_gfx, g_monsters, g_holmes, xprofiler, - sdlcarcass, gh_ui; + sdlcarcass, fui_ctls; const @@ -410,7 +410,7 @@ begin key := ev.key.keysym.scancode; down := (ev.type_ = SDL_KEYDOWN); {$IF not DEFINED(HEADLESS)} - if evSDLCB(ev) then + if fuiOnSDLEvent(ev) then begin // event eaten, but... if not down then e_KeyUpDown(key, false); @@ -423,7 +423,7 @@ begin {$IF not DEFINED(HEADLESS)} SDL_MOUSEBUTTONDOWN, SDL_MOUSEBUTTONUP, SDL_MOUSEWHEEL, SDL_MOUSEMOTION: - evSDLCB(ev); + fuiOnSDLEvent(ev); {$ENDIF} SDL_TEXTINPUT: @@ -803,7 +803,7 @@ begin begin if (idx <= ParamCount) then begin - if not conParseFloat(gh_ui_scale, ParamStr(idx)) then gh_ui_scale := 1.0; + if not conParseFloat(fuiRenderScale, ParamStr(idx)) then fuiRenderScale := 1.0; Inc(idx); end; end; diff --git a/src/gx/gh_ui_common.pas b/src/gx/gh_ui_common.pas deleted file mode 100644 index 034321a..0000000 --- a/src/gx/gh_ui_common.pas +++ /dev/null @@ -1,112 +0,0 @@ -(* coded by Ketmar // Invisible Vector - * Understanding is not required. Only obedience. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program. If not, see . - *) -{$INCLUDE ../shared/a_modes.inc} -unit gh_ui_common; - -interface - - -// ////////////////////////////////////////////////////////////////////////// // -type - TLaySize = record - public - w, h: Integer; - - private - function getIdx (idx: Integer): Integer; inline; - procedure setIdx (idx, v: Integer); inline; - - public - constructor Create (aw, ah: Integer); - - function toString (): AnsiString; - - function equals (constref a: TLaySize): Boolean; inline; - public - property item[idx: Integer]: Integer read getIdx write setIdx; default; - end; - - TLayPos = record - public - x, y: Integer; - - private - function getIdx (idx: Integer): Integer; inline; - procedure setIdx (idx, v: Integer); inline; - - public - constructor Create (ax, ay: Integer); - - function toString (): AnsiString; - - function equals (constref a: TLayPos): Boolean; inline; - - public - property item[idx: Integer]: Integer read getIdx write setIdx; default; - end; - - TLayMargins = record - public - top, right, bottom, left: Integer; - - public - constructor Create (atop, aright, abottom, aleft: Integer); - - function toString (): AnsiString; - - function horiz (): Integer; inline; - function vert (): Integer; inline; - end; - - - -implementation - -uses - utils; - - -// ////////////////////////////////////////////////////////////////////////// // -constructor TLaySize.Create (aw, ah: Integer); begin w := aw; h := ah; end; -function TLaySize.getIdx (idx: Integer): Integer; inline; begin if (idx = 0) then result := w else if (idx = 1) then result := h else result := -1; end; -procedure TLaySize.setIdx (idx, v: Integer); inline; begin if (idx = 0) then w := v else if (idx = 1) then h := v; end; -function TLaySize.toString (): AnsiString; begin result := formatstrf('[%d,%d]', [w, h]); end; -function TLaySize.equals (constref a: TLaySize): Boolean; inline; begin result := (w = a.w) and (h = a.h); end; - -constructor TLayPos.Create (ax, ay: Integer); begin x := ax; y := ay; end; -function TLayPos.getIdx (idx: Integer): Integer; inline; begin if (idx = 0) then result := x else if (idx = 1) then result := y else result := -1; end; -procedure TLayPos.setIdx (idx, v: Integer); inline; begin if (idx = 0) then x := v else if (idx = 1) then y := v; end; -function TLayPos.toString (): AnsiString; begin result := formatstrf('(%d,%d)', [x, y]); end; -function TLayPos.equals (constref a: TLayPos): Boolean; inline; begin result := (x = a.x) and (y = a.y); end; - -constructor TLayMargins.Create (atop, aright, abottom, aleft: Integer); -begin - if (atop < 0) then atop := 0; - if (aright < 0) then aright := 0; - if (abottom < 0) then abottom := 0; - if (aleft < 0) then aleft := 0; - left := aleft; - right := aright; - top := atop; - bottom := abottom; -end; -function TLayMargins.toString (): AnsiString; begin result := formatstrf('(%s,%s,%s,%s)', [top, right, bottom, left]); end; -function TLayMargins.horiz (): Integer; inline; begin result := left+right; end; -function TLayMargins.vert (): Integer; inline; begin result := top+bottom; end; - - -end. diff --git a/src/gx/gh_ui_style.pas b/src/gx/gh_ui_style.pas deleted file mode 100644 index 5c77405..0000000 --- a/src/gx/gh_ui_style.pas +++ /dev/null @@ -1,633 +0,0 @@ -(* coded by Ketmar // Invisible Vector - * Understanding is not required. Only obedience. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program. If not, see . - *) -{$INCLUDE ../../shared/a_modes.inc} -unit gh_ui_style; - -interface - -uses - SysUtils, Classes, - glgfx, - xstreams, xparser, utils, hashtable; - - -type - TStyleValue = packed record - public - type TType = (Empty, Bool, Int, Color); - - 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); - - 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; - - public - vtype: TType; - allowInherit: Boolean; - case TType of - TType.Bool: (bval: Boolean); - TType.Int: (ival: Integer); - TType.Color: (r, g, b, a: Byte); - end; - - TStyleSection = class; - - THashStrStyleVal = specialize THashBase; - THashStrSection = specialize THashBase; - - TStyleSection = class - private - mVals: THashStrStyleVal; - mHashVals: THashStrSection; // "#..." - mCtlVals: THashStrSection; - - private - // "text-color#inactive@label" - function getValue (const path: AnsiString): TStyleValue; - procedure setValue (const path: AnsiString; const val: TStyleValue); - - public - constructor Create (); - destructor Destroy (); override; - - public - property value[const path: AnsiString]: TStyleValue read getValue write setValue; default; - end; - - TUIStyle = class - private - mId: AnsiString; // style name ('default', for example) - mMain: TStyleSection; - - private - procedure parse (par: TTextParser); - - function getValue (const path: AnsiString): TStyleValue; inline; - procedure setValue (const path: AnsiString; const val: TStyleValue); inline; - - public - constructor Create (const aid: AnsiString); - constructor Create (st: TStream); // parse from stream - constructor CreateFromFile (const fname: AnsiString); - destructor Destroy (); override; - - public - property id: AnsiString read mId; - property value[const path: AnsiString]: TStyleValue read getValue write setValue; default; - end; - - -procedure uiLoadStyles (const fname: AnsiString); -procedure uiLoadStyles (st: TStream); - -// will return "default" (or raise an exception if there is no "default") -function uiFindStyle (const stname: AnsiString): TUIStyle; - - -implementation - - -// ////////////////////////////////////////////////////////////////////////// // -var - styles: array of TUIStyle = nil; - - -function createDefaultStyle (): TUIStyle; -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)); -end; - - -function uiFindStyle (const stname: AnsiString): TUIStyle; -var - stl: TUIStyle; -begin - if (Length(stname) > 0) then - begin - for stl in styles do if (strEquCI1251(stl.mId, stname)) then begin result := stl; exit; end; - end; - for stl in styles do if (strEquCI1251(stl.mId, 'default')) then begin result := stl; exit; end; - stl := createDefaultStyle(); - SetLength(styles, Length(styles)+1); - styles[High(styles)] := stl; - result := stl; -end; - - -procedure uiLoadStyles (const fname: AnsiString); -var - st: TStream; -begin - st := openDiskFileRO(fname); - try - uiLoadStyles(st); - finally - st.Free(); - end; -end; - - -procedure uiLoadStyles (st: TStream); -var - par: TTextParser; - stl: TUIStyle = nil; - 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]); - styles := nil; - try - while (not par.isEOF) do - begin - stl := TUIStyle.Create(''); - stl.parse(par); - //writeln('new style: <', stl.mId, '>'); - f := 0; - while (f < Length(styles)) do begin if (strEquCI1251(styles[f].mId, stl.mId)) then break; Inc(f); end; - if (f < Length(styles)) then - begin - FreeAndNil(styles[f]); - end - else - begin - f := Length(styles); - SetLength(styles, f+1); - end; - styles[f] := stl; - stl := nil; - end; - finally - stl.Free(); - par.Free(); - end; - // we should have "default" style - for f := 0 to High(styles) do if (strEquCI1251(styles[f].mId, 'default')) then exit; - stl := createDefaultStyle(); - SetLength(styles, Length(styles)+1); - styles[High(styles)] := stl; -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; -end; - -constructor TStyleValue.Create (ar, ag, ab, aa: 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 := nmax(0, nmin(aa, 255)); -end; - -constructor TStyleValue.Create (const v: TGxRGBA; okToInherit: Boolean=true); -begin - vtype := TType.Color; - allowInherit := okToInherit; - r := v.r; - g := v.g; - b := v.b; - a := v.a; -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.toString (): AnsiString; -begin - case vtype of - TType.Empty: result := ''; - TType.Bool: if bval then result := 'true' else result := 'false'; - TType.Int: result := formatstrf('%s', [ival]); - TType.Color: if (a = 255) then result := formatstrf('rgb(%s,%s,%s)', [r, g, b]) else result := formatstrf('rgba(%s,%s,%s)', [r, g, b, a]); - else result := ''; - end; -end; - - -// ////////////////////////////////////////////////////////////////////////// // -procedure freeSectionCB (var v: TStyleSection); begin FreeAndNil(v); end; - - -function splitPath (const path: AnsiString; out name, hash, ctl: AnsiString): Boolean; -var - hashPos, atPos: Integer; -begin - result := false; - name := ''; - hash := ''; - ctl := ''; - hashPos := pos('#', path); - atPos := pos('@', path); - // split - if (atPos > 0) then - begin - // has ctl, and (possible) hash - 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); - end - else - begin - // has only ctl - if (atPos > 1) then name := Copy(path, 1, 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 - // has hash - if (hashPos > 1) then name := Copy(path, 1, hashPos-1); - Inc(hashPos); // skip hash - if (hashPos <= Length(path)) then hash := Copy(path, hashPos, Length(path)-hashPos+1); - end - else - begin - // only name - name := path; - end; - result := true; -end; - - -// ////////////////////////////////////////////////////////////////////////// // -constructor TStyleSection.Create (); -begin - mVals := THashStrStyleVal.Create(); - mHashVals := THashStrSection.Create(); - mCtlVals := THashStrSection.Create(freeSectionCB); -end; - - -destructor TStyleSection.Destroy (); -begin - FreeAndNil(mVals); - FreeAndNil(mHashVals); - FreeAndNil(mCtlVals); - inherited; -end; - - -// "text-color#inactive@label" -function TStyleSection.getValue (const path: AnsiString): TStyleValue; -var - name, hash, ctl: AnsiString; - sect: TStyleSection = nil; - s1: TStyleSection = nil; - checkInheritance: 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 - // try control - if (Length(ctl) > 0) then - begin - // has ctl section? - if not mCtlVals.get(ctl, sect) then - begin - sect := self; - checkInheritance := true; - end; - end - else - begin - sect := self; - end; - // has hash? - if (Length(hash) > 0) then - begin - if sect.mHashVals.get(hash, s1) 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; - end; - //writeln('NO hash: <', hash, '>: val=', result.toString); - checkInheritance := true; - end; - // try just a name - if sect.mVals.get(name, result) then - begin - if (not result.isEmpty) and ((not checkInheritance) or (result.canInherit)) then exit; - end; - // alas - result.vtype := result.TType.Empty; -end; - - -procedure TStyleSection.setValue (const path: AnsiString; const val: TStyleValue); -var - name, hash, ctl: AnsiString; - sect: TStyleSection = nil; - s1: TStyleSection = nil; -begin - 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); -end; - - -// ////////////////////////////////////////////////////////////////////////// // -constructor TUIStyle.Create (const aid: AnsiString); -begin - mId := aid; - mMain := TStyleSection.Create(); -end; - - -constructor TUIStyle.Create (st: TStream); // parse from stream -var - par: TTextParser; -begin - mId := ''; - mMain := TStyleSection.Create(); - if (st = nil) then exit; - par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]); - try - parse(par); - finally - par.Free(); - end; -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; - finally - st.Free(); - end; -end; - - -destructor TUIStyle.Destroy (); -begin - mId := ''; - FreeAndNil(mMain); -end; - - -function TUIStyle.getValue (const path: AnsiString): TStyleValue; inline; -begin - result := mMain[path]; -end; - -procedure TUIStyle.setValue (const path: AnsiString; const val: TStyleValue); inline; -begin - mMain.setValue(path, val); -end; - - -procedure TUIStyle.parse (par: TTextParser); - function getByte (): Byte; - begin - if (par.tokType <> par.TTInt) then par.expectInt(); - if (par.tokInt < 0) or (par.tokInt > 255) then par.error('invalid byte value'); - result := Byte(par.tokInt); - par.skipToken(); - end; - - procedure parseSection (sect: TStyleSection; ctlAllowed: Boolean; hashAllowed: Boolean); - var - s: AnsiString; - sc: TStyleSection = nil; - v: TStyleValue; - begin - par.expectDelim('{'); - while (not par.isDelim('}')) do - begin - while (par.eatDelim(';')) do begin end; - // hash - if hashAllowed and (par.eatDelim('#')) then - begin - s := par.expectIdOrStr(); - //writeln('hash: <', s, '>'); - par.eatDelim(':'); // optional - if not sect.mHashVals.get(s, sc) then - begin - // create new section - sc := TStyleSection.Create(); - sect.mHashVals.put(s, sc); - end; - parseSection(sc, false, false); - continue; - end; - // ctl - if ctlAllowed and (par.eatDelim('@')) then - begin - s := par.expectIdOrStr(); - //writeln('ctl: <', s, '>'); - par.eatDelim(':'); // optional - if not sect.mCtlVals.get(s, sc) then - begin - // create new section - sc := TStyleSection.Create(); - sect.mCtlVals.put(s, sc); - end; - parseSection(sc, false, true); - continue; - end; - // name - s := par.expectIdOrStr(); - //writeln('name: <', s, '>'); - v.allowInherit := true; - par.expectDelim(':'); - if (par.eatId('rgb')) or (par.eatId('rgba')) then - begin - // color - par.expectDelim('('); - v.vtype := v.TType.Color; - v.r := getByte(); par.eatDelim(','); // optional - v.g := getByte(); par.eatDelim(','); // optional - v.b := getByte(); par.eatDelim(','); // optional - if (par.tokType = par.TTInt) then - begin - v.a := getByte(); par.eatDelim(','); // optional - end - else - begin - v.a := 255; // opaque - end; - par.expectDelim(')'); - end - else if (par.eatId('true')) or (par.eatId('tan')) then - begin - v.vtype := v.TType.Bool; - v.bval := true; - end - else if (par.eatId('false')) or (par.eatId('ona')) then - begin - v.vtype := v.TType.Bool; - v.bval := false; - 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; - par.expectDelim('}'); - end; - -begin - // style name - if (not par.isIdOrStr) then - begin - if (Length(mId) = 0) then par.error('style name expected'); - end - else - begin - mId := par.tokStr; - end; - if (Length(mId) = 0) then mId := 'default'; - par.skipToken(); - parseSection(mMain, true, true); -end; - - -end. diff --git a/src/gx/glgfx.pas b/src/gx/glgfx.pas deleted file mode 100644 index d39d2f0..0000000 --- a/src/gx/glgfx.pas +++ /dev/null @@ -1,1663 +0,0 @@ -(* coded by Ketmar // Invisible Vector - * Understanding is not required. Only obedience. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program. If not, see . - *) -{$INCLUDE ../shared/a_modes.inc} -unit glgfx; - -interface - -uses - SysUtils, Classes, - GL, GLExt, SDL2, - sdlcarcass; - - -// ////////////////////////////////////////////////////////////////////////// // -type - TGxRGBA = packed record - public - r, g, b, a: Byte; - - public - constructor Create (ar, ag, ab: Integer; aa: Integer=255); - - function asUInt (): LongWord; inline; - function isOpaque (): Boolean; inline; - function isTransparent (): Boolean; inline; - - // WARNING! This function does blending in RGB space, and RGB space is not linear! - // alpha value of `self` doesn't matter - // `aa` means: 255 for replace color, 0 for keep `self` - function blend (ar, ag, ab, aa: Integer): TGxRGBA; inline; - end; - - -// ////////////////////////////////////////////////////////////////////////// // -type - THMouseEvent = record - public - const - // both for but and for bstate - None = 0; - Left = $0001; - Right = $0002; - Middle = $0004; - WheelUp = $0008; - WheelDown = $0010; - - // event types - type - TKind = (Release, Press, Motion); - - private - mEaten: Boolean; - mCancelled: Boolean; - - public - kind: TKind; // motion, press, release - x, y: Integer; // current mouse position - dx, dy: Integer; // for wheel this is wheel motion, otherwise this is relative mouse motion - but: Word; // current pressed/released button, or 0 for motion - bstate: Word; // button state BEFORE event (i.e. press/release modifications aren't done yet) - kstate: Word; // keyboard state (see THKeyEvent); - - public - procedure intrInit (); inline; // init hidden fields - - function press (): Boolean; inline; - function release (): Boolean; inline; - function motion (): Boolean; inline; - procedure eat (); inline; - procedure cancel (); inline; - - public - property eaten: Boolean read mEaten; - property cancelled: Boolean read mCancelled; - end; - - THKeyEvent = record - public - const - // modifiers - ModCtrl = $0001; - ModAlt = $0002; - ModShift = $0004; - ModHyper = $0008; - - // event types - type - TKind = (Release, Press); - - private - mEaten: Boolean; - mCancelled: Boolean; - - public - kind: TKind; - scan: Word; // SDL_SCANCODE_XXX - sym: LongWord; // SDLK_XXX - x, y: Integer; // current mouse position - bstate: Word; // button state - kstate: Word; // keyboard state BEFORE event (i.e. press/release modifications aren't done yet) - - public - procedure intrInit (); inline; // init hidden fields - - function press (): Boolean; inline; - function release (): Boolean; inline; - procedure eat (); inline; - procedure cancel (); inline; - - public - property eaten: Boolean read mEaten; - property cancelled: Boolean read mCancelled; - end; - - - -// ////////////////////////////////////////////////////////////////////////// // -// setup 2D OpenGL mode; will be called automatically in `glInit()` -procedure oglSetup2D (winWidth, winHeight: Integer; upsideDown: Boolean=false); - -type - TScissorSave = record - public - wassc: Boolean; - scxywh: packed array[0..3] of GLint; - - public - - public - procedure save (enableScissoring: Boolean); - procedure restore (); - - // set new scissor rect, bounded by the saved scissor rect - procedure combineRect (x, y, w, h: Integer); - end; - - -procedure oglDrawCursor (); -procedure oglDrawCursorAt (msX, msY: Integer); - -// return `false` if destination rect is empty -// modifies rect0 -function intersectRect (var x0, y0, w0, h0: Integer; const x1, y1, w1, h1: Integer): Boolean; - -procedure normRGBA (var r, g, b, a: Integer); inline; -function setupGLColor (r, g, b, a: Integer): Boolean; -function setupGLColor (constref clr: TGxRGBA): Boolean; -function isScaled (): Boolean; - -function textWidth6 (const s: AnsiString): Integer; -function textWidth8 (const s: AnsiString): Integer; -// return width (including last empty pixel) -function drawTextInternal (wdt, x, y: Integer; const s: AnsiString; constref clr: TGxRGBA; tid: GLuint; constref fontwdt: array of Byte; prop: Boolean): Integer; -procedure drawLine (x1, y1, x2, y2: Integer; constref clr: TGxRGBA); -procedure drawVLine (x, y, len: Integer; constref clr: TGxRGBA); -procedure drawHLine (x, y, len: Integer; constref clr: TGxRGBA); -procedure drawRect (x, y, w, h: Integer; constref clr: TGxRGBA); -procedure drawRectUI (x, y, w, h: Integer; constref clr: TGxRGBA); -procedure darkenRect (x, y, w, h: Integer; a: Integer); -procedure fillRect (x, y, w, h: Integer; constref clr: TGxRGBA); -function drawText6 (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -function drawText8 (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -function drawText6Prop (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -function drawText8Prop (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -// x-centered at `x` -function drawText6XC (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -function drawText8XC (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -function drawText6PropXC (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -function drawText8PropXC (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; - - -// ////////////////////////////////////////////////////////////////////////// // -// event handlers -var - evMouseCB: procedure (var ev: THMouseEvent) = nil; - evKeyCB: procedure (var ev: THKeyEvent) = nil; - - -// ////////////////////////////////////////////////////////////////////////// // -function getMouseX (): Integer; inline; -function getMouseY (): Integer; inline; -function getButState (): Word; inline; -function getModState (): Word; inline; - - -// ////////////////////////////////////////////////////////////////////////// // -property - gMouseX: Integer read getMouseX; - gMouseY: Integer read getMouseY; - gButState: Word read getButState; - gModState: Word read getModState; - -var - gGfxDoClear: Boolean = true; - - -// ////////////////////////////////////////////////////////////////////////// // -// any mods = 255: nothing was defined -function parseModKeys (const s: AnsiString; out kmods: Byte; out mbuts: Byte): AnsiString; - -operator = (constref ev: THKeyEvent; const s: AnsiString): Boolean; -operator = (const s: AnsiString; constref ev: THKeyEvent): Boolean; - -operator = (constref ev: THMouseEvent; const s: AnsiString): Boolean; -operator = (const s: AnsiString; constref ev: THMouseEvent): Boolean; - - -implementation - - -var - curButState: Word = 0; - curModState: Word = 0; - curMsX: Integer = 0; - curMsY: Integer = 0; - - -// ////////////////////////////////////////////////////////////////////////// // -function strEquCI (const s0, s1: AnsiString): Boolean; -var - f: Integer; - c0, c1: AnsiChar; -begin - result := (Length(s0) = Length(s1)); - if result then - begin - for f := 1 to Length(s0) do - begin - c0 := s0[f]; - if (c0 >= 'a') and (c0 <= 'z') then Dec(c0, 32); // poor man's `toupper()` - c1 := s1[f]; - if (c1 >= 'a') and (c1 <= 'z') then Dec(c1, 32); // poor man's `toupper()` - if (c0 <> c1) then begin result := false; exit; end; - end; - end; -end; - - -// ////////////////////////////////////////////////////////////////////////// // -function getMouseX (): Integer; inline; begin result := curMsX; end; -function getMouseY (): Integer; inline; begin result := curMsY; end; -function getButState (): Word; inline; begin result := curButState; end; -function getModState (): Word; inline; begin result := curModState; end; - - -// ////////////////////////////////////////////////////////////////////////// // -procedure THMouseEvent.intrInit (); inline; begin mEaten := false; mCancelled := false; end; -function THMouseEvent.press (): Boolean; inline; begin result := (kind = TKind.Press); end; -function THMouseEvent.release (): Boolean; inline; begin result := (kind = TKind.Release); end; -function THMouseEvent.motion (): Boolean; inline; begin result := (kind = TKind.Motion); end; -procedure THMouseEvent.eat (); inline; begin mEaten := true; end; -procedure THMouseEvent.cancel (); inline; begin mCancelled := true; end; - -procedure THKeyEvent.intrInit (); inline; begin mEaten := false; mCancelled := false; end; -function THKeyEvent.press (): Boolean; inline; begin result := (kind = TKind.Press); end; -function THKeyEvent.release (): Boolean; inline; begin result := (kind = TKind.Release); end; -procedure THKeyEvent.eat (); inline; begin mEaten := true; end; -procedure THKeyEvent.cancel (); inline; begin mCancelled := true; end; - - -// ////////////////////////////////////////////////////////////////////////// // -constructor TGxRGBA.Create (ar, ag, ab: Integer; aa: Integer=255); -begin - if (ar < 0) then r := 0 else if (ar > 255) then r := 255 else r := Byte(ar); - if (ag < 0) then g := 0 else if (ag > 255) then g := 255 else g := Byte(ag); - if (ab < 0) then b := 0 else if (ab > 255) then b := 255 else b := Byte(ab); - if (aa < 0) then a := 0 else if (aa > 255) then a := 255 else a := Byte(aa); -end; - -function TGxRGBA.asUInt (): LongWord; inline; begin result := LongWord(r) or (LongWord(g) shl 8) or (LongWord(b) shl 16) or (LongWord(a) shl 24); end; - -function TGxRGBA.isOpaque (): Boolean; inline; begin result := (a = 255); end; -function TGxRGBA.isTransparent (): Boolean; inline; begin result := (a = 0); end; - -function TGxRGBA.blend (ar, ag, ab, aa: Integer): TGxRGBA; inline; -var - me, it, a_tmp_, dc_tmp_, srb_tmp_, sg_tmp_, drb_tmp_, dg_tmp_, orb_tmp_, og_tmp_: LongWord; -begin - if (aa <= 0) then begin result := self; exit; end; - result := TGxRGBA.Create(ar, ag, ab, aa); - if (aa >= 255) then begin result.a := a; exit; end; - me := asUInt; - it := result.asUInt; - a_tmp_ := (256-(255-(it shr 24))) and (-(1-(((255-(it shr 24))+1) shr 8))); // to not loose bits, but 255 should become 0 - dc_tmp_ := me and $ffffff; - srb_tmp_ := (it and $ff00ff); - sg_tmp_ := (it and $00ff00); - drb_tmp_ := (dc_tmp_ and $ff00ff); - dg_tmp_ := (dc_tmp_ and $00ff00); - orb_tmp_ := (drb_tmp_+(((srb_tmp_-drb_tmp_)*a_tmp_+$800080) shr 8)) and $ff00ff; - og_tmp_ := (dg_tmp_+(((sg_tmp_-dg_tmp_)*a_tmp_+$008000) shr 8)) and $00ff00; - me := (orb_tmp_ or og_tmp_); // or $ff000000; /* and $ffffff;*/ - result.r := Byte(me and $ff); - result.g := Byte((me shr 8) and $ff); - result.b := Byte((me shr 16) and $ff); - result.a := a; -end; - - -// ////////////////////////////////////////////////////////////////////////// // -// any mods = 255: nothing was defined -function parseModKeys (const s: AnsiString; out kmods: Byte; out mbuts: Byte): AnsiString; -var - pos, epos: Integer; -begin - kmods := 255; - mbuts := 255; - pos := 1; - //while (pos <= Length(s)) and (s[pos] <= ' ') do Inc(pos); - if (pos < Length(s)) and ((s[pos] = '+') or (s[pos] = '-') or (s[pos] = '*')) then Inc(pos); - while (pos <= Length(s)) do - begin - if (Length(s)-pos >= 1) and (s[pos+1] = '-') then - begin - case s[pos] of - 'C', 'c': begin if (kmods = 255) then kmods := 0; kmods := kmods or THKeyEvent.ModCtrl; Inc(pos, 2); continue; end; - 'M', 'm': begin if (kmods = 255) then kmods := 0; kmods := kmods or THKeyEvent.ModAlt; Inc(pos, 2); continue; end; - 'S', 's': begin if (kmods = 255) then kmods := 0; kmods := kmods or THKeyEvent.ModShift; Inc(pos, 2); continue; end; - end; - break; - end; - if (Length(s)-pos >= 3) and (s[pos+3] = '-') and ((s[pos+1] = 'M') or (s[pos+1] = 'm')) and ((s[pos+2] = 'B') or (s[pos+2] = 'b')) then - begin - case s[pos] of - 'L', 'l': begin if (mbuts = 255) then mbuts := 0; mbuts := mbuts or THMouseEvent.Left; Inc(pos, 4); continue; end; - 'R', 'r': begin if (mbuts = 255) then mbuts := 0; mbuts := mbuts or THMouseEvent.Right; Inc(pos, 4); continue; end; - 'M', 'm': begin if (mbuts = 255) then mbuts := 0; mbuts := mbuts or THMouseEvent.Middle; Inc(pos, 4); continue; end; - end; - break; - end; - break; - end; - epos := Length(s)+1; - while (epos > pos) and (s[epos-1] <= ' ') do Dec(epos); - if (epos > pos) then result := Copy(s, pos, epos-pos) else result := ''; -end; - - -operator = (constref ev: THKeyEvent; const s: AnsiString): Boolean; -var - f: Integer; - kmods: Byte = 255; - mbuts: Byte = 255; - kname: AnsiString; -begin - result := false; - if (Length(s) > 0) then - begin - if (s[1] = '+') then begin if (not ev.press) then exit; end - else if (s[1] = '-') then begin if (not ev.release) then exit; end - else if (s[1] = '*') then begin end - else if (not ev.press) then exit; - end; - kname := parseModKeys(s, kmods, mbuts); - if (kmods = 255) then kmods := 0; - if (ev.kstate <> kmods) then exit; - if (mbuts <> 255) and (ev.bstate <> mbuts) then exit; - - if (strEquCI(kname, 'Enter')) then kname := 'RETURN'; - - for f := 0 to SDL_NUM_SCANCODES-1 do - begin - if strEquCI(kname, SDL_GetScancodeName(f)) then - begin - result := (ev.scan = f); - exit; - end; - end; -end; - - -operator = (const s: AnsiString; constref ev: THKeyEvent): Boolean; -begin - result := (ev = s); -end; - - -operator = (constref ev: THMouseEvent; const s: AnsiString): Boolean; -var - kmods: Byte = 255; - mbuts: Byte = 255; - kname: AnsiString; - but: Integer = -1; - modch: AnsiChar = ' '; -begin - result := false; - - if (Length(s) > 0) then - begin - if (s[1] = '+') then begin if (not ev.press) then exit; modch := '+'; end - else if (s[1] = '-') then begin if (not ev.release) then exit; modch := '-'; end - else if (s[1] = '*') then begin if (not ev.motion) then exit; end - else if (not ev.press) then exit; - end; - - kname := parseModKeys(s, kmods, mbuts); - if strEquCI(kname, 'LMB') then but := THMouseEvent.Left - else if strEquCI(kname, 'RMB') then but := THMouseEvent.Right - else if strEquCI(kname, 'MMB') then but := THMouseEvent.Middle - else if strEquCI(kname, 'WheelUp') or strEquCI(kname, 'WUP') then but := THMouseEvent.WheelUp - else if strEquCI(kname, 'WheelDown') or strEquCI(kname, 'WDN') or strEquCI(kname, 'WDOWN') then but := THMouseEvent.WheelDown - else if strEquCI(kname, 'None') then but := 0 - else exit; - - if (mbuts = 255) then mbuts := 0; - if (kmods = 255) then kmods := 0; - if (ev.kstate <> kmods) then exit; - if (modch = '-') then mbuts := mbuts or but else if (modch = '+') then mbuts := mbuts and (not but); - - result := (ev.bstate = mbuts) and (ev.but = but); -end; - - -operator = (const s: AnsiString; constref ev: THMouseEvent): Boolean; -begin - result := (ev = s); -end; - - -// ////////////////////////////////////////////////////////////////////////// // -procedure resetKMState (sendEvents: Boolean=true); -var - mask: Word; - mev: THMouseEvent; - kev: THKeyEvent; -begin - // generate mouse release events - if (curButState <> 0) then - begin - if sendEvents then - begin - mask := 1; - while (mask <> 0) do - begin - // checked each time, 'cause `evMouseCB` can be changed from the handler - if ((curButState and mask) <> 0) and assigned(evMouseCB) then - begin - FillChar(mev, sizeof(mev), 0); - mev.intrInit(); - mev.kind := mev.TKind.Release; - mev.x := curMsX; - mev.y := curMsY; - mev.dx := 0; - mev.dy := 0; - mev.but := mask; - mev.bstate := curButState; - mev.kstate := curModState; - curButState := curButState and (not mask); - evMouseCB(mev); - end; - mask := mask shl 1; - end; - end; - curButState := 0; - end; - - // generate modifier release events - if (curModState <> 0) then - begin - if sendEvents then - begin - mask := 1; - while (mask <= 8) do - begin - // checked each time, 'cause `evMouseCB` can be changed from the handler - if ((curModState and mask) <> 0) and assigned(evKeyCB) then - begin - FillChar(kev, sizeof(kev), 0); - kev.intrInit(); - kev.kind := kev.TKind.Release; - case mask of - THKeyEvent.ModCtrl: begin kev.scan := SDL_SCANCODE_LCTRL; kev.sym := SDLK_LCTRL;{arbitrary} end; - THKeyEvent.ModAlt: begin kev.scan := SDL_SCANCODE_LALT; kev.sym := SDLK_LALT;{arbitrary} end; - THKeyEvent.ModShift: begin kev.scan := SDL_SCANCODE_LSHIFT; kev.sym := SDLK_LSHIFT;{arbitrary} end; - THKeyEvent.ModHyper: begin kev.scan := SDL_SCANCODE_LGUI; kev.sym := SDLK_LGUI;{arbitrary} end; - else assert(false); - end; - kev.x := curMsX; - kev.y := curMsY; - mev.bstate := 0{curMsButState}; // anyway - mev.kstate := curModState; - curModState := curModState and (not mask); - evKeyCB(kev); - end; - mask := mask shl 1; - end; - end; - curModState := 0; - end; -end; - - -function onSDLEvent (var ev: TSDL_Event): Boolean; -var - mev: THMouseEvent; - kev: THKeyEvent; - - function buildBut (b: Byte): Word; - begin - result := 0; - case b of - SDL_BUTTON_LEFT: result := result or THMouseEvent.Left; - SDL_BUTTON_MIDDLE: result := result or THMouseEvent.Middle; - SDL_BUTTON_RIGHT: result := result or THMouseEvent.Right; - end; - end; - -begin - result := false; - - case ev.type_ of - SDL_KEYDOWN, SDL_KEYUP: - begin - // fix left/right modifiers - FillChar(kev, sizeof(kev), 0); - kev.intrInit(); - if (ev.type_ = SDL_KEYDOWN) then kev.kind := THKeyEvent.TKind.Press else kev.kind := THKeyEvent.TKind.Release; - kev.scan := ev.key.keysym.scancode; - kev.sym := ev.key.keysym.sym; - - if (kev.scan = SDL_SCANCODE_RCTRL) then kev.scan := SDL_SCANCODE_LCTRL; - if (kev.scan = SDL_SCANCODE_RALT) then kev.scan := SDL_SCANCODE_LALT; - if (kev.scan = SDL_SCANCODE_RSHIFT) then kev.scan := SDL_SCANCODE_LSHIFT; - if (kev.scan = SDL_SCANCODE_RGUI) then kev.scan := SDL_SCANCODE_LGUI; - - if (kev.sym = SDLK_RCTRL) then kev.sym := SDLK_LCTRL; - if (kev.sym = SDLK_RALT) then kev.sym := SDLK_LALT; - if (kev.sym = SDLK_RSHIFT) then kev.sym := SDLK_LSHIFT; - if (kev.sym = SDLK_RGUI) then kev.sym := SDLK_LGUI; - - kev.x := curMsX; - kev.y := curMsY; - kev.bstate := curButState; - kev.kstate := curModState; - - case kev.scan of - SDL_SCANCODE_LCTRL: if (kev.press) then curModState := curModState or THKeyEvent.ModCtrl else curModState := curModState and (not THKeyEvent.ModCtrl); - SDL_SCANCODE_LALT: if (kev.press) then curModState := curModState or THKeyEvent.ModAlt else curModState := curModState and (not THKeyEvent.ModAlt); - SDL_SCANCODE_LSHIFT: if (kev.press) then curModState := curModState or THKeyEvent.ModShift else curModState := curModState and (not THKeyEvent.ModShift); - end; - - if assigned(evKeyCB) then - begin - evKeyCB(kev); - result := kev.eaten; - end; - end; - - SDL_MOUSEBUTTONDOWN, SDL_MOUSEBUTTONUP: - begin - FillChar(mev, sizeof(mev), 0); - mev.intrInit(); - if (ev.type_ = SDL_MOUSEBUTTONDOWN) then mev.kind := THMouseEvent.TKind.Press else mev.kind := THMouseEvent.TKind.Release; - mev.dx := ev.button.x-curMsX; - mev.dy := ev.button.y-curMsY; - curMsX := ev.button.x; - curMsY := ev.button.y; - mev.but := buildBut(ev.button.button); - mev.x := curMsX; - mev.y := curMsY; - mev.bstate := curButState; - mev.kstate := curModState; - if (mev.but <> 0) then - begin - // ev.button.clicks: Byte - if (ev.type_ = SDL_MOUSEBUTTONDOWN) then curButState := curButState or mev.but else curButState := curButState and (not mev.but); - if assigned(evMouseCB) then - begin - evMouseCB(mev); - result := mev.eaten; - end; - end; - end; - SDL_MOUSEWHEEL: - begin - if (ev.wheel.y <> 0) then - begin - FillChar(mev, sizeof(mev), 0); - mev.intrInit(); - mev.kind := THMouseEvent.TKind.Press; - mev.dx := 0; - mev.dy := ev.wheel.y; - if (ev.wheel.y < 0) then mev.but := THMouseEvent.WheelUp else mev.but := THMouseEvent.WheelDown; - mev.x := curMsX; - mev.y := curMsY; - mev.bstate := curButState; - mev.kstate := curModState; - if assigned(evMouseCB) then - begin - evMouseCB(mev); - result := mev.eaten; - end; - end; - end; - SDL_MOUSEMOTION: - begin - FillChar(mev, sizeof(mev), 0); - mev.intrInit(); - mev.kind := THMouseEvent.TKind.Motion; - mev.dx := ev.button.x-curMsX; - mev.dy := ev.button.y-curMsY; - curMsX := ev.button.x; - curMsY := ev.button.y; - mev.but := 0; - mev.x := curMsX; - mev.y := curMsY; - mev.bstate := curButState; - mev.kstate := curModState; - if assigned(evMouseCB) then - begin - evMouseCB(mev); - result := mev.eaten; - end; - end; - - { - SDL_TEXTINPUT: - begin - Utf8ToUnicode(@uc, PChar(ev.text.text), 1); - keychr := Word(uc); - if (keychr > 127) then keychr := Word(wchar2win(WideChar(keychr))); - CharPress(AnsiChar(keychr)); - end; - } - end; -end; - - -// ////////////////////////////////////////////////////////////////////////// // -procedure oglSetup2D (winWidth, winHeight: Integer; upsideDown: Boolean=false); -begin - glViewport(0, 0, winWidth, winHeight); - - glDisable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glDisable(GL_LINE_SMOOTH); - glDisable(GL_POINT_SMOOTH); - glDisable(GL_DEPTH_TEST); - glDisable(GL_TEXTURE_2D); - glDisable(GL_LIGHTING); - glDisable(GL_DITHER); - glDisable(GL_STENCIL_TEST); - glDisable(GL_SCISSOR_TEST); - glDisable(GL_CULL_FACE); - - glMatrixMode(GL_PROJECTION); - glLoadIdentity(); - if (upsideDown) then - begin - glOrtho(0, winWidth, 0, winHeight, -1, 1); // set origin to bottom left - end - else - begin - glOrtho(0, winWidth, winHeight, 0, -1, 1); // set origin to top left - end; - - glMatrixMode(GL_MODELVIEW); - glLoadIdentity(); - - glClearColor(0, 0, 0, 0); - glColor4f(1, 1, 1, 1); -end; - - -// ////////////////////////////////////////////////////////////////////////// // -// cursor (hi, Death Track!) -const curTexWidth = 32; -const curTexHeight = 32; -const curWidth = 17; -const curHeight = 23; - -const cursorImg: array[0..curWidth*curHeight-1] of Byte = ( - 2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 3,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 3,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 3,3,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0, - 3,3,4,2,2,0,0,0,0,0,0,0,0,0,0,0,0, - 3,3,4,4,2,2,0,0,0,0,0,0,0,0,0,0,0, - 3,3,4,4,4,2,2,0,0,0,0,0,0,0,0,0,0, - 3,3,4,4,4,4,2,2,0,0,0,0,0,0,0,0,0, - 3,3,4,4,4,5,6,2,2,0,0,0,0,0,0,0,0, - 3,3,4,4,5,6,7,5,2,2,0,0,0,0,0,0,0, - 3,3,4,5,6,7,5,4,5,2,2,0,0,0,0,0,0, - 3,3,5,6,7,5,4,5,6,7,2,2,0,0,0,0,0, - 3,3,6,7,5,4,5,6,7,7,7,2,2,0,0,0,0, - 3,3,7,5,4,5,6,7,7,7,7,7,2,2,0,0,0, - 3,3,5,4,5,6,8,8,8,8,8,8,8,8,2,0,0, - 3,3,4,5,6,3,8,8,8,8,8,8,8,8,8,0,0, - 3,3,5,6,3,3,0,0,0,0,0,0,0,0,0,0,0, - 3,3,6,3,3,0,0,0,0,0,0,0,0,0,0,0,0, - 3,3,3,3,0,0,0,0,0,0,0,0,0,0,0,0,0, - 3,3,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 3,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 -); -const cursorPal: array[0..9*4-1] of Byte = ( - 0, 0, 0, 0, - 0, 0, 0,163, - 85,255,255,255, - 85, 85,255,255, - 255, 85, 85,255, - 170, 0,170,255, - 85, 85, 85,255, - 0, 0, 0,255, - 0, 0,170,255 -); - - -var - curtexid: GLuint = 0; - -procedure createCursorTexture (); -var - tex, tpp: PByte; - c: Integer; - x, y: Integer; -begin - if (curtexid <> 0) then exit; //begin glDeleteTextures(1, @curtexid); curtexid := 0; end; - - GetMem(tex, curTexWidth*curTexHeight*4); - try - FillChar(tex^, curTexWidth*curTexHeight*4, 0); - - // draw shadow - for y := 0 to curHeight-1 do - begin - for x := 0 to curWidth-1 do - begin - if (cursorImg[y*curWidth+x] <> 0) then - begin - c := 1*4; - tpp := tex+((y+1)*(curTexWidth*4)+(x+3)*4); - tpp^ := cursorPal[c+0]; Inc(tpp); - tpp^ := cursorPal[c+1]; Inc(tpp); - tpp^ := cursorPal[c+2]; Inc(tpp); - tpp^ := cursorPal[c+3]; Inc(tpp); - tpp^ := cursorPal[c+0]; Inc(tpp); - tpp^ := cursorPal[c+1]; Inc(tpp); - tpp^ := cursorPal[c+2]; Inc(tpp); - tpp^ := cursorPal[c+3]; Inc(tpp); - end; - end; - end; - - // draw cursor - for y := 0 to curHeight-1 do - begin - for x := 0 to curWidth-1 do - begin - c := cursorImg[y*curWidth+x]*4; - if (c <> 0) then - begin - tpp := tex+(y*(curTexWidth*4)+x*4); - tpp^ := cursorPal[c+0]; Inc(tpp); - tpp^ := cursorPal[c+1]; Inc(tpp); - tpp^ := cursorPal[c+2]; Inc(tpp); - tpp^ := cursorPal[c+3]; Inc(tpp); - end; - end; - end; - - glGenTextures(1, @curtexid); - if (curtexid = 0) then raise Exception.Create('can''t create cursor texture'); - - glBindTexture(GL_TEXTURE_2D, curtexid); - glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT); - glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST); - - //GLfloat[4] bclr = 0.0; - //glTexParameterfv(GL_TEXTURE_2D, GL_TEXTURE_BORDER_COLOR, bclr.ptr); - - glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, curTexWidth, curTexHeight, 0, GL_RGBA{gltt}, GL_UNSIGNED_BYTE, tex); - glFlush(); - finally - FreeMem(tex); - end; -end; - -procedure oglDrawCursorAt (msX, msY: Integer); -begin - //if (curtexid = 0) then createCursorTexture() else glBindTexture(GL_TEXTURE_2D, curtexid); - glBindTexture(GL_TEXTURE_2D, curtexid); - // blend it - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_TEXTURE_2D); - glDisable(GL_STENCIL_TEST); - glDisable(GL_SCISSOR_TEST); - glDisable(GL_LIGHTING); - glDisable(GL_DEPTH_TEST); - glDisable(GL_CULL_FACE); - // color and opacity - glColor4f(1, 1, 1, 0.9); - //Dec(msX, 2); - glBegin(GL_QUADS); - glTexCoord2f(0.0, 0.0); glVertex2i(msX, msY); // top-left - glTexCoord2f(1.0, 0.0); glVertex2i(msX+curTexWidth, msY); // top-right - glTexCoord2f(1.0, 1.0); glVertex2i(msX+curTexWidth, msY+curTexHeight); // bottom-right - glTexCoord2f(0.0, 1.0); glVertex2i(msX, msY+curTexHeight); // bottom-left - glEnd(); - //Inc(msX, 2); - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); - glColor4f(1, 1, 1, 1); - glBindTexture(GL_TEXTURE_2D, 0); -end; - -procedure oglDrawCursor (); begin oglDrawCursorAt(curMsX, curMsY); end; - - -// ////////////////////////////////////////////////////////////////////////// // -// fonts -const kgiFont6: array[0..256*8-1] of Byte = ( -$00,$00,$00,$00,$00,$00,$00,$00,$3c,$42,$a5,$81,$a5,$99,$42,$3c,$3c,$7e,$db,$ff,$ff,$db,$66,$3c,$6c,$fe, -$fe,$fe,$7c,$38,$10,$00,$10,$38,$7c,$fe,$7c,$38,$10,$00,$10,$38,$54,$fe,$54,$10,$38,$00,$10,$38,$7c,$fe, -$fe,$10,$38,$00,$00,$00,$00,$30,$30,$00,$00,$00,$ff,$ff,$ff,$e7,$e7,$ff,$ff,$ff,$38,$44,$82,$82,$82,$44, -$38,$00,$c7,$bb,$7d,$7d,$7d,$bb,$c7,$ff,$0f,$03,$05,$79,$88,$88,$88,$70,$38,$44,$44,$44,$38,$10,$7c,$10, -$30,$28,$24,$24,$28,$20,$e0,$c0,$3c,$24,$3c,$24,$24,$e4,$dc,$18,$10,$54,$38,$ee,$38,$54,$10,$00,$10,$10, -$10,$7c,$10,$10,$10,$10,$10,$10,$10,$ff,$00,$00,$00,$00,$00,$00,$00,$ff,$10,$10,$10,$10,$10,$10,$10,$f0, -$10,$10,$10,$10,$10,$10,$10,$1f,$10,$10,$10,$10,$10,$10,$10,$ff,$10,$10,$10,$10,$10,$10,$10,$10,$10,$10, -$10,$10,$00,$00,$00,$ff,$00,$00,$00,$00,$00,$00,$00,$1f,$10,$10,$10,$10,$00,$00,$00,$f0,$10,$10,$10,$10, -$10,$10,$10,$1f,$00,$00,$00,$00,$10,$10,$10,$f0,$00,$00,$00,$00,$81,$42,$24,$18,$18,$24,$42,$81,$01,$02, -$04,$08,$10,$20,$40,$80,$80,$40,$20,$10,$08,$04,$02,$01,$00,$10,$10,$ff,$10,$10,$00,$00,$00,$00,$00,$00, -$00,$00,$00,$00,$20,$20,$20,$20,$00,$00,$20,$00,$50,$50,$50,$00,$00,$00,$00,$00,$50,$50,$f8,$50,$f8,$50, -$50,$00,$20,$78,$a0,$70,$28,$f0,$20,$00,$c0,$c8,$10,$20,$40,$98,$18,$00,$40,$a0,$40,$a8,$90,$98,$60,$00, -$10,$20,$40,$00,$00,$00,$00,$00,$10,$20,$40,$40,$40,$20,$10,$00,$40,$20,$10,$10,$10,$20,$40,$00,$88,$50, -$20,$f8,$20,$50,$88,$00,$00,$20,$20,$f8,$20,$20,$00,$00,$00,$00,$00,$00,$00,$20,$20,$40,$00,$00,$00,$78, -$00,$00,$00,$00,$00,$00,$00,$00,$00,$60,$60,$00,$00,$00,$08,$10,$20,$40,$80,$00,$70,$88,$98,$a8,$c8,$88, -$70,$00,$20,$60,$a0,$20,$20,$20,$f8,$00,$70,$88,$08,$10,$60,$80,$f8,$00,$70,$88,$08,$30,$08,$88,$70,$00, -$10,$30,$50,$90,$f8,$10,$10,$00,$f8,$80,$e0,$10,$08,$10,$e0,$00,$30,$40,$80,$f0,$88,$88,$70,$00,$f8,$88, -$10,$20,$20,$20,$20,$00,$70,$88,$88,$70,$88,$88,$70,$00,$70,$88,$88,$78,$08,$10,$60,$00,$00,$00,$20,$00, -$00,$20,$00,$00,$00,$00,$20,$00,$00,$20,$20,$40,$18,$30,$60,$c0,$60,$30,$18,$00,$00,$00,$f8,$00,$f8,$00, -$00,$00,$c0,$60,$30,$18,$30,$60,$c0,$00,$70,$88,$08,$10,$20,$00,$20,$00,$70,$88,$08,$68,$a8,$a8,$70,$00, -$20,$50,$88,$88,$f8,$88,$88,$00,$f0,$48,$48,$70,$48,$48,$f0,$00,$30,$48,$80,$80,$80,$48,$30,$00,$e0,$50, -$48,$48,$48,$50,$e0,$00,$f8,$80,$80,$f0,$80,$80,$f8,$00,$f8,$80,$80,$f0,$80,$80,$80,$00,$70,$88,$80,$b8, -$88,$88,$70,$00,$88,$88,$88,$f8,$88,$88,$88,$00,$70,$20,$20,$20,$20,$20,$70,$00,$38,$10,$10,$10,$90,$90, -$60,$00,$88,$90,$a0,$c0,$a0,$90,$88,$00,$80,$80,$80,$80,$80,$80,$f8,$00,$88,$d8,$a8,$a8,$88,$88,$88,$00, -$88,$c8,$c8,$a8,$98,$98,$88,$00,$70,$88,$88,$88,$88,$88,$70,$00,$f0,$88,$88,$f0,$80,$80,$80,$00,$70,$88, -$88,$88,$a8,$90,$68,$00,$f0,$88,$88,$f0,$a0,$90,$88,$00,$70,$88,$80,$70,$08,$88,$70,$00,$f8,$20,$20,$20, -$20,$20,$20,$00,$88,$88,$88,$88,$88,$88,$70,$00,$88,$88,$88,$88,$50,$50,$20,$00,$88,$88,$88,$a8,$a8,$d8, -$88,$00,$88,$88,$50,$20,$50,$88,$88,$00,$88,$88,$88,$70,$20,$20,$20,$00,$f8,$08,$10,$20,$40,$80,$f8,$00, -$70,$40,$40,$40,$40,$40,$70,$00,$00,$00,$80,$40,$20,$10,$08,$00,$70,$10,$10,$10,$10,$10,$70,$00,$20,$50, -$88,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$f8,$00,$40,$20,$10,$00,$00,$00,$00,$00,$00,$00,$70,$08, -$78,$88,$78,$00,$80,$80,$b0,$c8,$88,$c8,$b0,$00,$00,$00,$70,$88,$80,$88,$70,$00,$08,$08,$68,$98,$88,$98, -$68,$00,$00,$00,$70,$88,$f8,$80,$70,$00,$10,$28,$20,$f8,$20,$20,$20,$00,$00,$00,$68,$98,$98,$68,$08,$70, -$80,$80,$f0,$88,$88,$88,$88,$00,$20,$00,$60,$20,$20,$20,$70,$00,$10,$00,$30,$10,$10,$10,$90,$60,$40,$40, -$48,$50,$60,$50,$48,$00,$60,$20,$20,$20,$20,$20,$70,$00,$00,$00,$d0,$a8,$a8,$a8,$a8,$00,$00,$00,$b0,$c8, -$88,$88,$88,$00,$00,$00,$70,$88,$88,$88,$70,$00,$00,$00,$b0,$c8,$c8,$b0,$80,$80,$00,$00,$68,$98,$98,$68, -$08,$08,$00,$00,$b0,$c8,$80,$80,$80,$00,$00,$00,$78,$80,$f0,$08,$f0,$00,$40,$40,$f0,$40,$40,$48,$30,$00, -$00,$00,$90,$90,$90,$90,$68,$00,$00,$00,$88,$88,$88,$50,$20,$00,$00,$00,$88,$a8,$a8,$a8,$50,$00,$00,$00, -$88,$50,$20,$50,$88,$00,$00,$00,$88,$88,$98,$68,$08,$70,$00,$00,$f8,$10,$20,$40,$f8,$00,$18,$20,$20,$40, -$20,$20,$18,$00,$20,$20,$20,$00,$20,$20,$20,$00,$c0,$20,$20,$10,$20,$20,$c0,$00,$40,$a8,$10,$00,$00,$00, -$00,$00,$00,$00,$20,$50,$f8,$00,$00,$00,$00,$00,$00,$00,$00,$00,$ff,$ff,$f0,$f0,$f0,$f0,$0f,$0f,$0f,$0f, -$00,$00,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$00,$00,$00,$00,$00,$00,$00,$00,$00,$3c,$3c,$00,$00,$00,$ff,$ff, -$ff,$ff,$ff,$ff,$00,$00,$c0,$c0,$c0,$c0,$c0,$c0,$c0,$c0,$0f,$0f,$0f,$0f,$f0,$f0,$f0,$f0,$fc,$fc,$fc,$fc, -$fc,$fc,$fc,$fc,$03,$03,$03,$03,$03,$03,$03,$03,$3f,$3f,$3f,$3f,$3f,$3f,$3f,$3f,$11,$22,$44,$88,$11,$22, -$44,$88,$88,$44,$22,$11,$88,$44,$22,$11,$fe,$7c,$38,$10,$00,$00,$00,$00,$00,$00,$00,$00,$10,$38,$7c,$fe, -$80,$c0,$e0,$f0,$e0,$c0,$80,$00,$01,$03,$07,$0f,$07,$03,$01,$00,$ff,$7e,$3c,$18,$18,$3c,$7e,$ff,$81,$c3, -$e7,$ff,$ff,$e7,$c3,$81,$f0,$f0,$f0,$f0,$00,$00,$00,$00,$00,$00,$00,$00,$0f,$0f,$0f,$0f,$0f,$0f,$0f,$0f, -$00,$00,$00,$00,$00,$00,$00,$00,$f0,$f0,$f0,$f0,$33,$33,$cc,$cc,$33,$33,$cc,$cc,$00,$20,$20,$50,$50,$88, -$f8,$00,$20,$20,$70,$20,$70,$20,$20,$00,$00,$00,$00,$50,$88,$a8,$50,$00,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff, -$00,$00,$00,$00,$ff,$ff,$ff,$ff,$f0,$f0,$f0,$f0,$f0,$f0,$f0,$f0,$0f,$0f,$0f,$0f,$0f,$0f,$0f,$0f,$ff,$ff, -$ff,$ff,$00,$00,$00,$00,$00,$00,$68,$90,$90,$90,$68,$00,$30,$48,$48,$70,$48,$48,$70,$c0,$f8,$88,$80,$80, -$80,$80,$80,$00,$00,$50,$70,$88,$f8,$80,$70,$00,$00,$00,$78,$80,$f0,$80,$78,$00,$00,$00,$78,$90,$90,$90, -$60,$00,$20,$00,$60,$20,$20,$20,$70,$00,$50,$00,$70,$20,$20,$20,$70,$00,$f8,$20,$70,$a8,$a8,$70,$20,$f8, -$20,$50,$88,$f8,$88,$50,$20,$00,$70,$88,$88,$88,$50,$50,$d8,$00,$30,$40,$40,$20,$50,$50,$50,$20,$00,$00, -$00,$50,$a8,$a8,$50,$00,$08,$70,$a8,$a8,$a8,$70,$80,$00,$38,$40,$80,$f8,$80,$40,$38,$00,$70,$88,$88,$88, -$88,$88,$88,$00,$00,$f8,$00,$f8,$00,$f8,$00,$00,$20,$20,$f8,$20,$20,$00,$f8,$00,$c0,$30,$08,$30,$c0,$00, -$f8,$00,$50,$f8,$80,$f0,$80,$80,$f8,$00,$78,$80,$80,$f0,$80,$80,$78,$00,$20,$20,$20,$20,$20,$20,$a0,$40, -$70,$20,$20,$20,$20,$20,$70,$00,$50,$70,$20,$20,$20,$20,$70,$00,$00,$18,$24,$24,$18,$00,$00,$00,$00,$30, -$78,$78,$30,$00,$00,$00,$00,$00,$00,$00,$30,$00,$00,$00,$3e,$20,$20,$20,$a0,$60,$20,$00,$a0,$50,$50,$50, -$00,$00,$00,$00,$40,$a0,$20,$40,$e0,$00,$00,$00,$00,$38,$38,$38,$38,$38,$38,$00,$3c,$42,$99,$a1,$a1,$99, -$42,$3c,$00,$00,$90,$a8,$e8,$a8,$90,$00,$00,$00,$60,$10,$70,$90,$68,$00,$00,$00,$f0,$80,$f0,$88,$f0,$00, -$00,$00,$90,$90,$90,$f8,$08,$00,$00,$00,$30,$50,$50,$70,$88,$00,$00,$00,$70,$88,$f8,$80,$70,$00,$00,$20, -$70,$a8,$a8,$70,$20,$00,$00,$00,$78,$48,$40,$40,$40,$00,$00,$00,$88,$50,$20,$50,$88,$00,$00,$00,$88,$98, -$a8,$c8,$88,$00,$00,$50,$20,$00,$98,$a8,$c8,$00,$00,$00,$90,$a0,$c0,$a0,$90,$00,$00,$00,$38,$28,$28,$48, -$88,$00,$00,$00,$88,$d8,$a8,$88,$88,$00,$00,$00,$88,$88,$f8,$88,$88,$00,$00,$00,$70,$88,$88,$88,$70,$00, -$00,$00,$78,$48,$48,$48,$48,$00,$00,$00,$78,$88,$78,$28,$48,$00,$00,$00,$f0,$88,$f0,$80,$80,$00,$00,$00, -$78,$80,$80,$80,$78,$00,$00,$00,$f8,$20,$20,$20,$20,$00,$00,$00,$88,$50,$20,$40,$80,$00,$00,$00,$a8,$70, -$20,$70,$a8,$00,$00,$00,$f0,$48,$70,$48,$f0,$00,$00,$00,$40,$40,$70,$48,$70,$00,$00,$00,$88,$88,$c8,$a8, -$c8,$00,$00,$00,$f0,$08,$70,$08,$f0,$00,$00,$00,$a8,$a8,$a8,$a8,$f8,$00,$00,$00,$70,$88,$38,$88,$70,$00, -$00,$00,$a8,$a8,$a8,$f8,$08,$00,$00,$00,$48,$48,$78,$08,$08,$00,$00,$00,$c0,$40,$70,$48,$70,$00,$90,$a8, -$a8,$e8,$a8,$a8,$90,$00,$20,$50,$88,$88,$f8,$88,$88,$00,$f8,$88,$80,$f0,$88,$88,$f0,$00,$90,$90,$90,$90, -$90,$f8,$08,$00,$38,$28,$28,$48,$48,$f8,$88,$00,$f8,$80,$80,$f0,$80,$80,$f8,$00,$20,$70,$a8,$a8,$a8,$70, -$20,$00,$f8,$88,$88,$80,$80,$80,$80,$00,$88,$88,$50,$20,$50,$88,$88,$00,$88,$88,$98,$a8,$c8,$88,$88,$00, -$50,$20,$88,$98,$a8,$c8,$88,$00,$88,$90,$a0,$c0,$a0,$90,$88,$00,$18,$28,$48,$48,$48,$48,$88,$00,$88,$d8, -$a8,$a8,$88,$88,$88,$00,$88,$88,$88,$f8,$88,$88,$88,$00,$70,$88,$88,$88,$88,$88,$70,$00,$f8,$88,$88,$88, -$88,$88,$88,$00,$78,$88,$88,$78,$28,$48,$88,$00,$f0,$88,$88,$f0,$80,$80,$80,$00,$70,$88,$80,$80,$80,$88, -$70,$00,$f8,$20,$20,$20,$20,$20,$20,$00,$88,$88,$88,$50,$20,$40,$80,$00,$a8,$a8,$70,$20,$70,$a8,$a8,$00, -$f0,$48,$48,$70,$48,$48,$f0,$00,$80,$80,$80,$f0,$88,$88,$f0,$00,$88,$88,$88,$c8,$a8,$a8,$c8,$00,$f0,$08, -$08,$30,$08,$08,$f0,$00,$a8,$a8,$a8,$a8,$a8,$a8,$f8,$00,$70,$88,$08,$78,$08,$88,$70,$00,$a8,$a8,$a8,$a8, -$a8,$f8,$08,$00,$88,$88,$88,$88,$78,$08,$08,$00,$c0,$40,$40,$70,$48,$48,$70,$00 -); - -const kgiFont8: array[0..256*8-1] of Byte = ( -$00,$00,$00,$00,$00,$00,$00,$00,$7e,$81,$a5,$81,$bd,$99,$81,$7e,$7e,$ff,$db,$ff,$c3,$e7,$ff,$7e,$6c,$fe, -$fe,$fe,$7c,$38,$10,$00,$10,$38,$7c,$fe,$7c,$38,$10,$00,$38,$7c,$38,$fe,$fe,$d6,$10,$38,$10,$10,$38,$7c, -$fe,$7c,$10,$38,$00,$00,$18,$3c,$3c,$18,$00,$00,$ff,$ff,$e7,$c3,$c3,$e7,$ff,$ff,$00,$3c,$66,$42,$42,$66, -$3c,$00,$ff,$c3,$99,$bd,$bd,$99,$c3,$ff,$0f,$07,$0f,$7d,$cc,$cc,$cc,$78,$3c,$66,$66,$66,$3c,$18,$7e,$18, -$3f,$33,$3f,$30,$30,$70,$f0,$e0,$7f,$63,$7f,$63,$63,$67,$e6,$c0,$99,$5a,$3c,$e7,$e7,$3c,$5a,$99,$80,$e0, -$f8,$fe,$f8,$e0,$80,$00,$02,$0e,$3e,$fe,$3e,$0e,$02,$00,$18,$3c,$7e,$18,$18,$7e,$3c,$18,$66,$66,$66,$66, -$66,$00,$66,$00,$7f,$db,$db,$7b,$1b,$1b,$1b,$00,$7e,$c3,$78,$cc,$cc,$78,$8c,$f8,$00,$00,$00,$00,$7e,$7e, -$7e,$00,$18,$3c,$7e,$18,$7e,$3c,$18,$ff,$18,$3c,$7e,$18,$18,$18,$18,$00,$18,$18,$18,$18,$7e,$3c,$18,$00, -$00,$18,$0c,$fe,$0c,$18,$00,$00,$00,$30,$60,$fe,$60,$30,$00,$00,$00,$00,$c0,$c0,$c0,$fe,$00,$00,$00,$24, -$66,$ff,$66,$24,$00,$00,$00,$18,$3c,$7e,$ff,$ff,$00,$00,$00,$ff,$ff,$7e,$3c,$18,$00,$00,$00,$00,$00,$00, -$00,$00,$00,$00,$30,$78,$78,$30,$30,$00,$30,$00,$6c,$6c,$6c,$00,$00,$00,$00,$00,$6c,$6c,$fe,$6c,$fe,$6c, -$6c,$00,$30,$7c,$c0,$78,$0c,$f8,$30,$00,$00,$c6,$cc,$18,$30,$66,$c6,$00,$38,$6c,$38,$76,$dc,$cc,$76,$00, -$60,$60,$c0,$00,$00,$00,$00,$00,$18,$30,$60,$60,$60,$30,$18,$00,$60,$30,$18,$18,$18,$30,$60,$00,$00,$66, -$3c,$ff,$3c,$66,$00,$00,$00,$30,$30,$fc,$30,$30,$00,$00,$00,$00,$00,$00,$00,$70,$30,$60,$00,$00,$00,$fc, -$00,$00,$00,$00,$00,$00,$00,$00,$00,$30,$30,$00,$06,$0c,$18,$30,$60,$c0,$80,$00,$78,$cc,$dc,$fc,$ec,$cc, -$78,$00,$30,$f0,$30,$30,$30,$30,$fc,$00,$78,$cc,$0c,$38,$60,$cc,$fc,$00,$78,$cc,$0c,$38,$0c,$cc,$78,$00, -$1c,$3c,$6c,$cc,$fe,$0c,$0c,$00,$fc,$c0,$f8,$0c,$0c,$cc,$78,$00,$38,$60,$c0,$f8,$cc,$cc,$78,$00,$fc,$cc, -$0c,$18,$30,$60,$60,$00,$78,$cc,$cc,$78,$cc,$cc,$78,$00,$78,$cc,$cc,$7c,$0c,$18,$70,$00,$00,$00,$30,$30, -$00,$30,$30,$00,$00,$00,$30,$30,$00,$70,$30,$60,$18,$30,$60,$c0,$60,$30,$18,$00,$00,$00,$fc,$00,$fc,$00, -$00,$00,$60,$30,$18,$0c,$18,$30,$60,$00,$78,$cc,$0c,$18,$30,$00,$30,$00,$7c,$c6,$de,$de,$de,$c0,$78,$00, -$30,$78,$cc,$cc,$fc,$cc,$cc,$00,$fc,$66,$66,$7c,$66,$66,$fc,$00,$3c,$66,$c0,$c0,$c0,$66,$3c,$00,$fc,$6c, -$66,$66,$66,$6c,$fc,$00,$fe,$62,$68,$78,$68,$62,$fe,$00,$fe,$62,$68,$78,$68,$60,$f0,$00,$3c,$66,$c0,$c0, -$ce,$66,$3e,$00,$cc,$cc,$cc,$fc,$cc,$cc,$cc,$00,$78,$30,$30,$30,$30,$30,$78,$00,$1e,$0c,$0c,$0c,$cc,$cc, -$78,$00,$e6,$66,$6c,$78,$6c,$66,$e6,$00,$f0,$60,$60,$60,$62,$66,$fe,$00,$c6,$ee,$fe,$d6,$c6,$c6,$c6,$00, -$c6,$e6,$f6,$de,$ce,$c6,$c6,$00,$38,$6c,$c6,$c6,$c6,$6c,$38,$00,$fc,$66,$66,$7c,$60,$60,$f0,$00,$78,$cc, -$cc,$cc,$dc,$78,$1c,$00,$fc,$66,$66,$7c,$78,$6c,$e6,$00,$78,$cc,$e0,$38,$1c,$cc,$78,$00,$fc,$b4,$30,$30, -$30,$30,$78,$00,$cc,$cc,$cc,$cc,$cc,$cc,$fc,$00,$cc,$cc,$cc,$cc,$cc,$78,$30,$00,$c6,$c6,$c6,$d6,$fe,$ee, -$c6,$00,$c6,$c6,$6c,$38,$6c,$c6,$c6,$00,$cc,$cc,$cc,$78,$30,$30,$78,$00,$fe,$cc,$98,$30,$62,$c6,$fe,$00, -$78,$60,$60,$60,$60,$60,$78,$00,$c0,$60,$30,$18,$0c,$06,$02,$00,$78,$18,$18,$18,$18,$18,$78,$00,$10,$38, -$6c,$c6,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$ff,$30,$30,$18,$00,$00,$00,$00,$00,$00,$00,$78,$0c, -$7c,$cc,$76,$00,$e0,$60,$7c,$66,$66,$66,$bc,$00,$00,$00,$78,$cc,$c0,$cc,$78,$00,$1c,$0c,$0c,$7c,$cc,$cc, -$76,$00,$00,$00,$78,$cc,$fc,$c0,$78,$00,$38,$6c,$60,$f0,$60,$60,$f0,$00,$00,$00,$76,$cc,$cc,$7c,$0c,$f8, -$e0,$60,$6c,$76,$66,$66,$e6,$00,$30,$00,$70,$30,$30,$30,$78,$00,$18,$00,$78,$18,$18,$18,$d8,$70,$e0,$60, -$66,$6c,$78,$6c,$e6,$00,$70,$30,$30,$30,$30,$30,$78,$00,$00,$00,$ec,$fe,$d6,$c6,$c6,$00,$00,$00,$f8,$cc, -$cc,$cc,$cc,$00,$00,$00,$78,$cc,$cc,$cc,$78,$00,$00,$00,$dc,$66,$66,$7c,$60,$f0,$00,$00,$76,$cc,$cc,$7c, -$0c,$1e,$00,$00,$d8,$6c,$6c,$60,$f0,$00,$00,$00,$7c,$c0,$78,$0c,$f8,$00,$10,$30,$7c,$30,$30,$34,$18,$00, -$00,$00,$cc,$cc,$cc,$cc,$76,$00,$00,$00,$cc,$cc,$cc,$78,$30,$00,$00,$00,$c6,$c6,$d6,$fe,$6c,$00,$00,$00, -$c6,$6c,$38,$6c,$c6,$00,$00,$00,$cc,$cc,$cc,$7c,$0c,$f8,$00,$00,$fc,$98,$30,$64,$fc,$00,$1c,$30,$30,$e0, -$30,$30,$1c,$00,$18,$18,$18,$00,$18,$18,$18,$00,$e0,$30,$30,$1c,$30,$30,$e0,$00,$76,$dc,$00,$00,$00,$00, -$00,$00,$10,$38,$6c,$c6,$c6,$c6,$fe,$00,$78,$cc,$c0,$cc,$78,$18,$0c,$78,$00,$cc,$00,$cc,$cc,$cc,$7e,$00, -$1c,$00,$78,$cc,$fc,$c0,$78,$00,$7e,$c3,$3c,$06,$3e,$66,$3f,$00,$cc,$00,$78,$0c,$7c,$cc,$7e,$00,$e0,$00, -$78,$0c,$7c,$cc,$7e,$00,$30,$30,$78,$0c,$7c,$cc,$7e,$00,$00,$00,$7c,$c0,$c0,$7c,$06,$3c,$7e,$c3,$3c,$66, -$7e,$60,$3c,$00,$cc,$00,$78,$cc,$fc,$c0,$78,$00,$e0,$00,$78,$cc,$fc,$c0,$78,$00,$cc,$00,$70,$30,$30,$30, -$78,$00,$7c,$c6,$38,$18,$18,$18,$3c,$00,$e0,$00,$70,$30,$30,$30,$78,$00,$cc,$30,$78,$cc,$cc,$fc,$cc,$00, -$30,$30,$00,$78,$cc,$fc,$cc,$00,$1c,$00,$fc,$60,$78,$60,$fc,$00,$00,$00,$7f,$0c,$7f,$cc,$7f,$00,$3e,$6c, -$cc,$fe,$cc,$cc,$ce,$00,$78,$cc,$00,$78,$cc,$cc,$78,$00,$00,$cc,$00,$78,$cc,$cc,$78,$00,$00,$e0,$00,$78, -$cc,$cc,$78,$00,$78,$cc,$00,$cc,$cc,$cc,$7e,$00,$00,$e0,$00,$cc,$cc,$cc,$7e,$00,$00,$cc,$00,$cc,$cc,$fc, -$0c,$f8,$c6,$38,$7c,$c6,$c6,$7c,$38,$00,$cc,$00,$cc,$cc,$cc,$cc,$78,$00,$18,$18,$7e,$c0,$c0,$7e,$18,$18, -$38,$6c,$64,$f0,$60,$e6,$fc,$00,$cc,$cc,$78,$fc,$30,$fc,$30,$00,$f0,$d8,$d8,$f4,$cc,$de,$cc,$0e,$0e,$1b, -$18,$7e,$18,$18,$d8,$70,$1c,$00,$78,$0c,$7c,$cc,$7e,$00,$38,$00,$70,$30,$30,$30,$78,$00,$00,$1c,$00,$78, -$cc,$cc,$78,$00,$00,$1c,$00,$cc,$cc,$cc,$7e,$00,$00,$f8,$00,$f8,$cc,$cc,$cc,$00,$fc,$00,$cc,$ec,$fc,$dc, -$cc,$00,$3c,$6c,$6c,$3e,$00,$7e,$00,$00,$3c,$66,$66,$3c,$00,$7e,$00,$00,$30,$00,$30,$60,$c0,$cc,$78,$00, -$00,$00,$00,$fc,$c0,$c0,$00,$00,$00,$00,$00,$fc,$0c,$0c,$00,$00,$c6,$cc,$d8,$3e,$63,$ce,$98,$1f,$c6,$cc, -$d8,$f3,$67,$cf,$9f,$03,$00,$18,$00,$18,$18,$3c,$3c,$18,$00,$33,$66,$cc,$66,$33,$00,$00,$00,$cc,$66,$33, -$66,$cc,$00,$00,$22,$88,$22,$88,$22,$88,$22,$88,$55,$aa,$55,$aa,$55,$aa,$55,$aa,$dc,$76,$dc,$76,$dc,$76, -$dc,$76,$18,$18,$18,$18,$18,$18,$18,$18,$18,$18,$18,$18,$f8,$18,$18,$18,$18,$18,$f8,$18,$f8,$18,$18,$18, -$36,$36,$36,$36,$f6,$36,$36,$36,$00,$00,$00,$00,$fe,$36,$36,$36,$00,$00,$f8,$18,$f8,$18,$18,$18,$36,$36, -$f6,$06,$f6,$36,$36,$36,$36,$36,$36,$36,$36,$36,$36,$36,$00,$00,$fe,$06,$f6,$36,$36,$36,$36,$36,$f6,$06, -$fe,$00,$00,$00,$36,$36,$36,$36,$fe,$00,$00,$00,$18,$18,$f8,$18,$f8,$00,$00,$00,$00,$00,$00,$00,$f8,$18, -$18,$18,$18,$18,$18,$18,$1f,$00,$00,$00,$18,$18,$18,$18,$ff,$00,$00,$00,$00,$00,$00,$00,$ff,$18,$18,$18, -$18,$18,$18,$18,$1f,$18,$18,$18,$00,$00,$00,$00,$ff,$00,$00,$00,$18,$18,$18,$18,$ff,$18,$18,$18,$18,$18, -$1f,$18,$1f,$18,$18,$18,$36,$36,$36,$36,$37,$36,$36,$36,$36,$36,$37,$30,$3f,$00,$00,$00,$00,$00,$3f,$30, -$37,$36,$36,$36,$36,$36,$f7,$00,$ff,$00,$00,$00,$00,$00,$ff,$00,$f7,$36,$36,$36,$36,$36,$37,$30,$37,$36, -$36,$36,$00,$00,$ff,$00,$ff,$00,$00,$00,$36,$36,$f7,$00,$f7,$36,$36,$36,$18,$18,$ff,$00,$ff,$00,$00,$00, -$36,$36,$36,$36,$ff,$00,$00,$00,$00,$00,$ff,$00,$ff,$18,$18,$18,$00,$00,$00,$00,$ff,$36,$36,$36,$36,$36, -$36,$36,$3f,$00,$00,$00,$18,$18,$1f,$18,$1f,$00,$00,$00,$00,$00,$1f,$18,$1f,$18,$18,$18,$00,$00,$00,$00, -$3f,$36,$36,$36,$36,$36,$36,$36,$f7,$36,$36,$36,$18,$18,$ff,$00,$ff,$18,$18,$18,$18,$18,$18,$18,$f8,$00, -$00,$00,$00,$00,$00,$00,$1f,$18,$18,$18,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$00,$00,$00,$00,$ff,$ff,$ff,$ff, -$f0,$f0,$f0,$f0,$f0,$f0,$f0,$f0,$0f,$0f,$0f,$0f,$0f,$0f,$0f,$0f,$ff,$ff,$ff,$ff,$00,$00,$00,$00,$00,$00, -$76,$dc,$c8,$dc,$76,$00,$00,$78,$cc,$f8,$cc,$f8,$c0,$c0,$00,$fe,$c6,$c0,$c0,$c0,$c0,$00,$00,$fe,$6c,$6c, -$6c,$6c,$6c,$00,$fe,$66,$30,$18,$30,$66,$fe,$00,$00,$00,$7e,$cc,$cc,$cc,$78,$00,$00,$66,$66,$66,$66,$7c, -$60,$c0,$00,$76,$dc,$18,$18,$18,$18,$00,$fc,$30,$78,$cc,$cc,$78,$30,$fc,$38,$6c,$c6,$fe,$c6,$6c,$38,$00, -$38,$6c,$c6,$c6,$6c,$6c,$ee,$00,$1c,$30,$18,$7c,$cc,$cc,$78,$00,$00,$00,$7e,$db,$db,$7e,$00,$00,$06,$0c, -$7e,$db,$db,$7e,$60,$c0,$3c,$60,$c0,$fc,$c0,$60,$3c,$00,$78,$cc,$cc,$cc,$cc,$cc,$cc,$00,$00,$fc,$00,$fc, -$00,$fc,$00,$00,$30,$30,$fc,$30,$30,$00,$fc,$00,$60,$30,$18,$30,$60,$00,$fc,$00,$18,$30,$60,$30,$18,$00, -$fc,$00,$0e,$1b,$1b,$18,$18,$18,$18,$18,$18,$18,$18,$18,$18,$d8,$d8,$70,$30,$30,$00,$fc,$00,$30,$30,$00, -$00,$72,$9c,$00,$72,$9c,$00,$00,$38,$6c,$6c,$38,$00,$00,$00,$00,$00,$00,$00,$18,$18,$00,$00,$00,$00,$00, -$00,$00,$18,$00,$00,$00,$0f,$0c,$0c,$0c,$ec,$6c,$3c,$1c,$78,$6c,$6c,$6c,$6c,$00,$00,$00,$78,$0c,$38,$60, -$7c,$00,$00,$00,$00,$00,$3c,$3c,$3c,$3c,$00,$00,$ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff -); - -const kgiFont6PropWidth: array[0..256-1] of Byte = ( - $08,$08,$08,$07,$07,$07,$07,$04,$08,$07,$08,$08,$06,$06,$06,$07, - $06,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08, - $85,$21,$13,$05,$05,$05,$05,$13,$13,$13,$05,$05,$12,$14,$12,$05, - $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$21,$12,$05,$05,$05,$05, - $05,$05,$05,$05,$05,$05,$05,$05,$05,$13,$05,$05,$05,$05,$05,$05, - $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$13,$05,$13,$05,$05, - $13,$05,$05,$05,$05,$05,$05,$05,$05,$13,$04,$14,$13,$05,$05,$05, - $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$14,$21,$04,$05,$08, - $08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$04, - $44,$08,$08,$08,$08,$08,$08,$08,$05,$04,$05,$08,$08,$08,$08,$08, - $05,$05,$05,$05,$05,$05,$13,$13,$05,$05,$05,$04,$05,$05,$05,$05, - $05,$05,$05,$05,$05,$03,$04,$04,$06,$05,$04,$07,$04,$03,$05,$08, - $05,$05,$05,$05,$05,$05,$05,$14,$05,$05,$05,$04,$05,$05,$05,$05, - $14,$05,$05,$05,$05,$05,$05,$05,$14,$05,$05,$05,$05,$05,$14,$05, - $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05, - $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05 -); - -const kgiFont8PropWidth: array[0..256-1] of Byte = ( - $08,$08,$08,$07,$07,$07,$07,$06,$08,$07,$08,$08,$07,$08,$08,$08, - $07,$07,$07,$07,$08,$08,$07,$08,$07,$07,$07,$07,$07,$08,$08,$08, - $85,$14,$15,$07,$06,$07,$07,$03,$14,$14,$08,$06,$13,$06,$22,$07, - $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$22,$13,$05,$06,$15,$06, - $07,$06,$07,$07,$07,$07,$07,$07,$06,$14,$07,$07,$07,$07,$07,$07, - $07,$06,$07,$06,$06,$06,$06,$07,$07,$06,$07,$14,$07,$14,$07,$08, - $23,$07,$07,$06,$07,$06,$06,$07,$07,$14,$05,$07,$14,$07,$06,$06, - $07,$07,$06,$06,$15,$07,$06,$07,$07,$06,$06,$06,$32,$06,$07,$07, - $06,$07,$06,$08,$07,$07,$07,$07,$08,$06,$06,$06,$07,$05,$06,$06, - $06,$08,$07,$06,$06,$06,$07,$07,$06,$07,$06,$07,$07,$06,$07,$08, - $07,$05,$06,$07,$06,$06,$16,$16,$06,$06,$06,$08,$08,$06,$08,$08, - $08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08, - $38,$08,$08,$38,$08,$08,$38,$28,$28,$28,$08,$08,$28,$08,$08,$08, - $08,$08,$08,$28,$38,$38,$28,$08,$08,$08,$38,$08,$08,$08,$48,$08, - $07,$06,$07,$07,$07,$07,$07,$07,$06,$07,$07,$06,$08,$08,$06,$06, - $06,$06,$06,$06,$35,$05,$06,$07,$15,$32,$32,$08,$15,$15,$24,$08 -); - - -function createFontTexture (constref font: array of Byte; constref fontwdt: array of Byte; prop: Boolean): GLuint; -const - Width = 16*8; - Height = 16*8; -var - tex, tpp: PByte; - b: Byte; - cc: Integer; - x, y, dx, dy: Integer; -begin - GetMem(tex, Width*Height*4); - - for cc := 0 to 255 do - begin - x := (cc mod 16)*8; - y := (cc div 16)*8; - for dy := 0 to 7 do - begin - b := font[cc*8+dy]; - if prop then b := b shl (fontwdt[cc] shr 4); - tpp := tex+((y+dy)*(Width*4))+x*4; - for dx := 0 to 7 do - begin - if ((b and $80) <> 0) then - begin - tpp^ := 255; Inc(tpp); - tpp^ := 255; Inc(tpp); - tpp^ := 255; Inc(tpp); - tpp^ := 255; Inc(tpp); - end - else - begin - tpp^ := 0; Inc(tpp); - tpp^ := 0; Inc(tpp); - tpp^ := 0; Inc(tpp); - tpp^ := 0; Inc(tpp); - end; - b := (b and $7f) shl 1; - end; - end; - end; - - glGenTextures(1, @result); - if (result = 0) then raise Exception.Create('can''t create Holmes font texture'); - - glBindTexture(GL_TEXTURE_2D, result); - glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT); - glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST); - - //GLfloat[4] bclr = 0.0; - //glTexParameterfv(GL_TEXTURE_2D, GL_TEXTURE_BORDER_COLOR, bclr.ptr); - - glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, Width, Height, 0, GL_RGBA{gltt}, GL_UNSIGNED_BYTE, tex); - glFlush(); - - //FreeMem(tex); -end; - - -var - font6texid: GLuint = 0; - font8texid: GLuint = 0; - prfont6texid: GLuint = 0; - prfont8texid: GLuint = 0; - - -procedure deleteFonts (); -begin - if (font6texid <> 0) then glDeleteTextures(1, @font6texid); - if (font8texid <> 0) then glDeleteTextures(1, @font8texid); - if (prfont6texid <> 0) then glDeleteTextures(1, @prfont6texid); - if (prfont8texid <> 0) then glDeleteTextures(1, @prfont8texid); - font6texid := 0; - font8texid := 0; - prfont6texid := 0; - prfont8texid := 0; -end; - - -procedure createFonts (); -begin - if (font6texid = 0) then font6texid := createFontTexture(kgiFont6, kgiFont6PropWidth, false); - if (font8texid = 0) then font8texid := createFontTexture(kgiFont8, kgiFont8PropWidth, false); - if (prfont6texid = 0) then prfont6texid := createFontTexture(kgiFont6, kgiFont6PropWidth, true); - if (prfont8texid = 0) then prfont8texid := createFontTexture(kgiFont8, kgiFont8PropWidth, true); -end; - - -// ////////////////////////////////////////////////////////////////////////// // -procedure TScissorSave.save (enableScissoring: Boolean); -begin - wassc := (glIsEnabled(GL_SCISSOR_TEST) <> 0); - if wassc then glGetIntegerv(GL_SCISSOR_BOX, @scxywh[0]) else glGetIntegerv(GL_VIEWPORT, @scxywh[0]); - //conwritefln('(%d,%d)-(%d,%d)', [scxywh[0], scxywh[1], scxywh[2], scxywh[3]]); - if enableScissoring and (not wassc) then glEnable(GL_SCISSOR_TEST); -end; - -procedure TScissorSave.restore (); -begin - glScissor(scxywh[0], scxywh[1], scxywh[2], scxywh[3]); - if wassc then glEnable(GL_SCISSOR_TEST) else glDisable(GL_SCISSOR_TEST); -end; - -procedure TScissorSave.combineRect (x, y, w, h: Integer); -//var ox, oy, ow, oh: Integer; -begin - if (w < 1) or (h < 1) then begin glScissor(0, 0, 0, 0); exit; end; - y := gScrHeight-(y+h); - //ox := x; oy := y; ow := w; oh := h; - if not intersectRect(x, y, w, h, scxywh[0], scxywh[1], scxywh[2], scxywh[3]) then - begin - //writeln('oops: COMBINE: old=(', ox, ',', oy, ')-(', ox+ow-1, ',', oy+oh-1, '); sci: (', scxywh[0], ',', scxywh[1], ')-(', scxywh[0]+scxywh[2]-1, ',', scxywh[1]+scxywh[3]-1, ')'); - //writeln('oops: COMBINE: oldx=<', ox, '-', ox+ow-1, '>; oldy=<', oy, ',', oy+oh-1, '> : scix=<', scxywh[0], '-', scxywh[0]+scxywh[2]-1, '>; sciy=<', scxywh[1], '-', scxywh[1]+scxywh[3]-1, '>'); - glScissor(0, 0, 0, 0); - end - else - begin - glScissor(x, y, w, h); - end; -end; - -//TODO: overflow checks -function intersectRect (var x0, y0, w0, h0: Integer; const x1, y1, w1, h1: Integer): Boolean; -var - ex0, ey0: Integer; - ex1, ey1: Integer; -begin - result := false; - if (w0 < 1) or (h0 < 1) or (w1 < 1) or (h1 < 1) then exit; // at least one rect is null - // check for intersection - ex0 := x0+w0; - ey0 := y0+h0; - ex1 := x1+w1; - ey1 := y1+h1; - if (ex0 <= x1) or (ey0 <= y1) or (ex1 <= x0) or (ey1 <= y0) then exit; - if (x0 >= ex1) or (y0 >= ey1) or (x1 >= ex0) or (y1 >= ey0) then exit; - // ok, intersects - if (x0 < x1) then x0 := x1; - if (y0 < y1) then y0 := y1; - if (ex0 > ex1) then ex0 := ex1; - if (ey0 > ey1) then ey0 := ey1; - w0 := ex0-x0; - h0 := ey0-y0; - result := (w0 > 0) and (h0 > 0); -end; - - -// ////////////////////////////////////////////////////////////////////////// // -procedure normRGBA (var r, g, b, a: Integer); inline; -begin - if (a < 0) then a := 0 else if (a > 255) then a := 255; - if (r < 0) then r := 0 else if (r > 255) then r := 255; - if (g < 0) then g := 0 else if (g > 255) then g := 255; - if (b < 0) then b := 0 else if (b > 255) then b := 255; -end; - -// returns `false` if the color is transparent -function setupGLColor (r, g, b, a: Integer): Boolean; -begin - normRGBA(r, g, b, a); - if (a < 255) then - begin - if (a = 0) then begin result := false; exit; end; - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - end - else - begin - glDisable(GL_BLEND); - end; - glColor4ub(Byte(r), Byte(g), Byte(b), Byte(a)); - result := true; -end; - -// returns `false` if the color is transparent -function setupGLColor (constref clr: TGxRGBA): Boolean; -begin - if (clr.a < 255) then - begin - if (clr.a = 0) then begin result := false; exit; end; - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - end - else - begin - glDisable(GL_BLEND); - end; - glColor4ub(clr.r, clr.g, clr.b, clr.a); - result := true; -end; - -function isScaled (): Boolean; -var - mt: packed array [0..15] of Double; -begin - glGetDoublev(GL_MODELVIEW_MATRIX, @mt[0]); - result := (mt[0] <> 1.0) or (mt[1*4+1] <> 1.0); -end; - - -// ////////////////////////////////////////////////////////////////////////// // -function textWidth6 (const s: AnsiString): Integer; -var - f: Integer; -begin - result := 0; - for f := 1 to Length(s) do Inc(result, Integer(kgiFont6PropWidth[Integer(s[f])] and $0f)+1); - if (result > 0) then Dec(result); // don't count last empty pixel -end; - - -function textWidth8 (const s: AnsiString): Integer; -var - f: Integer; -begin - result := 0; - for f := 1 to Length(s) do Inc(result, Integer(kgiFont8PropWidth[Integer(s[f])] and $0f)+1); - if (result > 0) then Dec(result); // don't count last empty pixel -end; - - -// return width (including last empty pixel) -function drawTextInternal (wdt, x, y: Integer; const s: AnsiString; constref clr: TGxRGBA; tid: GLuint; constref fontwdt: array of Byte; prop: Boolean): Integer; -var - f, c: Integer; - tx, ty: Integer; -begin - result := 0; - if (Length(s) = 0) then exit; - if not setupGLColor(clr) then exit; - - glEnable(GL_ALPHA_TEST); - glAlphaFunc(GL_NOTEQUAL, 0.0); - glEnable(GL_TEXTURE_2D); - glBindTexture(GL_TEXTURE_2D, tid); - - for f := 1 to Length(s) do - begin - c := Integer(s[f]) and $ff; - tx := (c mod 16)*8; - ty := (c div 16)*8; - glBegin(GL_QUADS); - glTexCoord2f((tx+0)/128.0, (ty+0)/128.0); glVertex2i(x+0, y+0); // top-left - glTexCoord2f((tx+8)/128.0, (ty+0)/128.0); glVertex2i(x+8, y+0); // top-right - glTexCoord2f((tx+8)/128.0, (ty+8)/128.0); glVertex2i(x+8, y+8); // bottom-right - glTexCoord2f((tx+0)/128.0, (ty+8)/128.0); glVertex2i(x+0, y+8); // bottom-left - glEnd(); - if prop then - begin - x += Integer(fontwdt[c] and $0f)+1; - result += Integer(fontwdt[c] and $0f)+1; - end - else - begin - x += wdt; - result += wdt; - end; - end; - - glDisable(GL_ALPHA_TEST); - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); - glColor4f(1, 1, 1, 1); - glBindTexture(GL_TEXTURE_2D, 0); -end; - - -// ////////////////////////////////////////////////////////////////////////// // -procedure drawHLine (x, y, len: Integer; constref clr: TGxRGBA); -begin - if (len < 1) then exit; - if not setupGLColor(clr) then exit; - glDisable(GL_TEXTURE_2D); - if (not isScaled) then - begin - glLineWidth(1); - glBegin(GL_LINES); - glVertex2f(x+0.375, y+0.375); - glVertex2f(x+len+0.375, y+0.375); - glEnd(); - end - else - begin - glBegin(GL_QUADS); - glVertex2i(x, y); - glVertex2i(x+len, y); - glVertex2i(x+len, y+1); - glVertex2i(x, y+1); - glEnd(); - end; -end; - - -procedure drawVLine (x, y, len: Integer; constref clr: TGxRGBA); -begin - if (len < 1) then exit; - if not setupGLColor(clr) then exit; - glDisable(GL_TEXTURE_2D); - if (not isScaled) then - begin - glLineWidth(1); - glBegin(GL_LINES); - glVertex2f(x+0.375, y+0.375); - glVertex2f(x+0.375, y+len+0.375); - glEnd(); - end - else - begin - glBegin(GL_QUADS); - glVertex2i(x, y); - glVertex2i(x, y+len); - glVertex2i(x+1, y+len); - glVertex2i(x+1, y); - glEnd(); - end; -end; - - -procedure drawLine (x1, y1, x2, y2: Integer; constref clr: TGxRGBA); -begin - if not setupGLColor(clr) then exit; - - glDisable(GL_TEXTURE_2D); - - glLineWidth(1); - glPointSize(1); - - if (not isScaled) then - begin - glLineWidth(1); - glBegin(GL_LINES); - glVertex2f(x1+0.375, y1+0.375); - glVertex2f(x2+0.375, y2+0.375); - glEnd(); - - if (x1 <> x2) or (y1 <> y2) then - begin - glBegin(GL_POINTS); - glVertex2f(x2+0.375, y2+0.375); - glEnd(); - end; - end - else - begin - glLineWidth(1); - glBegin(GL_LINES); - glVertex2i(x1, y1); - glVertex2i(x2, y2); - // draw last point - glVertex2i(x2, y2); - glVertex2i(x2+1, y2+1); - glEnd(); - end; - - glColor4f(1, 1, 1, 1); - glDisable(GL_BLEND); -end; - - -procedure drawRect (x, y, w, h: Integer; constref clr: TGxRGBA); -begin - if (w < 0) or (h < 0) then exit; - if not setupGLColor(clr) then exit; - glDisable(GL_TEXTURE_2D); - glLineWidth(1); - glDisable(GL_LINE_SMOOTH); - glDisable(GL_POLYGON_SMOOTH); - if (w = 1) and (h = 1) then - begin - glBegin(GL_POINTS); - glVertex2f(x+0.375, y+0.375); - glEnd(); - end - else - begin - glLineWidth(1); - glBegin(GL_LINES); - glVertex2i(x, y); glVertex2i(x+w, y); // top - glVertex2i(x, y+h-1); glVertex2i(x+w, y+h-1); // bottom - glVertex2f(x+0.375, y+1); glVertex2f(x+0.375, y+h-1); // left - glVertex2f(x+w-1+0.375, y+1); glVertex2f(x+w-1+0.375, y+h-1); // right - glEnd(); - end; - //glRect(x, y, x+w, y+h); - glColor4f(1, 1, 1, 1); - glDisable(GL_BLEND); -end; - - -procedure drawRectUI (x, y, w, h: Integer; constref clr: TGxRGBA); - procedure hline (x, y, len: Integer); - begin - if (len < 1) then exit; - glBegin(GL_QUADS); - glVertex2i(x, y); - glVertex2i(x+len, y); - glVertex2i(x+len, y+1); - glVertex2i(x, y+1); - glEnd(); - end; - - procedure vline (x, y, len: Integer); - begin - if (len < 1) then exit; - glBegin(GL_QUADS); - glVertex2i(x, y); - glVertex2i(x, y+len); - glVertex2i(x+1, y+len); - glVertex2i(x+1, y); - glEnd(); - end; - -var - scaled: Boolean; -begin - if (w < 0) or (h < 0) then exit; - if not setupGLColor(clr) then exit; - glDisable(GL_TEXTURE_2D); - glLineWidth(1); - glDisable(GL_LINE_SMOOTH); - glDisable(GL_POLYGON_SMOOTH); - scaled := isScaled(); - if (w = 1) and (h = 1) then - begin - glBegin(GL_POINTS); - if scaled then glVertex2i(x, y) else glVertex2f(x+0.375, y+0.375); - glEnd(); - end - else - begin - if not scaled then - begin - glLineWidth(1); - glBegin(GL_LINES); - glVertex2i(x, y); glVertex2i(x+w, y); // top - glVertex2i(x, y+h-1); glVertex2i(x+w, y+h-1); // bottom - glVertex2f(x+0.375, y+1); glVertex2f(x+0.375, y+h-1); // left - glVertex2f(x+w-1+0.375, y+1); glVertex2f(x+w-1+0.375, y+h-1); // right - glEnd(); - end - else - begin - hline(x, y, w); - hline(x, y+h-1, w); - vline(x, y+1, h-2); - vline(x+w-1, y+1, h-2); - end; - end; - //glRect(x, y, x+w, y+h); - glColor4f(1, 1, 1, 1); - glDisable(GL_BLEND); -end; - - -procedure darkenRect (x, y, w, h: Integer; a: Integer); -begin - if (w < 0) or (h < 0) then exit; - if (a < 0) then a := 0; - if (a >= 255) then exit; - glEnable(GL_BLEND); - glBlendFunc(GL_ZERO, GL_SRC_ALPHA); - glDisable(GL_LINE_SMOOTH); - glDisable(GL_POLYGON_SMOOTH); - glDisable(GL_TEXTURE_2D); - glColor4f(0.0, 0.0, 0.0, a/255.0); - glBegin(GL_QUADS); - glVertex2i(x, y); - glVertex2i(x+w, y); - glVertex2i(x+w, y+h); - glVertex2i(x, y+h); - glEnd(); - //glRect(x, y, x+w, y+h); - glColor4f(1, 1, 1, 1); - glDisable(GL_BLEND); - //glBlendEquation(GL_FUNC_ADD); -end; - - -procedure fillRect (x, y, w, h: Integer; constref clr: TGxRGBA); -begin - if (w < 0) or (h < 0) then exit; - if not setupGLColor(clr) then exit; - glDisable(GL_LINE_SMOOTH); - glDisable(GL_POLYGON_SMOOTH); - glDisable(GL_TEXTURE_2D); - glBegin(GL_QUADS); - glVertex2f(x, y); - glVertex2f(x+w, y); - glVertex2f(x+w, y+h); - glVertex2f(x, y+h); - glEnd(); - glColor4f(1, 1, 1, 1); - glDisable(GL_BLEND); -end; - - -// ////////////////////////////////////////////////////////////////////////// // -function drawText6 (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -begin - if (font6texid = 0) then createFonts(); - drawTextInternal(6, x, y, s, clr, font6texid, kgiFont6PropWidth, false); - result := Length(s)*6; -end; - -function drawText8 (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -begin - if (font8texid = 0) then createFonts(); - drawTextInternal(8, x, y, s, clr, font8texid, kgiFont8PropWidth, false); - result := Length(s)*8; -end; - -function drawText6Prop (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -begin - if (prfont6texid = 0) then createFonts(); - result := drawTextInternal(6, x, y, s, clr, prfont6texid, kgiFont6PropWidth, true); -end; - -function drawText8Prop (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -begin - if (prfont8texid = 0) then createFonts(); - result := drawTextInternal(8, x, y, s, clr, prfont8texid, kgiFont8PropWidth, true); -end; - - -// ////////////////////////////////////////////////////////////////////////// // -// x-centered at `x` -function drawText6XC (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -begin - if (font6texid = 0) then createFonts(); - x -= Length(s)*6 div 2; - drawTextInternal(6, x, y, s, clr, font6texid, kgiFont6PropWidth, false); - result := Length(s)*6; -end; - -function drawText8XC (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -begin - if (font8texid = 0) then createFonts(); - x -= Length(s)*8 div 2; - drawTextInternal(8, x, y, s, clr, font8texid, kgiFont8PropWidth, false); - result := Length(s)*8; -end; - -function drawText6PropXC (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -begin - if (prfont6texid = 0) then createFonts(); - x -= textWidth6(s) div 2; - result := drawTextInternal(6, x, y, s, clr, prfont6texid, kgiFont6PropWidth, true); -end; - -function drawText8PropXC (x, y: Integer; const s: AnsiString; constref clr: TGxRGBA): Integer; -begin - if (prfont8texid = 0) then createFonts(); - x -= textWidth8(s) div 2; - result := drawTextInternal(8, x, y, s, clr, prfont8texid, kgiFont8PropWidth, true); -end; - - -// ////////////////////////////////////////////////////////////////////////// // -procedure oglRestoreMode (doClear: Boolean); -begin - oglSetup2D(gScrWidth, gScrHeight); - glScissor(0, 0, gScrWidth, gScrHeight); - - glBindTexture(GL_TEXTURE_2D, 0); - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); - glDisable(GL_STENCIL_TEST); - glDisable(GL_SCISSOR_TEST); - glDisable(GL_LIGHTING); - glDisable(GL_DEPTH_TEST); - glDisable(GL_CULL_FACE); - glDisable(GL_LINE_SMOOTH); - glDisable(GL_POINT_SMOOTH); - glLineWidth(1); - glPointSize(1); - glColor4f(1, 1, 1, 1); - - if doClear then - begin - glClearColor(0, 0, 0, 0); - glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT or GL_ACCUM_BUFFER_BIT or GL_STENCIL_BUFFER_BIT); - end; - - // scale everything - glMatrixMode(GL_MODELVIEW); - glLoadIdentity(); - //glScalef(4, 4, 1); -end; - - -procedure onWinFocus (); begin end; - -procedure onWinBlur (); begin resetKMState(true); end; - -procedure onPreRender (); begin oglRestoreMode(gGfxDoClear); end; - -procedure onPostRender (); begin oglRestoreMode(false); oglDrawCursor(); end; - -procedure onInit (); -begin - oglSetup2D(gScrWidth, gScrHeight); - - createCursorTexture(); - createFonts(); -end; - -procedure onDeinit (); -begin - resetKMState(false); - if (curtexid <> 0) then glDeleteTextures(1, @curtexid); - curtexid := 0; - deleteFonts(); - curButState := 0; - curModState := 0; - curMsX := 0; - curMsY := 0; -end; - - -// ////////////////////////////////////////////////////////////////////////// // -begin - evSDLCB := onSDLEvent; - winFocusCB := onWinFocus; - winBlurCB := onWinBlur; - prerenderFrameCB := onPreRender; - postrenderFrameCB := onPostRender; - oglInitCB := onInit; - oglDeinitCB := onDeinit; -end. diff --git a/src/gx/sdlcarcass.pas b/src/gx/sdlcarcass.pas deleted file mode 100644 index 29c1c3f..0000000 --- a/src/gx/sdlcarcass.pas +++ /dev/null @@ -1,57 +0,0 @@ -(* Copyright (C) DooM 2D:Forever Developers - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program. If not, see . - *) -{$INCLUDE ../shared/a_modes.inc} -unit sdlcarcass; - -interface - -uses - SDL2; - - -// ////////////////////////////////////////////////////////////////////////// // -// event handlers -var - evSDLCB: function (var ev: TSDL_Event): Boolean = nil; - winFocusCB: procedure () = nil; - winBlurCB: procedure () = nil; - //buildFrameCB: procedure () = nil; - //renderFrameCB: procedure () = nil; // no need to call `glSwap()` here - prerenderFrameCB: procedure () = nil; - postrenderFrameCB: procedure () = nil; - oglInitCB: procedure () = nil; - oglDeinitCB: procedure () = nil; - - -function getScrWdt (): Integer; inline; -function getScrHgt (): Integer; inline; - -property - gScrWidth: Integer read getScrWdt; - gScrHeight: Integer read getScrHgt; - - -implementation - -uses - g_options; - - -function getScrWdt (): Integer; inline; begin result := gScreenWidth; end; -function getScrHgt (): Integer; inline; begin result := gScreenHeight; end; - - -end. 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;