src/gx/gh_ui_style.pas

   1 (* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
   2  * Understanding is not required. Only obedience.
   3  *
   4  * This program is free software: you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation, either version 3 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program. If not, see <http://www.gnu.org/licenses/>.
  16  *)
  17 {$INCLUDE ../../shared/a_modes.inc}
  18 {.$DEFINE UI_STYLE_DEBUG_SEARCH}
  19 unit gh_ui_style;
  20
  21 interface
  22
  23 uses
  24   SysUtils, Classes,
  25   glgfx,
  26   xstreams, xparser, utils, hashtable;
  27
  28
  29 type
  30   TStyleSection = class;
  31
  32   TStyleValue = packed record
  33   public
  34     type TType = (Empty, Bool, Int, Color, Str);
  35
  36   public
  37     constructor Create (v: Boolean);
  38     constructor Create (v: Integer);
  39     constructor Create (ar, ag, ab: Integer; aa: Integer=255);
  40     constructor Create (const v: TGxRGBA);
  41     constructor Create (const v: AnsiString);
  42
  43     function isEmpty (): Boolean; inline;
  44
  45     function toString (): AnsiString;
  46     function asRGBA: TGxRGBA; inline;
  47     function asRGBADef (const def: TGxRGBA): TGxRGBA; inline;
  48     function asInt (const def: Integer=0): Integer; inline;
  49     function asBool (const def: Boolean=false): Boolean; inline;
  50     function asStr (const def: AnsiString=''): AnsiString; inline;
  51
  52   public
  53     vtype: TType;
  54     case TType of
  55       TType.Bool: (bval: Boolean);
  56       TType.Int: (ival: Integer);
  57       TType.Color: (r, g, b, a: Byte);
  58       TType.Str: (sval: Pointer); // AnsiString
  59   end;
  60
  61   THashStrStyleVal = specialize THashBase<AnsiString, TStyleValue, THashKeyStrAnsiCI>;
  62   THashStrSection = specialize THashBase<AnsiString, TStyleSection, THashKeyStrAnsiCI>;
  63
  64   TStyleSection = class
  65   private
  66     mParent: TStyleSection; // for inheritance
  67     mInherits: AnsiString;
  68     mHashName: AnsiString; // for this section
  69     mCtlName: AnsiString; // for this section
  70     mVals: THashStrStyleVal;
  71     mHashes: THashStrSection;
  72     mCtls: THashStrSection;
  73
  74   private
  75     function getTopLevel (): TStyleSection; inline;
  76     // "text-color#inactive@label"
  77     function getValue (const path: AnsiString): TStyleValue;
  78
  79   public
  80     constructor Create ();
  81     destructor Destroy (); override;
  82
  83     function get (name, hash, ctl: AnsiString): TStyleValue;
  84
  85   public
  86     property value[const path: AnsiString]: TStyleValue read getValue; default;
  87     property topLevel: TStyleSection read getTopLevel;
  88   end;
  89
  90   TUIStyle = class
  91   private
  92     mId: AnsiString; // style name ('default', for example)
  93     mMain: TStyleSection;
  94
  95   private
  96     procedure createMain ();
  97
  98     procedure parse (par: TTextParser);
  99
 100     function getValue (const path: AnsiString): TStyleValue; inline;
 101
 102   public
 103     constructor Create (const aid: AnsiString);
 104     constructor Create (st: TStream); // parse from stream
 105     constructor CreateFromFile (const fname: AnsiString);
 106     destructor Destroy (); override;
 107
 108     function get (name, hash, ctl: AnsiString): TStyleValue;
 109
 110   public
 111     property id: AnsiString read mId;
 112     property value[const path: AnsiString]: TStyleValue read getValue; default;
 113   end;
 114
 115
 116 procedure uiLoadStyles (const fname: AnsiString);
 117 procedure uiLoadStyles (st: TStream);
 118
 119 // will return "default" (or raise an exception if there is no "default")
 120 function uiFindStyle (const stname: AnsiString): TUIStyle;
 121
 122
 123 implementation
 124
 125
 126 // ////////////////////////////////////////////////////////////////////////// //
 127 const
 128   defaultStyleStr =
 129     'default {'#10+
 130     '  back-color: #008;'#10+
 131     '  #active: { text-color: #fff; frame-color: #fff; frame-text-color: #fff; frame-icon-color: #0f0; }'#10+
 132     '  #inactive: { text-color: #aaa; frame-color: #aaa; frame-text-color: #aaa; frame-icon-color: #0a0; }'#10+
 133     '  #disabled: { text-color: #666; frame-color: #888; frame-text-color: #888; frame-icon-color: #080; }'#10+
 134     '  @simple_text: { text-color: #ff0; #inactive(#active); }'#10+
 135     '  @cb_listbox: { current-item-back-color: #080; text-color: #ff0; #inactive(#active) { current-item-back-color: #000; } }'#10+
 136     '  @window: { #inactive(#active): { darken: 128; } }'#10+
 137     '  @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+
 138     '  @label: { #active: {back-color: #440;} #inactive(#active); }'#10+
 139     '  @static: { text-color: #ff0; #inactive(#active); }'#10+
 140     '  @box: { #inactive(#active); }'#10+
 141     '}'#10+
 142     '';
 143 var
 144   styles: array of TUIStyle = nil;
 145
 146
 147 function createDefaultStyle (): TUIStyle;
 148 var
 149   st: TStream;
 150 begin
 151   result := nil;
 152   st := TStringStream.Create(defaultStyleStr);
 153   st.position := 0;
 154   try
 155     result := TUIStyle.Create(st);
 156   finally
 157     FreeAndNil(st);
 158   end;
 159 end;
 160
 161
 162 function uiFindStyle (const stname: AnsiString): TUIStyle;
 163 var
 164   stl: TUIStyle;
 165 begin
 166   if (Length(stname) > 0) then
 167   begin
 168     for stl in styles do if (strEquCI1251(stl.mId, stname)) then begin result := stl; exit; end;
 169   end;
 170   for stl in styles do if (strEquCI1251(stl.mId, 'default')) then begin result := stl; exit; end;
 171   stl := createDefaultStyle();
 172   SetLength(styles, Length(styles)+1);
 173   styles[High(styles)] := stl;
 174   result := stl;
 175 end;
 176
 177
 178 procedure uiLoadStyles (const fname: AnsiString);
 179 var
 180   st: TStream;
 181 begin
 182   st := openDiskFileRO(fname);
 183   try
 184     uiLoadStyles(st);
 185   finally
 186     st.Free();
 187   end;
 188 end;
 189
 190
 191 procedure uiLoadStyles (st: TStream);
 192 var
 193   par: TTextParser;
 194   stl: TUIStyle = nil;
 195   f: Integer;
 196 begin
 197   if (st = nil) then raise Exception.Create('cannot load UI styles from nil stream');
 198   par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId, par.TOption.HtmlColors]);
 199   styles := nil;
 200   try
 201     while (not par.isEOF) do
 202     begin
 203       stl := TUIStyle.Create('');
 204       stl.parse(par);
 205       //writeln('new style: <', stl.mId, '>');
 206       f := 0;
 207       while (f < Length(styles)) do begin if (strEquCI1251(styles[f].mId, stl.mId)) then break; Inc(f); end;
 208       if (f < Length(styles)) then
 209       begin
 210         FreeAndNil(styles[f]);
 211       end
 212       else
 213       begin
 214         f := Length(styles);
 215         SetLength(styles, f+1);
 216       end;
 217       styles[f] := stl;
 218       stl := nil;
 219     end;
 220   finally
 221     stl.Free();
 222     par.Free();
 223   end;
 224   // we should have "default" style
 225   for f := 0 to High(styles) do if (strEquCI1251(styles[f].mId, 'default')) then exit;
 226   stl := createDefaultStyle();
 227   SetLength(styles, Length(styles)+1);
 228   styles[High(styles)] := stl;
 229 end;
 230
 231
 232 // ////////////////////////////////////////////////////////////////////////// //
 233 procedure freeValueCB (var v: TStyleValue); begin
 234   if (v.vtype = v.TType.Str) then
 235   begin
 236     AnsiString(v.sval) := '';
 237   end;
 238   v.vtype := v.TType.Empty;
 239 end;
 240
 241 constructor TStyleValue.Create (v: Boolean); begin vtype := TType.Bool; bval := v; end;
 242 constructor TStyleValue.Create (v: Integer); begin vtype := TType.Int; ival := v; end;
 243 constructor TStyleValue.Create (const v: AnsiString); begin vtype := TType.Str; sval := Pointer(v); end;
 244
 245 constructor TStyleValue.Create (ar, ag, ab: Integer; aa: Integer=255);
 246 begin
 247   vtype := TType.Color;
 248   r := nmax(0, nmin(ar, 255));
 249   g := nmax(0, nmin(ag, 255));
 250   b := nmax(0, nmin(ab, 255));
 251   a := nmax(0, nmin(aa, 255));
 252 end;
 253
 254 constructor TStyleValue.Create (const v: TGxRGBA);
 255 begin
 256   vtype := TType.Color;
 257   r := v.r;
 258   g := v.g;
 259   b := v.b;
 260   a := v.a;
 261 end;
 262
 263 function TStyleValue.isEmpty (): Boolean; inline; begin result := (vtype = TType.Empty); end;
 264 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;
 265 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;
 266 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;
 267 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;
 268 function TStyleValue.asStr (const def: AnsiString=''): AnsiString; inline; begin if (vtype = TType.Str) then result := AnsiString(sval) else result := def; end;
 269
 270 function TStyleValue.toString (): AnsiString;
 271 begin
 272   case vtype of
 273     TType.Empty: result := '<empty>';
 274     TType.Bool: if bval then result := 'true' else result := 'false';
 275     TType.Int: result := formatstrf('%s', [ival]);
 276     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]);
 277     else result := '<invalid>';
 278   end;
 279 end;
 280
 281
 282 // ////////////////////////////////////////////////////////////////////////// //
 283 procedure freeSectionCB (var v: TStyleSection); begin FreeAndNil(v); end;
 284
 285
 286 function splitPath (const path: AnsiString; out name, hash, ctl: AnsiString): Boolean;
 287 var
 288   hashPos, atPos: Integer;
 289 begin
 290   result := false;
 291   name := '';
 292   hash := '';
 293   ctl := '';
 294   hashPos := pos('#', path);
 295   atPos := pos('@', path);
 296   // split
 297   if (atPos > 0) then
 298   begin
 299     // has ctl, and (possible) hash
 300     if (hashPos > 0) then
 301     begin
 302       // has ctl and hash
 303       if (atPos < hashPos) then
 304       begin
 305         // @ctl#hash
 306         if (atPos > 1) then name := Copy(path, 1, atPos-1);
 307         Inc(atPos); // skip "at"
 308         if (atPos < hashPos) then ctl := Copy(path, atPos, hashPos-atPos);
 309         Inc(hashPos); // skip hash
 310         if (hashPos <= Length(path)) then hash := Copy(path, hashPos, Length(path)-hashPos+1);
 311       end
 312       else
 313       begin
 314         // #hash@ctl
 315         if (hashPos > 1) then name := Copy(path, 1, hashPos-1);
 316         Inc(hashPos); // skip hash
 317         if (hashPos < atPos) then hash := Copy(path, hashPos, atPos-hashPos);
 318         Inc(atPos); // skip "at"
 319         if (atPos <= Length(path)) then ctl := Copy(path, atPos, Length(path)-atPos+1);
 320       end;
 321     end
 322     else
 323     begin
 324       // has only ctl
 325       if (atPos > 1) then name := Copy(path, 1, atPos-1);
 326       Inc(atPos); // skip "at"
 327       if (atPos <= Length(path)) then ctl := Copy(path, atPos, Length(path)-atPos+1);
 328     end;
 329   end
 330   else if (hashPos > 0) then
 331   begin
 332     // has hash
 333     if (hashPos > 1) then name := Copy(path, 1, hashPos-1);
 334     Inc(hashPos); // skip hash
 335     if (hashPos <= Length(path)) then hash := Copy(path, hashPos, Length(path)-hashPos+1);
 336   end
 337   else
 338   begin
 339     // only name
 340     name := path;
 341   end;
 342   result := true;
 343 end;
 344
 345
 346 // ////////////////////////////////////////////////////////////////////////// //
 347 constructor TStyleSection.Create ();
 348 begin
 349   mParent := nil;
 350   mInherits := '';
 351   mHashName := '';
 352   mCtlName := '';
 353   mVals := THashStrStyleVal.Create(freeValueCB);
 354   mHashes := THashStrSection.Create(freeSectionCB);
 355   mCtls := THashStrSection.Create(freeSectionCB);
 356 end;
 357
 358
 359 destructor TStyleSection.Destroy ();
 360 begin
 361   FreeAndNil(mVals);
 362   FreeAndNil(mHashes);
 363   FreeAndNil(mCtls);
 364   mParent := nil;
 365   mInherits := '';
 366   mHashName := '';
 367   mCtlName := '';
 368   inherited;
 369 end;
 370
 371
 372 function TStyleSection.getTopLevel (): TStyleSection; inline;
 373 begin
 374   result := self;
 375   while (result.mParent <> nil) do result := result.mParent;
 376 end;
 377
 378
 379 function TStyleSection.get (name, hash, ctl: AnsiString): TStyleValue;
 380 var
 381   tmp: AnsiString;
 382   sect, s1, so: TStyleSection;
 383   jumpsLeft: Integer = 32; // max inheritance level
 384   skipInherits: Boolean = false;
 385 begin
 386   result.vtype := result.TType.Empty;
 387   if (Length(name) = 0) then exit; // alas
 388   {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('***GET: <', name, '#', hash, '@', ctl, '>');{$ENDIF}
 389   // try control
 390   sect := self;
 391   if (Length(ctl) > 0) then
 392   begin
 393     if (not strEquCI1251(ctl, mCtlName)) then
 394     begin
 395       // has ctl section?
 396       if (not topLevel.mCtls.get(ctl, sect)) then sect := topLevel;
 397     end;
 398   end;
 399   // has hash?
 400   if (Length(hash) > 0) then
 401   begin
 402     if (not strEquCI1251(hash, sect.mHashName)) then
 403     begin
 404       if (sect.mHashes.get(hash, s1)) then sect := s1;
 405     end;
 406   end;
 407   // try name, go up with inheritance
 408   while (jumpsLeft > 0) do
 409   begin
 410     if (sect.mVals.get(name, result)) then
 411     begin
 412       if (not result.isEmpty) then exit; // i found her!
 413     end;
 414     // go up
 415     if (skipInherits) or (Length(sect.mInherits) = 0) then
 416     begin
 417       skipInherits := false;
 418       // for hash section: try parent section first
 419       if (Length(sect.mHashName) > 0) then
 420       begin
 421         {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('search for <#', hash, '@', ctl, '> at <#', sect.mHashName, '@', sect.mCtlName, '>: hash up');{$ENDIF}
 422         sect := sect.mParent;
 423         if (sect = nil) then break; // alas
 424         {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' hash up: trying <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
 425         if (sect.mVals.get(name, result)) then
 426         begin
 427           if (not result.isEmpty) then exit; // i found her!
 428         end;
 429         // move another parent up
 430         sect := sect.mParent;
 431         if (sect = nil) then break; // alas
 432         {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' hash up: jumped up twice to <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
 433       end
 434       else
 435       begin
 436         // one parent up
 437         {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('search for <#', hash, '@', ctl, '> at <#', sect.mHashName, '@', sect.mCtlName, '>: jump up');{$ENDIF}
 438         sect := sect.mParent;
 439         if (sect = nil) then break; // alas
 440       end;
 441       // here, we should have non-hash section
 442       assert(Length(sect.mHashName) = 0);
 443       // if we want hash, try to find it, otherwise do nothing
 444       if (Length(hash) > 0) then
 445       begin
 446         {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' search for <#', hash, '@', ctl, '> at <#', sect.mHashName, '@', sect.mCtlName, '>: hash down');{$ENDIF}
 447         if (sect.mHashes.get(hash, s1)) then
 448         begin
 449           sect := s1;
 450           {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('  found <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
 451         end;
 452       end;
 453     end
 454     else
 455     begin
 456       // inheritance
 457       Dec(jumpsLeft);
 458       if (jumpsLeft < 1) then break; // alas
 459       {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('inherits: <', sect.mInherits, '>');{$ENDIF}
 460       // parse inherit string
 461       if (not splitPath(sect.mInherits, tmp, hash, ctl)) then exit; // alas
 462       {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('inherits: <', hash, '>:<', ctl, '>');{$ENDIF}
 463       // find section
 464       if (Length(ctl) > 0) then
 465       begin
 466         // ctl
 467              if (strEquCI1251(ctl, '$main$')) then sect := topLevel
 468         else if (strEquCI1251(ctl, '$up$')) then begin if (Length(sect.mHashName) <> 0) then sect := sect.mParent.mParent else sect := sect.mParent; end
 469         else if (not topLevel.mCtls.get(ctl, sect)) then sect := topLevel;
 470         if (sect = nil) then break; // alas
 471         if (Length(hash) > 0) then
 472         begin
 473           if (sect.mHashes.get(hash, s1)) then sect := s1;
 474         end;
 475       end
 476       else
 477       begin
 478         // hash
 479         assert(Length(hash) > 0);
 480         // dummy loop, so i can use `break`
 481         repeat
 482           // get out of hash section
 483           if (Length(sect.mHashName) > 0) then
 484           begin
 485             {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('hash-jump-up: <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
 486             sect := sect.mParent;
 487             if (sect = nil) then break; // alas
 488             // check for hash section in parent; use parent if there is no such hash section
 489             {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' checking parent: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
 490             so := sect;
 491             if (sect.mHashes.get(hash, s1)) then
 492             begin
 493               if (s1 <> sect) and (s1 <> so) then
 494               begin
 495                 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('  found in parent: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
 496                 sect := s1;
 497               end;
 498             end;
 499           end
 500           else
 501           begin
 502             // we're in parent, try to find hash section
 503             {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' checking: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
 504             if (sect.mHashes.get(hash, s1)) then
 505             begin
 506               {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('  found: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
 507               sect := s1;
 508             end
 509             else
 510             begin
 511               // reuse current parent, but don't follow inheritance for it
 512               skipInherits := true;
 513             end;
 514           end;
 515         until true;
 516         if (sect = nil) then break;
 517       end;
 518     end;
 519   end;
 520   // alas
 521   result.vtype := result.TType.Empty;
 522 end;
 523
 524
 525 // "text-color#inactive@label"
 526 function TStyleSection.getValue (const path: AnsiString): TStyleValue;
 527 var
 528   name, hash, ctl: AnsiString;
 529 begin
 530   result.vtype := result.TType.Empty;
 531   if (not splitPath(path, name, hash, ctl)) then exit; // alas
 532   //writeln('name:<', name, '>; hash:<', hash, '>; ctl:<', ctl, '>');
 533   result := get(name, hash, ctl);
 534 end;
 535
 536
 537 // ////////////////////////////////////////////////////////////////////////// //
 538 constructor TUIStyle.Create (const aid: AnsiString);
 539 begin
 540   mId := aid;
 541   createMain();
 542 end;
 543
 544
 545 constructor TUIStyle.Create (st: TStream); // parse from stream
 546 var
 547   par: TTextParser;
 548 begin
 549   mId := '';
 550   createMain();
 551   if (st = nil) then exit;
 552   par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId, par.TOption.HtmlColors]);
 553   try
 554     parse(par);
 555   finally
 556     par.Free();
 557   end;
 558 end;
 559
 560
 561 constructor TUIStyle.CreateFromFile (const fname: AnsiString);
 562 var
 563   st: TStream;
 564 begin
 565   st := openDiskFileRO(fname);
 566   try
 567     Create(st);
 568   finally
 569     st.Free();
 570   end;
 571 end;
 572
 573
 574 destructor TUIStyle.Destroy ();
 575 begin
 576   mId := '';
 577   FreeAndNil(mMain);
 578 end;
 579
 580
 581 procedure TUIStyle.createMain ();
 582 begin
 583   mMain := TStyleSection.Create();
 584   mMain.mCtlName := '$main$';
 585 end;
 586
 587
 588 function TUIStyle.getValue (const path: AnsiString): TStyleValue; inline;
 589 begin
 590   result := mMain[path];
 591 end;
 592
 593 function TUIStyle.get (name, hash, ctl: AnsiString): TStyleValue;
 594 begin
 595   result := mMain.get(name, hash, ctl);
 596 end;
 597
 598
 599 procedure TUIStyle.parse (par: TTextParser);
 600   function getByte (): Byte;
 601   begin
 602     if (par.tokType <> par.TTInt) then par.expectInt();
 603     if (par.tokInt < 0) or (par.tokInt > 255) then par.error('invalid byte value');
 604     result := Byte(par.tokInt);
 605     par.skipToken();
 606   end;
 607
 608   procedure parseSection (sect: TStyleSection; ctlAllowed: Boolean; hashAllowed: Boolean);
 609   var
 610     s, inh: AnsiString;
 611     sc: TStyleSection = nil;
 612     v: TStyleValue;
 613
 614     procedure parseInherit ();
 615     begin
 616       inh := '';
 617       if (par.eatDelim('(')) then
 618       begin
 619         if (par.eatDelim(')')) then par.error('empty inheritance is not allowed');
 620         if (par.eatDelim('#')) then
 621         begin
 622           inh := '#';
 623           inh += par.expectId();
 624         end;
 625         if (par.eatDelim('@')) then
 626         begin
 627           inh += '#';
 628           inh += par.expectId();
 629         end;
 630         par.expectDelim(')');
 631       end;
 632     end;
 633
 634     function nib2c (n: Integer): Byte; inline;
 635     begin
 636            if (n < 0) then result := 0
 637       else if (n > 15) then result := 255
 638       else result := Byte(255*n div 15);
 639     end;
 640
 641   begin
 642     s := '';
 643     inh := '';
 644     par.expectDelim('{');
 645     while (not par.isDelim('}')) do
 646     begin
 647       while (par.eatDelim(';')) do begin end;
 648       // ctl
 649       if ctlAllowed and (par.eatDelim('@')) then
 650       begin
 651         s := par.expectId();
 652         parseInherit();
 653         par.eatDelim(':'); // optional
 654         if (not sect.mCtls.get(s, sc)) then
 655         begin
 656           // create new section
 657           sc := TStyleSection.Create();
 658           sc.mParent := sect;
 659           sc.mInherits := inh;
 660           sc.mHashName := '';
 661           sc.mCtlName := s;
 662           sect.mCtls.put(s, sc);
 663         end
 664         else
 665         begin
 666           assert(sc.mParent = sect);
 667           assert(sc.mHashName = '');
 668           assert(sc.mCtlName = s);
 669           if (Length(sc.mInherits) <> 0) and (Length(inh) <> 0) then par.error('double inheritance');
 670           sc.mInherits := inh;
 671         end;
 672         if (not par.eatDelim(';')) then parseSection(sc, false, true);
 673         continue;
 674       end;
 675       // hash
 676       if hashAllowed and (par.eatDelim('#')) then
 677       begin
 678         s := par.expectId();
 679         parseInherit();
 680         par.eatDelim(':'); // optional
 681         if (not sect.mHashes.get(s, sc)) then
 682         begin
 683           // create new section
 684           sc := TStyleSection.Create();
 685           sc.mParent := sect;
 686           sc.mInherits := inh;
 687           sc.mHashName := s;
 688           sc.mCtlName := '';
 689           sect.mHashes.put(s, sc);
 690         end
 691         else
 692         begin
 693           assert(sc.mParent = sect);
 694           assert(sc.mHashName = s);
 695           assert(sc.mCtlName = '');
 696           if (Length(sc.mInherits) <> 0) and (Length(inh) <> 0) then par.error('double inheritance');
 697           sc.mInherits := inh;
 698         end;
 699         if (not par.eatDelim(';')) then parseSection(sc, false, false);
 700         continue;
 701       end;
 702       // name
 703       s := par.expectId();
 704       par.expectDelim(':');
 705       if (par.eatId('rgb')) or (par.eatId('rgba')) then
 706       begin
 707         // color
 708         par.expectDelim('(');
 709         v.vtype := v.TType.Color;
 710         v.r := getByte(); par.eatDelim(','); // optional
 711         v.g := getByte(); par.eatDelim(','); // optional
 712         v.b := getByte(); par.eatDelim(','); // optional
 713         if (par.tokType = par.TTInt) then
 714         begin
 715           v.a := getByte(); par.eatDelim(','); // optional
 716         end
 717         else
 718         begin
 719           v.a := 255; // opaque
 720         end;
 721         par.expectDelim(')');
 722       end
 723       else if (par.isId) and (par.tokStr[1] = '#') then
 724       begin
 725         // html color
 726         assert((Length(par.tokStr) = 4) or (Length(par.tokStr) = 7));
 727         //writeln('<', par.tokStr, '>; {', par.curChar, '}');
 728         v.vtype := v.TType.Color;
 729         if (Length(par.tokStr) = 4) then
 730         begin
 731           // #rgb
 732           v.r := nib2c(digitInBase(par.tokStr[2], 16));
 733           v.g := nib2c(digitInBase(par.tokStr[3], 16));
 734           v.b := nib2c(digitInBase(par.tokStr[4], 16));
 735         end
 736         else
 737         begin
 738          // #rrggbb
 739           v.r := Byte(digitInBase(par.tokStr[2], 16)*16+digitInBase(par.tokStr[3], 16));
 740           v.g := Byte(digitInBase(par.tokStr[4], 16)*16+digitInBase(par.tokStr[5], 16));
 741           v.b := Byte(digitInBase(par.tokStr[6], 16)*16+digitInBase(par.tokStr[7], 16));
 742         end;
 743         v.a := 255;
 744         //writeln('  r=', v.r, '; g=', v.g, '; b=', v.b);
 745         par.skipToken();
 746       end
 747       else if (par.eatId('true')) or (par.eatId('tan')) then
 748       begin
 749         v.vtype := v.TType.Bool;
 750         v.bval := true;
 751       end
 752       else if (par.eatId('false')) or (par.eatId('ona')) then
 753       begin
 754         v.vtype := v.TType.Bool;
 755         v.bval := false;
 756       end
 757       else if (par.isStr) then
 758       begin
 759         // string value
 760         v := TStyleValue.Create(par.tokStr);
 761         par.skipToken();
 762       end
 763       else if (par.eatId('inherit')) then
 764       begin
 765         v.vtype := v.TType.Empty;
 766       end
 767       else
 768       begin
 769         // should be int
 770         v.vtype := v.TType.Int;
 771         v.ival := par.expectInt();
 772       end;
 773       par.expectDelim(';');
 774       sect.mVals.put(s, v);
 775     end;
 776     par.expectDelim('}');
 777   end;
 778
 779 begin
 780   // style name
 781   if (not par.isIdOrStr) then
 782   begin
 783     if (Length(mId) = 0) then par.error('style name expected');
 784   end
 785   else
 786   begin
 787     mId := par.tokStr;
 788   end;
 789   if (Length(mId) = 0) then mId := 'default';
 790   par.skipToken();
 791   if (not par.eatDelim(';')) then parseSection(mMain, true, true);
 792 end;
 793
 794
 795 end.