basis/ui/gadgets/worlds/worlds.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs cache colors combinators
   4 combinators.short-circuit concurrency.promises continuations
   5 destructors kernel literals math models namespaces opengl
   6 sequences strings ui.backend ui.gadgets ui.gadgets.tracks
   7 ui.gestures ui.pixel-formats ui.render ;
   8 IN: ui.gadgets.worlds
   9
  10 SYMBOLS:
  11     close-button
  12     minimize-button
  13     maximize-button
  14     resize-handles
  15     small-title-bar
  16     normal-title-bar
  17     textured-background
  18     dialog-window ;
  19
  20 CONSTANT: default-world-pixel-format-attributes
  21     {
  22         windowed
  23         double-buffered
  24     }
  25
  26 CONSTANT: default-world-window-controls
  27     {
  28         normal-title-bar
  29         close-button
  30         minimize-button
  31         maximize-button
  32         resize-handles
  33     }
  34
  35 TUPLE: world < track
  36     active? focused? grab-input? fullscreen?
  37     saved-position
  38     layers
  39     title status status-owner
  40     text-handle handle images
  41     window-loc
  42     pixel-format-attributes
  43     background-color
  44     promise
  45     window-controls
  46     window-resources ;
  47
  48 TUPLE: world-attributes
  49     { world-class initial: world }
  50     grab-input?
  51     { title string initial: "Factor Window" }
  52     status
  53     gadgets
  54     { pixel-format-attributes initial: $ default-world-pixel-format-attributes }
  55     { window-controls initial: $ default-world-window-controls }
  56     pref-dim
  57     { fill initial: 1 }
  58     { orientation initial: $ vertical } ;
  59
  60 : <world-attributes> ( -- world-attributes )
  61     world-attributes new ; inline
  62
  63 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
  64
  65 : grab-input ( gadget -- )
  66     find-world dup grab-input?>>
  67     [ drop ] [
  68         t >>grab-input?
  69         dup focused?>> [ handle>> (grab-input) ] [ drop ] if
  70     ] if ;
  71
  72 : ungrab-input ( gadget -- )
  73     find-world dup grab-input?>>
  74     [
  75         f >>grab-input?
  76         dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if
  77     ] [ drop ] if ;
  78
  79 : show-status ( string/f gadget -- )
  80     dup find-world dup [
  81         dup status>> [
  82             [ status-owner<< ] [ status>> set-model ] bi
  83         ] [ 3drop ] if
  84     ] [ 3drop ] if ;
  85
  86 : hide-status ( gadget -- )
  87     dup find-world dup [
  88         [ status-owner>> eq? ] keep
  89         '[ f _ [ status-owner<< ] [ status>> set-model ] 2bi ] when
  90     ] [ 2drop ] if ;
  91
  92 : window-resource ( resource -- resource )
  93     dup world get-global window-resources>> push ;
  94
  95 : set-gl-context ( world -- )
  96     [ world set-global ]
  97     [ handle>> select-gl-context ] bi ;
  98
  99 : with-gl-context ( world quot -- )
 100     '[ set-gl-context @ ]
 101     [ handle>> flush-gl-context gl-error ] bi ; inline
 102
 103 ERROR: no-world-found ;
 104
 105 : find-gl-context ( gadget -- )
 106     find-world [ set-gl-context ] [ no-world-found ] if* ;
 107
 108 : (request-focus) ( child world ? -- )
 109     pick parent>> pick eq? [
 110         [ dup parent>> dup ] 2dip
 111         [ (request-focus) ] keep
 112     ] unless focus-child ;
 113
 114 M: world request-focus-on
 115     2dup eq?
 116     [ 2drop ] [ dup focused?>> (request-focus) ] if ;
 117
 118 : new-world ( class -- world )
 119     vertical swap new-track
 120         t >>root?
 121         f >>active?
 122         { 0 0 } >>window-loc
 123         f >>grab-input?
 124         V{ } clone >>window-resources
 125         <promise> >>promise ;
 126
 127 : initial-background-color ( attributes -- color )
 128     window-controls>> textured-background swap member-eq?
 129     [ T{ rgba f 0.0 0.0 0.0 0.0 } ]
 130     [ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ;
 131
 132 GENERIC#: apply-world-attributes 1 ( world attributes -- world )
 133
 134 M: world apply-world-attributes
 135     {
 136         [ title>> >>title ]
 137         [ status>> >>status ]
 138         [ pixel-format-attributes>> >>pixel-format-attributes ]
 139         [ window-controls>> >>window-controls ]
 140         [ initial-background-color >>background-color ]
 141         [ grab-input?>> >>grab-input? ]
 142         [ gadgets>> dup sequence? [ [ 1 track-add ] each ] [ 1 track-add ] if ]
 143         [ pref-dim>> >>pref-dim ]
 144         [ fill>> >>fill ]
 145         [ orientation>> >>orientation ]
 146     } cleave ;
 147
 148 : <world> ( world-attributes -- world )
 149     [ world-class>> new-world ] keep apply-world-attributes
 150     dup request-focus ;
 151
 152 : as-big-as-possible ( world gadget -- )
 153     dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
 154
 155 M: world layout*
 156     [ call-next-method ]
 157     [ dup layers>> [ as-big-as-possible ] with each ] bi ;
 158
 159 M: world focusable-child* children>> [ t ] [ first ] if-empty ;
 160
 161 M: world children-on nip children>> ;
 162
 163 M: world remove-gadget
 164     2dup layers>> member-eq?
 165     [ layers>> remove-eq! drop ] [ call-next-method ] if ;
 166
 167 SYMBOL: flush-layout-cache-hook
 168
 169 flush-layout-cache-hook [ [ ] ] initialize
 170
 171 GENERIC: begin-world ( world -- )
 172 GENERIC: end-world ( world -- )
 173 GENERIC: resize-world ( world -- )
 174
 175 M: world begin-world drop ;
 176 M: world end-world drop ;
 177 M: world resize-world drop ;
 178
 179 M: world dim<<
 180     [ call-next-method ]
 181     [
 182         dup active?>> [
 183             dup handle>>
 184             [ [ set-gl-context ] [ resize-world ] bi ]
 185             [ drop ] if
 186         ] [ drop ] if
 187     ] bi ;
 188
 189 GENERIC: draw-world* ( world -- )
 190
 191 M: world draw-world*
 192     {
 193         [ gl-draw-init ]
 194         [ draw-gadget ]
 195         [ text-handle>> [ purge-cache ] when* ]
 196         [ images>> [ purge-cache ] when* ]
 197     } cleave ;
 198
 199 : draw-world? ( world -- ? )
 200     ! We don't draw deactivated worlds, or those with 0 size.
 201     ! On Windows, the latter case results in GL errors.
 202     { [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] } 1&& ;
 203
 204 TUPLE: world-error error world ;
 205
 206 C: <world-error> world-error
 207
 208 SYMBOL: ui-error-hook ! ( error -- )
 209
 210 : ui-error ( error -- )
 211     ui-error-hook get [ call( error -- ) ] [ die drop ] if* ;
 212
 213 ui-error-hook [ [ rethrow ] ] initialize
 214
 215 : draw-world ( world -- )
 216     dup draw-world? [
 217         [
 218             dup [ draw-world* ] with-gl-context
 219             flush-layout-cache-hook get call( -- )
 220         ] [
 221             swap f >>active? <world-error> rethrow
 222         ] recover
 223     ] [ drop ] if ;
 224
 225 world
 226 action-gestures [
 227     [ [ { C+ } ] dip f <key-down> ]
 228     [ '[ _ send-action ] ]
 229     bi*
 230 ] H{ } assoc-map-as
 231 H{
 232     { T{ key-down f { S+ } "DELETE" } [ \ cut-action send-action ] }
 233     { T{ key-down f { S+ } "INSERT" } [ \ paste-action send-action ] }
 234     { T{ key-down f { C+ } "INSERT" } [ \ copy-action send-action ] }
 235     { T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
 236     { T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
 237     { T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
 238     { T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
 239     { T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
 240     { T{ button-up f { M+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
 241 } assoc-union set-gestures
 242
 243 PREDICATE: specific-button-up < button-up #>> ;
 244 PREDICATE: specific-button-down < button-down #>> ;
 245 PREDICATE: specific-drag < drag #>> ;
 246
 247 : generalize-gesture ( gesture -- )
 248     clone f >># button-gesture ;
 249
 250 M: world handle-gesture
 251     2dup call-next-method [
 252         {
 253             { [ over specific-button-up? ] [ drop generalize-gesture f ] }
 254             { [ over specific-button-down? ] [ drop generalize-gesture f ] }
 255             { [ over specific-drag? ] [ drop generalize-gesture f ] }
 256             [ 2drop t ]
 257         } cond
 258     ] [ 2drop f ] if ;
 259
 260 : close-global ( world global -- )
 261     [ get-global find-world eq? ] keep '[ f _ set-global ] when ;
 262
 263 M: world world-pixel-format-attributes
 264     pixel-format-attributes>> ;
 265
 266 M: world check-world-pixel-format
 267     2drop ;
 268
 269 : with-world-pixel-format ( world quot -- )
 270     [ dup dup world-pixel-format-attributes <pixel-format> ]
 271     dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline