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, version 3 of the License ONLY.
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this program. If not, see <http://www.gnu.org/licenses/>.
16 {$INCLUDE ../shared/a_modes.inc}
17 {$DEFINE FUI_TEXT_ICONS}
25 TGxContext
= class abstract
28 TMarkIcon
= (Checkbox
, Radiobox
);
31 public (* abstract interface *)
32 procedure line (x1
, y1
, x2
, y2
: Integer); virtual; abstract;
33 procedure hline (x
, y
, len
: Integer); virtual; abstract;
34 procedure vline (x
, y
, len
: Integer); virtual; abstract;
35 procedure rect (x
, y
, w
, h
: Integer); virtual; abstract;
36 procedure fillRect (x
, y
, w
, h
: Integer); virtual; abstract;
37 procedure darkenRect (x
, y
, w
, h
: Integer; a
: Integer); virtual; abstract;
39 function charWidth (const ch
: AnsiChar): Integer; virtual; abstract;
40 function charHeight (const ch
: AnsiChar): Integer; virtual; abstract;
41 function textWidth (const s
: AnsiString): Integer; virtual; abstract;
42 function textHeight (const s
: AnsiString): Integer; virtual; abstract;
43 function drawChar (x
, y
: Integer; const ch
: AnsiChar): Integer; virtual; abstract; // returns char width
44 function drawText (x
, y
: Integer; const s
: AnsiString): Integer; virtual; abstract; // returns text width
46 procedure resetClip (); virtual; abstract;
47 function combineClip (constref aclip
: TGxRect
): TGxRect
; virtual; abstract; // returns previous clip
49 protected (* abstract interface *)
50 function getColor (): TGxRGBA
; virtual; abstract;
51 procedure setColor (const clr
: TGxRGBA
); virtual; abstract;
53 function getFont (): AnsiString; virtual; abstract;
54 procedure setFont (const aname
: AnsiString); virtual; abstract;
56 function getClipRect (): TGxRect
; virtual; abstract;
57 procedure setClipRect (const aclip
: TGxRect
); virtual; abstract;
59 procedure onActivate (); virtual; abstract;
60 procedure onDeactivate (); virtual; abstract;
62 procedure setScale (a
: Single); virtual; abstract;
64 public (* portable interface *)
65 function iconMarkWidth (ic
: TMarkIcon
): Integer;
66 function iconMarkHeight (ic
: TMarkIcon
): Integer;
67 procedure drawIconMark (ic
: TMarkIcon
; x
, y
: Integer; marked
: Boolean);
69 function iconWinWidth (ic
: TWinIcon
): Integer;
70 function iconWinHeight (ic
: TWinIcon
): Integer;
71 procedure drawIconWin (ic
: TWinIcon
; x
, y
: Integer; pressed
: Boolean);
73 procedure drawVSBar (x
, y
, wdt
, hgt
: Integer; cur
, min
, max
: Integer; constref clrfull
, clrempty
: TGxRGBA
);
74 procedure drawHSBar (x
, y
, wdt
, hgt
: Integer; cur
, min
, max
: Integer; constref clrfull
, clrempty
: TGxRGBA
);
76 class function sbarFilled (wh
: Integer; cur
, min
, max
: Integer): Integer;
77 class function sbarPos (cxy
: Integer; xy
, wh
: Integer; min
, max
: Integer): Integer;
83 property active
: Boolean read mActive
;
84 property color
: TGxRGBA read getColor write setColor
;
85 property font
: AnsiString read getFont write setFont
;
86 property clip
: TGxRect read getClipRect write setClipRect
; // clipping is unaffected by offset
89 // set active context; `ctx` can be `nil`
90 function gxCreateContext (): TGxContext
;
91 procedure gxSetContext (ctx
: TGxContext
; ascale
: Single=1.0);
92 procedure gxGfxLoadFont (const fontname
: AnsiString; const fontFile
: AnsiString; proportional
: Boolean=false);
94 var (* installed by implementation *)
95 gxPreSetContextCallback
: procedure = nil;
96 gxCreateContextCallback
: function (): TGxContext
= nil;
97 gxFuiGfxLoadFontCallback
: procedure (const fontname
: AnsiString; const fontFile
: AnsiString; proportional
: Boolean) = nil;
101 uses SysUtils
, utils
;
104 curCtx
: TGxContext
= nil;
106 function gxCreateContext (): TGxContext
;
109 if Assigned(gxCreateContextCallback
) then
110 result
:= gxCreateContextCallback();
113 procedure gxSetContext (ctx
: TGxContext
; ascale
: Single=1.0);
115 if Assigned(gxPreSetContextCallback
) then
116 gxPreSetContextCallback
;
117 if curCtx
<> nil then
119 curCtx
.onDeactivate();
120 curCtx
.mActive
:= false;
127 ctx
.setScale(ascale
);
131 procedure gxGfxLoadFont (const fontname
: AnsiString; const fontFile
: AnsiString; proportional
: Boolean=false);
133 if Assigned(gxFuiGfxLoadFontCallback
) then
134 gxFuiGfxLoadFontCallback(fontname
, fontFile
, proportional
)
136 raise Exception
.Create('FlexUI: hook not installed: font named '''+fontname
+''' can not be loaded')
139 function TGxContext
.iconMarkWidth (ic
: TMarkIcon
): Integer;
141 {$IFDEF FUI_TEXT_ICONS}
143 TMarkIcon
.Checkbox
: result
:= textWidth('[x]');
144 TMarkIcon
.Radiobox
: result
:= textWidth('(*)');
145 else result
:= textWidth('[x]');
152 function TGxContext
.iconMarkHeight (ic
: TMarkIcon
): Integer;
154 {$IFDEF FUI_TEXT_ICONS}
156 TMarkIcon
.Checkbox
: result
:= textHeight('[x]');
157 TMarkIcon
.Radiobox
: result
:= textHeight('(*)');
158 else result
:= textHeight('[x]');
165 procedure TGxContext
.drawIconMark (ic
: TMarkIcon
; x
, y
: Integer; marked
: Boolean);
167 {$IFDEF FUI_TEXT_ICONS}
173 if (not self
.active
) or (self
.clip
.w
< 1) or (self
.clip
.h
< 1) or (self
.color
.a
= 0) then exit
;
174 {$IFDEF FUI_TEXT_ICONS}
176 TMarkIcon
.Checkbox
: xstr
:= '[x]';
177 TMarkIcon
.Radiobox
: xstr
:= '(*)';
182 drawText(x
, y
, xstr
);
186 drawChar(x
, y
, xstr
[1]);
187 drawChar(x
+textWidth(xstr
)-charWidth(xstr
[3]), y
, xstr
[3]);
190 if (ic
= TMarkIcon
.Checkbox
) then
208 if (not marked
) then exit
;
214 vline(x
+3+f
, y
+1+f
, 1);
215 vline(x
+7-f
, y
+1+f
, 1);
230 function TGxContext
.iconWinWidth (ic
: TWinIcon
): Integer;
232 {$IFDEF FUI_TEXT_ICONS}
234 TWinIcon
.Close
: result
:= nmax(textWidth('[x]'), textWidth('[#]'));
235 else result
:= nmax(textWidth('[x]'), textWidth('[#]'));
242 function TGxContext
.iconWinHeight (ic
: TWinIcon
): Integer;
244 {$IFDEF FUI_TEXT_ICONS}
246 TWinIcon
.Close
: result
:= nmax(textHeight('[x]'), textHeight('[#]'));
247 else result
:= nmax(textHeight('[x]'), textHeight('[#]'));
254 procedure TGxContext
.drawIconWin (ic
: TWinIcon
; x
, y
: Integer; pressed
: Boolean);
256 {$IFDEF FUI_TEXT_ICONS}
263 if (not self
.active
) or (self
.clip
.w
< 1) or (self
.clip
.h
< 1) or (self
.color
.a
= 0) then exit
;
264 {$IFDEF FUI_TEXT_ICONS}
266 TWinIcon
.Close
: if (pressed
) then xstr
:= '[#]' else xstr
:= '[x]';
269 wdt
:= nmax(textWidth('[x]'), textWidth('[#]'));
270 drawChar(x
, y
, xstr
[1]);
271 drawChar(x
+wdt
-charWidth(xstr
[3]), y
, xstr
[3]);
272 drawChar(x
+((wdt
-charWidth(xstr
[2])) div 2), y
, xstr
[2]);
274 if pressed
then rect(x
, y
, 9, 8);
277 vline(x
+1+f
, y
+f
, 1);
278 vline(x
+1+6-f
, y
+f
, 1);
283 // vertical scroll bar
284 procedure TGxContext
.drawVSBar (x
, y
, wdt
, hgt
: Integer; cur
, min
, max
: Integer; constref clrfull
, clrempty
: TGxRGBA
);
288 if (wdt
< 1) or (hgt
< 1) then exit
;
289 filled
:= sbarFilled(hgt
, cur
, min
, max
);
291 fillRect(x
, y
, wdt
, filled
);
293 fillRect(x
, y
+filled
, wdt
, hgt
-filled
);
296 // horizontal scrollbar
297 procedure TGxContext
.drawHSBar (x
, y
, wdt
, hgt
: Integer; cur
, min
, max
: Integer; constref clrfull
, clrempty
: TGxRGBA
);
301 if (wdt
< 1) or (hgt
< 1) then exit
;
302 filled
:= sbarFilled(wdt
, cur
, min
, max
);
304 fillRect(x
, y
, filled
, hgt
);
306 fillRect(x
+filled
, y
, wdt
-filled
, hgt
);
309 class function TGxContext
.sbarFilled (wh
: Integer; cur
, min
, max
: Integer): Integer;
311 if (wh
< 1) then result
:= 0
312 else if (min
> max
) then result
:= 0
313 else if (min
= max
) then result
:= wh
316 if (cur
< min
) then cur
:= min
else if (cur
> max
) then cur
:= max
;
317 result
:= wh
*(cur
-min
) div (max
-min
);
321 class function TGxContext
.sbarPos (cxy
: Integer; xy
, wh
: Integer; min
, max
: Integer): Integer;
323 if (wh
< 1) then begin result
:= 0; exit
; end;
324 if (min
> max
) then begin result
:= 0; exit
; end;
325 if (min
= max
) then begin result
:= max
; exit
; end;
326 if (cxy
< xy
) then begin result
:= min
; exit
; end;
327 if (cxy
>= xy
+wh
) then begin result
:= max
; exit
; end;
328 result
:= min
+((max
-min
)*(cxy
-xy
) div wh
);
329 assert((result
>= min
) and (result
<= max
));