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