\ Xft fonts

Module xft

[defined] VFXForth [IF]
    library: libXft.so.2

    LocalExtern: XftFontMatch int XftFontMatch( int , int , int , int ); ( dpy screen pattern result -- pattern )
    LocalExtern: XftFontOpenPattern int XftFontOpenPattern( int , int ); ( dpy pattern -- font )
    LocalExtern: XftFontOpenXlfd int XftFontOpenXlfd( int , int , int ); ( dpy screen xlfd -- font )
    LocalExtern: XftXlfdParse int XftXlfdParse( int , int , int ); ( xlfd igf compf -- pattern )
    LocalExtern: XftTextExtents8 void XftTextExtents8( int , int , int , int , int ); ( dpy font string len extents -- )
    LocalExtern: XftTextExtentsUtf8 void XftTextExtentsUtf8( int , int , int , int , int ); ( dpy font string len extents -- )
    LocalExtern: XftDrawCreate int XftDrawCreate( int , int , int , int ); ( dpy drawable visual colormap -- draw )
    LocalExtern: XftDrawCreateAlpha int XftDrawCreateAlpha( int , int , int ); ( dpy drawable depth -- draw )
    LocalExtern: XftDrawChange void XftDrawChange( int , int ); ( draw drawable -- )
    LocalExtern: XftDrawDestroy void XftDrawDestroy( int ); ( draw -- )
    LocalExtern: XftDrawString8 void XftDrawString8( int , int , int , int , int , int , int ); ( d color font x y addr u -- )
    LocalExtern: XftDrawString16 void XftDrawString16( int , int , int , int , int , int , int ); ( d color font x y addr u -- )
    LocalExtern: XftDrawString32 void XftDrawString32( int , int , int , int , int , int , int ); ( d color font x y addr u -- )
    LocalExtern: XftDrawStringUtf8 void XftDrawStringUtf8( int , int , int , int , int , int , int ); ( d color font x y addr u -- )
    LocalExtern: XftDrawRect void XftDrawRect( int , int , int , int , int , int , int ); ( d color x y w h -- )
    LocalExtern: XftColorAllocValue int XftColorAllocValue( int , int , int , int , int ); ( d v cmap color result -- )
    LocalExtern: XftColorFree void XftColorFree( int , int , int , int ); ( d v cmap color -- )
    LocalExtern: XftDrawSetClip int XftDrawSetClip( int , int ); ( d r -- bool )

[ELSE]

also dos

legacy off

[defined] osx [IF]
    s" /usr/X11/lib/libXft.dylib" file-status nip 0= [IF]
	library libXft /usr/X11/lib/libXft.dylib
    [ELSE]
	library libXft /usr/X11R6/lib/libXft.dylib
    [THEN]
[ELSE]
    library libXft libXft.so.2
[THEN]

libXft XftFontMatch int int int int (int) XftFontMatch ( dpy screen pattern result -- pattern )
libXft XftFontOpenPattern int int (int) XftFontOpenPattern ( dpy pattern -- font )
libXft XftFontOpenXlfd int int int (int) XftFontOpenXlfd ( dpy screen xlfd -- font )
libXft XftXlfdParse int int int (int) XftXlfdParse ( xlfd igf compf -- pattern )
libXft XftTextExtents8 int int int int int (void) XftTextExtents8 ( dpy font string len extents -- )
libXft XftTextExtentsUtf8 int int int int int (void) XftTextExtentsUtf8 ( dpy font string len extents -- )
libXft XftDrawCreate int int int int (int) XftDrawCreate ( dpy drawable visual colormap -- draw )
libXft XftDrawCreateAlpha int int int (int) XftDrawCreateAlpha ( dpy drawable depth -- draw )
libXft XftDrawChange int int (void) XftDrawChange ( draw drawable -- )
libXft XftDrawDestroy int (void) XftDrawDestroy ( draw -- )
libXft XftDrawString8 int int int int int int int (void) XftDrawString8 ( d color font x y addr u -- )
libXft XftDrawString16 int int int int int int int (void) XftDrawString16 ( d color font x y addr u -- )
libXft XftDrawString32 int int int int int int int (void) XftDrawString32 ( d color font x y addr u -- )
libXft XftDrawStringUtf8 int int int int int int int (void) XftDrawStringUtf8 ( d color font x y addr u -- )
libXft XftDrawRect int int int int int int (void) XftDrawRect ( d color x y w h -- )
libXft XftColorAllocValue int int int int int (int) XftColorAllocValue ( d v cmap color result -- )
libXft XftColorFree int int int int (void) XftColorFree ( d v cmap color -- )
libXft XftDrawSetClip int int (int) XftDrawSetClip ( d r -- bool )

previous
[THEN]

: XftTextExtents  maxascii $80 =
    IF  XftTextExtentsUtf8  ELSE  XftTextExtents8  THEN ;
: XftDrawString  maxascii $80 =
    IF  XftDrawStringUtf8  ELSE  XftDrawString8  THEN ;

0 Constant XftTypeVoid
1 Constant XftTypeInteger
2 Constant XftTypeDouble
3 Constant XftTypeString
4 Constant XftTypeBool
5 Constant XftTypeMatrix

struct{
    short red
    short green
    short blue
    short alpha
} XRenderColor

 struct{
    cell pixel
    struct XRenderColor color
} XftColor   

struct{
    double xx
    double xy
    double yx
    double yy
} XftMatrix

\ Create Xft0Matrix  $3FF00000. 2, 0. 2, 0. 2, $3FF00000. 2,
\ Create Xft90Matrix  0. 2, $3FF00000. 2, $3FF00000. 2, 0. 2,

struct{
    cell type
    {
        ptr s
|       cell i
|       cell b
|       double d
|       ptr m
    }
} XftValue

struct{
    ptr next
    struct XftValue value
} XftValueList

struct{
    ptr object
    ptr values
} XftPatternElt

struct{
    cell num
    cell size
    ptr elts
} XftPattern

struct{
    cell ascent
    cell descent
    cell height
    cell max_advance_width
    ptr charset
    ptr pattern
} XftFont

struct{
    short width
    short height
    short x
    short y
    short xOff
    short yOff
} XGlyphInfo

also minos also

Variable xft-draw'

displays implements
    : dispose  xft-draw @ IF  xft-draw @ XftDrawDestroy  THEN
        :: dispose ;
class;

backing implements
    : create-pixmap  xft-draw @ IF  xft-draw @ XftDrawDestroy  THEN
        xft-draw off  :: create-pixmap ;
    : dispose  xft-draw @ IF  xft-draw @ XftDrawDestroy  THEN
        :: dispose ;
class;

doublebuffer implements
    : create-pixmap  xft-draw @ IF  xft-draw @ XftDrawDestroy  THEN
        xft-draw off  :: create-pixmap ;
    : dispose  xft-draw @ IF  xft-draw @ XftDrawDestroy  THEN
        :: dispose ;
class;

pixmap implements
    : create-pixmap  xft-draw @ IF  xft-draw @ XftDrawDestroy  THEN
        xft-draw off  :: create-pixmap ;
    : dispose  xft-draw @ IF  xft-draw @ XftDrawDestroy  THEN
        :: dispose ;
class;

previous xft definitions minos

X-font class Xft-font
    method add-font
    cell var extra-id
    cell var extra-name
    cell var extra-ascent
    2 cells var extra-code
how:
    : assign ( addr u -- )
        name-string $! 0 name-string $@ + c!
        screen xrc dpy @  screen xrc screen @
        name-string $@ drop XftFontOpenXlfd dup id !
        dup 0= abort" Font not found!"
        XftFont ascent @ ascent ! ;
    : add-font ( addr u clow chigh -- )
        extra-code 2! extra-name $! 0 extra-name $@ + c!
        screen xrc dpy @  screen xrc screen @
        extra-name $@ drop XftFontOpenXlfd dup extra-id !
        dup 0= abort" Font not found!"
        XftFont ascent @ extra-ascent ! ;
    | Create xft-color  sizeof XftColor allot
    $FFFF xft-color XftColor color XRenderColor alpha w!
    : set-color ( color dpy -- )
        displays with
            dup xrc color xft-color XftColor pixel !
            cells Colortable + @
            dup cfix >r 8 >> dup cfix >r 8 >> cfix r> r>
            [ xft-color XftColor color XRenderColor red ] ALiteral w!+ w!+ w!
        endwith ;
    : scan-within ( addr u -- addr' ) over + >r
        dup  BEGIN  nip dup r@ u<  WHILE
            dup xc@+ extra-code 2@ within  UNTIL
            drop  THEN  rdrop ;
    : swap-id ( -- )
        id @ extra-id @ id ! extra-id !
        ascent @ extra-ascent @ ascent ! extra-ascent !
        extra-code 2@ swap extra-code 2! ;
    | Create text_r sizeof XGlyphInfo allot
    : size ( addr u -- w h ) 0 { addr u w }
        0  BEGIN
            1 +  addr u  scan-within >r
            screen xrc dpy @ id @ addr r@ over - text_r XftTextExtents
            text_r XGlyphInfo xOff w@ w + to w
            addr u r> addr - safe/string to u to addr  swap-id
        u 0<= UNTIL
        1 and IF  swap-id  THEN
        w id @ dup XftFont ascent @ swap XftFont descent @ + ;
    : draw ( addr u x y dpy -- ) { addr u x y dpy }
        color @ $FF and dpy set-color
        dpy displays with
            xft-draw @ 0= IF
                & pixmap @ class? IF
                    drawable drop xrc depth @
                    XftDrawCreateAlpha
                ELSE
                    drawable drop xrc vis @
                    xrc cmap @ XftDrawCreate
                THEN  xft-draw !
            THEN
            xft-draw @ dup clip-r @ XftDrawSetClip drop
        endwith xft-draw' ! 0
        BEGIN
            1+  addr u  scan-within >r
            xft-draw' @ xft-color id @ x y ascent @ +
            addr r@ over - XftDrawString
            screen xrc dpy @ id @ addr r@ over - text_r XftTextExtents
            text_r XGlyphInfo xOff w@ x + to x
            addr u r> addr - safe/string to u to addr  swap-id
        u 0<= UNTIL
        1 and IF  swap-id  THEN ;
class;

: xft-new-font  Xft-font new ;

: clear-font ( n -- )
    screen xrc font[] off ;
: add-font ( addr u encl ench n -- )
    screen xrc font[] @ Xft-font with add-font endwith ;

: (normal-font ( -- )
    screen xrc with
    [defined] osx [IF]
        s" -*-Helvetica Neue-bold-r-normal--12-*-*-*-p-*-iso10646-1" 0 font!
        s" -*-Andale Mono-medium-r-normal--12-*-*-*-c-*-iso10646-1" 1 font!
        s" -*-Helvetica Neue-medium-r-normal--8-*-*-*-p-*-iso10646-1" 2 font!
	s" -*-Helvetica Neue-medium-r-normal--12-*-*-*-c-*-iso10646-1" 3 font!
    [ELSE]
        s" -*-FreeSans-bold-r-normal--12-*-*-*-p-*-iso10646-1" 0 font!
        s" -*-FreeMono-medium-r-normal--12-*-*-*-c-*-iso10646-1" 1 font!
        s" -*-FreeSans-medium-r-normal--8-*-*-*-p-*-iso10646-1" 2 font!
	s" -*-FreeSans-medium-r-normal--12-*-*-*-c-*-iso10646-1" 3 font!
    [THEN]
    endwith
    maxascii $80 = IF
	s" -*-ar pl kaitim gb-bold-r-normal--15-*-*-*-c-*-iso10646-1"   $2E80 $A000 0 add-font
	s" -*-ar pl kaitim gb-medium-r-normal--14-*-*-*-c-*-iso10646-1" $2E80 $A000 1 add-font
	s" -*-ar pl kaitim gb-medium-r-normal--10-*-*-*-c-*-iso10646-1" $2E80 $A000 2 add-font
	s" -*-ar pl kaitim gb-medium-r-normal--15-*-*-*-c-*-iso10646-1" $2E80 $A000 3 add-font
    THEN
    0" -*-FreeSans-*-r-*-*-*-120-*-*-*-*-*-*,-misc-fixed-*-r-*-*-*-130-*-*-*-*-*-*" screen xrc fontset!
    screen !resized ;

: (large-font ( -- )
    screen xrc with
    [defined] osx [IF]
       s" -*-Helvetica Neue-bold-r-normal--16-*-*-*-p-*-iso10646-1" 0 font!
       s" -*-Andale Mono-medium-r-normal--16-*-*-*-c-*-iso10646-1" 1 font!
       s" -*-Helvetica Neue-medium-r-normal--10-*-*-*-p-*-iso10646-1" 2 font!
       s" -*-Helvetica Neue-medium-r-normal--16-*-*-*-p-*-iso10646-1" 3 font!
    [ELSE]
       s" -*-FreeSans-bold-r-normal--16-*-*-*-p-*-iso10646-1" 0 font!
       s" -*-FreeMono-medium-r-normal--16-*-*-*-c-*-iso10646-1" 1 font!
       s" -*-FreeSans-medium-r-normal--10-*-*-*-p-*-iso10646-1" 2 font!
       s" -*-FreeSans-medium-r-normal--16-*-*-*-p-*-iso10646-1" 3 font!
    [THEN]
    endwith
    maxascii $80 = IF
	s" -*-ar pl kaitim gb-bold-r-normal--22-*-*-*-c-*-iso10646-1"   $2E80 $A000 0 add-font
	s" -*-ar pl kaitim gb-medium-r-normal--20-*-*-*-c-*-iso10646-1" $2E80 $A000 1 add-font
	s" -*-ar pl kaitim gb-medium-r-normal--12-*-*-*-c-*-iso10646-1" $2E80 $A000 2 add-font
	s" -*-ar pl kaitim gb-medium-r-normal--22-*-*-*-c-*-iso10646-1" $2E80 $A000 3 add-font
    THEN
    0" -*-FreeSans-*-r-*-*-*-120-*-*-*-*-*-*,-misc-fixed-*-r-*-*-*-130-*-*-*-*-*-*" screen xrc fontset!
    screen !resized ;

[defined] VFXForth [IF]
    also minos xft
[ELSE]
    also xft
[THEN]

: xft-fonts ( -- )
    ['] xft-new-font IS new-font
    ['] (large-font IS large-font
    ['] (normal-font IS normal-font ;

previous previous

[defined] VFXForth [IF]
    module;
    also minos also xft
    synonym (normal-font (normal-font
    synonym (large-font (large-font
    synonym clear-font clear-font
    synonym xft-fonts xft-fonts

    ' xft-fonts IS font-init

    xft-fonts
    previous previous
[ELSE]
main: xft-fonts ;

export xft (normal-font (large-font clear-font xft-fonts ;

module;

xft-fonts
[THEN]

