DEADSOFTWARE

FlexUI: simple styling system (yay, no more hardcoded colors!)
authorKetmar Dark <ketmar@ketmar.no-ip.org>
Thu, 28 Sep 2017 18:52:34 +0000 (21:52 +0300)
committerKetmar Dark <ketmar@ketmar.no-ip.org>
Thu, 28 Sep 2017 18:53:05 +0000 (21:53 +0300)
src/game/Doom2DF.dpr
src/gx/gh_ui.pas
src/gx/gh_ui_style.pas [new file with mode: 0644]
src/shared/hashtable.pas
src/shared/utils.pas
src/shared/xdynrec.pas
src/shared/xparser.pas

index e81b4ae970bdaa871bed0e864ebf94105417be26..41c7aaca14256e6a33ec8e3891e9b0fbd8f615e3 100644 (file)
@@ -114,6 +114,7 @@ uses
   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';
 
index c33a93fb6b3d72a67fbd38f604bcf5bf32522aef..be597b0dfbb75b933b1ed816eca27470b6d1eb10 100644 (file)
@@ -24,6 +24,7 @@ uses
   SysUtils, Classes,
   GL, GLExt, SDL2,
   gh_ui_common,
+  gh_ui_style,
   sdlcarcass, glgfx,
   xparser;
 
@@ -36,9 +37,16 @@ type
   public
     type TActionCB = procedure (me: TUIControl; uinfo: Integer);
 
+  public
+    const ClrIdxActive = 0;
+    const ClrIdxDisabled = 1;
+    const ClrIdxInactive = 2;
+    const ClrIdxMax = 2;
+
   private
     mParent: TUIControl;
     mId: AnsiString;
+    mStyleId: AnsiString;
     mX, mY: Integer;
     mWidth, mHeight: Integer;
     mFrameWidth, mFrameHeight: Integer;
@@ -50,11 +58,24 @@ type
     mEscClose: Boolean; // valid only for top-level controls
     mEatKeys: Boolean;
     mDrawShadow: Boolean;
+    // colors
+    mCtl4Style: AnsiString;
+    mBackColor: array[0..ClrIdxMax] of TGxRGBA;
+    mTextColor: array[0..ClrIdxMax] of TGxRGBA;
+    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;
 
+  protected
+    procedure updateStyle (); virtual;
+    procedure cacheStyle (root: TUIStyle); virtual;
+    function getColorIndex (): Integer; inline;
+
   protected
     function getEnabled (): Boolean;
     procedure setEnabled (v: Boolean); inline;
@@ -197,6 +218,7 @@ type
 
   public
     property id: AnsiString read mId;
+    property styleId: AnsiString read mStyleId;
     property x0: Integer read mX;
     property y0: Integer read mY;
     property height: Integer read mHeight;
@@ -219,6 +241,9 @@ type
     mFreeOnClose: Boolean; // default: false
     mDoCenter: Boolean; // after layouting
 
+  protected
+    procedure cacheStyle (root: TUIStyle); override;
+
   protected
     procedure activated (); override;
     procedure blurred (); override;
@@ -229,6 +254,8 @@ type
   public
     constructor Create (const atitle: AnsiString; ax, ay: Integer; aw: Integer=-1; ah: Integer=-1);
 
+    procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser
+
     function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override;
 
     procedure centerInScreen ();
@@ -304,6 +331,8 @@ type
   public
     constructor Create (ahoriz: Boolean);
 
+    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;
@@ -335,6 +364,8 @@ type
   // ////////////////////////////////////////////////////////////////////// //
   TUILine = class(TUIControl)
   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;
@@ -382,6 +413,8 @@ procedure uiAddWindow (ctl: TUIControl);
 procedure uiRemoveWindow (ctl: TUIControl); // will free window if `mFreeOnClose` is `true`
 function uiVisibleWindow (ctl: TUIControl): Boolean;
 
+procedure uiUpdateStyles ();
+
 
 // ////////////////////////////////////////////////////////////////////////// //
 // do layouting
@@ -482,6 +515,14 @@ var
   uiTopList: array of TUIControl = nil;
 
 
+procedure uiUpdateStyles ();
+var
+  ctl: TUIControl;
+begin
+  for ctl in uiTopList do ctl.updateStyle();
+end;
+
+
 function uiMouseEvent (ev: THMouseEvent): Boolean;
 var
   f, c: Integer;
@@ -528,7 +569,7 @@ end;
 
 procedure uiDraw ();
 var
-  f: Integer;
+  f, cidx: Integer;
   ctl: TUIControl;
 begin
   glMatrixMode(GL_MODELVIEW);
@@ -540,7 +581,9 @@ begin
     begin
       ctl := uiTopList[f];
       ctl.draw();
-      if (f <> High(uiTopList)) then darkenRect(ctl.x0, ctl.y0, ctl.width, ctl.height, 128);
+      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]);
     end;
   finally
     glMatrixMode(GL_MODELVIEW);
@@ -573,6 +616,7 @@ begin
   if (Length(uiTopList) > 0) then uiTopList[High(uiTopList)].blurred();
   SetLength(uiTopList, Length(uiTopList)+1);
   uiTopList[High(uiTopList)] := ctl;
+  ctl.updateStyle();
   ctl.activated();
 end;
 
@@ -624,6 +668,7 @@ end;
 constructor TUIControl.Create ();
 begin
   mParent := nil;
+  mId := '';
   mX := 0;
   mY := 0;
   mWidth := 64;
@@ -650,6 +695,8 @@ begin
   mLineStart := false;
   mHGroup := '';
   mVGroup := '';
+  mStyleId := '';
+  mCtl4Style := '';
   mAlign := -1; // left/top
   mExpand := false;
 end;
@@ -690,6 +737,63 @@ begin
 end;
 
 
+function TUIControl.getColorIndex (): Integer; inline;
+begin
+  if (not mEnabled) then begin result := ClrIdxDisabled; exit; end;
+  if (getFocused) then begin result := ClrIdxActive; exit; end;
+  result := ClrIdxInactive;
+end;
+
+procedure TUIControl.updateStyle ();
+var
+  stl: TUIStyle = nil;
+  ctl: TUIControl;
+begin
+  ctl := self;
+  while (ctl <> nil) do
+  begin
+    if (Length(ctl.mStyleId) <> 0) then begin stl := uiFindStyle(ctl.mStyleId); break; end;
+    ctl := ctl.mParent;
+  end;
+  if (stl = nil) then stl := uiFindStyle(''); // default
+  cacheStyle(stl);
+  for ctl in mChildren do ctl.updateStyle();
+end;
+
+procedure TUIControl.cacheStyle (root: TUIStyle);
+var
+  cst: AnsiString = '';
+begin
+  //writeln('caching style for <', className, '> (', mCtl4Style, ')...');
+  if (Length(mCtl4Style) > 0) then
+  begin
+    cst := mCtl4Style;
+    if (cst[1] <> '@') then cst := '@'+cst;
+  end;
+  // 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);
+  // 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);
+  // 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);
+end;
+
+
 // ////////////////////////////////////////////////////////////////////////// //
 function TUIControl.getDefSize (): TLaySize; inline; begin result := mLayDefSize; end;
 function TUIControl.getMaxSize (): TLaySize; inline; begin result := mLayMaxSize; end;
@@ -926,7 +1030,8 @@ end;
 function TUIControl.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
 begin
   result := true;
-  if (strEquCI1251(prname, 'id')) then begin mId := par.expectStrOrId(true); exit; end; // allow empty strings
+  if (strEquCI1251(prname, 'id')) then begin mId := par.expectIdOrStr(true); exit; end; // allow empty strings
+  if (strEquCI1251(prname, 'style')) then begin mStyleId := par.expectIdOrStr(); exit; end; // no empty strings
   if (strEquCI1251(prname, 'flex')) then begin flex := par.expectInt(); exit; end;
   // sizes
   if (strEquCI1251(prname, 'defsize')) or (strEquCI1251(prname, 'size')) then begin mDefSize := parseSize(par); exit; end;
@@ -941,8 +1046,8 @@ begin
   if (strEquCI1251(prname, 'expand')) then begin mExpand := parseBool(par); exit; end;
   // align
   if (strEquCI1251(prname, 'align')) then begin mAlign := parseAnyAlign(par); exit; end;
-  if (strEquCI1251(prname, 'hgroup')) then begin mHGroup := par.expectStrOrId(true); exit; end; // allow empty strings
-  if (strEquCI1251(prname, 'vgroup')) then begin mVGroup := par.expectStrOrId(true); exit; end; // allow empty strings
+  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;
@@ -998,7 +1103,15 @@ end;
 
 function TUIControl.getFocused (): Boolean; inline;
 begin
-  if (mParent = nil) then result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = self) else result := (topLevel.mFocused = self);
+  if (mParent = nil) then
+  begin
+    result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = self);
+  end
+  else
+  begin
+    result := (topLevel.mFocused = self);
+    if (result) then result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = topLevel);
+  end;
 end;
 
 
@@ -1305,7 +1418,7 @@ end;
 
 procedure TUIControl.drawControl (gx, gy: Integer);
 begin
-  if (mParent = nil) then darkenRect(gx, gy, mWidth, mHeight, 64);
+  //if (mParent = nil) then darkenRect(gx, gy, mWidth, mHeight, 64);
 end;
 
 procedure TUIControl.drawControlPost (gx, gy: Integer);
@@ -1399,6 +1512,11 @@ begin
   mFrameWidth := 8;
   mFrameHeight := 8;
   mTitle := atitle;
+end;
+
+procedure TUITopWindow.AfterConstruction ();
+begin
+  inherited AfterConstruction();
   if (mWidth < mFrameWidth*2+3*8) then mWidth := mFrameWidth*2+3*8;
   if (mHeight < mFrameHeight*2) then mHeight := mFrameHeight*2;
   if (Length(mTitle) > 0) then
@@ -1410,6 +1528,7 @@ begin
   mWaitingClose := false;
   mInClose := false;
   closeCB := nil;
+  mCtl4Style := '';
 end;
 
 
@@ -1417,7 +1536,7 @@ function TUITopWindow.parseProperty (const prname: AnsiString; par: TTextParser)
 begin
   if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then
   begin
-    mTitle := par.expectStrOrId(true);
+    mTitle := par.expectIdOrStr(true);
     result := true;
     exit;
   end;
@@ -1440,6 +1559,12 @@ begin
 end;
 
 
+procedure TUITopWindow.cacheStyle (root: TUIStyle);
+begin
+  inherited cacheStyle(root);
+end;
+
+
 procedure TUITopWindow.centerInScreen ();
 begin
   if (mWidth > 0) and (mHeight > 0) then
@@ -1452,37 +1577,36 @@ end;
 
 procedure TUITopWindow.drawControl (gx, gy: Integer);
 begin
-  fillRect(gx, gy, mWidth, mHeight, TGxRGBA.Create(0, 0, 128));
+  fillRect(gx, gy, mWidth, mHeight, mBackColor[getColorIndex]);
 end;
 
 
 procedure TUITopWindow.drawControlPost (gx, gy: Integer);
-const r = 255;
-const g = 255;
-const b = 255;
 var
+  cidx: Integer;
   tx: Integer;
 begin
+  cidx := getColorIndex;
   if mDragging then
   begin
-    drawRectUI(mX+4, mY+4, mWidth-8, mHeight-8, TGxRGBA.Create(r, g, b));
+    drawRectUI(mX+4, mY+4, mWidth-8, mHeight-8, mFrameColor[cidx]);
   end
   else
   begin
-    drawRectUI(mX+3, mY+3, mWidth-6, mHeight-6, TGxRGBA.Create(r, g, b));
-    drawRectUI(mX+5, mY+5, mWidth-10, mHeight-10, TGxRGBA.Create(r, g, b));
+    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, TGxRGBA.Create(0, 0, 128));
-    drawText8(mX+mFrameWidth, mY, '[ ]', TGxRGBA.Create(r, g, b));
-    if mInClose then drawText8(mX+mFrameWidth+7, mY, '#', TGxRGBA.Create(0, 255, 0))
-    else drawText8(mX+mFrameWidth+7, mY, '*', TGxRGBA.Create(0, 255, 0));
+    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;
   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, TGxRGBA.Create(0, 0, 128));
-    drawText8(tx, mY, mTitle, TGxRGBA.Create(r, g, b));
+    fillRect(tx-3, mY, Length(mTitle)*8+3+2, 8, mBackColor[cidx]);
+    drawText8(tx, mY, mTitle, mFrameTextColor[cidx]);
   end;
   inherited drawControlPost(gx, gy);
 end;
@@ -1845,7 +1969,14 @@ constructor TUIBox.Create (ahoriz: Boolean);
 begin
   inherited Create();
   mHoriz := ahoriz;
+end;
+
+
+procedure TUIBox.AfterConstruction ();
+begin
+  inherited AfterConstruction();
   mCanFocus := false;
+  mCtl4Style := 'box';
 end;
 
 
@@ -1861,7 +1992,7 @@ begin
   end;
   if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then
   begin
-    mCaption := par.expectStrOrId(true);
+    mCaption := par.expectIdOrStr(true);
     mDefSize := TLaySize.Create(Length(mCaption)*8+3, 8);
     result := true;
     exit;
@@ -1878,22 +2009,23 @@ end;
 
 procedure TUIBox.drawControl (gx, gy: Integer);
 var
-  r, g, b: Integer;
+  cidx: Integer;
   tx: Integer;
 begin
-  if focused then begin r := 255; g := 255; b := 255; end else begin r := 255; g := 255; b := 0; end;
+  cidx := getColorIndex;
+  fillRect(gx, gy, mWidth, mHeight, mBackColor[cidx]);
   if mHasFrame then
   begin
     // draw frame
-    drawRectUI(gx+3, gy+3, mWidth-6, mHeight-6, TGxRGBA.Create(r, g, b));
+    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, TGxRGBA.Create(0, 0, 128));
-    drawText8(tx, gy, mCaption, TGxRGBA.Create(r, g, b));
+    if mHasFrame then fillRect(tx-2, gy, Length(mCaption)*8+3, 8, mBackColor[cidx]);
+    drawText8(tx, gy, mCaption, mFrameTextColor[cidx]);
   end;
 end;
 
@@ -1930,7 +2062,6 @@ procedure TUIVBox.AfterConstruction ();
 begin
   inherited AfterConstruction();
   mHoriz := false;
-  mCanFocus := false;
 end;
 
 
@@ -1940,6 +2071,7 @@ begin
   inherited AfterConstruction();
   mExpand := true;
   mCanFocus := false;
+  mCtl4Style := 'span';
 end;
 
 
@@ -1956,6 +2088,15 @@ end;
 
 
 // ////////////////////////////////////////////////////////////////////// //
+procedure TUILine.AfterConstruction ();
+begin
+  inherited AfterConstruction();
+  mExpand := true;
+  mCanFocus := false;
+  mCtl4Style := 'line';
+end;
+
+
 function TUILine.parseProperty (const prname: AnsiString; par: TTextParser): Boolean;
 begin
   if (parseOrientation(prname, par)) then begin result := true; exit; end;
@@ -1964,14 +2105,17 @@ end;
 
 
 procedure TUILine.drawControl (gx, gy: Integer);
+var
+  cidx: Integer;
 begin
+  cidx := getColorIndex;
   if mHoriz then
   begin
-    drawHLine(gx, gy+(mHeight div 2), mWidth, TGxRGBA.Create(255, 255, 255));
+    drawHLine(gx, gy+(mHeight div 2), mWidth, mTextColor[cidx]);
   end
   else
   begin
-    drawVLine(gx+(mWidth div 2), gy, mHeight, TGxRGBA.Create(255, 255, 255));
+    drawVLine(gx+(mWidth div 2), gy, mHeight, mTextColor[cidx]);
   end;
 end;
 
@@ -1979,8 +2123,8 @@ end;
 // ////////////////////////////////////////////////////////////////////////// //
 procedure TUIHLine.AfterConstruction ();
 begin
+  inherited AfterConstruction();
   mHoriz := true;
-  mExpand := true;
   mDefSize.h := 1;
 end;
 
@@ -1988,10 +2132,9 @@ end;
 // ////////////////////////////////////////////////////////////////////////// //
 procedure TUIVLine.AfterConstruction ();
 begin
+  inherited AfterConstruction();
   mHoriz := false;
-  mExpand := true;
   mDefSize.w := 1;
-  //mDefSize.h := 8;
 end;
 
 
@@ -2011,6 +2154,7 @@ begin
   mVAlign := 0;
   mCanFocus := false;
   if (mDefSize.h <= 0) then mDefSize.h := 8;
+  mCtl4Style := 'label';
 end;
 
 
@@ -2018,7 +2162,7 @@ function TUITextLabel.parseProperty (const prname: AnsiString; par: TTextParser)
 begin
   if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then
   begin
-    mText := par.expectStrOrId(true);
+    mText := par.expectIdOrStr(true);
     mDefSize := TLaySize.Create(Length(mText)*8, 8);
     result := true;
     exit;
@@ -2036,11 +2180,10 @@ end;
 procedure TUITextLabel.drawControl (gx, gy: Integer);
 var
   xpos, ypos: Integer;
+  cidx: Integer;
 begin
-  // debug
-  fillRect(gx, gy, mWidth, mHeight, TGxRGBA.Create(96, 96, 0));
-  drawRectUI(gx, gy, mWidth, mHeight, TGxRGBA.Create(96, 96, 96));
-
+  cidx := getColorIndex;
+  fillRect(gx, gy, mWidth, mHeight, mBackColor[cidx]);
   if (Length(mText) > 0) then
   begin
          if (mHAlign < 0) then xpos := 0
@@ -2051,7 +2194,7 @@ begin
     else if (mVAlign > 0) then ypos := mHeight-8
     else ypos := (mHeight-8) div 2;
 
-    drawText8(gx+xpos, gy+ypos, mText, TGxRGBA.Create(255, 255, 255));
+    drawText8(gx+xpos, gy+ypos, mText, mTextColor[cidx]);
   end;
 end;
 
diff --git a/src/gx/gh_ui_style.pas b/src/gx/gh_ui_style.pas
new file mode 100644 (file)
index 0000000..34e5f50
--- /dev/null
@@ -0,0 +1,615 @@
+(* 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 putValue (const path: AnsiString; const val: TStyleValue);
+
+  public
+    constructor Create ();
+    destructor Destroy (); override;
+
+  public
+    property value[const path: AnsiString]: TStyleValue read getValue write putValue; 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 putValue (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 putValue; 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
+  result['back-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 128));
+  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
+
+  result['text-color@label'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
+  result['text-color#disabled@label'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
+
+  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#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));
+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.putValue (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();
+      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.putValue (const path: AnsiString; const val: TStyleValue); inline;
+begin
+  mMain.putValue(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.
index 33920a176e70261225a843d9ffc0dd0cb7663937..1e0cd97c960e19c601d7f50639a0bdcafc3cb489 100644 (file)
@@ -194,6 +194,14 @@ type
     class procedure freekey (var k: AnsiString); inline;
   end;
 
+  // case-insensitive (ansi)
+  THashKeyStrAnsiCI = class
+  public
+    class function hash (const k: AnsiString): LongWord; inline;
+    class function equ (const a, b: AnsiString): Boolean; inline;
+    class procedure freekey (var k: AnsiString); inline;
+  end;
+
 type
   THashIntInt = specialize THashBase<Integer, Integer, THashKeyInt>;
   THashStrInt = specialize THashBase<AnsiString, Integer, THashKeyStr>;
@@ -204,7 +212,7 @@ type
 
 function u32Hash (a: LongWord): LongWord; inline;
 function fnvHash (constref buf; len: LongWord): LongWord;
-function joaatHash (constref buf; len: LongWord): LongWord;
+function joaatHash (constref buf; len: LongWord; seed: LongWord=0): LongWord;
 
 // has to be public due to FPC generics limitation
 function nextPOTU32 (x: LongWord): LongWord; inline;
@@ -281,17 +289,30 @@ end;
 {$POP}
 
 
-function joaatHash (constref buf; len: LongWord): LongWord;
+// ////////////////////////////////////////////////////////////////////////// //
+{$PUSH}
+{$RANGECHECKS OFF}
+function joaatHash (constref buf; len: LongWord; seed: LongWord=0): LongWord;
 var
-  h: TJoaatHasher;
+  b: PByte;
+  f: LongWord;
 begin
-  h := TJoaatHasher.Create(0);
-  h.put(PByte(@buf)^, len);
-  result := h.value;
+  result := seed;
+  b := PByte(@buf);
+  for f := 1 to len do
+  begin
+    result += b^;
+    result += (result shl 10);
+    result := result xor (result shr 6);
+    Inc(b);
+  end;
+  // finalize
+  result += (result shl 3);
+  result := result xor (result shr 11);
+  result += (result shl 15);
 end;
+{$POP}
 
-
-// ////////////////////////////////////////////////////////////////////////// //
 {$PUSH}
 {$RANGECHECKS OFF}
 // fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/
@@ -311,7 +332,6 @@ begin
 end;
 {$POP}
 
-
 {$PUSH}
 {$RANGECHECKS OFF}
 function u32Hash (a: LongWord): LongWord; inline;
@@ -327,6 +347,29 @@ begin
 end;
 {$POP}
 
+function locase1251 (ch: AnsiChar): AnsiChar; inline;
+begin
+  if ch < #128 then
+  begin
+    if (ch >= 'A') and (ch <= 'Z') then Inc(ch, 32);
+  end
+  else
+  begin
+    if (ch >= #192) and (ch <= #223) then
+    begin
+      Inc(ch, 32);
+    end
+    else
+    begin
+      case ch of
+        #168, #170, #175: Inc(ch, 16);
+        #161, #178: Inc(ch);
+      end;
+    end;
+  end;
+  result := ch;
+end;
+
 
 // ////////////////////////////////////////////////////////////////////////// //
 // THashKeyInt
@@ -353,6 +396,42 @@ class function THashKeyStr.equ (const a, b: AnsiString): Boolean; inline; begin
 class procedure THashKeyStr.freekey (var k: AnsiString); inline; begin k := ''; end;
 
 
+// ////////////////////////////////////////////////////////////////////////// //
+// case-insensitive (ansi)
+{$PUSH}
+{$RANGECHECKS OFF}
+// fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/
+function fnvHashLo (constref buf; len: LongWord): LongWord;
+var
+  b: PAnsiChar;
+begin
+  b := @buf;
+  result := 2166136261; // fnv offset basis
+  while (len > 0) do
+  begin
+    result := result xor Byte(locase1251(b^));
+    result := result*16777619; // 32-bit fnv prime
+    Inc(b);
+    Dec(len);
+  end;
+end;
+{$POP}
+
+class function THashKeyStrAnsiCI.hash (const k: AnsiString): LongWord; inline; begin if (Length(k) > 0) then result := fnvHash((@k[1])^, Length(k)) else result := 0; end;
+class function THashKeyStrAnsiCI.equ (const a, b: AnsiString): Boolean; inline;
+var
+  f: Integer;
+begin
+  result := false;
+  if (Length(a) = Length(b)) then
+  begin
+    for f := 1 to Length(a) do if (locase1251(a[f]) <> locase1251(b[f])) then exit;
+  end;
+  result := true;
+end;
+class procedure THashKeyStrAnsiCI.freekey (var k: AnsiString); inline; begin k := ''; end;
+
+
 // ////////////////////////////////////////////////////////////////////////// //
 function THashBase.TEntry.getEmpty (): Boolean; inline; begin result := (hash = 0); end;
 
@@ -366,6 +445,7 @@ begin
   freevalfn := afreevalfn;
   mSeed := u32Hash($29a);
 
+  mFreeEntryHead := nil;
   mFirstEntry := -1;
   mLastEntry := -1;
   clear();
@@ -374,6 +454,7 @@ end;
 
 destructor THashBase.Destroy ();
 begin
+  freeEntries();
   mBuckets := nil;
   mEntries := nil;
   inherited;
@@ -414,14 +495,19 @@ end;
 
 
 procedure THashBase.clear ();
-//var idx: Integer;
 begin
   freeEntries();
+  {
   SetLength(mBuckets, InitSize);
   FillChar(mBuckets[0], InitSize*sizeof(mBuckets[0]), 0);
-  //for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
   SetLength(mEntries, InitSize);
   FillChar(mEntries[0], InitSize*sizeof(mEntries[0]), 0);
+  }
+  mFreeEntryHead := nil;
+  mBuckets := nil;
+  mEntries := nil;
+  mFirstEntry := -1;
+  mLastEntry := -1;
   mBucketsUsed := 0;
 end;
 
@@ -445,6 +531,21 @@ var
 begin
   if (mFreeEntryHead = nil) then
   begin
+    // nothing was allocated, so allocate something now
+    if (Length(mBuckets) = 0) then
+    begin
+      assert(Length(mEntries) = 0);
+      assert(mFirstEntry = -1);
+      assert(mLastEntry = -1);
+      assert(mBucketsUsed = 0);
+      {$IFDEF RBHASH_SANITY_CHECKS}
+      mEntriesUsed := 0;
+      {$ENDIF}
+      SetLength(mBuckets, InitSize);
+      FillChar(mBuckets[0], InitSize*sizeof(mBuckets[0]), 0);
+      SetLength(mEntries, InitSize);
+      FillChar(mEntries[0], InitSize*sizeof(mEntries[0]), 0);
+    end;
     if (mLastEntry = High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (0.0)');
     Inc(mLastEntry);
     if (mFirstEntry = -1) then
index 308293da64e3aed41b94449e6f71a2b3d69727ac..59a49f251dbb3b927cfea195b442f38ab3656ae8 100644 (file)
@@ -81,15 +81,15 @@ function isWadPath (const fn: AnsiString): Boolean;
 function addWadExtension (const fn: AnsiString): AnsiString;
 
 // convert number to strig with nice commas
-function Int64ToStrComma (i: Int64): AnsiString;
+function int64ToStrComma (i: Int64): AnsiString;
 
-function UpCase1251 (ch: Char): Char;
-function LoCase1251 (ch: Char): Char;
+function upcase1251 (ch: AnsiChar): AnsiChar; inline;
+function locase1251 (ch: AnsiChar): AnsiChar; inline;
 
 function toLowerCase1251 (const s: AnsiString): AnsiString;
 
 // `true` if strings are equal; ignoring case for cp1251
-function StrEquCI1251 (const s0, s1: AnsiString): Boolean;
+function strEquCI1251 (const s0, s1: AnsiString): Boolean;
 
 function utf8Valid (const s: AnsiString): Boolean;
 
@@ -537,25 +537,25 @@ var
     if (code < 0) or (code > $10FFFF) then begin result := '?'; exit; end;
     if (code <= $7f) then
     begin
-      result := Char(code and $ff);
+      result := AnsiChar(code and $ff);
     end
     else if (code <= $7FF) then
     begin
-      result := Char($C0 or (code shr 6));
-      result += Char($80 or (code and $3F));
+      result := AnsiChar($C0 or (code shr 6));
+      result += AnsiChar($80 or (code and $3F));
     end
     else if (code <= $FFFF) then
     begin
-      result := Char($E0 or (code shr 12));
-      result += Char($80 or ((code shr 6) and $3F));
-      result += Char($80 or (code and $3F));
+      result := AnsiChar($E0 or (code shr 12));
+      result += AnsiChar($80 or ((code shr 6) and $3F));
+      result += AnsiChar($80 or (code and $3F));
     end
     else if (code <= $10FFFF) then
     begin
-      result := Char($F0 or (code shr 18));
-      result += Char($80 or ((code shr 12) and $3F));
-      result += Char($80 or ((code shr 6) and $3F));
-      result += Char($80 or (code and $3F));
+      result := AnsiChar($F0 or (code shr 18));
+      result += AnsiChar($80 or ((code shr 12) and $3F));
+      result += AnsiChar($80 or ((code shr 6) and $3F));
+      result += AnsiChar($80 or (code and $3F));
     end
     else
     begin
@@ -844,7 +844,7 @@ begin
 end;
 
 
-function Int64ToStrComma (i: Int64): AnsiString;
+function int64ToStrComma (i: Int64): AnsiString;
 var
   f: Integer;
 begin
@@ -857,7 +857,7 @@ begin
 end;
 
 
-function UpCase1251 (ch: Char): Char;
+function upcase1251 (ch: AnsiChar): AnsiChar; inline;
 begin
   if ch < #128 then
   begin
@@ -881,7 +881,7 @@ begin
 end;
 
 
-function LoCase1251 (ch: Char): Char;
+function locase1251 (ch: AnsiChar): AnsiChar; inline;
 begin
   if ch < #128 then
   begin
@@ -905,7 +905,7 @@ begin
 end;
 
 
-function StrEquCI1251 (const s0, s1: AnsiString): Boolean;
+function strEquCI1251 (const s0, s1: AnsiString): Boolean;
 var
   i: Integer;
 begin
@@ -991,7 +991,7 @@ const
   );
 
 
-function decodeUtf8Char (s: AnsiString; var pos: Integer): char;
+function decodeUtf8Char (s: AnsiString; var pos: Integer): AnsiChar;
 var
   b, c: Integer;
 begin
@@ -1009,7 +1009,7 @@ begin
 
   b := Byte(s[pos]);
   Inc(pos);
-  if b < $80 then begin result := char(b); exit; end;
+  if b < $80 then begin result := AnsiChar(b); exit; end;
 
   // mask out unused bits
        if (b and $FE) = $FC then b := b and $01
@@ -1030,7 +1030,7 @@ begin
   end;
 
   // done, try 1251
-  for c := 128 to 255 do if uni2wint[c] = b then begin result := char(c and $FF); exit; end;
+  for c := 128 to 255 do if uni2wint[c] = b then begin result := AnsiChar(c and $FF); exit; end;
   // alas
 end;
 
@@ -1186,7 +1186,7 @@ end;
 
 function checkSign (st: TStream; const sign: AnsiString): Boolean;
 var
-  buf: packed array[0..7] of Char;
+  buf: packed array[0..7] of AnsiChar;
   f: Integer;
 begin
   result := false;
index 7d1098ee7de0710dfef124fb51c02de429561f66..4676ae7dbacedee78877876546e29260a5cd34bf 100644 (file)
@@ -1180,7 +1180,7 @@ begin
   ahelp := '';
 
   // field name
-  fldname := pr.expectStrOrId();
+  fldname := pr.expectIdOrStr();
 
   while (not pr.isDelim(';')) do
   begin
@@ -2612,7 +2612,7 @@ begin
   end
   else
   begin
-    mTypeName := pr.expectStrOrId();
+    mTypeName := pr.expectIdOrStr();
     while (not pr.isDelim('{')) do
     begin
       if pr.eatId('header') then begin mHeader := true; continue; end;
index 4e45fc6849cf1e6861e94c87664996b1153e6b6d..5332f0afe7c4af022019799a6d2eb4ce796f40c0 100644 (file)
@@ -65,6 +65,7 @@ type
         SignedNumbers, // allow signed numbers; otherwise sign will be TTDelim
         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 '-')
         PascalComments // allow `{}` pascal comments
       );
       TOptions = set of TOption;
@@ -118,7 +119,7 @@ type
     function expectStr (allowEmpty: Boolean=false): AnsiString;
     function expectInt (): Integer;
 
-    function expectStrOrId (allowEmpty: Boolean=false): AnsiString;
+    function expectIdOrStr (allowEmpty: Boolean=false): AnsiString;
 
     procedure expectTT (ttype: Integer);
     function eatTT (ttype: Integer): Boolean;
@@ -306,7 +307,7 @@ begin
 end;
 
 
-function TTextParser.isEOF (): Boolean; inline; begin result := (mCurChar = #0); end;
+function TTextParser.isEOF (): Boolean; inline; begin {result := (mCurChar = #0);} result := (mTokType = TTEOF); end;
 
 
 procedure TTextParser.warmup ();
@@ -339,26 +340,26 @@ function TTextParser.skipBlanks (): Boolean;
 var
   level: Integer;
 begin
-  while not isEOF do
+  while (mCurChar <> #0) do
   begin
-    if (curChar = '/') then
+    if (mCurChar = '/') then
     begin
       // single-line comment
-      if (nextChar = '/') then
+      if (mNextChar = '/') then
       begin
-        while not isEOF and (curChar <> #10) do skipChar();
+        while (mCurChar <> #0) and (mCurChar <> #10) do skipChar();
         skipChar(); // skip EOL
         continue;
       end;
       // multline comment
-      if (nextChar = '*') then
+      if (mNextChar = '*') then
       begin
         // skip comment start
         skipChar();
         skipChar();
-        while not isEOF do
+        while (mCurChar <> #0) do
         begin
-          if (curChar = '*') and (nextChar = '/') then
+          if (mCurChar = '*') and (mNextChar = '/') then
           begin
             // skip comment end
             skipChar();
@@ -370,15 +371,15 @@ begin
         continue;
       end;
       // nesting multline comment
-      if (nextChar = '+') then
+      if (mNextChar = '+') then
       begin
         // skip comment start
         skipChar();
         skipChar();
         level := 1;
-        while not isEOF do
+        while (mCurChar <> #0) do
         begin
-          if (curChar = '+') and (nextChar = '/') then
+          if (mCurChar = '+') and (mNextChar = '/') then
           begin
             // skip comment end
             skipChar();
@@ -387,7 +388,7 @@ begin
             if (level = 0) then break;
             continue;
           end;
-          if (curChar = '/') and (nextChar = '+') then
+          if (mCurChar = '/') and (mNextChar = '+') then
           begin
             // skip comment start
             skipChar();
@@ -400,14 +401,14 @@ begin
         continue;
       end;
     end
-    else if (curChar = '(') and (nextChar = '*') then
+    else if (mCurChar = '(') and (mNextChar = '*') then
     begin
       // pascal comment; skip comment start
       skipChar();
       skipChar();
-      while not isEOF do
+      while (mCurChar <> #0) do
       begin
-        if (curChar = '*') and (nextChar = ')') then
+        if (mCurChar = '*') and (mNextChar = ')') then
         begin
           // skip comment end
           skipChar();
@@ -418,13 +419,13 @@ begin
       end;
       continue;
     end
-    else if (curChar = '{') and (TOption.PascalComments in mOptions) then
+    else if (mCurChar = '{') and (TOption.PascalComments in mOptions) then
     begin
       // pascal comment; skip comment start
       skipChar();
-      while not isEOF do
+      while (mCurChar <> #0) do
       begin
-        if (curChar = '}') then
+        if (mCurChar = '}') then
         begin
           // skip comment end
           skipChar();
@@ -434,10 +435,10 @@ begin
       end;
       continue;
     end;
-    if (curChar > ' ') then break;
+    if (mCurChar > ' ') then break;
     skipChar(); // skip blank
   end;
-  result := not isEOF;
+  result := (mCurChar <> #0);
 end;
 
 
@@ -461,11 +462,11 @@ function TTextParser.skipToken (): Boolean;
   begin
     if (TOption.SignedNumbers in mOptions) then
     begin
-      if (curChar = '+') or (curChar = '-') then
+      if (mCurChar = '+') or (mCurChar = '-') then
       begin
-        neg := (curChar = '-');
+        neg := (mCurChar = '-');
         skipChar();
-        if (curChar < '0') or (curChar > '9') then
+        if (mCurChar < '0') or (mCurChar > '9') then
         begin
           mTokType := TTDelim;
           if (neg) then mTokChar := '-' else mTokChar := '+';
@@ -473,9 +474,9 @@ function TTextParser.skipToken (): Boolean;
         end;
       end;
     end;
-    if (curChar = '0') then
+    if (mCurChar = '0') then
     begin
-      case nextChar of
+      case mNextChar of
         'b','B': base := 2;
         'o','O': base := 8;
         'd','D': base := 10;
@@ -490,12 +491,12 @@ function TTextParser.skipToken (): Boolean;
     end;
     // default base
     if (base < 0) then base := 10;
-    if (digitInBase(curChar, base) < 0) then raise Exception.Create('invalid number');
+    if (digitInBase(mCurChar, base) < 0) then raise Exception.Create('invalid number');
     mTokType := TTInt;
     mTokInt := 0; // just in case
-    while not isEOF do
+    while (mCurChar <> #0) do
     begin
-      n := digitInBase(curChar, base);
+      n := digitInBase(mCurChar, base);
       if (n < 0) then break;
       n := mTokInt*10+n;
       if (n < 0) or (n < mTokInt) then raise Exception.Create('integer overflow');
@@ -503,10 +504,10 @@ function TTextParser.skipToken (): Boolean;
       skipChar();
     end;
     // check for valid number end
-    if not isEOF then
+    if (mCurChar <> #0) then
     begin
-      if (curChar = '.') then raise Exception.Create('floating numbers aren''t supported yet');
-      if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then
+      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;
@@ -521,15 +522,15 @@ function TTextParser.skipToken (): Boolean;
   begin
     mTokType := TTStr;
     mTokStr := ''; // just in case
-    qch := curChar;
+    qch := mCurChar;
     skipChar(); // skip starting quote
-    while not isEOF do
+    while (mCurChar <> #0) do
     begin
       // escape
-      if (qch = '"') and (curChar = '\') then
+      if (qch = '"') and (mCurChar = '\') then
       begin
-        if (nextChar = #0) then raise Exception.Create('unterminated string escape');
-        ch := nextChar;
+        if (mNextChar = #0) then raise Exception.Create('unterminated string escape');
+        ch := mNextChar;
         // skip backslash and escape type
         skipChar();
         skipChar();
@@ -541,12 +542,12 @@ function TTextParser.skipToken (): Boolean;
           'e': mTokStr += #27;
           'x', 'X': // hex escape
             begin
-              n := digitInBase(curChar, 16);
+              n := digitInBase(mCurChar, 16);
               if (n < 0) then raise Exception.Create('invalid hexstr escape');
               skipChar();
-              if (digitInBase(curChar, 16) > 0) then
+              if (digitInBase(mCurChar, 16) > 0) then
               begin
-                n := n*16+digitInBase(curChar, 16);
+                n := n*16+digitInBase(mCurChar, 16);
                 skipChar();
               end;
               mTokStr += AnsiChar(n);
@@ -556,7 +557,7 @@ function TTextParser.skipToken (): Boolean;
         continue;
       end;
       // duplicate single quote (pascal style)
-      if (qch = '''') and (curChar = '''') and (nextChar = '''') then
+      if (qch = '''') and (mCurChar = '''') and (mNextChar = '''') then
       begin
         // skip both quotes
         skipChar();
@@ -564,12 +565,12 @@ function TTextParser.skipToken (): Boolean;
         mTokStr += '''';
         continue;
       end;
-      if (curChar = qch) then
+      if (mCurChar = qch) then
       begin
         skipChar(); // skip ending quote
         break;
       end;
-      mTokStr += curChar;
+      mTokStr += mCurChar;
       skipChar();
     end;
   end;
@@ -578,20 +579,21 @@ function TTextParser.skipToken (): Boolean;
   begin
     mTokType := TTId;
     mTokStr := ''; // just in case
-    while (curChar = '_') or ((curChar >= '0') and (curChar <= '9')) or
-          ((curChar >= 'A') and (curChar <= 'Z')) or
-          ((curChar >= 'a') and (curChar <= 'z')) or
-          (curChar >= #128) or
-          ((TOption.DollarIsId in mOptions) and (curChar = '$')) or
-          ((TOption.DotIsId in mOptions) and (curChar = '.') and (nextChar <> '.')) do
+    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
     begin
-      mTokStr += curChar;
+      mTokStr += mCurChar;
       skipChar();
     end;
   end;
 
 begin
-  mTokType := TTEOF;
+  mTokType := TTNone;
   mTokStr := '';
   mTokChar := #0;
   mTokInt := 0;
@@ -599,6 +601,7 @@ begin
   if not skipBlanks() then
   begin
     result := false;
+    mTokType := TTEOF;
     mTokLine := mLine;
     mTokCol := mCol;
     exit;
@@ -610,22 +613,22 @@ begin
   result := true;
 
   // number?
-  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;
+  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;
 
   // string?
-  if (curChar = '"') or (curChar = '''') then begin parseString(); exit; end;
+  if (mCurChar = '"') or (mCurChar = '''') then begin parseString(); exit; end;
 
   // identifier?
-  if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then begin parseId(); exit; end;
-  if (TOption.DollarIsId in mOptions) and (curChar = '$') then begin parseId(); exit; end;
-  if (TOption.DotIsId in mOptions) and (curChar = '.') and (nextChar <> '.') then begin parseId(); exit; end;
+  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;
 
   // known delimiters?
-  mTokChar := curChar;
+  mTokChar := mCurChar;
   mTokType := TTDelim;
   skipChar();
-  if (curChar = '=') then
+  if (mCurChar = '=') then
   begin
     case mTokChar of
       '<': begin mTokType := TTLessEqu; mTokStr := '<='; skipChar(); exit; end;
@@ -635,7 +638,7 @@ begin
       ':': begin mTokType := TTAss; mTokStr := ':='; skipChar(); exit; end;
     end;
   end
-  else if (mTokChar = curChar) then
+  else if (mTokChar = mCurChar) then
   begin
     case mTokChar of
       '<': begin mTokType := TTShl; mTokStr := '<<'; skipChar(); exit; end;
@@ -647,8 +650,8 @@ begin
   else
   begin
     case mTokChar of
-      '<': if (curChar = '>') then begin mTokType := TTNotEqu; mTokStr := '<>'; skipChar(); exit; end;
-      '.': if (curChar = '.') then begin mTokType := TTDotDot; mTokStr := '..'; skipChar(); exit; end;
+      '<': if (mCurChar = '>') then begin mTokType := TTNotEqu; mTokStr := '<>'; skipChar(); exit; end;
+      '.': if (mCurChar = '.') then begin mTokType := TTDotDot; mTokStr := '..'; skipChar(); exit; end;
     end;
   end;
 end;
@@ -727,7 +730,7 @@ begin
 end;
 
 
-function TTextParser.expectStrOrId (allowEmpty: Boolean=false): AnsiString;
+function TTextParser.expectIdOrStr (allowEmpty: Boolean=false): AnsiString;
 begin
   case mTokType of
     TTStr: