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