extra/ui/gadgets/worlds/worlds.factor

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