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