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 assocs cache colors combinators
   4 combinators.short-circuit concurrency.promises continuations
   5 destructors fry kernel literals math models namespaces opengl
   6 opengl.capabilities opengl.textures sequences strings ui.backend
   7 ui.gadgets ui.gadgets.tracks ui.gestures ui.pixel-formats
   8 ui.render ;
   9 IN: ui.gadgets.worlds
  10
  11 SYMBOLS:
  12     close-button
  13     minimize-button
  14     maximize-button
  15     resize-handles
  16     small-title-bar
  17     normal-title-bar
  18     textured-background
  19     dialog-window ;
  20
  21 CONSTANT: default-world-pixel-format-attributes
  22     {
  23         windowed
  24         double-buffered
  25     }
  26
  27 CONSTANT: default-world-window-controls
  28     {
  29         normal-title-bar
  30         close-button
  31         minimize-button
  32         maximize-button
  33         resize-handles
  34     }
  35
  36 TUPLE: world < track
  37     active? focused? grab-input? fullscreen?
  38     saved-position
  39     layers
  40     title status status-owner
  41     text-handle handle images
  42     window-loc
  43     pixel-format-attributes
  44     background-color
  45     promise
  46     window-controls
  47     window-resources ;
  48
  49 TUPLE: world-attributes
  50     { world-class initial: world }
  51     grab-input?
  52     { title string initial: "Factor Window" }
  53     status
  54     gadgets
  55     { pixel-format-attributes initial: $ default-world-pixel-format-attributes }
  56     { window-controls initial: $ default-world-window-controls }
  57     pref-dim ;
  58
  59 : <world-attributes> ( -- world-attributes )
  60     world-attributes new ; inline
  61
  62 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
  63
  64 : grab-input ( gadget -- )
  65     find-world dup grab-input?>>
  66     [ drop ] [
  67         t >>grab-input?
  68         dup focused?>> [ handle>> (grab-input) ] [ drop ] if
  69     ] if ;
  70
  71 : ungrab-input ( gadget -- )
  72     find-world dup grab-input?>>
  73     [
  74         f >>grab-input?
  75         dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if
  76     ] [ drop ] if ;
  77
  78 : show-status ( string/f gadget -- )
  79     dup find-world dup [
  80         dup status>> [
  81             [ status-owner<< ] [ status>> set-model ] bi
  82         ] [ 3drop ] if
  83     ] [ 3drop ] if ;
  84
  85 : hide-status ( gadget -- )
  86     dup find-world dup [
  87         [ status-owner>> eq? ] keep
  88         '[ f _ [ status-owner<< ] [ status>> set-model ] 2bi ] when
  89     ] [ 2drop ] if ;
  90
  91 : window-resource ( resource -- resource )
  92     dup world get-global window-resources>> push ;
  93
  94 : set-gl-context ( world -- )
  95     [ world set-global ]
  96     [ handle>> select-gl-context ] bi ;
  97
  98 : with-gl-context ( world quot -- )
  99     '[ set-gl-context @ ]
 100     [ handle>> flush-gl-context gl-error-nonfatal ] bi ; inline
 101
 102 ERROR: no-world-found ;
 103
 104 : find-gl-context ( gadget -- )
 105     find-world dup
 106     [ 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 ( child gadget -- )
 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     } cleave ;
 145
 146 : <world> ( world-attributes -- world )
 147     [ world-class>> new-world ] keep apply-world-attributes
 148     dup request-focus ;
 149
 150 : as-big-as-possible ( world gadget -- )
 151     dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
 152
 153 M: world layout*
 154     [ call-next-method ]
 155     [ dup layers>> [ as-big-as-possible ] with each ] bi ;
 156
 157 M: world focusable-child* children>> [ t ] [ first ] if-empty ;
 158
 159 M: world children-on nip children>> ;
 160
 161 M: world remove-gadget
 162     2dup layers>> member-eq?
 163     [ layers>> remove-eq! drop ] [ call-next-method ] if ;
 164
 165 SYMBOL: flush-layout-cache-hook
 166
 167 flush-layout-cache-hook [ [ ] ] initialize
 168
 169 GENERIC: begin-world ( world -- )
 170 GENERIC: end-world ( world -- )
 171 GENERIC: resize-world ( world -- )
 172
 173 M: world begin-world drop ;
 174 M: world end-world drop ;
 175 M: world resize-world 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     "1.0" require-gl-version
 192     {
 193         [ init-gl ]
 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
 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         dup world [
 218             [
 219                 dup [ draw-world* ] with-gl-context
 220                 flush-layout-cache-hook get call( -- )
 221             ] [
 222                 swap f >>active? <world-error> ui-error
 223             ] recover
 224         ] with-variable
 225     ] [ drop ] if ;
 226
 227 world
 228 action-gestures [
 229     [ [ { C+ } ] dip f <key-down> ]
 230     [ '[ _ send-action ] ]
 231     bi*
 232 ] H{ } assoc-map-as
 233 H{
 234     { T{ key-down f { S+ } "DELETE" } [ \ cut-action send-action ] }
 235     { T{ key-down f { S+ } "INSERT" } [ \ paste-action send-action ] }
 236     { T{ key-down f { C+ } "INSERT" } [ \ copy-action send-action ] }
 237     { T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
 238     { T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
 239     { T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
 240     { T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
 241     { T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
 242     { T{ button-up f { M+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
 243 } assoc-union set-gestures
 244
 245 PREDICATE: specific-button-up < button-up #>> ;
 246 PREDICATE: specific-button-down < button-down #>> ;
 247 PREDICATE: specific-drag < drag #>> ;
 248
 249 : generalize-gesture ( gesture -- )
 250     clone f >># button-gesture ;
 251
 252 M: world handle-gesture ( gesture gadget -- ? )
 253     2dup call-next-method [
 254         {
 255             { [ over specific-button-up? ] [ drop generalize-gesture f ] }
 256             { [ over specific-button-down? ] [ drop generalize-gesture f ] }
 257             { [ over specific-drag? ] [ drop generalize-gesture f ] }
 258             [ 2drop t ]
 259         } cond
 260     ] [ 2drop f ] if ;
 261
 262 : close-global ( world global -- )
 263     [ get-global find-world eq? ] keep '[ f _ set-global ] when ;
 264
 265 M: world world-pixel-format-attributes
 266     pixel-format-attributes>> ;
 267
 268 M: world check-world-pixel-format
 269     2drop ;
 270
 271 : with-world-pixel-format ( world quot -- )
 272     [ dup dup world-pixel-format-attributes <pixel-format> ]
 273     dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline