libs/xog/xog-widget-base.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 Base Widget Class
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 use-libs: oof x11
   9
  10 also x11 also xconst
  11
  12
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14 also xog-style definitions
  15 CoreFont oop:new-allot oop:value font BaseFont
  16
  17 \ FIXME: make this adjustable
  18 ..: (xog-dpy-after-open)  ( -- )
  19   14 FontType-Normal font build-font-name
  20   font create not-?abort" cannot create X11 font"
  21 ;..
  22
  23 previous definitions
  24
  25
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 BaseWindow oop:class
  28   field hotkey
  29   field caption-width
  30   field caption-height
  31   field caption-hotofs  ;; offset of caption underscore
  32   field caption-hotlen  ;; pixel length of caption underscore
  33   field caption-hotpos  ;; string position of hotkey underscore
  34   field cb-action  ( self -- )
  35   field down?
  36
  37   ;; this WILL MODIFY THE STRING!
  38   ;; it will also update the corresponding fields
  39   method (caption-extract-hotkey)  ( addr count -- newcount )
  40
  41   method (calc-caption-props)  ( -- )
  42
  43   method set-action  ( actionptr -- )
  44
  45   ;; calls cb-action by default
  46   method click  ( -- )
  47
  48   method draw-caption  ( -- )
  49   method draw-bevel  ( -- )
  50   method draw-focus-rect  ( -- )
  51 end-class: BaseWidget
  52
  53
  54 BaseWidget method: (caption-extract-hotkey)  ( addr count -- newcount )
  55   0 to hotkey -1 to caption-hotpos 0 to caption-hotlen
  56   ;; reset caption size, so everything will be recalced
  57   0 to caption-width 0 to caption-height
  58   dup 2 < if nip 0 max exit endif
  59   2dup [char] & str-char-index ifnot nip exit endif
  60   dup to caption-hotpos >r  ( addr count | pos )
  61   over r@ + 1+ c@ locase-char
  62   dup case
  63     [char] 0 [char] 9 bounds-of to hotkey endof
  64     [char] a [char] z bounds-of to hotkey endof
  65     otherwise 2drop nip rdrop exit
  66   endcase
  67   r> over 1- >r /string >r dup 1+ swap r> 1- move r>
  68 ;
  69
  70 BaseWidget method: get-caption  ( -- addr count )  NullString ;
  71
  72 BaseWidget method: bg-color  ( -- color )  xog-style:background-color ;
  73
  74 BaseWidget method: init  ( -- )
  75   call-super
  76   92 to width
  77   42 to height
  78   true to visible?
  79   false to down?
  80   0 to cb-action
  81   0 to hotkey
  82   0 to caption-width
  83   0 to caption-height
  84   0 to caption-hotofs
  85   0 to caption-hotlen
  86   -1 to caption-hotpos
  87 ;
  88
  89 BaseWidget method: set-action  ( actionptr -- )
  90   to cb-action
  91 ;
  92
  93 BaseWidget method: click  ( -- )
  94   cb-action ?dup if self swap execute-tail endif
  95 ;
  96
  97 BaseWidget method: (calc-caption-props)  ( -- )
  98   caption-width caption-height logand ifnot
  99     get-caption ?dup if
 100       2dup xog-style:font log-extents
 101       to caption-height to caption-width 2drop
 102       caption-hotpos over 0 swap within if
 103         ;; calculate hotkey underscore
 104         drop dup caption-hotpos +
 105         swap caption-hotpos xog-style:font log-width to caption-hotofs
 106         1 xog-style:font log-width to caption-hotlen
 107           \ endcr get-caption type ." : hotpos=" caption-hotpos . ." hotofs=" caption-hotofs . ." hotlen=" caption-hotlen . cr
 108       else 2drop 0 to caption-hotlen endif
 109     else drop 0 to caption-hotlen ( just in case) endif
 110   endif
 111 ;
 112
 113
 114 BaseWidget method: on-draw-part  ( x y width height count -- )
 115   dirty? double-buffered? logand if drop 2drop 2drop on-draw else call-super endif
 116 ;
 117
 118
 119 BaseWidget method: draw-caption  ( -- )
 120   get-caption ?dup if
 121     xog-style:text-color set-color
 122     (calc-caption-props)
 123     width caption-width - 2/ down? if 1+ endif
 124     height caption-height - 2/ down? if 1+ endif
 125     self xog-style:font draw
 126     caption-hotlen if
 127       set-line-solid
 128       width caption-width - 2/ down? if 1+ endif caption-hotpos +
 129       height caption-height - 2/ down? if 1+ endif caption-height + 1-
 130       over caption-hotlen + over draw-line
 131     endif
 132   else drop endif
 133 ;
 134
 135 BaseWidget method: draw-bevel  ( -- )
 136   ;; top and left
 137   down? if xog-style:dark-color else xog-style:light-color endif set-color
 138   0 0 width 0 draw-line
 139   0 0 0 height draw-line
 140   ;; right and bottom
 141   down? if xog-style:light-color else xog-style:dark-color endif set-color
 142   width 1- 0 width 1- height draw-line
 143   0 height 1- width height 1- draw-line
 144   ;; shadow
 145   down? if
 146     xog-style:shadow-color set-color
 147     1 1 width 2- 1 draw-line
 148     1 2 1 height 2- draw-line
 149   else
 150     xog-style:shadow-color set-color
 151     width 2- 1 width 2- height 2- draw-line
 152     1 height 2- width 2- height 2- draw-line
 153   endif
 154 ;
 155
 156 BaseWidget method: draw-focus-rect  ( -- )
 157   focused? if
 158     set-line-dashed
 159     xog-style:dark-color set-color
 160     2 down? if 1+ endif
 161     2 down? if 1+ endif
 162     width 6 - height 6 - draw-rect
 163     set-line-solid
 164   endif
 165 ;
 166
 167 BaseWidget method: on-draw  ( -- )
 168   dirty? if non-dirty!
 169       \ endcr ." on-draw for " (debug-id.) cr
 170     xog-style:background-color set-color
 171     0 0 width height fill-rect
 172     draw-caption
 173     draw-bevel
 174     draw-focus-rect
 175   endif
 176 ;
 177
 178 BaseWidget method: on-button-down  ( bnum -- )
 179   can-focus? if
 180     1 = if focus true to down? invalidate event-eat endif
 181   else drop endif
 182 ;
 183
 184 BaseWidget method: on-button-up  ( bnum -- )
 185   can-focus? if
 186     1 = if
 187       down? false to down? if
 188         invalidate
 189         (event) XButtonEvent x @ 0 width within
 190         (event) XButtonEvent y @ 0 height within and if click endif
 191       endif
 192       event-eat
 193     endif
 194   else drop down? if false to down? invalidate
 195   endif endif
 196 ;
 197
 198 BaseWidget method: on-focus  ( -- )
 199   focused? ifnot invalidate endif
 200 ;
 201
 202 BaseWidget method: on-blur  ( -- )
 203   focused? if invalidate endif
 204 ;
 205
 206 BaseWidget method: on-hide  ( -- )
 207   false to down?
 208 ;
 209
 210
 211 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 212 previous previous