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 unit gh_ui_style;
  19
  20 interface
  21
  22 uses
  23   SysUtils, Classes,
  24   glgfx,
  25   xstreams, xparser, utils, hashtable;
  26
  27
  28 type
  29   TStyleValue = packed record
  30   public
  31     type TType = (Empty, Bool, Int, Color);
  32
  33   public
  34     constructor Create (v: Boolean; okToInherit: Boolean=true);
  35     constructor Create (v: Integer; okToInherit: Boolean=true);
  36     constructor Create (ar, ag, ab: Integer; okToInherit: Boolean=true);
  37     constructor Create (ar, ag, ab, aa: Integer; okToInherit: Boolean=true);
  38     constructor Create (const v: TGxRGBA; okToInherit: Boolean=true);
  39
  40     function isEmpty (): Boolean; inline;
  41     function canInherit (): Boolean; inline;
  42
  43     function toString (): AnsiString;
  44     function asRGBA: TGxRGBA; inline;
  45     function asRGBADef (const def: TGxRGBA): TGxRGBA; inline;
  46     function asIntDef (const def: Integer): Integer; inline;
  47     function asBoolDef (const def: Boolean): Boolean; inline;
  48
  49   public
  50     vtype: TType;
  51     allowInherit: Boolean;
  52     case TType of
  53       TType.Bool: (bval: Boolean);
  54       TType.Int: (ival: Integer);
  55       TType.Color: (r, g, b, a: Byte);
  56   end;
  57
  58   TStyleSection = class;
  59
  60   THashStrStyleVal = specialize THashBase<AnsiString, TStyleValue, THashKeyStrAnsiCI>;
  61   THashStrSection = specialize THashBase<AnsiString, TStyleSection, THashKeyStrAnsiCI>;
  62
  63   TStyleSection = class
  64   private
  65     mVals: THashStrStyleVal;
  66     mHashVals: THashStrSection; // "#..."
  67     mCtlVals: THashStrSection;
  68
  69   private
  70     // "text-color#inactive@label"
  71     function getValue (const path: AnsiString): TStyleValue;
  72     procedure setValue (const path: AnsiString; const val: TStyleValue);
  73
  74   public
  75     constructor Create ();
  76     destructor Destroy (); override;
  77
  78   public
  79     property value[const path: AnsiString]: TStyleValue read getValue write setValue; default;
  80   end;
  81
  82   TUIStyle = class
  83   private
  84     mId: AnsiString; // style name ('default', for example)
  85     mMain: TStyleSection;
  86
  87   private
  88     procedure parse (par: TTextParser);
  89
  90     function getValue (const path: AnsiString): TStyleValue; inline;
  91     procedure setValue (const path: AnsiString; const val: TStyleValue); inline;
  92
  93   public
  94     constructor Create (const aid: AnsiString);
  95     constructor Create (st: TStream); // parse from stream
  96     constructor CreateFromFile (const fname: AnsiString);
  97     destructor Destroy (); override;
  98
  99   public
 100     property id: AnsiString read mId;
 101     property value[const path: AnsiString]: TStyleValue read getValue write setValue; default;
 102   end;
 103
 104
 105 procedure uiLoadStyles (const fname: AnsiString);
 106 procedure uiLoadStyles (st: TStream);
 107
 108 // will return "default" (or raise an exception if there is no "default")
 109 function uiFindStyle (const stname: AnsiString): TUIStyle;
 110
 111
 112 implementation
 113
 114
 115 // ////////////////////////////////////////////////////////////////////////// //
 116 var
 117   styles: array of TUIStyle = nil;
 118
 119
 120 function createDefaultStyle (): TUIStyle;
 121 begin
 122   result := TUIStyle.Create('default');
 123
 124   result['back-color'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 128));
 125   result['text-color'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
 126   result['frame-color'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
 127   result['frame-text-color'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
 128   result['frame-icon-color'] := TStyleValue.Create(TGxRGBA.Create(0, 255, 0));
 129
 130   // disabled is always inactive too
 131
 132   // main colors
 133   result['back-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 127));
 134   result['text-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 135   result['frame-text-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 136   result['frame-icon-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(0, 127, 0));
 137   result['darken#disabled'] := TStyleValue.Create(128, false); // darken inactive windows, no-inherit
 138   result['darken#inactive'] := TStyleValue.Create(128, false); // darken inactive windows, no-inherit
 139
 140   // label
 141   result['text-color@label'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
 142   result['text-color#disabled@label'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 143
 144   // box
 145   result['frame-color@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 0));
 146   result['frame-text-color@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 0));
 147   result['frame-icon-color@box'] := TStyleValue.Create(TGxRGBA.Create(0, 255, 0));
 148
 149   result['frame-color#inactive@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
 150   result['frame-text-color#inactive@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
 151   result['frame-icon-color#inactive@box'] := TStyleValue.Create(TGxRGBA.Create(0, 255, 0));
 152
 153   result['frame-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 154   result['frame-text-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 155   result['frame-icon-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 156
 157   // button
 158   result['back-color@button'] := TStyleValue.Create(TGxRGBA.Create(0, 96, 255));
 159   result['text-color@button'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
 160
 161   result['back-color#inactive@button'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 127));
 162   result['text-color#inactive@button'] := TStyleValue.Create(TGxRGBA.Create(196, 196, 196));
 163
 164   result['back-color#disabled@button'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 127));
 165   result['text-color#disabled@button'] := TStyleValue.Create(TGxRGBA.Create(96, 96, 96));
 166 end;
 167
 168
 169 function uiFindStyle (const stname: AnsiString): TUIStyle;
 170 var
 171   stl: TUIStyle;
 172 begin
 173   if (Length(stname) > 0) then
 174   begin
 175     for stl in styles do if (strEquCI1251(stl.mId, stname)) then begin result := stl; exit; end;
 176   end;
 177   for stl in styles do if (strEquCI1251(stl.mId, 'default')) then begin result := stl; exit; end;
 178   stl := createDefaultStyle();
 179   SetLength(styles, Length(styles)+1);
 180   styles[High(styles)] := stl;
 181   result := stl;
 182 end;
 183
 184
 185 procedure uiLoadStyles (const fname: AnsiString);
 186 var
 187   st: TStream;
 188 begin
 189   st := openDiskFileRO(fname);
 190   try
 191     uiLoadStyles(st);
 192   finally
 193     st.Free();
 194   end;
 195 end;
 196
 197
 198 procedure uiLoadStyles (st: TStream);
 199 var
 200   par: TTextParser;
 201   stl: TUIStyle = nil;
 202   f: Integer;
 203 begin
 204   if (st = nil) then raise Exception.Create('cannot load UI styles from nil stream');
 205   par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]);
 206   styles := nil;
 207   try
 208     while (not par.isEOF) do
 209     begin
 210       stl := TUIStyle.Create('');
 211       stl.parse(par);
 212       //writeln('new style: <', stl.mId, '>');
 213       f := 0;
 214       while (f < Length(styles)) do begin if (strEquCI1251(styles[f].mId, stl.mId)) then break; Inc(f); end;
 215       if (f < Length(styles)) then
 216       begin
 217         FreeAndNil(styles[f]);
 218       end
 219       else
 220       begin
 221         f := Length(styles);
 222         SetLength(styles, f+1);
 223       end;
 224       styles[f] := stl;
 225       stl := nil;
 226     end;
 227   finally
 228     stl.Free();
 229     par.Free();
 230   end;
 231   // we should have "default" style
 232   for f := 0 to High(styles) do if (strEquCI1251(styles[f].mId, 'default')) then exit;
 233   stl := createDefaultStyle();
 234   SetLength(styles, Length(styles)+1);
 235   styles[High(styles)] := stl;
 236 end;
 237
 238
 239 // ////////////////////////////////////////////////////////////////////////// //
 240 constructor TStyleValue.Create (v: Boolean; okToInherit: Boolean=true); begin vtype := TType.Bool; allowInherit := okToInherit; bval := v; end;
 241 constructor TStyleValue.Create (v: Integer; okToInherit: Boolean=true); begin vtype := TType.Int; allowInherit := okToInherit; ival := v; end;
 242
 243 constructor TStyleValue.Create (ar, ag, ab: Integer; okToInherit: Boolean=true);
 244 begin
 245   vtype := TType.Color;
 246   allowInherit := okToInherit;
 247   r := nmax(0, nmin(ar, 255));
 248   g := nmax(0, nmin(ag, 255));
 249   b := nmax(0, nmin(ab, 255));
 250   a := 255;
 251 end;
 252
 253 constructor TStyleValue.Create (ar, ag, ab, aa: Integer; okToInherit: Boolean=true);
 254 begin
 255   vtype := TType.Color;
 256   allowInherit := okToInherit;
 257   r := nmax(0, nmin(ar, 255));
 258   g := nmax(0, nmin(ag, 255));
 259   b := nmax(0, nmin(ab, 255));
 260   a := nmax(0, nmin(aa, 255));
 261 end;
 262
 263 constructor TStyleValue.Create (const v: TGxRGBA; okToInherit: Boolean=true);
 264 begin
 265   vtype := TType.Color;
 266   allowInherit := okToInherit;
 267   r := v.r;
 268   g := v.g;
 269   b := v.b;
 270   a := v.a;
 271 end;
 272
 273 function TStyleValue.isEmpty (): Boolean; inline; begin result := (vtype = TType.Empty); end;
 274 function TStyleValue.canInherit (): Boolean; inline; begin result := allowInherit; end;
 275 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;
 276 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;
 277 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;
 278 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;
 279
 280
 281 function TStyleValue.toString (): AnsiString;
 282 begin
 283   case vtype of
 284     TType.Empty: result := '<empty>';
 285     TType.Bool: if bval then result := 'true' else result := 'false';
 286     TType.Int: result := formatstrf('%s', [ival]);
 287     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]);
 288     else result := '<invalid>';
 289   end;
 290 end;
 291
 292
 293 // ////////////////////////////////////////////////////////////////////////// //
 294 procedure freeSectionCB (var v: TStyleSection); begin FreeAndNil(v); end;
 295
 296
 297 function splitPath (const path: AnsiString; out name, hash, ctl: AnsiString): Boolean;
 298 var
 299   hashPos, atPos: Integer;
 300 begin
 301   result := false;
 302   name := '';
 303   hash := '';
 304   ctl := '';
 305   hashPos := pos('#', path);
 306   atPos := pos('@', path);
 307   // split
 308   if (atPos > 0) then
 309   begin
 310     // has ctl, and (possible) hash
 311     if (hashPos > 0) then
 312     begin
 313       // has ctl and hash
 314       if (atPos < hashPos) then exit; // alas
 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     end
 319     else
 320     begin
 321       // has only ctl
 322       if (atPos > 1) then name := Copy(path, 1, atPos-1);
 323     end;
 324     Inc(atPos); // skip "at"
 325     if (atPos <= Length(path)) then ctl := Copy(path, atPos, Length(path)-atPos+1);
 326   end
 327   else if (hashPos > 0) then
 328   begin
 329     // has hash
 330     if (hashPos > 1) then name := Copy(path, 1, hashPos-1);
 331     Inc(hashPos); // skip hash
 332     if (hashPos <= Length(path)) then hash := Copy(path, hashPos, Length(path)-hashPos+1);
 333   end
 334   else
 335   begin
 336     // only name
 337     name := path;
 338   end;
 339   result := true;
 340 end;
 341
 342
 343 // ////////////////////////////////////////////////////////////////////////// //
 344 constructor TStyleSection.Create ();
 345 begin
 346   mVals := THashStrStyleVal.Create();
 347   mHashVals := THashStrSection.Create();
 348   mCtlVals := THashStrSection.Create(freeSectionCB);
 349 end;
 350
 351
 352 destructor TStyleSection.Destroy ();
 353 begin
 354   FreeAndNil(mVals);
 355   FreeAndNil(mHashVals);
 356   FreeAndNil(mCtlVals);
 357   inherited;
 358 end;
 359
 360
 361 // "text-color#inactive@label"
 362 function TStyleSection.getValue (const path: AnsiString): TStyleValue;
 363 var
 364   name, hash, ctl: AnsiString;
 365   sect: TStyleSection = nil;
 366   s1: TStyleSection = nil;
 367   checkInheritance: Boolean = false;
 368 begin
 369   result.vtype := result.TType.Empty;
 370   if (not splitPath(path, name, hash, ctl)) then exit; // alas
 371   //writeln('name:<', name, '>; hash:<', hash, '>; ctl:<', ctl, '>');
 372   if (Length(name) = 0) then exit; // alas
 373   // try control
 374   if (Length(ctl) > 0) then
 375   begin
 376     // has ctl section?
 377     if not mCtlVals.get(ctl, sect) then
 378     begin
 379       sect := self;
 380       checkInheritance := true;
 381     end;
 382   end
 383   else
 384   begin
 385     sect := self;
 386   end;
 387   // has hash?
 388   if (Length(hash) > 0) then
 389   begin
 390     if sect.mHashVals.get(hash, s1) then
 391     begin
 392       if s1.mVals.get(name, result) then
 393       begin
 394         //writeln('hash: <', hash, '>: val=', result.toString);
 395         if (not result.isEmpty) and ((not checkInheritance) or (result.canInherit)) then exit;
 396       end;
 397     end;
 398     //writeln('NO hash: <', hash, '>: val=', result.toString);
 399     checkInheritance := true;
 400   end;
 401   // try just a name
 402   if sect.mVals.get(name, result) then
 403   begin
 404     if (not result.isEmpty) and ((not checkInheritance) or (result.canInherit)) then exit;
 405   end;
 406   // alas
 407   result.vtype := result.TType.Empty;
 408 end;
 409
 410
 411 procedure TStyleSection.setValue (const path: AnsiString; const val: TStyleValue);
 412 var
 413   name, hash, ctl: AnsiString;
 414   sect: TStyleSection = nil;
 415   s1: TStyleSection = nil;
 416 begin
 417   if (not splitPath(path, name, hash, ctl)) then exit; // alas
 418   // has name?
 419   if (Length(name) = 0) then exit; // no name -> nothing to do
 420   // has ctl?
 421   if (Length(ctl) > 0) then
 422   begin
 423     if not mCtlVals.get(ctl, sect) then
 424     begin
 425       // create new section
 426       sect := TStyleSection.Create();
 427       mCtlVals.put(ctl, sect);
 428     end;
 429   end
 430   else
 431   begin
 432     // no ctl, use default section
 433     sect := self;
 434   end;
 435   // has hash?
 436   if (Length(hash) > 0) then
 437   begin
 438     if not sect.mHashVals.get(hash, s1) then
 439     begin
 440       // create new section
 441       s1 := TStyleSection.Create();
 442       sect.mHashVals.put(hash, s1);
 443     end;
 444   end
 445   else
 446   begin
 447     // no hash, use default section
 448     s1 := sect;
 449   end;
 450   s1.mVals.put(name, val);
 451 end;
 452
 453
 454 // ////////////////////////////////////////////////////////////////////////// //
 455 constructor TUIStyle.Create (const aid: AnsiString);
 456 begin
 457   mId := aid;
 458   mMain := TStyleSection.Create();
 459 end;
 460
 461
 462 constructor TUIStyle.Create (st: TStream); // parse from stream
 463 var
 464   par: TTextParser;
 465 begin
 466   mId := '';
 467   mMain := TStyleSection.Create();
 468   if (st = nil) then exit;
 469   par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]);
 470   try
 471     parse(par);
 472   finally
 473     par.Free();
 474   end;
 475 end;
 476
 477
 478 constructor TUIStyle.CreateFromFile (const fname: AnsiString);
 479 var
 480   par: TTextParser;
 481   st: TStream;
 482 begin
 483   mId := '';
 484   mMain := TStyleSection.Create();
 485   st := openDiskFileRO(fname);
 486   try
 487     par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]);
 488     try
 489       parse(par);
 490     finally
 491       par.Free();
 492     end;
 493   finally
 494     st.Free();
 495   end;
 496 end;
 497
 498
 499 destructor TUIStyle.Destroy ();
 500 begin
 501   mId := '';
 502   FreeAndNil(mMain);
 503 end;
 504
 505
 506 function TUIStyle.getValue (const path: AnsiString): TStyleValue; inline;
 507 begin
 508   result := mMain[path];
 509 end;
 510
 511 procedure TUIStyle.setValue (const path: AnsiString; const val: TStyleValue); inline;
 512 begin
 513   mMain.setValue(path, val);
 514 end;
 515
 516
 517 procedure TUIStyle.parse (par: TTextParser);
 518   function getByte (): Byte;
 519   begin
 520     if (par.tokType <> par.TTInt) then par.expectInt();
 521     if (par.tokInt < 0) or (par.tokInt > 255) then par.error('invalid byte value');
 522     result := Byte(par.tokInt);
 523     par.skipToken();
 524   end;
 525
 526   procedure parseSection (sect: TStyleSection; ctlAllowed: Boolean; hashAllowed: Boolean);
 527   var
 528     s: AnsiString;
 529     sc: TStyleSection = nil;
 530     v: TStyleValue;
 531   begin
 532     par.expectDelim('{');
 533     while (not par.isDelim('}')) do
 534     begin
 535       while (par.eatDelim(';')) do begin end;
 536       // hash
 537       if hashAllowed and (par.eatDelim('#')) then
 538       begin
 539         s := par.expectIdOrStr();
 540         //writeln('hash: <', s, '>');
 541         par.eatDelim(':'); // optional
 542         if not sect.mHashVals.get(s, sc) then
 543         begin
 544           // create new section
 545           sc := TStyleSection.Create();
 546           sect.mHashVals.put(s, sc);
 547         end;
 548         parseSection(sc, false, false);
 549         continue;
 550       end;
 551       // ctl
 552       if ctlAllowed and (par.eatDelim('@')) then
 553       begin
 554         s := par.expectIdOrStr();
 555         //writeln('ctl: <', s, '>');
 556         par.eatDelim(':'); // optional
 557         if not sect.mCtlVals.get(s, sc) then
 558         begin
 559           // create new section
 560           sc := TStyleSection.Create();
 561           sect.mCtlVals.put(s, sc);
 562         end;
 563         parseSection(sc, false, true);
 564         continue;
 565       end;
 566       // name
 567       s := par.expectIdOrStr();
 568       //writeln('name: <', s, '>');
 569       v.allowInherit := true;
 570       par.expectDelim(':');
 571       if (par.eatId('rgb')) or (par.eatId('rgba')) then
 572       begin
 573         // color
 574         par.expectDelim('(');
 575         v.vtype := v.TType.Color;
 576         v.r := getByte(); par.eatDelim(','); // optional
 577         v.g := getByte(); par.eatDelim(','); // optional
 578         v.b := getByte(); par.eatDelim(','); // optional
 579         if (par.tokType = par.TTInt) then
 580         begin
 581           v.a := getByte(); par.eatDelim(','); // optional
 582         end
 583         else
 584         begin
 585           v.a := 255; // opaque
 586         end;
 587         par.expectDelim(')');
 588       end
 589       else if (par.eatId('true')) or (par.eatId('tan')) then
 590       begin
 591         v.vtype := v.TType.Bool;
 592         v.bval := true;
 593       end
 594       else if (par.eatId('false')) or (par.eatId('ona')) then
 595       begin
 596         v.vtype := v.TType.Bool;
 597         v.bval := false;
 598       end
 599       else
 600       begin
 601         // should be int
 602         v.vtype := v.TType.Int;
 603         v.ival := par.expectInt();
 604       end;
 605       // '!' flags
 606       while (par.eatDelim('!')) do
 607       begin
 608         if (par.eatId('no-inherit')) then v.allowInherit := false
 609         else par.error('unknown flag');
 610       end;
 611       par.expectDelim(';');
 612       sect.mVals.put(s, v);
 613     end;
 614     par.expectDelim('}');
 615   end;
 616
 617 begin
 618   // style name
 619   if (not par.isIdOrStr) then
 620   begin
 621     if (Length(mId) = 0) then par.error('style name expected');
 622   end
 623   else
 624   begin
 625     mId := par.tokStr;
 626   end;
 627   if (Length(mId) = 0) then mId := 'default';
 628   par.skipToken();
 629   parseSection(mMain, true, true);
 630 end;
 631
 632
 633 end.