\ X fonts                                              07dec04py

[defined] x11 [IF]
font class X-font
public: cell var name-string
        cell var id
        cell var fontset
        cell var ascent
how:    : assign ( addr u -- )  name-string $!
          0 name-string $@ + c!
          screen xrc dpy @  name-string $@ drop XLoadQueryFont
          dup 0= abort" Font not found"
\          dup 0<= IF  drop 0 screen xrc font@
\                      with id @ endwith  THEN
          dup id ! XFontStruct ascent @ ascent !
          0 sp@ >r 0 sp@ >r 0 sp@ >r screen xrc dpy @  name-string $@ drop
          r> r> r> XCreateFontSet  fontset !  drop 2drop ;
        : init ( addr u -- )  assign ;

\ X fonts                                              21aug99py

        | Create text_r sizeof XCharStruct allot
        | Variable font_d
        | Variable font_a
        | Variable dir_r
        : size ( addr u -- w h )  id @ -rot
          dir_r font_a font_d text_r
	    [defined] has-utf8' [IF] \ incomplete
		maxascii $80 =
		IF  Xutf8TextExtents  ELSE  XTextExtents  THEN
	    [ELSE]
		XTextExtents
	    [THEN]
          font_d @ font_a @ +
          text_r XCharStruct rbearing wx@
          text_r XCharStruct lbearing wx@ -
          text_r XCharStruct width w@ max swap ;

\ X fonts                                              12nov06py

        | Create text_i here sizeof XTextItem dup allot erase
        : draw ( addr u x y dpy -- )
	    >r
	    [defined] has-utf8 [IF]
		maxascii $80 = IF  fontset @  ELSE
		    id @ XFontStruct fid @  THEN
	    [ELSE]
		id @ XFontStruct fid @
	    [THEN]
	    text_i XTextItem font !
	    2swap swap text_i XTextItem chars 2!
	    ascent @ +
	    r> displays with
	    2>r drawable 2r> text_i 1
	    [defined] has-utf8 [IF]
		maxascii $80 =
		IF  Xutf8DrawText  ELSE  XDrawText  THEN
	    [ELSE]
		XDrawText
	    [THEN]
	    endwith ;
class;

: new-x-font ( addr u -- font ) x-font new ;
' new-x-font IS new-font

\ X fonts 16 bit                                       24oct99py

X-font class X-font16
how:    : size ( addr u -- w h )  2/ id @ -rot
          dir_r font_a font_d text_r
          XTextExtents16
          font_d @ font_a @ +
          text_r XCharStruct rbearing wx@
          text_r XCharStruct lbearing wx@ -
          text_r XCharStruct width w@ max swap ;

\ X fonts 16 bit                                       26may02py

        : draw ( addr u x y dpy -- )
          >r id @ XFontStruct fid @ text_i XTextItem font !
          2swap 2/ swap text_i XTextItem chars 2!
          ascent @ +
          r> displays with
	    2>r drawable 2r> text_i 1 XDrawText16
          endwith ;
class;

: new-x-font16 ( -- font ) x-font16 new ;
' new-x-font16 IS new-font16

[THEN]

\ win-font                                             28jul07py

[defined] win32 [IF]
font class win-font
public: cell var name-string
        cell var id
how:    : ?? ( flags n -- flag )  >> 1 and ; hmacro
        : assign ( addr u family flags width height -- )
          { family flags w h |
          name-string $! 0 name-string $@ + c!
          name-string $@ dup IF  drop  ELSE  nip  THEN
          family ANTIALIASED_QUALITY
          CLIP_DEFAULT_PRECIS OUT_TT_PRECIS DEFAULT_CHARSET
          flags 2 ??  flags 1 ??  flags 0 ??
          0 0 0 w h CreateFont }  id ! ;
        : init ( params -- ) assign ;

\ win-font                                             29jul07py
        : size ( addr u -- x y )  >utf16 >r >r
          id @ screen drawable SelectObject drop
          0. sp@ r> r> swap screen drawable GetTextExtentPoint32
          drop swap ;
        : draw ( addr u x y dpy -- )
          id @ swap displays with
              drawable SelectObject drop swap
              2swap >utf16 swap 2swap drawable TextOutW ?err
          endwith ;
class;
: new-win-font ( params -- font ) win-font new ;

\ win-font with X string convention                    12nov06py
slowvoc on
Vocabulary X-family             also X-family definitions
FF_DONTCARE    Constant *
FF_DECORATIVE  Constant decorative
FF_MODERN      Constant modern
FF_ROMAN       Constant roman
FF_SCRIPT      Constant script
FF_SWISS       Constant swiss   previous definitions
Vocabulary X-pitch              also X-pitch definitions
DEFAULT_PITCH  Constant *
FIXED_PITCH    Constant m
FIXED_PITCH    Constant c
VARIABLE_PITCH Constant p       previous definitions
Vocabulary X-charset            also X-charset definitions
DEFAULT_CHARSET     Constant *

\ win-font with X string convention                    23sep99py
ANSI_CHARSET        Constant iso8859-1
SYMBOL_CHARSET      Constant microsoft-symbol
SHIFTJIS_CHARSET    Constant jisx0208.1983-0
HANGEUL_CHARSET     Constant hangeul-0
GB2312_CHARSET      Constant gb2312.1980-0
CHINESEBIG5_CHARSET Constant big5-0
GREEK_CHARSET       Constant iso8859-7
TURKISH_CHARSET     Constant iso8859-9
HEBREW_CHARSET      Constant iso8859-8
ARABIC_CHARSET      Constant iso8859-6
BALTIC_CHARSET      Constant iso8859-4
RUSSIAN_CHARSET     Constant iso8859-5
THAI_CHARSET        Constant thai-0
EASTEUROPE_CHARSET  Constant iso8859-2
OEM_CHARSET         Constant oem-0  previous definitions

\ win-font with X string convention                    12nov06py
Vocabulary X-slant              also X-slant definitions
0 Constant r      1 Constant i    2 Constant u    3 Constant ui
4 Constant s      5 Constant si   6 Constant su   7 Constant sui
 0 Constant *                   previous definitions
Vocabulary X-weight             also X-weight definitions
FW_DONTCARE   Constant *
FW_THIN       Constant thin
FW_EXTRALIGHT Constant extralight
FW_LIGHT      Constant light
FW_NORMAL     Constant normal
FW_MEDIUM     Constant medium
FW_SEMIBOLD   Constant semibold
FW_BOLD       Constant bold
FW_EXTRABOLD  Constant extrabold
FW_HEAVY      Constant heavy    previous definitions slowvoc off

\ win-font with X string convention                    28jul07py

win-font class X-font
public: cell var win-name
how:    : -extract   '- skip 2dup '- scan 2swap 2 pick - ;
        : ?exec ( addr u wid -- ) dup >r search-wordlist
          IF  execute rdrop   ELSE  s" *" r> recurse  THEN ;
        : make-font ( family addr u wd s w h pitch chset -- id )
          { family addr u wd s w h pitch chset |
          addr u win-name $! 0 win-name $@ + c!
          u IF  win-name $@ drop  ELSE  0  THEN
          family pitch or ANTIALIASED_QUALITY
          CLIP_DEFAULT_PRECIS OUT_TT_PRECIS chset
          s 2 ??  s 1 ??  s 0 ??
          wd 0 0 0 w CreateFont } ;

\ win-font with X string convention                    28jul07py
        : assign ( addr u -- ) base push decimal  name-string $!
          name-string $@
          -extract & X-family ?exec -rot        \ foundry
          -extract 2swap                        \ family
          -extract & X-weight ?exec -rot        \ weight
          -extract & X-slant ?exec -rot         \ slant
          -extract 2drop                        \ adjstyl
          -extract 0. 2swap >number 2drop drop -rot \ width
          -extract 0. 2swap >number 2drop drop -rot \ pixelsize
          -extract 2drop  -extract 2drop  -extract 2drop
          -extract & X-pitch ?exec -rot         \ spacing
          -extract 2drop                        \ avgwidth
                   & X-charset ?exec  make-font  id ! ;  class;
: new-X-font ( params -- font )  X-font new ;
' new-X-font IS new-font                        [THEN]

