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