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.gl opengl.textures sequences strings
   7 ui.backend 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     { fill initial: 1 }
  59     { orientation initial: $ vertical } ;
  60
  61 : <world-attributes> ( -- world-attributes )
  62     world-attributes new ; inline
  63
  64 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
  65
  66 : grab-input ( gadget -- )
  67     find-world dup grab-input?>>
  68     [ drop ] [
  69         t >>grab-input?
  70         dup focused?>> [ handle>> (grab-input) ] [ drop ] if
  71     ] if ;
  72
  73 : ungrab-input ( gadget -- )
  74     find-world dup grab-input?>>
  75     [
  76         f >>grab-input?
  77         dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if
  78     ] [ drop ] if ;
  79
  80 : show-status ( string/f gadget -- )
  81     dup find-world dup [
  82         dup status>> [
  83             [ status-owner<< ] [ status>> set-model ] bi
  84         ] [ 3drop ] if
  85     ] [ 3drop ] if ;
  86
  87 : hide-status ( gadget -- )
  88     dup find-world dup [
  89         [ status-owner>> eq? ] keep
  90         '[ f _ [ status-owner<< ] [ status>> set-model ] 2bi ] when
  91     ] [ 2drop ] if ;
  92
  93 : window-resource ( resource -- resource )
  94     dup world get-global window-resources>> push ;
  95
  96 : set-gl-context ( world -- )
  97     [ world set-global ]
  98     [ handle>> select-gl-context ] bi ;
  99
 100 : with-gl-context ( world quot -- )
 101     '[ set-gl-context @ ]
 102     [ handle>> flush-gl-context gl-error ] bi ; inline
 103
 104 ERROR: no-world-found ;
 105
 106 : find-gl-context ( gadget -- )
 107     find-world [ set-gl-context ] [ no-world-found ] if* ;
 108
 109 : (request-focus) ( child world ? -- )
 110     pick parent>> pick eq? [
 111         [ dup parent>> dup ] 2dip
 112         [ (request-focus) ] keep
 113     ] unless focus-child ;
 114
 115 M: world request-focus-on
 116     2dup eq?
 117     [ 2drop ] [ dup focused?>> (request-focus) ] if ;
 118
 119 : new-world ( class -- world )
 120     vertical swap new-track
 121         t >>root?
 122         f >>active?
 123         { 0 0 } >>window-loc
 124         f >>grab-input?
 125         V{ } clone >>window-resources
 126         <promise> >>promise ;
 127
 128 : initial-background-color ( attributes -- color )
 129     window-controls>> textured-background swap member-eq?
 130     [ T{ rgba f 0.0 0.0 0.0 0.0 } ]
 131     [ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ;
 132
 133 GENERIC#: apply-world-attributes 1 ( world attributes -- world )
 134
 135 M: world apply-world-attributes
 136     {
 137         [ title>> >>title ]
 138         [ status>> >>status ]
 139         [ pixel-format-attributes>> >>pixel-format-attributes ]
 140         [ window-controls>> >>window-controls ]
 141         [ initial-background-color >>background-color ]
 142         [ grab-input?>> >>grab-input? ]
 143         [ gadgets>> dup sequence? [ [ 1 track-add ] each ] [ 1 track-add ] if ]
 144         [ pref-dim>> >>pref-dim ]
 145         [ fill>> >>fill ]
 146         [ orientation>> >>orientation ]
 147     } cleave ;
 148
 149 : <world> ( world-attributes -- world )
 150     [ world-class>> new-world ] keep apply-world-attributes
 151     dup request-focus ;
 152
 153 : as-big-as-possible ( world gadget -- )
 154     dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
 155
 156 M: world layout*
 157     [ call-next-method ]
 158     [ dup layers>> [ as-big-as-possible ] with each ] bi ;
 159
 160 M: world focusable-child* children>> [ t ] [ first ] if-empty ;
 161
 162 M: world children-on nip children>> ;
 163
 164 M: world remove-gadget
 165     2dup layers>> member-eq?
 166     [ layers>> remove-eq! drop ] [ call-next-method ] if ;
 167
 168 SYMBOL: flush-layout-cache-hook
 169
 170 flush-layout-cache-hook [ [ ] ] initialize
 171
 172 GENERIC: begin-world ( world -- )
 173 GENERIC: end-world ( world -- )
 174 GENERIC: resize-world ( world -- )
 175
 176 M: world begin-world drop ;
 177 M: world end-world drop ;
 178 M: world resize-world drop ;
 179
 180 M: world dim<<
 181     [ call-next-method ]
 182     [
 183         dup active?>> [
 184             dup handle>>
 185             [ [ set-gl-context ] [ resize-world ] bi ]
 186             [ drop ] if
 187         ] [ drop ] if
 188     ] bi ;
 189
 190 GENERIC: draw-world* ( world -- )
 191
 192 M: world draw-world*
 193     {
 194         [ gl-draw-init ]
 195         [ draw-gadget ]
 196         [ text-handle>> [ purge-cache ] when* ]
 197         [ images>> [ purge-cache ] when* ]
 198     } cleave ;
 199
 200 : draw-world? ( world -- ? )
 201     ! We don't draw deactivated worlds, or those with 0 size.
 202     ! On Windows, the latter case results in GL errors.
 203     { [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] } 1&& ;
 204
 205 TUPLE: world-error error world ;
 206
 207 C: <world-error> world-error
 208
 209 SYMBOL: ui-error-hook ! ( error -- )
 210
 211 : ui-error ( error -- )
 212     ui-error-hook get [ call( error -- ) ] [ die drop ] if* ;
 213
 214 ui-error-hook [ [ rethrow ] ] initialize
 215
 216 : draw-world ( world -- )
 217     dup draw-world? [
 218         [
 219             dup [ draw-world* ] with-gl-context
 220             flush-layout-cache-hook get call( -- )
 221         ] [
 222             swap f >>active? <world-error> rethrow
 223         ] recover
 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
 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