library/ui/ui.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets
   4 USING: arrays errors gadgets gadgets-buttons gadgets-frames
   5 gadgets-grids gadgets-labels gadgets-panes gadgets-presentations
   6 gadgets-scrolling gadgets-theme gadgets-viewports generic
   7 hashtables io kernel math models namespaces prettyprint queues
   8 sequences test threads help sequences words ;
   9
  10 ! Assoc mapping aliens to gadgets
  11 SYMBOL: windows
  12
  13 : window ( handle -- world ) windows get-global assoc ;
  14
  15 : window-focus ( handle -- gadget ) window world-focus ;
  16
  17 : register-window ( world handle -- )
  18     swap 2array windows get-global push ;
  19
  20 : unregister-window ( handle -- )
  21     windows get-global
  22     [ first = not ] subset-with
  23     windows set-global  ;
  24
  25 : raised-window ( world -- )
  26     windows get-global [ second eq? ] find-with drop
  27     windows get-global [ length 1- ] keep exchange ;
  28
  29 : update-hand ( gadget -- )
  30     find-world [
  31         dup hand-world get-global eq?
  32         [ hand-loc get-global swap move-hand ] [ drop ] if
  33     ] when* ;
  34
  35 : post-layout ( gadget -- )
  36     find-world [ dup world-handle set ] when* ;
  37
  38 : layout-queued ( -- )
  39     invalid dup queue-empty? [
  40         drop
  41     ] [
  42         deque dup layout post-layout layout-queued
  43     ] if ;
  44
  45 : init-ui ( -- )
  46     <queue> \ invalid set-global
  47     V{ } clone windows set-global ;
  48
  49 : ui-step ( -- )
  50     [
  51         do-timers
  52         [ layout-queued ] make-hash hash-values [
  53             dup update-hand
  54             dup world-handle [ dup draw-world ] when
  55             drop
  56         ] each
  57         10 sleep
  58     ] assert-depth ;
  59
  60 TUPLE: titled-gadget title ;
  61
  62 M: titled-gadget gadget-title titled-gadget-title ;
  63
  64 M: titled-gadget focusable-child* gadget-child ;
  65
  66 C: titled-gadget ( gadget title -- )
  67     [ set-titled-gadget-title ] keep
  68     { { f f f @center } } make-frame* ;
  69
  70 : open-window ( world -- )
  71     dup pref-dim over set-gadget-dim
  72     dup open-window* draw-world ;
  73
  74 : open-titled-window ( gadget title -- )
  75     <model> <titled-gadget> <world> open-window ;
  76
  77 : find-window ( quot -- world )
  78     windows get [ second ] map
  79     [ world-gadget swap call ] find-last-with nip ; inline
  80
  81 : start-world ( world -- )
  82     dup graft
  83     dup relayout
  84     world-gadget request-focus ;
  85
  86 : close-global ( world global -- )
  87     dup get-global find-world rot eq?
  88     [ f swap set-global ] [ drop ] if ;
  89
  90 : focus-world ( world -- )
  91     #! Sent when native window receives focus
  92     t over set-world-focused?
  93     dup raised-window
  94     focused-ancestors f focus-gestures ;
  95
  96 : unfocus-world ( world -- )
  97     #! Sent when native window loses focus.
  98     f over set-world-focused?
  99     focused-ancestors f swap focus-gestures ;
 100
 101 : reset-world ( world -- )
 102     dup unfocus-world
 103     dup ungraft
 104     f over set-world-focus
 105     f over set-world-handle
 106     world-fonts clear-hash ;
 107
 108 : close-world ( world -- )
 109     dup hand-clicked close-global
 110     dup hand-gadget close-global
 111     dup free-fonts
 112     reset-world ;
 113
 114 : restore-windows ( -- )
 115     windows get [ [ second ] map ] keep delete-all
 116     [ dup reset-world open-window* ] each
 117     forget-rollover ;
 118
 119 : restore-windows? ( -- ? )
 120     windows get [ empty? not ] [ f ] if* ;
 121
 122 : <toolbar> ( target classes -- toolbar )
 123     [ commands "Toolbar" swap hash ] map concat
 124     [ <command-presentation> ] map-with
 125     make-shelf ;
 126
 127 : command-description ( command -- element )
 128     dup command-name swap command-gesture gesture>string
 129     2array ;
 130
 131 : command-table. ( commands group -- )
 132     $heading
 133     [ command-gesture key-down? ] subset
 134     [ command-description ] map
 135     { "Command" "Shortcut" } add* $table ;
 136
 137 : commands. ( hash -- )
 138     hash>alist
 139     [ [ first ] 2apply <=> ] sort
 140     [ first2 swap command-table. ] each ;
 141
 142 : $commands ( elt -- )
 143     dup array? [ first ] when commands commands. ;
 144
 145 TUPLE: labelled-gadget content ;
 146
 147 C: labelled-gadget ( gadget title -- gadget )
 148     {
 149         { [ <label> dup reverse-video-theme ] f f @top }
 150         { f set-labelled-gadget-content f @center }
 151     } make-frame* ;
 152
 153 M: labelled-gadget focusable-child* labelled-gadget-content ;
 154
 155 : <labelled-pane> ( model quot title -- gadget )
 156     >r <pane-control> <scroller> r> <labelled-gadget> ;
 157
 158 : pane-window ( quot title -- )
 159     >r make-pane <scroller> r> open-titled-window ;
 160
 161 : error-window ( error -- )
 162     [ print-error ] "Error" pane-window ;
 163
 164 : ui-try ( quot -- )
 165     [ error-window ] recover ;
 166
 167 TUPLE: world-error world ;
 168
 169 C: world-error ( error world -- error )
 170     [ set-world-error-world ] keep
 171     [ set-delegate ] keep ;
 172
 173 M: world-error error.
 174     "An error occurred while drawing the world " write
 175     dup world-error-world pprint-short "." print
 176     "This world has been deactivated to prevent cascading errors." print
 177     delegate error. ;
 178
 179 : draw-world? ( world -- ? )
 180     #! We don't draw deactivated worlds, or those with 0 size.
 181     #! On Windows, the latter case results in GL errors.
 182     dup world-active? swap rect-dim [ zero? not ] all? and ;
 183
 184 : draw-world ( world -- )
 185     dup draw-world? [
 186         [
 187             dup world set [
 188                 dup (draw-world)
 189             ] [
 190                 over <world-error> error-window
 191                 f over set-world-active?
 192             ] recover
 193         ] with-scope
 194     ] when drop ;
 195
 196 IN: shells
 197
 198 DEFER: ui