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.commands ui.pixel-formats destructors ;
   8 IN: ui.gadgets.worlds
   9
  10 TUPLE: world < track
  11 active? focused?
  12 layers
  13 title status status-owner
  14 text-handle handle images
  15 window-loc ;
  16
  17 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
  18
  19 : show-status ( string/f gadget -- )
  20     dup find-world dup [
  21         dup status>> [
  22             [ (>>status-owner) ] [ status>> set-model ] bi
  23         ] [ 3drop ] if
  24     ] [ 3drop ] if ;
  25
  26 : hide-status ( gadget -- )
  27     dup find-world dup [
  28         [ status-owner>> eq? ] keep
  29         '[ f _ [ (>>status-owner) ] [ status>> set-model ] 2bi ] when
  30     ] [ 2drop ] if ;
  31
  32 ERROR: no-world-found ;
  33
  34 : find-gl-context ( gadget -- )
  35     find-world dup
  36     [ handle>> select-gl-context ] [ no-world-found ] if ;
  37
  38 : (request-focus) ( child world ? -- )
  39     pick parent>> pick eq? [
  40         [ dup parent>> dup ] 2dip
  41         [ (request-focus) ] keep
  42     ] unless focus-child ;
  43
  44 M: world request-focus-on ( child gadget -- )
  45     2dup eq?
  46     [ 2drop ] [ dup focused?>> (request-focus) ] if ;
  47
  48 : new-world ( gadget title status class -- world )
  49     vertical swap new-track
  50         t >>root?
  51         t >>active?
  52         { 0 0 } >>window-loc
  53         swap >>status
  54         swap >>title
  55         swap 1 track-add
  56     dup request-focus ;
  57
  58 : <world> ( gadget title status -- world )
  59     world new-world ;
  60
  61 : as-big-as-possible ( world gadget -- )
  62     dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
  63
  64 M: world layout*
  65     [ call-next-method ]
  66     [ dup layers>> [ as-big-as-possible ] with each ] bi ;
  67
  68 M: world focusable-child* gadget-child ;
  69
  70 M: world children-on nip children>> ;
  71
  72 M: world remove-gadget
  73     2dup layers>> memq?
  74     [ layers>> delq ] [ call-next-method ] if ;
  75
  76 SYMBOL: flush-layout-cache-hook
  77
  78 flush-layout-cache-hook [ [ ] ] initialize
  79
  80 : (draw-world) ( world -- )
  81     dup handle>> [
  82         check-extensions
  83         {
  84             [ init-gl ]
  85             [ draw-gadget ]
  86             [ text-handle>> [ purge-cache ] when* ]
  87             [ images>> [ purge-cache ] when* ]
  88         } cleave
  89     ] with-gl-context
  90     flush-layout-cache-hook get call( -- ) ;
  91
  92 : draw-world? ( world -- ? )
  93     #! We don't draw deactivated worlds, or those with 0 size.
  94     #! On Windows, the latter case results in GL errors.
  95     { [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] } 1&& ;
  96
  97 TUPLE: world-error error world ;
  98
  99 C: <world-error> world-error
 100
 101 SYMBOL: ui-error-hook
 102
 103 : ui-error ( error -- )
 104     ui-error-hook get [ call( error -- ) ] [ die drop ] if* ;
 105
 106 ui-error-hook [ [ rethrow ] ] initialize
 107
 108 : draw-world ( world -- )
 109     dup draw-world? [
 110         dup world [
 111             [ (draw-world) ] [
 112                 over <world-error> ui-error
 113                 f >>active? drop
 114             ] recover
 115         ] with-variable
 116     ] [ drop ] if ;
 117
 118 world
 119 action-gestures [
 120     [ [ { C+ } ] dip f <key-down> ]
 121     [ '[ _ send-action ] ]
 122     bi*
 123 ] H{ } assoc-map-as
 124 H{
 125     { T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
 126     { T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
 127     { T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
 128     { T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
 129     { T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
 130     { T{ button-up f { M+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
 131 } assoc-union set-gestures
 132
 133 PREDICATE: specific-button-up < button-up #>> ;
 134 PREDICATE: specific-button-down < button-down #>> ;
 135 PREDICATE: specific-drag < drag #>> ;
 136
 137 : generalize-gesture ( gesture -- )
 138     clone f >># button-gesture ;
 139
 140 M: world handle-gesture ( gesture gadget -- ? )
 141     2dup call-next-method [
 142         {
 143             { [ over specific-button-up? ] [ drop generalize-gesture f ] }
 144             { [ over specific-button-down? ] [ drop generalize-gesture f ] }
 145             { [ over specific-drag? ] [ drop generalize-gesture f ] }
 146             [ 2drop t ]
 147         } cond
 148     ] [ 2drop f ] if ;
 149
 150 : close-global ( world global -- )
 151     [ get-global find-world eq? ] keep '[ f _ set-global ] when ;
 152
 153 GENERIC: world-pixel-format-attributes ( world -- attributes )
 154
 155 GENERIC# check-world-pixel-format 1 ( world pixel-format -- )
 156
 157 M: world world-pixel-format-attributes
 158     drop
 159     { windowed double-buffered T{ depth-bits { value 16 } } } ;
 160
 161 M: world check-world-pixel-format
 162     2drop ;
 163
 164 : with-world-pixel-format ( world quot -- )
 165     [ dup dup world-pixel-format-attributes <pixel-format> ]
 166     dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline