1 (* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
2 * Understanding is not required. Only obedience.
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.
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.
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/>.
17 {$INCLUDE ../../shared/a_modes.inc}
18 {.$DEFINE UI_STYLE_DEBUG_SEARCH}
25 fui_common
, // for TGxRGBA
26 xstreams
, xparser
, utils
, hashtable
;
30 TStyleSection
= class;
32 TStyleValue
= packed record
34 type TType
= (Empty
, Bool
, Int
, Color
, Str
);
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
);
43 function isEmpty (): Boolean; inline;
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;
55 TType
.Bool
: (bval
: Boolean);
56 TType
.Int
: (ival
: Integer);
57 TType
.Color
: (r
, g
, b
, a
: Byte);
58 TType
.Str
: (sval
: Pointer); // AnsiString
61 THashStrStyleVal
= specialize THashBase
<AnsiString
, TStyleValue
, THashKeyStrAnsiCI
>;
62 THashStrSection
= specialize THashBase
<AnsiString
, TStyleSection
, THashKeyStrAnsiCI
>;
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
;
75 function getTopLevel (): TStyleSection
; inline;
76 // "text-color#inactive@label"
77 function getValue (const path
: AnsiString
): TStyleValue
;
80 constructor Create ();
81 destructor Destroy (); override;
83 function get (name
, hash
, ctl
: AnsiString
): TStyleValue
;
86 property value
[const path
: AnsiString
]: TStyleValue read getValue
; default
;
87 property topLevel
: TStyleSection read getTopLevel
;
92 mId
: AnsiString
; // style name ('default', for example)
96 procedure createMain ();
98 procedure parse (par
: TTextParser
);
100 function getValue (const path
: AnsiString
): TStyleValue
; inline;
103 constructor Create (const aid
: AnsiString
);
104 constructor Create (st
: TStream
); // parse from stream
105 constructor CreateFromFile (const fname
: AnsiString
);
106 destructor Destroy (); override;
108 function get (name
, hash
, ctl
: AnsiString
): TStyleValue
;
111 property id
: AnsiString read mId
;
112 property value
[const path
: AnsiString
]: TStyleValue read getValue
; default
;
116 procedure uiLoadStyles (const fname
: AnsiString
);
117 procedure uiLoadStyles (st
: TStream
);
119 // will return "default" (or raise an exception if there is no "default")
120 function uiFindStyle (const stname
: AnsiString
): TUIStyle
;
130 styles
: array of TUIStyle
= nil;
134 function createDefaultStyle (): TUIStyle;
139 st := TStringStream.Create(defaultStyleStr);
142 result := TUIStyle.Create(st);
150 function uiFindStyle (const stname
: AnsiString
): TUIStyle
;
154 if (Length(stname
) > 0) then
156 for stl
in styles
do if (strEquCI1251(stl
.mId
, stname
)) then begin result
:= stl
; exit
; end;
158 for stl
in styles
do if (strEquCI1251(stl
.mId
, 'default')) then begin result
:= stl
; exit
; end;
159 raise Exception
.Create('FlexUI FATAL: no "default" style in stylesheet');
161 stl := createDefaultStyle();
162 SetLength(styles, Length(styles)+1);
163 styles[High(styles)] := stl;
169 procedure uiLoadStyles (const fname
: AnsiString
);
173 st
:= fuiOpenFile(fname
);
174 if (st
= nil) then raise Exception
.Create('FlexUI file '''+fname
+''' not found!');
183 procedure uiLoadStyles (st
: TStream
);
189 if (st
= nil) then raise Exception
.Create('cannot load UI styles from nil stream');
190 par
:= TFileTextParser
.Create(st
, false, [par
.TOption
.SignedNumbers
, par
.TOption
.DollarIsId
, par
.TOption
.DashIsId
, par
.TOption
.HtmlColors
]);
193 while (not par
.isEOF
) do
195 stl
:= TUIStyle
.Create('');
197 //writeln('new style: <', stl.mId, '>');
199 while (f
< Length(styles
)) do begin if (strEquCI1251(styles
[f
].mId
, stl
.mId
)) then break
; Inc(f
); end;
200 if (f
< Length(styles
)) then
202 FreeAndNil(styles
[f
]);
207 SetLength(styles
, f
+1);
216 // we should have "default" style
217 for f
:= 0 to High(styles
) do if (strEquCI1251(styles
[f
].mId
, 'default')) then exit
;
218 raise Exception
.Create('FlexUI FATAL: no "default" style in stylesheet');
220 stl := createDefaultStyle();
221 SetLength(styles, Length(styles)+1);
222 styles[High(styles)] := stl;
227 // ////////////////////////////////////////////////////////////////////////// //
228 procedure freeValueCB (var v
: TStyleValue
); begin
229 if (v
.vtype
= v
.TType
.Str
) then
231 AnsiString(v
.sval
) := '';
233 v
.vtype
:= v
.TType
.Empty
;
236 constructor TStyleValue
.Create (v
: Boolean); begin vtype
:= TType
.Bool
; bval
:= v
; end;
237 constructor TStyleValue
.Create (v
: Integer); begin vtype
:= TType
.Int
; ival
:= v
; end;
238 constructor TStyleValue
.Create (const v
: AnsiString
); begin vtype
:= TType
.Str
; sval
:= Pointer(v
); end;
240 constructor TStyleValue
.Create (ar
, ag
, ab
: Integer; aa
: Integer=255);
242 vtype
:= TType
.Color
;
243 r
:= nmax(0, nmin(ar
, 255));
244 g
:= nmax(0, nmin(ag
, 255));
245 b
:= nmax(0, nmin(ab
, 255));
246 a
:= nmax(0, nmin(aa
, 255));
249 constructor TStyleValue
.Create (const v
: TGxRGBA
);
251 vtype
:= TType
.Color
;
258 function TStyleValue
.isEmpty (): Boolean; inline; begin result
:= (vtype
= TType
.Empty
); end;
259 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;
260 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;
261 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;
262 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;
263 function TStyleValue
.asStr (const def
: AnsiString
=''): AnsiString
; inline; begin if (vtype
= TType
.Str
) then result
:= AnsiString(sval
) else result
:= def
; end;
265 function TStyleValue
.toString (): AnsiString
;
268 TType
.Empty
: result
:= '<empty>';
269 TType
.Bool
: if bval
then result
:= 'true' else result
:= 'false';
270 TType
.Int
: result
:= formatstrf('%s', [ival
]);
271 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
]);
272 else result
:= '<invalid>';
277 // ////////////////////////////////////////////////////////////////////////// //
278 procedure freeSectionCB (var v
: TStyleSection
); begin FreeAndNil(v
); end;
281 function splitPath (const path
: AnsiString
; out name
, hash
, ctl
: AnsiString
): Boolean;
283 hashPos
, atPos
: Integer;
289 hashPos
:= pos('#', path
);
290 atPos
:= pos('@', path
);
294 // has ctl, and (possible) hash
295 if (hashPos
> 0) then
298 if (atPos
< hashPos
) then
301 if (atPos
> 1) then name
:= Copy(path
, 1, atPos
-1);
302 Inc(atPos
); // skip "at"
303 if (atPos
< hashPos
) then ctl
:= Copy(path
, atPos
, hashPos
-atPos
);
304 Inc(hashPos
); // skip hash
305 if (hashPos
<= Length(path
)) then hash
:= Copy(path
, hashPos
, Length(path
)-hashPos
+1);
310 if (hashPos
> 1) then name
:= Copy(path
, 1, hashPos
-1);
311 Inc(hashPos
); // skip hash
312 if (hashPos
< atPos
) then hash
:= Copy(path
, hashPos
, atPos
-hashPos
);
313 Inc(atPos
); // skip "at"
314 if (atPos
<= Length(path
)) then ctl
:= Copy(path
, atPos
, Length(path
)-atPos
+1);
320 if (atPos
> 1) then name
:= Copy(path
, 1, atPos
-1);
321 Inc(atPos
); // skip "at"
322 if (atPos
<= Length(path
)) then ctl
:= Copy(path
, atPos
, Length(path
)-atPos
+1);
325 else if (hashPos
> 0) then
328 if (hashPos
> 1) then name
:= Copy(path
, 1, hashPos
-1);
329 Inc(hashPos
); // skip hash
330 if (hashPos
<= Length(path
)) then hash
:= Copy(path
, hashPos
, Length(path
)-hashPos
+1);
341 // ////////////////////////////////////////////////////////////////////////// //
342 constructor TStyleSection
.Create ();
348 mVals
:= THashStrStyleVal
.Create(freeValueCB
);
349 mHashes
:= THashStrSection
.Create(freeSectionCB
);
350 mCtls
:= THashStrSection
.Create(freeSectionCB
);
354 destructor TStyleSection
.Destroy ();
367 function TStyleSection
.getTopLevel (): TStyleSection
; inline;
370 while (result
.mParent
<> nil) do result
:= result
.mParent
;
374 function TStyleSection
.get (name
, hash
, ctl
: AnsiString
): TStyleValue
;
377 sect
, s1
, so
: TStyleSection
;
378 jumpsLeft
: Integer = 32; // max inheritance level
379 skipInherits
: Boolean = false;
381 result
.vtype
:= result
.TType
.Empty
;
382 if (Length(name
) = 0) then exit
; // alas
383 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('***GET: <', name
, '#', hash
, '@', ctl
, '>');{$ENDIF}
386 if (Length(ctl
) > 0) then
388 if (not strEquCI1251(ctl
, mCtlName
)) then
391 if (not topLevel
.mCtls
.get(ctl
, sect
)) then sect
:= topLevel
;
395 if (Length(hash
) > 0) then
397 if (not strEquCI1251(hash
, sect
.mHashName
)) then
399 if (sect
.mHashes
.get(hash
, s1
)) then sect
:= s1
;
402 // try name, go up with inheritance
403 while (jumpsLeft
> 0) do
405 if (sect
.mVals
.get(name
, result
)) then
407 if (not result
.isEmpty
) then exit
; // i found her!
410 if (skipInherits
) or (Length(sect
.mInherits
) = 0) then
412 skipInherits
:= false;
413 // for hash section: try parent section first
414 if (Length(sect
.mHashName
) > 0) then
416 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('search for <#', hash
, '@', ctl
, '> at <#', sect
.mHashName
, '@', sect
.mCtlName
, '>: hash up');{$ENDIF}
417 sect
:= sect
.mParent
;
418 if (sect
= nil) then break
; // alas
419 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' hash up: trying <#', sect
.mHashName
, '@', sect
.mCtlName
, '>');{$ENDIF}
420 if (sect
.mVals
.get(name
, result
)) then
422 if (not result
.isEmpty
) then exit
; // i found her!
424 // move another parent up
425 sect
:= sect
.mParent
;
426 if (sect
= nil) then break
; // alas
427 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' hash up: jumped up twice to <#', sect
.mHashName
, '@', sect
.mCtlName
, '>');{$ENDIF}
432 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('search for <#', hash
, '@', ctl
, '> at <#', sect
.mHashName
, '@', sect
.mCtlName
, '>: jump up');{$ENDIF}
433 sect
:= sect
.mParent
;
434 if (sect
= nil) then break
; // alas
436 // here, we should have non-hash section
437 assert(Length(sect
.mHashName
) = 0);
438 // if we want hash, try to find it, otherwise do nothing
439 if (Length(hash
) > 0) then
441 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' search for <#', hash
, '@', ctl
, '> at <#', sect
.mHashName
, '@', sect
.mCtlName
, '>: hash down');{$ENDIF}
442 if (sect
.mHashes
.get(hash
, s1
)) then
445 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' found <#', sect
.mHashName
, '@', sect
.mCtlName
, '>');{$ENDIF}
453 if (jumpsLeft
< 1) then break
; // alas
454 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('inherits: <', sect
.mInherits
, '>');{$ENDIF}
455 // parse inherit string
456 if (not splitPath(sect
.mInherits
, tmp
, hash
, ctl
)) then exit
; // alas
457 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('inherits: <', hash
, '>:<', ctl
, '>');{$ENDIF}
459 if (Length(ctl
) > 0) then
462 if (strEquCI1251(ctl
, '$main$')) then sect
:= topLevel
463 else if (strEquCI1251(ctl
, '$up$')) then begin if (Length(sect
.mHashName
) <> 0) then sect
:= sect
.mParent
.mParent
else sect
:= sect
.mParent
; end
464 else if (not topLevel
.mCtls
.get(ctl
, sect
)) then sect
:= topLevel
;
465 if (sect
= nil) then break
; // alas
466 if (Length(hash
) > 0) then
468 if (sect
.mHashes
.get(hash
, s1
)) then sect
:= s1
;
474 assert(Length(hash
) > 0);
475 // dummy loop, so i can use `break`
477 // get out of hash section
478 if (Length(sect
.mHashName
) > 0) then
480 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('hash-jump-up: <#', sect
.mHashName
, '@', sect
.mCtlName
, '>');{$ENDIF}
481 sect
:= sect
.mParent
;
482 if (sect
= nil) then break
; // alas
483 // check for hash section in parent; use parent if there is no such hash section
484 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' checking parent: <#', sect
.mHashName
, '@', sect
.mCtlName
, '> for <#', hash
, '>');{$ENDIF}
486 if (sect
.mHashes
.get(hash
, s1
)) then
488 if (s1
<> sect
) and (s1
<> so
) then
490 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' found in parent: <#', sect
.mHashName
, '@', sect
.mCtlName
, '> for <#', hash
, '>');{$ENDIF}
497 // we're in parent, try to find hash section
498 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' checking: <#', sect
.mHashName
, '@', sect
.mCtlName
, '> for <#', hash
, '>');{$ENDIF}
499 if (sect
.mHashes
.get(hash
, s1
)) then
501 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' found: <#', sect
.mHashName
, '@', sect
.mCtlName
, '> for <#', hash
, '>');{$ENDIF}
506 // reuse current parent, but don't follow inheritance for it
507 skipInherits
:= true;
511 if (sect
= nil) then break
;
516 result
.vtype
:= result
.TType
.Empty
;
520 // "text-color#inactive@label"
521 function TStyleSection
.getValue (const path
: AnsiString
): TStyleValue
;
523 name
, hash
, ctl
: AnsiString
;
525 result
.vtype
:= result
.TType
.Empty
;
526 if (not splitPath(path
, name
, hash
, ctl
)) then exit
; // alas
527 //writeln('name:<', name, '>; hash:<', hash, '>; ctl:<', ctl, '>');
528 result
:= get(name
, hash
, ctl
);
532 // ////////////////////////////////////////////////////////////////////////// //
533 constructor TUIStyle
.Create (const aid
: AnsiString
);
540 constructor TUIStyle
.Create (st
: TStream
); // parse from stream
546 if (st
= nil) then exit
;
547 par
:= TFileTextParser
.Create(st
, false, [par
.TOption
.SignedNumbers
, par
.TOption
.DollarIsId
, par
.TOption
.DashIsId
, par
.TOption
.HtmlColors
]);
556 constructor TUIStyle
.CreateFromFile (const fname
: AnsiString
);
560 st
:= openDiskFileRO(fname
);
569 destructor TUIStyle
.Destroy ();
576 procedure TUIStyle
.createMain ();
578 mMain
:= TStyleSection
.Create();
579 mMain
.mCtlName
:= '$main$';
583 function TUIStyle
.getValue (const path
: AnsiString
): TStyleValue
; inline;
585 result
:= mMain
[path
];
588 function TUIStyle
.get (name
, hash
, ctl
: AnsiString
): TStyleValue
;
590 result
:= mMain
.get(name
, hash
, ctl
);
594 procedure TUIStyle
.parse (par
: TTextParser
);
595 function getByte (): Byte;
597 if (par
.tokType
<> par
.TTInt
) then par
.expectInt();
598 if (par
.tokInt
< 0) or (par
.tokInt
> 255) then par
.error('invalid byte value');
599 result
:= Byte(par
.tokInt
);
603 procedure parseSection (sect
: TStyleSection
; ctlAllowed
: Boolean; hashAllowed
: Boolean);
606 sc
: TStyleSection
= nil;
609 procedure parseInherit ();
612 if (par
.eatDelim('(')) then
614 if (par
.eatDelim(')')) then par
.error('empty inheritance is not allowed');
615 if (par
.eatDelim('#')) then
618 inh
+= par
.expectId();
620 if (par
.eatDelim('@')) then
623 inh
+= par
.expectId();
625 par
.expectDelim(')');
629 function nib2c (n
: Integer): Byte; inline;
631 if (n
< 0) then result
:= 0
632 else if (n
> 15) then result
:= 255
633 else result
:= Byte(255*n
div 15);
639 par
.expectDelim('{');
640 while (not par
.isDelim('}')) do
642 while (par
.eatDelim(';')) do begin end;
644 if ctlAllowed
and (par
.eatDelim('@')) then
648 par
.eatDelim(':'); // optional
649 if (not sect
.mCtls
.get(s
, sc
)) then
651 // create new section
652 sc
:= TStyleSection
.Create();
657 sect
.mCtls
.put(s
, sc
);
661 assert(sc
.mParent
= sect
);
662 assert(sc
.mHashName
= '');
663 assert(sc
.mCtlName
= s
);
664 if (Length(sc
.mInherits
) <> 0) and (Length(inh
) <> 0) then par
.error('double inheritance');
667 if (not par
.eatDelim(';')) then parseSection(sc
, false, true);
671 if hashAllowed
and (par
.eatDelim('#')) then
675 par
.eatDelim(':'); // optional
676 if (not sect
.mHashes
.get(s
, sc
)) then
678 // create new section
679 sc
:= TStyleSection
.Create();
684 sect
.mHashes
.put(s
, sc
);
688 assert(sc
.mParent
= sect
);
689 assert(sc
.mHashName
= s
);
690 assert(sc
.mCtlName
= '');
691 if (Length(sc
.mInherits
) <> 0) and (Length(inh
) <> 0) then par
.error('double inheritance');
694 if (not par
.eatDelim(';')) then parseSection(sc
, false, false);
699 par
.expectDelim(':');
700 if (par
.eatId('rgb')) or (par
.eatId('rgba')) then
703 par
.expectDelim('(');
704 v
.vtype
:= v
.TType
.Color
;
705 v
.r
:= getByte(); par
.eatDelim(','); // optional
706 v
.g
:= getByte(); par
.eatDelim(','); // optional
707 v
.b
:= getByte(); par
.eatDelim(','); // optional
708 if (par
.tokType
= par
.TTInt
) then
710 v
.a
:= getByte(); par
.eatDelim(','); // optional
714 v
.a
:= 255; // opaque
716 par
.expectDelim(')');
718 else if (par
.isId
) and (par
.tokStr
[1] = '#') then
721 assert((Length(par
.tokStr
) = 4) or (Length(par
.tokStr
) = 7));
722 //writeln('<', par.tokStr, '>; {', par.curChar, '}');
723 v
.vtype
:= v
.TType
.Color
;
724 if (Length(par
.tokStr
) = 4) then
727 v
.r
:= nib2c(digitInBase(par
.tokStr
[2], 16));
728 v
.g
:= nib2c(digitInBase(par
.tokStr
[3], 16));
729 v
.b
:= nib2c(digitInBase(par
.tokStr
[4], 16));
734 v
.r
:= Byte(digitInBase(par
.tokStr
[2], 16)*16+digitInBase(par
.tokStr
[3], 16));
735 v
.g
:= Byte(digitInBase(par
.tokStr
[4], 16)*16+digitInBase(par
.tokStr
[5], 16));
736 v
.b
:= Byte(digitInBase(par
.tokStr
[6], 16)*16+digitInBase(par
.tokStr
[7], 16));
739 //writeln(' r=', v.r, '; g=', v.g, '; b=', v.b);
742 else if (par
.eatId('true')) or (par
.eatId('tan')) then
744 v
.vtype
:= v
.TType
.Bool
;
747 else if (par
.eatId('false')) or (par
.eatId('ona')) then
749 v
.vtype
:= v
.TType
.Bool
;
752 else if (par
.isStr
) then
755 v
:= TStyleValue
.Create(par
.tokStr
);
758 else if (par
.eatId('inherit')) then
760 v
.vtype
:= v
.TType
.Empty
;
765 v
.vtype
:= v
.TType
.Int
;
766 v
.ival
:= par
.expectInt();
768 par
.expectDelim(';');
769 sect
.mVals
.put(s
, v
);
771 par
.expectDelim('}');
776 if (not par
.isIdOrStr
) then
778 if (Length(mId
) = 0) then par
.error('style name expected');
784 if (Length(mId
) = 0) then mId
:= 'default';
786 if (not par
.eatDelim(';')) then parseSection(mMain
, true, true);