basis/ui/ui.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs io kernel math models namespaces make dlists
   4 deques sequences threads sequences words continuations init call
   5 combinators hashtables concurrency.flags sets accessors calendar fry
   6 destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
   7 ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text
   8 ui.text.private ;
   9 IN: ui
  10
  11 <PRIVATE
  12
  13 ! Assoc mapping aliens to gadgets
  14 SYMBOL: windows
  15
  16 : window ( handle -- world ) windows get-global at ;
  17
  18 : window-focus ( handle -- gadget ) window world-focus ;
  19
  20 : register-window ( world handle -- )
  21     #! Add the new window just below the topmost window. Why?
  22     #! So that if the new window doesn't actually receive focus
  23     #! (eg, we're using focus follows mouse and the mouse is not
  24     #! in the new window when it appears) Factor doesn't get
  25     #! confused and send workspace operations to the new window,
  26     #! etc.
  27     swap 2array windows get-global push
  28     windows get-global dup length 1 >
  29     [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
  30
  31 : unregister-window ( handle -- )
  32     windows global [ [ first = not ] with filter ] change-at ;
  33
  34 : raised-window ( world -- )
  35     windows get-global
  36     [ [ second eq? ] with find drop ] keep
  37     [ nth ] [ delete-nth ] [ nip ] 2tri push ;
  38
  39 : focus-gestures ( new old -- )
  40     drop-prefix <reversed>
  41     lose-focus swap each-gesture
  42     gain-focus swap each-gesture ;
  43
  44 : focus-world ( world -- )
  45     t >>focused?
  46     dup raised-window
  47     focus-path f focus-gestures ;
  48
  49 : unfocus-world ( world -- )
  50     f >>focused?
  51     focus-path f swap focus-gestures ;
  52
  53 M: world graft*
  54     [ (open-window) ]
  55     [ [ title>> ] keep set-title ]
  56     [ request-focus ] tri ;
  57
  58 : reset-world ( world -- )
  59     #! This is used when a window is being closed, but also
  60     #! when restoring saved worlds on image startup.
  61     f >>handle unfocus-world ;
  62
  63 : (ungraft-world) ( world -- )
  64     {
  65         [ handle>> select-gl-context ]
  66         [ text-handle>> dispose ]
  67         [ images>> [ dispose ] when* ]
  68         [ hand-clicked close-global ]
  69         [ hand-gadget close-global ]
  70     } cleave ;
  71
  72 M: world ungraft*
  73     [ (ungraft-world) ]
  74     [ handle>> (close-window) ]
  75     [ reset-world ] tri ;
  76
  77 : init-ui ( -- )
  78     <dlist> \ graft-queue set-global
  79     <dlist> \ layout-queue set-global
  80     <dlist> \ gesture-queue set-global
  81     V{ } clone windows set-global ;
  82
  83 : restore-gadget-later ( gadget -- )
  84     dup graft-state>> {
  85         { { f f } [ ] }
  86         { { f t } [ ] }
  87         { { t t } [ { f f } >>graft-state ] }
  88         { { t f } [ dup unqueue-graft { f f } >>graft-state ] }
  89     } case graft-later ;
  90
  91 : restore-gadget ( gadget -- )
  92     dup restore-gadget-later
  93     children>> [ restore-gadget ] each ;
  94
  95 : restore-world ( world -- )
  96     {
  97         [ reset-world ]
  98         [ init-text-rendering ]
  99         [ f >>images drop ]
 100         [ restore-gadget ]
 101     } cleave ;
 102
 103 : update-hand ( world -- )
 104     dup hand-world get-global eq?
 105     [ hand-loc get-global swap move-hand ] [ drop ] if ;
 106
 107 : layout-queued ( -- seq )
 108     [
 109         in-layout? on
 110         layout-queue [
 111             dup layout find-world [ , ] when*
 112         ] slurp-deque
 113     ] { } make prune ;
 114
 115 : redraw-worlds ( seq -- )
 116     [ dup update-hand draw-world ] each ;
 117
 118 : send-queued-gestures ( -- )
 119     gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
 120
 121 : update-ui ( -- )
 122     [
 123         notify-queued
 124         layout-queued
 125         redraw-worlds
 126         send-queued-gestures
 127     ] [ ui-error ] recover ;
 128
 129 SYMBOL: ui-thread
 130
 131 : ui-running ( quot -- )
 132     t \ ui-running set-global
 133     [ f \ ui-running set-global ] [ ] cleanup ; inline
 134
 135 PRIVATE>
 136
 137 : find-window ( quot -- world )
 138     windows get values
 139     [ gadget-child swap call ] with find-last nip ; inline
 140
 141 : ui-running? ( -- ? )
 142     \ ui-running get-global ;
 143
 144 <PRIVATE
 145
 146 : update-ui-loop ( -- )
 147     [ ui-running? ui-thread get-global self eq? and ]
 148     [ ui-notify-flag get lower-flag update-ui ]
 149     while ;
 150
 151 : start-ui-thread ( -- )
 152     [ self ui-thread set-global update-ui-loop ]
 153     "UI update" spawn drop ;
 154
 155 : start-ui ( quot -- )
 156     call notify-ui-thread start-ui-thread ;
 157
 158 : restore-windows ( -- )
 159     [
 160         windows get [ values ] [ delete-all ] bi
 161         [ restore-world ] each
 162         forget-rollover
 163     ] (with-ui) ;
 164
 165 : restore-windows? ( -- ? )
 166     windows get empty? not ;
 167
 168 PRIVATE>
 169
 170 : open-world-window ( world -- )
 171     dup pref-dim >>dim dup relayout graft ;
 172
 173 : open-window ( gadget title -- )
 174     f <world> open-world-window ;
 175
 176 : set-fullscreen? ( ? gadget -- )
 177     find-world set-fullscreen* ;
 178
 179 : fullscreen? ( gadget -- ? )
 180     find-world fullscreen* ;
 181
 182 : raise-window ( gadget -- )
 183     find-world raise-window* ;
 184
 185 HOOK: close-window ui-backend ( gadget -- )
 186
 187 M: object close-window
 188     find-world [ ungraft ] when* ;
 189
 190 [
 191     f \ ui-running set-global
 192     <flag> ui-notify-flag set-global
 193 ] "ui" add-init-hook
 194
 195 : with-ui ( quot -- )
 196     ui-running? [ call ] [ '[ init-ui @ ] (with-ui) ] if ;
 197
 198 HOOK: beep ui-backend ( -- )