basis/ui/gadgets/worlds/worlds.factor

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