| author | Ketmar Dark <ketmar@ketmar.no-ip.org> | |
| Mon, 2 Oct 2017 23:35:41 +0000 (02:35 +0300) | ||
| committer | Ketmar Dark <ketmar@ketmar.no-ip.org> | |
| Mon, 2 Oct 2017 23:35:41 +0000 (02:35 +0300) |
19 files changed:
diff --git a/src/flexui/fui_common.pas b/src/flexui/fui_common.pas
--- /dev/null
@@ -0,0 +1,251 @@
+(* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
+ * 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 <http://www.gnu.org/licenses/>.
+ *)
+{$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 b23362bdb35207813803c6fc5682483ac94fd6de..7969a2617ef52edbaeb113583ae4888d72052413 100644 (file)
rename from src/gx/gh_ui.pas
rename to src/flexui/fui_ctls.pas
index b23362bdb35207813803c6fc5682483ac94fd6de..7969a2617ef52edbaeb113583ae4888d72052413 100644 (file)
--- a/src/gx/gh_ui.pas
+++ b/src/flexui/fui_ctls.pas
*)
{$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;
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;
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;
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;
function getFocused (): Boolean; inline;
procedure setFocused (v: Boolean); inline;
+ function getActive (): Boolean; inline;
+
function getCanFocus (): Boolean; inline;
function isMyChild (ctl: TUIControl): Boolean;
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;
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;
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;
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;
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;
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;
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;
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;
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
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;
// ////////////////////////////////////////////////////////////////////// //
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);
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;
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;
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;
// ////////////////////////////////////////////////////////////////////////// //
var
- gh_ui_scale: Single = 1.0;
+ fuiRenderScale: Single = 1.0;
+ uiContext: TGxContext = nil;
implementation
uses
- gh_flexlay,
+ fui_flexlay,
utils;
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();
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;
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];
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();
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;
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;
// ////////////////////////////////////////////////////////////////////////// //
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;
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;
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;
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;
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
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 :=
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;
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;
// ////////////////////////////////////////////////////////////////////////// //
procedure TUIControl.activated ();
begin
+ makeVisibleInParent();
end;
end;
+procedure TUIControl.calcFullClientSize ();
+var
+ ctl: TUIControl;
+begin
+ mFullSize := TLaySize.Create(0, 0);
+ if (mWidth < 1) or (mHeight < 1) then exit;
+ for ctl in mChildren do
+ begin
+ ctl.calcFullClientSize();
+ mFullSize.w := nmax(mFullSize.w, ctl.mX-mFrameWidth+ctl.mFullSize.w);
+ mFullSize.h := nmax(mFullSize.h, ctl.mY-mFrameHeight+ctl.mFullSize.h);
+ end;
+ mFullSize.w := nmax(mFullSize.w, mWidth-mFrameWidth*2);
+ mFullSize.h := nmax(mFullSize.h, mHeight-mFrameHeight*2);
+end;
+
+
function TUIControl.topLevel (): TUIControl; inline;
begin
result := self;
end;
+function TUIControl.getActive (): Boolean; inline;
+var
+ ctl: TUIControl;
+begin
+ if (mParent = nil) then
+ begin
+ result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = self);
+ end
+ else
+ begin
+ ctl := topLevel.mFocused;
+ while (ctl <> nil) and (ctl <> self) do ctl := ctl.mParent;
+ result := (ctl = self);
+ if (result) then result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = topLevel);
+ end;
+end;
+
+
procedure TUIControl.setFocused (v: Boolean); inline;
var
tl: TUIControl;
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();
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;
// 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;
result := toLocal(x, y);
end;
+
procedure TUIControl.toGlobal (var x, y: Integer);
-var
- ctl: TUIControl;
begin
- ctl := self;
- while (ctl <> nil) do
+ Inc(x, mX);
+ Inc(y, mY);
+ if (mParent <> nil) then
begin
- Inc(x, ctl.mX);
- Inc(y, ctl.mY);
- ctl := ctl.mParent;
+ Dec(x, mParent.mScrollX);
+ Dec(y, mParent.mScrollY);
+ mParent.toGlobal(x, y);
end;
end;
toGlobal(x, y);
end;
+procedure TUIControl.getDrawRect (out gx, gy, wdt, hgt: Integer);
+var
+ cgx, cgy: Integer;
+begin
+ if (mParent = nil) then
+ begin
+ gx := mX;
+ gy := mY;
+ wdt := mWidth;
+ hgt := mHeight;
+ end
+ else
+ begin
+ toGlobal(0, 0, cgx, cgy);
+ mParent.getDrawRect(gx, gy, wdt, hgt);
+ if (wdt > 0) and (hgt > 0) then
+ begin
+ if not intersectRect(gx, gy, wdt, hgt, cgx, cgy, mWidth, mHeight) then
+ begin
+ wdt := 0;
+ hgt := 0;
+ end;
+ end;
+ end;
+end;
+
// x and y are global coords
function TUIControl.controlAtXY (x, y: Integer; allowDisabled: Boolean=false): TUIControl;
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
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;
result := mChildren[f].findFirstFocus();
if (result <> nil) then exit;
end;
- if canFocus then result := self;
+ if (canFocus) then result := self;
end;
end;
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;
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;
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;
end;
+function TUIControl.setActionCBFor (const aid: AnsiString; cb: TActionCB): TActionCB;
+var
+ ctl: TUIControl;
+begin
+ ctl := self[aid];
+ if (ctl <> nil) then
+ begin
+ result := ctl.actionCB;
+ ctl.actionCB := cb;
+ end
+ else
+ begin
+ result := nil;
+ end;
+end;
+
+
+function TUIControl.forEachChildren (cb: TCtlEnumCB): TUIControl;
+var
+ ctl: TUIControl;
+begin
+ result := nil;
+ if (not assigned(cb)) then exit;
+ for ctl in mChildren do
+ begin
+ if cb(ctl) then begin result := ctl; exit; end;
+ end;
+end;
+
+
+function TUIControl.forEachControl (cb: TCtlEnumCB; includeSelf: Boolean=true): TUIControl;
+
+ function forChildren (p: TUIControl; incSelf: Boolean): TUIControl;
+ var
+ ctl: TUIControl;
+ begin
+ result := nil;
+ if (p = nil) then exit;
+ if (incSelf) and (cb(p)) then begin result := p; exit; end;
+ for ctl in p.mChildren do
+ begin
+ result := forChildren(ctl, true);
+ if (result <> nil) then break;
+ end;
+ end;
+
+begin
+ result := nil;
+ if (not assigned(cb)) then exit;
+ result := forChildren(self, includeSelf);
+end;
+
+
procedure TUIControl.close (); // this closes *top-level* control
var
ctl: TUIControl;
procedure TUIControl.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
resetScissor(true); // full area
drawControlPost(gx, gy);
finally
- scis.restore();
- scallowed := false;
+ uiContext.clip := savedClip;
end;
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;
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;
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;
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;
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;
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;
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;
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
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;
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;
end
else
begin
- mDragging := true;
+ mDragScroll := TXMode.Drag;
mDragStartX := ev.x;
mDragStartY := ev.y;
end;
ev.eat();
exit;
end;
+ // check for vertical scrollbar
+ if (lx >= mWidth-mFrameWidth+1) and (ly >= 7) and (ly < mHeight-mFrameHeight+1) then
+ begin
+ sbhgt := mHeight-mFrameHeight*2+2;
+ hgt := mHeight-mFrameHeight*2;
+ if (hgt > 0) and (mFullSize.h > hgt) then
+ begin
+ hgt := (mFullSize.h*(ly-7) div (sbhgt-1))-(mHeight-mFrameHeight*2);
+ mScrollY := nmax(0, hgt);
+ uiGrabCtl := self;
+ mDragScroll := TXMode.Scroll;
+ ev.eat();
+ exit;
+ end;
+ end;
+ // drag
if (lx < mFrameWidth) or (lx >= mWidth-mFrameWidth) or (ly >= mHeight-mFrameHeight) then
begin
uiGrabCtl := self;
- mDragging := true;
+ mDragScroll := TXMode.Drag;
mDragStartX := ev.x;
mDragStartY := ev.y;
ev.eat();
begin
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
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;
// ////////////////////////////////////////////////////////////////////////// //
-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;
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;
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;
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;
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;
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
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');
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
--- /dev/null
@@ -0,0 +1,461 @@
+(* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
+ * 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 <http://www.gnu.org/licenses/>.
+ *)
+{$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.
similarity index 76%
rename from src/gx/gh_flexlay.pas
rename to src/flexui/fui_flexlay.pas
index 5f237f521de9df680b5b00e9f4e81aacc1817321..fb470c4fee5a71a41fd198e1b251b8466841ea3a 100644 (file)
rename from src/gx/gh_flexlay.pas
rename to src/flexui/fui_flexlay.pas
index 5f237f521de9df680b5b00e9f4e81aacc1817321..fb470c4fee5a71a41fd198e1b251b8466841ea3a 100644 (file)
--- a/src/gx/gh_flexlay.pas
* along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
{$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
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
interface
uses
- gh_ui_common;
+ fui_common;
// ////////////////////////////////////////////////////////////////////////// //
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
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;
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;
// 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);
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;
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;
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;
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;
// 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;
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`
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
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
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
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
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
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
end;
-(*
-third pass:
- if 'group-element-changed':
- for each group: adjust controls to max desired size (startsize), set 'temp-flex' flags to 0 for 'em, set 'second-again' flag
- for other controls: if 'desiredsize' > 'maxsize', set 'startsize' to 'maxsize', set 'temp-flex' flag to 0, set 'second-again' flag
- if 'second-again' or 'wrapping-changed':
- reset 'second-again'
- reset 'wrapping-changed'
- reset 'firsttime'
- goto second pass
-*)
procedure TFlexLayouterBase.thirdPass ();
var
secondAgain: Boolean;
ct.expand := false; // don't expand grouped controls anymore
ct.tempFlex := 0; // don't change control size anymore
end;
+ (*
for c := 0 to 1 do
begin
if (ct.maxsize[c] < 0) then continue;
secondAgain := true;
end;
end;
+ *)
end;
end;
if (not secondAgain) and (not wrappingChanged) then break;
diff --git a/src/flexui/fui_gfx_gl.pas b/src/flexui/fui_gfx_gl.pas
--- /dev/null
@@ -0,0 +1,1113 @@
+(* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
+ * 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 <http://www.gnu.org/licenses/>.
+ *)
+{$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
--- /dev/null
@@ -0,0 +1,171 @@
+(* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
+ * 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 <http://www.gnu.org/licenses/>.
+ *)
+// ////////////////////////////////////////////////////////////////////////// //
+// 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
--- /dev/null
@@ -0,0 +1,311 @@
+(* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
+ * 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 <http://www.gnu.org/licenses/>.
+ *)
+// ////////////////////////////////////////////////////////////////////////// //
+// 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
--- /dev/null
+++ b/src/flexui/fui_style.pas
@@ -0,0 +1,796 @@
+(* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
+ * 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 <http://www.gnu.org/licenses/>.
+ *)
+{$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<AnsiString, TStyleValue, THashKeyStrAnsiCI>;
+ THashStrSection = specialize THashBase<AnsiString, TStyleSection, THashKeyStrAnsiCI>;
+
+ TStyleSection = class
+ private
+ mParent: TStyleSection; // for inheritance
+ mInherits: AnsiString;
+ mHashName: AnsiString; // for this section
+ mCtlName: AnsiString; // for this section
+ mVals: THashStrStyleVal;
+ 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 := '<empty>';
+ 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 := '<invalid>';
+ 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
--- /dev/null
@@ -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 <http://www.gnu.org/licenses/>.
+ *)
+{$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
--- /dev/null
@@ -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 <http://www.gnu.org/licenses/>.
+ *)
+{$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 e95d6232a2f72d66c17ce9631d2861e474129ee4..5162d93ca16ec6b53360d46a7fc4774d93719f98 100644 (file)
--- a/src/game/Doom2DF.lpr
+++ b/src/game/Doom2DF.lpr
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 79c4349a32a98180e1be54c1ee5524f99d5b2a16..bcb2cfadb4ed56f09d3816b4121e313213a34b49 100644 (file)
--- a/src/game/g_holmes.pas
+++ b/src/game/g_holmes.pas
g_textures, g_basic, e_graphics, g_phys, g_grid, g_player, g_monsters,
g_window, g_map, g_triggers, g_items, g_game, g_panel, g_console, g_gfx,
xprofiler,
- sdlcarcass, glgfx, gh_ui;
+ sdlcarcass,
+ fui_common, fui_events, fui_ctls,
+ fui_gfx_gl;
procedure g_Holmes_Draw ();
var
+ hlmContext: TGxContext = nil;
//globalInited: Boolean = false;
msX: Integer = -666;
msY: Integer = -666;
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();
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();
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;
if (Length(cmd.help) > 0) then
begin
cmd.helpmark := true;
- if (maxkeylen < Length(bind.key)) then maxkeylen := Length(bind.key);
+ //if (maxkeylen < Length(bind.key)) then maxkeylen := Length(bind.key);
end;
end;
end;
for cmd in cmdlist do
begin
if not cmd.helpmark then continue;
- if (Length(cmd.help) = 0) then continue;
+ if (Length(cmd.help) = 0) then begin cmd.helpmark := false; continue; end;
f := 0;
while (f < Length(slist)) and (CompareText(slist[f], cmd.section) <> 0) do Inc(f);
if (f = Length(slist)) then
end;
end;
- llb := TUISimpleText.Create(0, 0);
+ addHelpCaptionLine('KEYBOARD');
+ //llb := TUISimpleText.Create(0, 0);
for f := 0 to High(slist) do
begin
- if (f > 0) then llb.appendItem('');
- llb.appendItem(slist[f], true, true);
+ //if (f > 0) then llb.appendItem('');
+ if (f > 0) then addHelpEmptyLine();
+ //llb.appendItem(slist[f], true, true);
+ addHelpCaption(slist[f]);
for cmd in cmdlist do
begin
if not cmd.helpmark then continue;
if (Length(bind.key) = 0) then continue;
if (cmd.name = bind.cmdName) then
begin
- s := bind.key;
- while (Length(s) < maxkeylen) do s += ' ';
- s := ' '+s+' -- '+cmd.help;
- llb.appendItem(s);
+ //s := bind.key;
+ //while (Length(s) < maxkeylen) do s += ' ';
+ //s := ' '+s+' -- '+cmd.help;
+ //llb.appendItem(s);
+ addHelpMouse(bind.key, cmd.help);
end;
end;
end;
end;
- maxkeylen := 0;
+ // mouse
+ for cmd in cmdlist do cmd.helpmark := false;
+
+ //maxkeylen := 0;
for bind in msbinds do
begin
if (Length(bind.key) = 0) then continue;
if (Length(cmd.help) > 0) then
begin
cmd.helpmark := true;
- if (maxkeylen < Length(bind.key)) then maxkeylen := Length(bind.key);
+ //if (maxkeylen < Length(bind.key)) then maxkeylen := Length(bind.key);
end;
end;
end;
- llb.appendItem('');
- llb.appendItem('mouse', true, true);
+ //llb.appendItem('');
+ //llb.appendItem('mouse', true, true);
+ if (f > 0) then addHelpEmptyLine();
+ addHelpCaptionLine('MOUSE');
for bind in msbinds do
begin
if (Length(bind.key) = 0) then continue;
begin
if (Length(cmd.help) > 0) then
begin
- s := bind.key;
- while (Length(s) < maxkeylen) do s += ' ';
- s := ' '+s+' -- '+cmd.help;
- llb.appendItem(s);
+ //s := bind.key;
+ //while (Length(s) < maxkeylen) do s += ' ';
+ //s := ' '+s+' -- '+cmd.help;
+ //llb.appendItem(s);
+ addHelpKey(bind.key, cmd.help);
end;
end;
end;
- winHelp := TUITopWindow.Create('Holmes Help', 10, 10);
- winHelp.escClose := true;
- winHelp.appendChild(llb);
+ //winHelp.appendChild(llb);
+
+ 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;
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);
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];
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
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;
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;
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);
//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;
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;
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;
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;
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;
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();
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);
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;
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;
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;
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();
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;
*)
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;
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 94762c9be1f59e69f6716da4afc3def5221cf882..57f12e98a45349501ccb52fd666817503eae7731 100644 (file)
--- a/src/game/g_main.pas
+++ b/src/game/g_main.pas
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 1db0c639efbfe27713abca1491ad2723fc4de1d5..258b489b1f8f35f335061f207515c48406bab2b0 100644 (file)
--- a/src/game/g_window.pas
+++ b/src/game/g_window.pas
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
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);
{$IF not DEFINED(HEADLESS)}
SDL_MOUSEBUTTONDOWN, SDL_MOUSEBUTTONUP, SDL_MOUSEWHEEL, SDL_MOUSEMOTION:
- evSDLCB(ev);
+ fuiOnSDLEvent(ev);
{$ENDIF}
SDL_TEXTINPUT:
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
--- a/src/gx/gh_ui_common.pas
+++ /dev/null
@@ -1,112 +0,0 @@
-(* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
- * 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 <http://www.gnu.org/licenses/>.
- *)
-{$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
--- a/src/gx/gh_ui_style.pas
+++ /dev/null
@@ -1,633 +0,0 @@
-(* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
- * 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 <http://www.gnu.org/licenses/>.
- *)
-{$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<AnsiString, TStyleValue, THashKeyStrAnsiCI>;
- THashStrSection = specialize THashBase<AnsiString, TStyleSection, THashKeyStrAnsiCI>;
-
- 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 := '<empty>';
- 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 := '<invalid>';
- 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
--- a/src/gx/glgfx.pas
+++ /dev/null
@@ -1,1663 +0,0 @@
-(* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
- * 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 <http://www.gnu.org/licenses/>.
- *)
-{$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
--- 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 <http://www.gnu.org/licenses/>.
- *)
-{$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 5332f0afe7c4af022019799a6d2eb4ce796f40c0..de2dfb38a379ac52872a91caaffd71ac61a11db2 100644 (file)
--- a/src/shared/xparser.pas
+++ b/src/shared/xparser.pas
DollarIsId, // allow dollar in identifiers; otherwise dollar will be TTDelim
DotIsId, // allow dot in identifiers; otherwise dot will be TTDelim
DashIsId, // '-' can be part of identifier (but identifier cannot start with '-')
+ HtmlColors, // #rgb or #rrggbb colors
PascalComments // allow `{}` pascal comments
);
TOptions = set of TOption;
private
type
TAnsiCharSet = set of AnsiChar;
+ const
+ CharBufSize = 8;
private
mLine, mCol: Integer;
- mCurChar, mNextChar: AnsiChar;
+ // chars for 'unget'
+ mCharBuf: packed array [0..CharBufSize-1] of AnsiChar;
+ mCharBufUsed: Integer;
+ mCharBufPos: Integer;
+ mEofHit: Boolean; // no more chars to load into mCharBuf
mOptions: TOptions;
mTokChar: AnsiChar; // for delimiters
mTokInt: Integer;
+ private
+ procedure fillCharBuf ();
+ function popFrontChar (): AnsiChar; inline; // never drains char buffer (except on "total EOF")
+ function peekCurChar (): AnsiChar; inline;
+ function peekNextChar (): AnsiChar; inline;
+ function peekChar (dest: Integer): AnsiChar; inline;
+
protected
- procedure warmup (); // called in constructor to warm up the system
- procedure loadNextChar (); virtual; abstract; // loads next char into mNextChar; #0 means 'eof'
+ function loadChar (): AnsiChar; virtual; abstract; // loads next char; #0 means 'eof'
+
+ public
+ function isIdStartChar (ch: AnsiChar): Boolean; inline;
+ function isIdMidChar (ch: AnsiChar): Boolean; inline;
public
constructor Create (aopts: TOptions=[TOption.SignedNumbers]);
procedure error (const amsg: AnsiString); noreturn;
procedure errorfmt (const afmt: AnsiString; const args: array of const); noreturn;
- function isEOF (): Boolean; inline;
-
function skipChar (): Boolean; // returns `false` on eof
function skipBlanks (): Boolean; // ...and comments; returns `false` on eof
function skipToken1 (): Boolean;
{$ENDIF}
+ function isEOF (): Boolean; inline;
+ function isId (): Boolean; inline;
+ function isInt (): Boolean; inline;
+ function isStr (): Boolean; inline;
+ function isDelim (): Boolean; inline;
function isIdOrStr (): Boolean; inline;
function expectId (): AnsiString;
property col: Integer read mCol;
property line: Integer read mLine;
- property curChar: AnsiChar read mCurChar;
- property nextChar: AnsiChar read mNextChar;
+ property curChar: AnsiChar read peekCurChar;
+ property nextChar: AnsiChar read peekNextChar;
// token start
property tokCol: Integer read mTokCol;
mBufPos: Integer;
protected
- procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
+ function loadChar (): AnsiChar; override; // loads next char; #0 means 'eof'
public
constructor Create (const fname: AnsiString; aopts: TOptions=[TOption.SignedNumbers]);
mPos: Integer;
protected
- procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
+ function loadChar (): AnsiChar; override; // loads next char; #0 means 'eof'
public
constructor Create (const astr: AnsiString; aopts: TOptions=[TOption.SignedNumbers]);
begin
mLine := 1;
mCol := 1;
- mCurChar := #0;
- mNextChar := #0;
+ mCharBufUsed := 0;
+ mCharBufPos := 0;
+ mEofHit := false;
mTokType := TTNone;
mTokStr := '';
mTokChar := #0;
mTokInt := 0;
mOptions := aopts;
- warmup();
skipToken();
end;
end;
-function TTextParser.isEOF (): Boolean; inline; begin {result := (mCurChar = #0);} result := (mTokType = TTEOF); end;
-
+function TTextParser.isIdStartChar (ch: AnsiChar): Boolean; inline;
+begin
+ result :=
+ (ch = '_') or
+ ((ch >= 'A') and (ch <= 'Z')) or
+ ((ch >= 'a') and (ch <= 'z')) or
+ (ch >= #128) or
+ ((ch = '$') and (TOption.DollarIsId in mOptions)) or
+ ((ch = '.') and (TOption.DotIsId in mOptions));
+end;
-procedure TTextParser.warmup ();
+function TTextParser.isIdMidChar (ch: AnsiChar): Boolean; inline;
begin
- mNextChar := ' ';
- loadNextChar();
- mCurChar := mNextChar;
- if (mNextChar <> #0) then loadNextChar();
+ result :=
+ ((ch >= '0') and (ch <= '9')) or
+ ((ch = '-') and (TOption.DashIsId in mOptions)) or
+ isIdStartChar(ch);
end;
-function TTextParser.skipChar (): Boolean;
+procedure TTextParser.fillCharBuf ();
+var
+ ch: AnsiChar;
begin
- if (mCurChar = #0) then begin result := false; exit; end;
- if (mCurChar = #10) then begin mCol := 1; Inc(mLine); end else Inc(mCol);
- mCurChar := mNextChar;
- if (mCurChar = #0) then begin result := false; exit; end;
- loadNextChar();
- // skip CR in CR/LF
- if (mCurChar = #13) then
+ if (mEofHit) then begin mCharBuf[mCharBufPos] := #0; exit; end;
+ while (not mEofHit) and (mCharBufUsed < CharBufSize) do
begin
- if (mNextChar = #10) then loadNextChar();
- mCurChar := #10;
+ ch := loadChar();
+ mCharBuf[(mCharBufPos+mCharBufUsed) mod CharBufSize] := ch;
+ if (ch = #0) then begin mEofHit := true; break; end;
+ Inc(mCharBufUsed);
end;
+end;
+
+
+// never drains char buffer (except on "total EOF")
+function TTextParser.popFrontChar (): AnsiChar; inline;
+begin
+ if (mEofHit) and (mCharBufUsed = 0) then begin result := #0; exit; end;
+ assert(mCharBufUsed > 0);
+ result := mCharBuf[mCharBufPos];
+ mCharBufPos := (mCharBufPos+1) mod CharBufSize;
+ Dec(mCharBufUsed);
+ if (not mEofHit) and (mCharBufUsed = 0) then fillCharBuf();
+end;
+
+function TTextParser.peekCurChar (): AnsiChar; inline;
+begin
+ if (mCharBufUsed = 0) and (not mEofHit) then fillCharBuf();
+ result := mCharBuf[mCharBufPos]; // it is safe, 'cause `fillCharBuf()` will put #0 on "total EOF"
+end;
+
+function TTextParser.peekNextChar (): AnsiChar; inline;
+begin
+ if (mCharBufUsed < 2) and (not mEofHit) then fillCharBuf();
+ if (mCharBufUsed < 2) then result := #0 else result := mCharBuf[(mCharBufPos+1) mod CharBufSize];
+end;
+
+function TTextParser.peekChar (dest: Integer): AnsiChar; inline;
+begin
+ if (dest < 0) or (dest >= CharBufSize) then error('internal text parser error');
+ if (mCharBufUsed < dest+1) then fillCharBuf();
+ if (mCharBufUsed < dest+1) then result := #0 else result := mCharBuf[(mCharBufPos+dest) mod CharBufSize];
+end;
+
+
+function TTextParser.skipChar (): Boolean;
+var
+ ch: AnsiChar;
+begin
+ ch := popFrontChar();
+ if (ch = #0) then begin result := false; exit; end;
result := true;
+ // CR?
+ case ch of
+ #10:
+ begin
+ mCol := 1;
+ Inc(mLine);
+ end;
+ #13:
+ begin
+ mCol := 1;
+ Inc(mLine);
+ if (mCharBufUsed > 0) and (mCharBuf[0] = #10) then
+ begin
+ if (popFrontChar() = #0) then result := false;
+ end;
+ end;
+ else
+ Inc(mCol);
+ end;
end;
var
level: Integer;
begin
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- if (mCurChar = '/') then
+ if (curChar = '/') then
begin
// single-line comment
- if (mNextChar = '/') then
+ if (nextChar = '/') then
begin
- while (mCurChar <> #0) and (mCurChar <> #10) do skipChar();
+ //writeln('spos=(', mLine, ',', mCol, ')');
+ while (curChar <> #0) and (curChar <> #10) and (curChar <> #13) do skipChar();
skipChar(); // skip EOL
+ //writeln('{', curChar, '}');
+ //writeln('epos=(', mLine, ',', mCol, ')');
continue;
end;
// multline comment
- if (mNextChar = '*') then
+ if (nextChar = '*') then
begin
// skip comment start
skipChar();
skipChar();
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- if (mCurChar = '*') and (mNextChar = '/') then
+ if (curChar = '*') and (nextChar = '/') then
begin
// skip comment end
skipChar();
continue;
end;
// nesting multline comment
- if (mNextChar = '+') then
+ if (nextChar = '+') then
begin
// skip comment start
skipChar();
skipChar();
level := 1;
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- if (mCurChar = '+') and (mNextChar = '/') then
+ if (curChar = '+') and (nextChar = '/') then
begin
// skip comment end
skipChar();
if (level = 0) then break;
continue;
end;
- if (mCurChar = '/') and (mNextChar = '+') then
+ if (curChar = '/') and (nextChar = '+') then
begin
// skip comment start
skipChar();
continue;
end;
end
- else if (mCurChar = '(') and (mNextChar = '*') then
+ else if (curChar = '(') and (nextChar = '*') then
begin
// pascal comment; skip comment start
skipChar();
skipChar();
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- if (mCurChar = '*') and (mNextChar = ')') then
+ if (curChar = '*') and (nextChar = ')') then
begin
// skip comment end
skipChar();
end;
continue;
end
- else if (mCurChar = '{') and (TOption.PascalComments in mOptions) then
+ else if (curChar = '{') and (TOption.PascalComments in mOptions) then
begin
// pascal comment; skip comment start
skipChar();
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- if (mCurChar = '}') then
+ if (curChar = '}') then
begin
// skip comment end
skipChar();
end;
continue;
end;
- if (mCurChar > ' ') then break;
+ if (curChar > ' ') then break;
skipChar(); // skip blank
end;
- result := (mCurChar <> #0);
+ result := (curChar <> #0);
end;
begin
if (TOption.SignedNumbers in mOptions) then
begin
- if (mCurChar = '+') or (mCurChar = '-') then
+ if (curChar = '+') or (curChar = '-') then
begin
- neg := (mCurChar = '-');
+ neg := (curChar = '-');
skipChar();
- if (mCurChar < '0') or (mCurChar > '9') then
+ if (curChar < '0') or (curChar > '9') then
begin
mTokType := TTDelim;
if (neg) then mTokChar := '-' else mTokChar := '+';
end;
end;
end;
- if (mCurChar = '0') then
+ if (curChar = '0') then
begin
- case mNextChar of
+ case nextChar of
'b','B': base := 2;
'o','O': base := 8;
'd','D': base := 10;
end;
// default base
if (base < 0) then base := 10;
- if (digitInBase(mCurChar, base) < 0) then raise Exception.Create('invalid number');
+ if (digitInBase(curChar, base) < 0) then error('invalid number');
mTokType := TTInt;
mTokInt := 0; // just in case
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
- n := digitInBase(mCurChar, base);
+ if (curChar = '_') then
+ begin
+ skipChar();
+ if (curChar = #0) then break;
+ end;
+ n := digitInBase(curChar, base);
if (n < 0) then break;
n := mTokInt*10+n;
- if (n < 0) or (n < mTokInt) then raise Exception.Create('integer overflow');
+ if (n < 0) or (n < mTokInt) then error('integer overflow');
mTokInt := n;
skipChar();
end;
// check for valid number end
- if (mCurChar <> #0) then
+ if (curChar <> #0) then
begin
- if (mCurChar = '.') then raise Exception.Create('floating numbers aren''t supported yet');
- if (mCurChar = '_') or ((mCurChar >= 'A') and (mCurChar <= 'Z')) or ((mCurChar >= 'a') and (mCurChar <= 'z')) or (mCurChar >= #128) then
- begin
- raise Exception.Create('invalid number');
- end;
+ if (curChar = '.') then error('floating numbers aren''t supported yet');
+ if (isIdMidChar(curChar)) then error('invalid number');
end;
if neg then mTokInt := -mTokInt;
end;
begin
mTokType := TTStr;
mTokStr := ''; // just in case
- qch := mCurChar;
+ qch := curChar;
skipChar(); // skip starting quote
- while (mCurChar <> #0) do
+ while (curChar <> #0) do
begin
// escape
- if (qch = '"') and (mCurChar = '\') then
+ if (qch = '"') and (curChar = '\') then
begin
- if (mNextChar = #0) then raise Exception.Create('unterminated string escape');
- ch := mNextChar;
+ if (nextChar = #0) then error('unterminated string escape');
+ ch := nextChar;
// skip backslash and escape type
skipChar();
skipChar();
'e': mTokStr += #27;
'x', 'X': // hex escape
begin
- n := digitInBase(mCurChar, 16);
- if (n < 0) then raise Exception.Create('invalid hexstr escape');
+ n := digitInBase(curChar, 16);
+ if (n < 0) then error('invalid hexstr escape');
skipChar();
- if (digitInBase(mCurChar, 16) > 0) then
+ if (digitInBase(curChar, 16) > 0) then
begin
- n := n*16+digitInBase(mCurChar, 16);
+ n := n*16+digitInBase(curChar, 16);
skipChar();
end;
mTokStr += AnsiChar(n);
continue;
end;
// duplicate single quote (pascal style)
- if (qch = '''') and (mCurChar = '''') and (mNextChar = '''') then
+ if (qch = '''') and (curChar = '''') and (nextChar = '''') then
begin
// skip both quotes
skipChar();
mTokStr += '''';
continue;
end;
- if (mCurChar = qch) then
+ if (curChar = qch) then
begin
skipChar(); // skip ending quote
break;
end;
- mTokStr += mCurChar;
+ mTokStr += curChar;
skipChar();
end;
end;
begin
mTokType := TTId;
mTokStr := ''; // just in case
- while (mCurChar = '_') or ((mCurChar >= '0') and (mCurChar <= '9')) or
- ((mCurChar >= 'A') and (mCurChar <= 'Z')) or
- ((mCurChar >= 'a') and (mCurChar <= 'z')) or
- (mCurChar >= #128) or
- ((TOption.DollarIsId in mOptions) and (mCurChar = '$')) or
- ((TOption.DotIsId in mOptions) and (mCurChar = '.') and (mNextChar <> '.')) or
- ((TOption.DashIsId in mOptions) and (mCurChar = '-')) do
+ while (isIdMidChar(curChar)) do
begin
- mTokStr += mCurChar;
+ if (curChar = '.') and (nextChar = '.') then break; // dotdot is a token by itself
+ mTokStr += curChar;
skipChar();
end;
end;
+var
+ xpos: Integer;
begin
mTokType := TTNone;
mTokStr := '';
result := true;
// number?
- if (TOption.SignedNumbers in mOptions) and ((mCurChar = '+') or (mCurChar = '-')) then begin parseInt(); exit; end;
- if (mCurChar >= '0') and (mCurChar <= '9') then begin parseInt(); exit; end;
+ if (TOption.SignedNumbers in mOptions) and ((curChar = '+') or (curChar = '-')) then begin parseInt(); exit; end;
+ if (curChar >= '0') and (curChar <= '9') then begin parseInt(); exit; end;
// string?
- if (mCurChar = '"') or (mCurChar = '''') then begin parseString(); exit; end;
+ if (curChar = '"') or (curChar = '''') or (curChar = '`') then begin parseString(); exit; end;
+
+ // html color?
+ if (curChar = '#') and (TOption.HtmlColors in mOptions) then
+ begin
+ if (digitInBase(peekChar(1), 16) >= 0) and (digitInBase(peekChar(2), 16) >= 0) and (digitInBase(peekChar(3), 16) >= 0) then
+ begin
+ if (digitInBase(peekChar(4), 16) >= 0) and (digitInBase(peekChar(5), 16) >= 0) and (digitInBase(peekChar(6), 16) >= 0) then xpos := 7 else xpos := 4;
+ if (not isIdMidChar(peekChar(xpos))) then
+ begin
+ mTokType := TTId;
+ mTokStr := '';
+ while (xpos > 0) do
+ begin
+ mTokStr += curChar;
+ skipChar();
+ Dec(xpos);
+ end;
+ exit;
+ end;
+ end;
+ end;
// identifier?
- if (mCurChar = '_') or ((mCurChar >= 'A') and (mCurChar <= 'Z')) or ((mCurChar >= 'a') and (mCurChar <= 'z')) or (mCurChar >= #128) then begin parseId(); exit; end;
- if (TOption.DollarIsId in mOptions) and (mCurChar = '$') then begin parseId(); exit; end;
- if (TOption.DotIsId in mOptions) and (mCurChar = '.') and (mNextChar <> '.') then begin parseId(); exit; end;
+ if (isIdStartChar(curChar)) then
+ begin
+ if (curChar = '.') and (nextChar = '.') then
+ begin
+ // nothing to do here, as dotdot is a token by itself
+ end
+ else
+ begin
+ parseId();
+ exit;
+ end;
+ end;
// known delimiters?
- mTokChar := mCurChar;
+ mTokChar := curChar;
mTokType := TTDelim;
skipChar();
- if (mCurChar = '=') then
+ if (curChar = '=') then
begin
case mTokChar of
'<': begin mTokType := TTLessEqu; mTokStr := '<='; skipChar(); exit; end;
':': begin mTokType := TTAss; mTokStr := ':='; skipChar(); exit; end;
end;
end
- else if (mTokChar = mCurChar) then
+ else if (mTokChar = curChar) then
begin
case mTokChar of
'<': begin mTokType := TTShl; mTokStr := '<<'; skipChar(); exit; end;
else
begin
case mTokChar of
- '<': if (mCurChar = '>') then begin mTokType := TTNotEqu; mTokStr := '<>'; skipChar(); exit; end;
- '.': if (mCurChar = '.') then begin mTokType := TTDotDot; mTokStr := '..'; skipChar(); exit; end;
+ '<': if (curChar = '>') then begin mTokType := TTNotEqu; mTokStr := '<>'; skipChar(); exit; end;
+ '.': if (curChar = '.') then begin mTokType := TTDotDot; mTokStr := '..'; skipChar(); exit; end;
end;
end;
end;
-function TTextParser.isIdOrStr (): Boolean; inline;
-begin
- result := (mTokType = TTId) or (mTokType = TTStr);
-end;
+function TTextParser.isEOF (): Boolean; inline; begin result := (mTokType = TTEOF); end;
+function TTextParser.isId (): Boolean; inline; begin result := (mTokType = TTId); end;
+function TTextParser.isInt (): Boolean; inline; begin result := (mTokType = TTInt); end;
+function TTextParser.isStr (): Boolean; inline; begin result := (mTokType = TTStr); end;
+function TTextParser.isDelim (): Boolean; inline; begin result := (mTokType = TTDelim); end;
+function TTextParser.isIdOrStr (): Boolean; inline; begin result := (mTokType = TTId) or (mTokType = TTStr); end;
function TTextParser.expectId (): AnsiString;
begin
- if (mTokType <> TTId) then raise Exception.Create('identifier expected');
+ if (mTokType <> TTId) then error('identifier expected');
result := mTokStr;
skipToken();
end;
@@ -675,11 +795,11 @@ procedure TTextParser.expectId (const aid: AnsiString; caseSens: Boolean=true);
begin
if caseSens then
begin
- if (mTokType <> TTId) or (mTokStr <> aid) then raise Exception.Create('identifier '''+aid+''' expected');
+ if (mTokType <> TTId) or (mTokStr <> aid) then error('identifier '''+aid+''' expected');
end
else
begin
- if (mTokType <> TTId) or (not strEquCI1251(mTokStr, aid)) then raise Exception.Create('identifier '''+aid+''' expected');
+ if (mTokType <> TTId) or (not strEquCI1251(mTokStr, aid)) then error('identifier '''+aid+''' expected');
end;
skipToken();
end;
function TTextParser.expectStr (allowEmpty: Boolean=false): AnsiString;
begin
- if (mTokType <> TTStr) then raise Exception.Create('string expected');
- if (not allowEmpty) and (Length(mTokStr) = 0) then raise Exception.Create('non-empty string expected');
+ if (mTokType <> TTStr) then error('string expected');
+ if (not allowEmpty) and (Length(mTokStr) = 0) then error('non-empty string expected');
result := mTokStr;
skipToken();
end;
begin
case mTokType of
TTStr:
- if (not allowEmpty) and (Length(mTokStr) = 0) then raise Exception.Create('non-empty string expected');
+ if (not allowEmpty) and (Length(mTokStr) = 0) then error('non-empty string expected');
TTId:
begin end;
else
- raise Exception.Create('string or identifier expected');
+ error('string or identifier expected');
end;
result := mTokStr;
skipToken();
function TTextParser.expectInt (): Integer;
begin
- if (mTokType <> TTInt) then raise Exception.Create('string expected');
+ if (mTokType <> TTInt) then error('string expected');
result := mTokInt;
skipToken();
end;
procedure TTextParser.expectTT (ttype: Integer);
begin
- if (mTokType <> ttype) then raise Exception.Create('unexpected token');
+ if (mTokType <> ttype) then error('unexpected token');
skipToken();
end;
procedure TTextParser.expectDelim (const ch: AnsiChar);
begin
- if (mTokType <> TTDelim) or (mTokChar <> ch) then raise Exception.CreateFmt('delimiter ''%s'' expected', [ch]);
+ if (mTokType <> TTDelim) or (mTokChar <> ch) then errorfmt('delimiter ''%s'' expected', [ch]);
skipToken();
end;
function TTextParser.expectDelims (const ch: TAnsiCharSet): AnsiChar;
begin
- if (mTokType <> TTDelim) then raise Exception.Create('delimiter expected');
- if not (mTokChar in ch) then raise Exception.Create('delimiter expected');
+ if (mTokType <> TTDelim) then error('delimiter expected');
+ if not (mTokChar in ch) then error('delimiter expected');
result := mTokChar;
skipToken();
end;
GetMem(mBuffer, BufSize);
mBufPos := 0;
mBufLen := mFile.Read(mBuffer^, BufSize);
- if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
+ if (mBufLen < 0) then error('TFileTextParser: read error');
inherited Create(aopts);
end;
constructor TFileTextParser.Create (st: TStream; astOwned: Boolean=true; aopts: TOptions=[TOption.SignedNumbers]);
begin
- if (st = nil) then raise Exception.Create('cannot create parser for nil stream');
+ if (st = nil) then error('cannot create parser for nil stream');
mFile := st;
mStreamOwned := astOwned;
GetMem(mBuffer, BufSize);
mBufPos := 0;
mBufLen := mFile.Read(mBuffer^, BufSize);
- if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
+ if (mBufLen < 0) then error('TFileTextParser: read error');
inherited Create(aopts);
end;
mBuffer := nil;
mBufPos := 0;
mBufLen := 0;
- if mStreamOwned then mFile.Free();
- mFile := nil;
+ if (mStreamOwned) then FreeAndNil(mFile) else mFile := nil;
inherited;
end;
-procedure TFileTextParser.loadNextChar ();
+function TFileTextParser.loadChar (): AnsiChar;
begin
- if (mBufLen = 0) then begin mNextChar := #0; exit; end;
+ if (mBufLen = 0) then begin result := #0; exit; end;
if (mBufPos >= mBufLen) then
begin
mBufLen := mFile.Read(mBuffer^, BufSize);
- if (mBufLen < 0) then raise Exception.Create('TFileTextParser: read error');
- if (mBufLen = 0) then begin mNextChar := #0; exit; end;
+ if (mBufLen < 0) then error('TFileTextParser: read error');
+ if (mBufLen = 0) then begin result := #0; exit; end;
mBufPos := 0;
end;
assert(mBufPos < mBufLen);
- mNextChar := mBuffer[mBufPos];
+ result := mBuffer[mBufPos];
Inc(mBufPos);
- if (mNextChar = #0) then mNextChar := ' ';
+ if (result = #0) then result := ' ';
end;
end;
-procedure TStrTextParser.loadNextChar ();
+function TStrTextParser.loadChar (): AnsiChar;
begin
- mNextChar := #0;
+ result := #0;
if (mPos > Length(mStr)) then exit;
- mNextChar := mStr[mPos]; Inc(mPos);
- if (mNextChar = #0) then mNextChar := ' ';
+ result := mStr[mPos];
+ Inc(mPos);
+ if (result = #0) then result := ' ';
end;