basis/ui/ui.factor

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