basis/ui/gadgets/worlds/worlds.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs continuations kernel math models
   4 namespaces opengl sequences io combinators fry math.vectors
   5 ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
   6 math.geometry.rect ;
   7 IN: ui.gadgets.worlds
   8
   9 TUPLE: world < track
  10 active? focused?
  11 glass
  12 title status
  13 fonts handle
  14 window-loc ;
  15
  16 TUPLE: offscreen-world < world ;
  17
  18 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
  19
  20 : show-status ( string/f gadget -- )
  21     find-world dup [
  22         status>> dup [ set-model ] [ 2drop ] if
  23     ] [ 2drop ] if ;
  24
  25 : hide-status ( gadget -- ) f swap show-status ;
  26
  27 ERROR: no-world-found ;
  28
  29 : find-gl-context ( gadget -- )
  30     find-world dup
  31     [ handle>> select-gl-context ] [ no-world-found ] if ;
  32
  33 : (request-focus) ( child world ? -- )
  34     pick parent>> pick eq? [
  35         [ dup parent>> dup ] 2dip
  36         [ (request-focus) ] keep
  37     ] unless focus-child ;
  38
  39 M: world request-focus-on ( child gadget -- )
  40     2dup eq?
  41     [ 2drop ] [ dup focused?>> (request-focus) ] if ;
  42
  43 : new-world ( gadget title status class -- world )
  44     { 0 1 } swap new-track
  45         t >>root?
  46         t >>active?
  47         H{ } clone >>fonts
  48         { 0 0 } >>window-loc
  49         swap >>status
  50         swap >>title
  51         swap 1 track-add
  52     dup request-focus ;
  53
  54 : <world> ( gadget title status -- world )
  55     world new-world ;
  56 : <offscreen-world> ( gadget title status -- world )
  57     offscreen-world new-world ;
  58
  59 M: world layout*
  60     dup call-next-method
  61     dup glass>> [
  62         [ dup rect-dim ] dip (>>dim)
  63     ] when* drop ;
  64
  65 M: world focusable-child* gadget-child ;
  66
  67 M: world children-on nip children>> ;
  68
  69 : (draw-world) ( world -- )
  70     dup handle>> [
  71         [ dup init-gl ] keep draw-gadget
  72     ] with-gl-context ;
  73
  74 : draw-world? ( world -- ? )
  75     #! We don't draw deactivated worlds, or those with 0 size.
  76     #! On Windows, the latter case results in GL errors.
  77     [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] tri and and ;
  78
  79 TUPLE: world-error error world ;
  80
  81 C: <world-error> world-error
  82
  83 SYMBOL: ui-error-hook
  84
  85 : ui-error ( error -- )
  86     ui-error-hook get [ call ] [ die ] if* ;
  87
  88 ui-error-hook global [ [ rethrow ] or ] change-at
  89
  90 : draw-world ( world -- )
  91     dup draw-world? [
  92         dup world [
  93             [
  94                 (draw-world)
  95             ] [
  96                 over <world-error> ui-error
  97                 f >>active? drop
  98             ] recover
  99         ] with-variable
 100     ] [
 101         drop
 102     ] if ;
 103
 104 world H{
 105     { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
 106     { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
 107     { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
 108     { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
 109     { T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
 110     { T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
 111     { T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
 112     { T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
 113     { T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
 114     { T{ button-up f { M+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
 115 } set-gestures
 116
 117 PREDICATE: specific-button-up < button-up #>> ;
 118 PREDICATE: specific-button-down < button-down #>> ;
 119 PREDICATE: specific-drag < drag #>> ;
 120
 121 : generalize-gesture ( gesture -- )
 122     clone f >># button-gesture ;
 123
 124 M: world handle-gesture ( gesture gadget -- ? )
 125     2dup call-next-method [
 126         {
 127             { [ over specific-button-up? ] [ drop generalize-gesture f ] }
 128             { [ over specific-button-down? ] [ drop generalize-gesture f ] }
 129             { [ over specific-drag? ] [ drop generalize-gesture f ] }
 130             [ 2drop t ]
 131         } cond
 132     ] [ 2drop f ] if ;
 133
 134 : close-global ( world global -- )
 135     [ get-global find-world eq? ] keep '[ f _ set-global ] when ;