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