libs/xog/xog-font-core.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; X11 OOF GUI -- X11 Core Font implementation
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 use-libs: oof x11
   9
  10
  11 BaseFont oop:class
  12   field fsetid  ;; fontset
  13
  14   method (setup-font-sizes)  ( -- )
  15
  16   method fsetid@  ( -- fsetid )
  17 end-class: CoreFont
  18
  19
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 also x11 also xconst
  22
  23
  24 CoreFont method: build-font-name  ( size fonttype -- addr count )
  25   NullString pad c4s:copy-counted
  26   " -*-" pad c4s:cat-counted
  27   " helvetica" pad c4s:cat-counted
  28   dup FontType-Bold and if " -bold-" else " -medium-" endif pad c4s:cat-counted
  29   dup FontType-Italic and if " i" else " r" endif pad c4s:cat-counted
  30   drop  ;; fonttype
  31   " -*-*-" pad c4s:cat-counted
  32   dup +if <#u #s #> else " *" endif pad c4s:cat-counted
  33   " -*-*-*-*-*-*-*" pad c4s:cat-counted
  34   pad c4s:zterm
  35   pad count
  36 ;
  37
  38
  39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40 CoreFont method: init  ( -- )  0 to fsetid call-super ;
  41 CoreFont method: fsetid@  ( -- ascent )  fsetid ;
  42 CoreFont method: is-valid?  ( -- flag )  fsetid notnot ;
  43
  44 CoreFont method: destroy  ( -- )
  45   fsetid xog-dpy logand if fsetid xog-dpy XFreeFontSet drop endif
  46   call-super
  47 ;
  48
  49
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51 CoreFont method: (setup-font-sizes)  ( -- )
  52   0 to ascent 0 to descent 0 to max-width  ;; just in case
  53   2 cells ralloca >r  ;; XFontStruct **, char **font_names
  54   r@ 2 cells erase
  55   r@ cell+ ( names) r@ ( fstructs) fsetid XFontsOfFontSet  ;; returns count
  56   begin dup +while
  57     (*
  58       ." font: " r@ cell+ @ @ zcount type space
  59       ." ascent: " r@ @ @ XFontStruct ascent c@ .
  60       ." descent: " r@ @ @ XFontStruct descent c@ . cr
  61     *)
  62     r@ @ @
  63     dup XFontStruct ascent c@ ascent max to ascent
  64     XFontStruct descent c@ descent max to descent
  65     cell r@ +! cell r@ cell+ +! 1-  ;; is this right?
  66   repeat drop rdrop 2 cells rdealloca
  67   (*
  68     ." final ascent: " ascent . cr
  69     ." final descent: " descent . cr
  70   *)
  71 ;
  72
  73
  74 CoreFont method: create  ( addr count -- successflag )
  75   is-valid? if 2drop false exit endif
  76   xog-dpy ifnot 2drop false exit endif
  77   ensure-asciiz >r
  78   2 cells ralloca >r
  79   0 r@ rot >r dup cell+ r> xog-dpy XCreateFontSet
  80   rdrop 2 cells rdealloca r> free-asciiz
  81   dup to fsetid notnot
  82   dup if (setup-font-sizes) endif
  83 ;
  84
  85
  86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87 ;; `XmbTextExtents` returns log width
  88
  89 ;; y is "up from the base line"
  90 CoreFont method: ink-extents  ( addr count -- x y width height )  0 max
  91   0 XRectangle @sizeof ralloca dup >r
  92   2swap swap fsetid XmbTextExtents drop \ ." !!!" . cr
  93   r> (xrect>stack) XRectangle @sizeof rdealloca
  94 ;
  95
  96 ;; y is "up from the base line"
  97 CoreFont method: log-extents  ( addr count -- x y width height )  0 max
  98   XRectangle @sizeof ralloca dup >r
  99   0 2swap swap fsetid XmbTextExtents drop \ ." !!!" . cr
 100   r> (xrect>stack) XRectangle @sizeof rdealloca
 101 ;
 102
 103
 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 105 CoreFont method: fill  ( addr count x y winobj -- )
 106   >r ( save winobj) ascent +  ;; to draw from (x, y)
 107   swap 2swap swap 2swap r@ ::invoke BaseWindow wingc fsetid r> ::invoke BaseWindow winid xog-dpy XmbDrawImageString
 108 ;
 109
 110 CoreFont method: draw  ( addr count x y winobj -- )
 111   >r ( save winobj) ascent +  ;; to draw from (x, y)
 112   swap 2swap swap 2swap r@ ::invoke BaseWindow wingc fsetid r> ::invoke BaseWindow winid xog-dpy XmbDrawString
 113 ;
 114
 115
 116 previous previous