1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays hashtables kernel models math namespaces
4 make sequences quotations math.vectors combinators sorting
5 binary-search vectors dlists deques models threads
6 concurrency.flags math.order math.rectangles fry locals
7 prettyprint.backend prettyprint.custom ;
10 ! Values for orientation slot
11 CONSTANT: horizontal { 1 0 }
12 CONSTANT: vertical { 0 1 }
19 { orientation initial: { 0 1 } }
21 { visible? initial: t }
25 { graft-state initial: { f f } }
31 ! Don't print gadgets with RECT: syntax
32 M: gadget pprint* pprint-tuple ;
34 M: gadget equal? 2drop f ;
36 M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
38 M: gadget model-changed 2drop ;
40 : gadget-child ( gadget -- child ) children>> first ;
42 : nth-gadget ( n gadget -- child ) children>> nth ;
44 : <gadget> ( -- gadget )
47 : control-value ( control -- value )
50 : set-control-value ( value control -- )
53 : relative-loc ( fromgadget togadget -- loc )
57 [ [ parent>> ] dip relative-loc ] [ drop loc>> ] 2bi v+
60 GENERIC: user-input* ( str gadget -- ? )
62 M: gadget user-input* 2drop t ;
64 GENERIC: children-on ( rect gadget -- seq )
66 M: gadget children-on nip children>> ;
70 : ((fast-children-on)) ( gadget dim axis -- <=> )
71 [ swap loc>> v- ] dip v. 0 <=> ;
73 :: (fast-children-on) ( dim axis children -- i )
74 children [ dim axis ((fast-children-on)) ] search drop ;
78 : fast-children-on ( rect axis children -- from to )
79 [ [ loc>> ] 2dip (fast-children-on) 0 or ]
80 [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
83 M: gadget contains-rect? ( bounds gadget -- ? )
84 dup visible?>> [ call-next-method ] [ 2drop f ] if ;
86 M: gadget contains-point? ( loc gadget -- ? )
87 dup visible?>> [ call-next-method ] [ 2drop f ] if ;
89 : pick-up ( point gadget -- child/f )
90 2dup [ dup point>rect ] dip children-on
91 [ contains-point? ] with find-last nip
92 [ [ loc>> v- ] keep pick-up ] [ nip ] ?if ;
94 : max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ;
96 : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
98 : each-child ( gadget quot -- )
99 [ children>> ] dip each ; inline
102 GENERIC: gadget-selection? ( gadget -- ? )
104 M: gadget gadget-selection? drop f ;
106 GENERIC: gadget-selection ( gadget -- string/f )
108 M: gadget gadget-selection drop f ;
111 GENERIC: gadget-text* ( gadget -- )
113 GENERIC: gadget-text-separator ( gadget -- str )
115 M: gadget gadget-text-separator
116 orientation>> vertical = "\n" "" ? ;
118 : gadget-seq-text ( seq gadget -- )
119 gadget-text-separator swap
120 [ dup % ] [ gadget-text* ] interleave drop ;
122 M: gadget gadget-text*
123 [ children>> ] keep gadget-seq-text ;
125 M: array gadget-text*
126 [ gadget-text* ] each ;
128 : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
134 SYMBOL: ui-notify-flag
136 : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
138 : invalidate ( gadget -- )
139 \ invalidate >>layout-state drop ;
141 : forget-pref-dim ( gadget -- ) f >>pref-dim drop ;
143 : layout-queue ( -- queue ) \ layout-queue get ;
145 : layout-later ( gadget -- )
146 #! When unit testing gadgets without the UI running, the
147 #! invalid queue is not initialized and we simply ignore
148 #! invalidation requests.
149 layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
151 : invalidate* ( gadget -- )
152 \ invalidate* >>layout-state
155 [ layout-later ] [ parent>> [ relayout ] when* ] if ;
159 : relayout ( gadget -- )
160 dup layout-state>> \ invalidate* eq?
161 [ drop ] [ invalidate* ] if ;
163 : relayout-1 ( gadget -- )
165 [ drop ] [ dup invalidate layout-later ] if ;
167 : show-gadget ( gadget -- ) t >>visible? drop ;
169 : hide-gadget ( gadget -- ) f >>visible? drop ;
175 GENERIC: dim-changed ( gadget -- )
177 M: gadget dim-changed
178 in-layout? get [ invalidate ] [ invalidate* ] if ;
182 M: gadget (>>dim) ( dim gadget -- )
185 [ [ nip ] [ call-next-method ] 2bi dim-changed ] if ;
187 GENERIC: pref-dim* ( gadget -- dim )
189 : pref-dim ( gadget -- dim )
191 [ pref-dim* ] keep dup layout-state>>
192 [ drop ] [ dupd (>>pref-dim) ] if
195 : pref-dims ( gadgets -- seq ) [ pref-dim ] map ;
197 M: gadget pref-dim* dim>> ;
199 GENERIC: layout* ( gadget -- )
201 M: gadget layout* drop ;
203 : prefer ( gadget -- ) dup pref-dim >>dim drop ;
205 : layout ( gadget -- )
209 dup [ layout ] each-child
212 GENERIC: graft* ( gadget -- )
214 M: gadget graft* drop ;
216 GENERIC: ungraft* ( gadget -- )
218 M: gadget ungraft* drop ;
222 : graft-queue ( -- dlist )
223 \ graft-queue get [ "UI not running" throw ] unless* ;
225 : unqueue-graft ( gadget -- )
226 [ graft-node>> graft-queue delete-node ]
227 [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
229 : (queue-graft) ( gadget flags -- )
231 dup graft-queue push-front* >>graft-node drop
234 : queue-graft ( gadget -- )
235 { f t } (queue-graft) ;
237 : queue-ungraft ( gadget -- )
238 { t f } (queue-graft) ;
240 : graft-later ( gadget -- )
244 { { t f } [ unqueue-graft ] }
245 { { f f } [ queue-graft ] }
248 : graft ( gadget -- )
249 dup graft-later [ graft ] each-child ;
251 : ungraft-later ( gadget -- )
255 { { f t } [ unqueue-graft ] }
256 { { t t } [ queue-ungraft ] }
259 : ungraft ( gadget -- )
260 dup [ ungraft ] each-child ungraft-later ;
262 : activate-control ( gadget -- )
270 : deactivate-control ( gadget -- )
271 dup model>> dup [ 2dup remove-connection ] when 2drop ;
273 : notify ( gadget -- )
275 [ first { f f } { t t } ? >>graft-state ] keep
277 { { f t } [ dup activate-control graft* ] }
278 { { t f } [ dup deactivate-control ungraft* ] }
281 : notify-queued ( -- )
282 graft-queue [ notify ] slurp-deque ;
284 : (unparent) ( gadget -- )
289 : (clear-gadget) ( gadget -- )
290 dup [ (unparent) ] each-child
291 f >>focus f >>children drop ;
293 : unfocus-gadget ( child gadget -- )
294 [ nip ] [ focus>> eq? ] 2bi [ f >>focus ] when drop ;
298 : not-in-layout ( -- )
300 [ "Cannot add/remove gadgets in layout*" throw ] when ;
302 GENERIC: remove-gadget ( gadget parent -- )
304 M: gadget remove-gadget 2drop ;
306 : unparent ( gadget -- )
314 [ children>> delete ]
321 : clear-gadget ( gadget -- )
323 [ (clear-gadget) ] [ relayout ] bi ;
327 : (add-gadget) ( child parent -- )
331 [ [ ?push ] change-children drop ]
332 [ graft-state>> second [ graft ] [ drop ] if ]
337 : add-gadget ( parent child -- parent )
342 : add-gadgets ( parent children -- parent )
344 [ over (add-gadget) ] each
347 : parents ( gadget -- seq )
348 [ parent>> ] follow ;
350 : each-parent ( gadget quot -- ? )
351 [ parents ] dip all? ; inline
353 : find-parent ( gadget quot -- parent )
354 [ parents ] dip find nip ; inline
356 : screen-loc ( gadget -- loc )
357 parents { 0 0 } [ loc>> v+ ] reduce ;
361 : (screen-rect) ( gadget -- loc ext )
363 [ rect-extent ] dip (screen-rect)
364 [ [ nip ] [ v+ ] 2bi ] dip [ v+ ] [ vmin ] 2bi*
371 : screen-rect ( gadget -- rect )
372 (screen-rect) <extent-rect> ;
374 : child? ( parent child -- ? )
376 { [ 2dup eq? ] [ 2drop t ] }
377 { [ dup not ] [ 2drop f ] }
381 GENERIC: focusable-child* ( gadget -- child/t )
383 M: gadget focusable-child* drop t ;
385 : focusable-child ( gadget -- child )
387 dup t eq? [ drop ] [ nip focusable-child ] if ;
389 GENERIC: request-focus-on ( child gadget -- )
391 M: gadget request-focus-on parent>> request-focus-on ;
393 M: f request-focus-on 2drop ;
395 : request-focus ( gadget -- )
396 [ focusable-child ] keep request-focus-on ;
398 : focus-path ( gadget -- seq )