extra/ui/gadgets/worlds/worlds.factor

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