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 math.vectors
   5 ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
   6 debugger 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 : 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 : (request-focus) ( child world ? -- )
  26     pick parent>> pick eq? [
  27         >r >r dup parent>> dup r> r>
  28         [ (request-focus) ] keep
  29     ] unless focus-child ;
  30
  31 M: world request-focus-on ( child gadget -- )
  32     2dup eq?
  33     [ 2drop ] [ dup focused?>> (request-focus) ] if ;
  34
  35 : <world> ( gadget title status -- world )
  36     { 0 1 } world new-track
  37         t >>root?
  38         t >>active?
  39         H{ } clone >>fonts
  40         { 0 0 } >>window-loc
  41         swap >>status
  42         swap >>title
  43         swap 1 track-add
  44     dup request-focus ;
  45
  46 M: world layout*
  47     dup call-next-method
  48     dup glass>> [
  49         >r dup rect-dim r> (>>dim)
  50     ] when* drop ;
  51
  52 M: world focusable-child* gadget-child ;
  53
  54 M: world children-on nip children>> ;
  55
  56 : (draw-world) ( world -- )
  57     dup handle>> [
  58         [ dup init-gl ] keep draw-gadget
  59     ] with-gl-context ;
  60
  61 : draw-world? ( world -- ? )
  62     #! We don't draw deactivated worlds, or those with 0 size.
  63     #! On Windows, the latter case results in GL errors.
  64     dup active?>>
  65     over handle>>
  66     rot rect-dim [ 0 > ] all? and and ;
  67
  68 TUPLE: world-error error world ;
  69
  70 C: <world-error> world-error
  71
  72 SYMBOL: ui-error-hook
  73
  74 : ui-error ( error -- )
  75     ui-error-hook get [ call ] [ print-error ] if* ;
  76
  77 [ rethrow ] ui-error-hook set-global
  78
  79 : draw-world ( world -- )
  80     dup draw-world? [
  81         dup world [
  82             [
  83                 (draw-world)
  84             ] [
  85                 over <world-error> ui-error
  86                 f swap (>>active?)
  87             ] recover
  88         ] with-variable
  89     ] [
  90         drop
  91     ] if ;
  92
  93 world H{
  94     { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
  95     { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
  96     { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
  97     { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
  98     { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] }
  99     { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] }
 100     { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] }
 101     { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
 102 } set-gestures
 103
 104 : close-global ( world global -- )
 105     dup get-global find-world rot eq?
 106     [ f swap set-global ] [ drop ] if ;