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 putValue (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 putValue; 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 putValue (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 putValue; 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   result['back-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 128));
 132   result['text-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 133   result['frame-text-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 134   result['frame-icon-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(0, 127, 0));
 135   result['darken#disabled'] := TStyleValue.Create(128, false); // darken inactive windows, no-inherit
 136   result['darken#inactive'] := TStyleValue.Create(128, false); // darken inactive windows, no-inherit
 137
 138   result['text-color@label'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255));
 139   result['text-color#disabled@label'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 140
 141   result['frame-color@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 0));
 142   result['frame-text-color@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 0));
 143   result['frame-icon-color@box'] := TStyleValue.Create(TGxRGBA.Create(0, 255, 0));
 144
 145   result['frame-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 146   result['frame-text-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 147   result['frame-icon-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127));
 148 end;
 149
 150
 151 function uiFindStyle (const stname: AnsiString): TUIStyle;
 152 var
 153   stl: TUIStyle;
 154 begin
 155   if (Length(stname) > 0) then
 156   begin
 157     for stl in styles do if (strEquCI1251(stl.mId, stname)) then begin result := stl; exit; end;
 158   end;
 159   for stl in styles do if (strEquCI1251(stl.mId, 'default')) then begin result := stl; exit; end;
 160   stl := createDefaultStyle();
 161   SetLength(styles, Length(styles)+1);
 162   styles[High(styles)] := stl;
 163   result := stl;
 164 end;
 165
 166
 167 procedure uiLoadStyles (const fname: AnsiString);
 168 var
 169   st: TStream;
 170 begin
 171   st := openDiskFileRO(fname);
 172   try
 173     uiLoadStyles(st);
 174   finally
 175     st.Free();
 176   end;
 177 end;
 178
 179
 180 procedure uiLoadStyles (st: TStream);
 181 var
 182   par: TTextParser;
 183   stl: TUIStyle = nil;
 184   f: Integer;
 185 begin
 186   if (st = nil) then raise Exception.Create('cannot load UI styles from nil stream');
 187   par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]);
 188   styles := nil;
 189   try
 190     while (not par.isEOF) do
 191     begin
 192       stl := TUIStyle.Create('');
 193       stl.parse(par);
 194       //writeln('new style: <', stl.mId, '>');
 195       f := 0;
 196       while (f < Length(styles)) do begin if (strEquCI1251(styles[f].mId, stl.mId)) then break; Inc(f); end;
 197       if (f < Length(styles)) then
 198       begin
 199         FreeAndNil(styles[f]);
 200       end
 201       else
 202       begin
 203         f := Length(styles);
 204         SetLength(styles, f+1);
 205       end;
 206       styles[f] := stl;
 207       stl := nil;
 208     end;
 209   finally
 210     stl.Free();
 211     par.Free();
 212   end;
 213   // we should have "default" style
 214   for f := 0 to High(styles) do if (strEquCI1251(styles[f].mId, 'default')) then exit;
 215   stl := createDefaultStyle();
 216   SetLength(styles, Length(styles)+1);
 217   styles[High(styles)] := stl;
 218 end;
 219
 220
 221 // ////////////////////////////////////////////////////////////////////////// //
 222 constructor TStyleValue.Create (v: Boolean; okToInherit: Boolean=true); begin vtype := TType.Bool; allowInherit := okToInherit; bval := v; end;
 223 constructor TStyleValue.Create (v: Integer; okToInherit: Boolean=true); begin vtype := TType.Int; allowInherit := okToInherit; ival := v; end;
 224
 225 constructor TStyleValue.Create (ar, ag, ab: Integer; okToInherit: Boolean=true);
 226 begin
 227   vtype := TType.Color;
 228   allowInherit := okToInherit;
 229   r := nmax(0, nmin(ar, 255));
 230   g := nmax(0, nmin(ag, 255));
 231   b := nmax(0, nmin(ab, 255));
 232   a := 255;
 233 end;
 234
 235 constructor TStyleValue.Create (ar, ag, ab, aa: Integer; okToInherit: Boolean=true);
 236 begin
 237   vtype := TType.Color;
 238   allowInherit := okToInherit;
 239   r := nmax(0, nmin(ar, 255));
 240   g := nmax(0, nmin(ag, 255));
 241   b := nmax(0, nmin(ab, 255));
 242   a := nmax(0, nmin(aa, 255));
 243 end;
 244
 245 constructor TStyleValue.Create (const v: TGxRGBA; okToInherit: Boolean=true);
 246 begin
 247   vtype := TType.Color;
 248   allowInherit := okToInherit;
 249   r := v.r;
 250   g := v.g;
 251   b := v.b;
 252   a := v.a;
 253 end;
 254
 255 function TStyleValue.isEmpty (): Boolean; inline; begin result := (vtype = TType.Empty); end;
 256 function TStyleValue.canInherit (): Boolean; inline; begin result := allowInherit; end;
 257 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;
 258 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;
 259 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;
 260 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;
 261
 262
 263 function TStyleValue.toString (): AnsiString;
 264 begin
 265   case vtype of
 266     TType.Empty: result := '<empty>';
 267     TType.Bool: if bval then result := 'true' else result := 'false';
 268     TType.Int: result := formatstrf('%s', [ival]);
 269     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]);
 270     else result := '<invalid>';
 271   end;
 272 end;
 273
 274
 275 // ////////////////////////////////////////////////////////////////////////// //
 276 procedure freeSectionCB (var v: TStyleSection); begin FreeAndNil(v); end;
 277
 278
 279 function splitPath (const path: AnsiString; out name, hash, ctl: AnsiString): Boolean;
 280 var
 281   hashPos, atPos: Integer;
 282 begin
 283   result := false;
 284   name := '';
 285   hash := '';
 286   ctl := '';
 287   hashPos := pos('#', path);
 288   atPos := pos('@', path);
 289   // split
 290   if (atPos > 0) then
 291   begin
 292     // has ctl, and (possible) hash
 293     if (hashPos > 0) then
 294     begin
 295       // has ctl and hash
 296       if (atPos < hashPos) then exit; // alas
 297       if (hashPos > 1) then name := Copy(path, 1, hashPos-1);
 298       Inc(hashPos); // skip hash
 299       if (hashPos < atPos) then hash := Copy(path, hashPos, atPos-hashPos);
 300     end
 301     else
 302     begin
 303       // has only ctl
 304       if (atPos > 1) then name := Copy(path, 1, atPos-1);
 305     end;
 306     Inc(atPos); // skip "at"
 307     if (atPos <= Length(path)) then ctl := Copy(path, atPos, Length(path)-atPos+1);
 308   end
 309   else if (hashPos > 0) then
 310   begin
 311     // has hash
 312     if (hashPos > 1) then name := Copy(path, 1, hashPos-1);
 313     Inc(hashPos); // skip hash
 314     if (hashPos <= Length(path)) then hash := Copy(path, hashPos, Length(path)-hashPos+1);
 315   end
 316   else
 317   begin
 318     // only name
 319     name := path;
 320   end;
 321   result := true;
 322 end;
 323
 324
 325 // ////////////////////////////////////////////////////////////////////////// //
 326 constructor TStyleSection.Create ();
 327 begin
 328   mVals := THashStrStyleVal.Create();
 329   mHashVals := THashStrSection.Create();
 330   mCtlVals := THashStrSection.Create(freeSectionCB);
 331 end;
 332
 333
 334 destructor TStyleSection.Destroy ();
 335 begin
 336   FreeAndNil(mVals);
 337   FreeAndNil(mHashVals);
 338   FreeAndNil(mCtlVals);
 339   inherited;
 340 end;
 341
 342
 343 // "text-color#inactive@label"
 344 function TStyleSection.getValue (const path: AnsiString): TStyleValue;
 345 var
 346   name, hash, ctl: AnsiString;
 347   sect: TStyleSection = nil;
 348   s1: TStyleSection = nil;
 349   checkInheritance: Boolean = false;
 350 begin
 351   result.vtype := result.TType.Empty;
 352   if (not splitPath(path, name, hash, ctl)) then exit; // alas
 353   //writeln('name:<', name, '>; hash:<', hash, '>; ctl:<', ctl, '>');
 354   if (Length(name) = 0) then exit; // alas
 355   // try control
 356   if (Length(ctl) > 0) then
 357   begin
 358     // has ctl section?
 359     if not mCtlVals.get(ctl, sect) then
 360     begin
 361       sect := self;
 362       checkInheritance := true;
 363     end;
 364   end
 365   else
 366   begin
 367     sect := self;
 368   end;
 369   // has hash?
 370   if (Length(hash) > 0) then
 371   begin
 372     if sect.mHashVals.get(hash, s1) then
 373     begin
 374       if s1.mVals.get(name, result) then
 375       begin
 376         //writeln('hash: <', hash, '>: val=', result.toString);
 377         if (not result.isEmpty) and ((not checkInheritance) or (result.canInherit)) then exit;
 378       end;
 379     end;
 380     //writeln('NO hash: <', hash, '>: val=', result.toString);
 381     checkInheritance := true;
 382   end;
 383   // try just a name
 384   if sect.mVals.get(name, result) then
 385   begin
 386     if (not result.isEmpty) and ((not checkInheritance) or (result.canInherit)) then exit;
 387   end;
 388   // alas
 389   result.vtype := result.TType.Empty;
 390 end;
 391
 392
 393 procedure TStyleSection.putValue (const path: AnsiString; const val: TStyleValue);
 394 var
 395   name, hash, ctl: AnsiString;
 396   sect: TStyleSection = nil;
 397   s1: TStyleSection = nil;
 398 begin
 399   if (not splitPath(path, name, hash, ctl)) then exit; // alas
 400   // has name?
 401   if (Length(name) = 0) then exit; // no name -> nothing to do
 402   // has ctl?
 403   if (Length(ctl) > 0) then
 404   begin
 405     if not mCtlVals.get(ctl, sect) then
 406     begin
 407       // create new section
 408       sect := TStyleSection.Create();
 409       mCtlVals.put(ctl, sect);
 410     end;
 411   end
 412   else
 413   begin
 414     // no ctl, use default section
 415     sect := self;
 416   end;
 417   // has hash?
 418   if (Length(hash) > 0) then
 419   begin
 420     if not sect.mHashVals.get(hash, s1) then
 421     begin
 422       // create new section
 423       s1 := TStyleSection.Create();
 424       mHashVals.put(hash, s1);
 425     end;
 426   end
 427   else
 428   begin
 429     // no hash, use default section
 430     s1 := sect;
 431   end;
 432   s1.mVals.put(name, val);
 433 end;
 434
 435
 436 // ////////////////////////////////////////////////////////////////////////// //
 437 constructor TUIStyle.Create (const aid: AnsiString);
 438 begin
 439   mId := aid;
 440   mMain := TStyleSection.Create();
 441 end;
 442
 443
 444 constructor TUIStyle.Create (st: TStream); // parse from stream
 445 var
 446   par: TTextParser;
 447 begin
 448   mId := '';
 449   mMain := TStyleSection.Create();
 450   if (st = nil) then exit;
 451   par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]);
 452   try
 453     parse(par);
 454   finally
 455     par.Free();
 456   end;
 457 end;
 458
 459
 460 constructor TUIStyle.CreateFromFile (const fname: AnsiString);
 461 var
 462   par: TTextParser;
 463   st: TStream;
 464 begin
 465   mId := '';
 466   mMain := TStyleSection.Create();
 467   st := openDiskFileRO(fname);
 468   try
 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   finally
 476     st.Free();
 477   end;
 478 end;
 479
 480
 481 destructor TUIStyle.Destroy ();
 482 begin
 483   mId := '';
 484   FreeAndNil(mMain);
 485 end;
 486
 487
 488 function TUIStyle.getValue (const path: AnsiString): TStyleValue; inline;
 489 begin
 490   result := mMain[path];
 491 end;
 492
 493 procedure TUIStyle.putValue (const path: AnsiString; const val: TStyleValue); inline;
 494 begin
 495   mMain.putValue(path, val);
 496 end;
 497
 498
 499 procedure TUIStyle.parse (par: TTextParser);
 500   function getByte (): Byte;
 501   begin
 502     if (par.tokType <> par.TTInt) then par.expectInt();
 503     if (par.tokInt < 0) or (par.tokInt > 255) then par.error('invalid byte value');
 504     result := Byte(par.tokInt);
 505     par.skipToken();
 506   end;
 507
 508   procedure parseSection (sect: TStyleSection; ctlAllowed: Boolean; hashAllowed: Boolean);
 509   var
 510     s: AnsiString;
 511     sc: TStyleSection = nil;
 512     v: TStyleValue;
 513   begin
 514     par.expectDelim('{');
 515     while (not par.isDelim('}')) do
 516     begin
 517       while (par.eatDelim(';')) do begin end;
 518       // hash
 519       if hashAllowed and (par.eatDelim('#')) then
 520       begin
 521         s := par.expectIdOrStr();
 522         //writeln('hash: <', s, '>');
 523         par.eatDelim(':'); // optional
 524         if not sect.mHashVals.get(s, sc) then
 525         begin
 526           // create new section
 527           sc := TStyleSection.Create();
 528           sect.mHashVals.put(s, sc);
 529         end;
 530         parseSection(sc, false, false);
 531         continue;
 532       end;
 533       // ctl
 534       if ctlAllowed and (par.eatDelim('@')) then
 535       begin
 536         s := par.expectIdOrStr();
 537         //writeln('ctl: <', s, '>');
 538         par.eatDelim(':'); // optional
 539         if not sect.mCtlVals.get(s, sc) then
 540         begin
 541           // create new section
 542           sc := TStyleSection.Create();
 543           sect.mCtlVals.put(s, sc);
 544         end;
 545         parseSection(sc, false, true);
 546         continue;
 547       end;
 548       // name
 549       s := par.expectIdOrStr();
 550       //writeln('name: <', s, '>');
 551       v.allowInherit := true;
 552       par.expectDelim(':');
 553       if (par.eatId('rgb')) or (par.eatId('rgba')) then
 554       begin
 555         // color
 556         par.expectDelim('(');
 557         v.vtype := v.TType.Color;
 558         v.r := getByte(); par.eatDelim(','); // optional
 559         v.g := getByte(); par.eatDelim(','); // optional
 560         v.b := getByte(); par.eatDelim(','); // optional
 561         if (par.tokType = par.TTInt) then
 562         begin
 563           v.a := getByte(); par.eatDelim(','); // optional
 564         end
 565         else
 566         begin
 567           v.a := 255; // opaque
 568         end;
 569         par.expectDelim(')');
 570       end
 571       else if (par.eatId('true')) or (par.eatId('tan')) then
 572       begin
 573         v.vtype := v.TType.Bool;
 574         v.bval := true;
 575       end
 576       else if (par.eatId('false')) or (par.eatId('ona')) then
 577       begin
 578         v.vtype := v.TType.Bool;
 579         v.bval := false;
 580       end
 581       else
 582       begin
 583         // should be int
 584         v.vtype := v.TType.Int;
 585         v.ival := par.expectInt();
 586       end;
 587       // '!' flags
 588       while (par.eatDelim('!')) do
 589       begin
 590         if (par.eatId('no-inherit')) then v.allowInherit := false
 591         else par.error('unknown flag');
 592       end;
 593       par.expectDelim(';');
 594       sect.mVals.put(s, v);
 595     end;
 596     par.expectDelim('}');
 597   end;
 598
 599 begin
 600   // style name
 601   if (not par.isIdOrStr) then
 602   begin
 603     if (Length(mId) = 0) then par.error('style name expected');
 604   end
 605   else
 606   begin
 607     mId := par.tokStr;
 608   end;
 609   if (Length(mId) = 0) then mId := 'default';
 610   par.skipToken();
 611   parseSection(mMain, true, true);
 612 end;
 613
 614
 615 end.