Bug fixes for lcs.diff2html; xml.writer
[factor/jcg.git] / basis / ui / gadgets / gadgets.factor
blob2af0f6e6a2584694b9d1b537e24f9c2bc8c04815
1 ! Copyright (C) 2005, 2008 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.geometry.rect fry ;
7 IN: ui.gadgets
9 SYMBOL: ui-notify-flag
11 : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
13 TUPLE: gadget < rect pref-dim parent children orientation focus
14 visible? root? clipped? layout-state graft-state graft-node
15 interior boundary model ;
17 M: gadget equal? 2drop f ;
19 M: gadget hashcode* drop gadget hashcode* ;
21 M: gadget model-changed 2drop ;
23 : gadget-child ( gadget -- child ) children>> first ;
25 : nth-gadget ( n gadget -- child ) children>> nth ;
27 : init-gadget ( gadget -- gadget )
28     init-rect
29     { 0 1 } >>orientation
30     t >>visible?
31     { f f } >>graft-state ; inline
33 : new-gadget ( class -- gadget ) new init-gadget ; inline
35 : <gadget> ( -- gadget )
36     gadget new-gadget ;
38 : activate-control ( gadget -- )
39     dup model>> dup [
40         2dup add-connection
41         swap model-changed
42     ] [
43         2drop
44     ] if ;
46 : deactivate-control ( gadget -- )
47     dup model>> dup [ 2dup remove-connection ] when 2drop ;
49 : control-value ( control -- value )
50     model>> value>> ;
52 : set-control-value ( value control -- )
53     model>> set-model ;
55 : relative-loc ( fromgadget togadget -- loc )
56     2dup eq? [
57         2drop { 0 0 }
58     ] [
59         over rect-loc [ [ parent>> ] dip relative-loc ] dip v+
60     ] if ;
62 GENERIC: user-input* ( str gadget -- ? )
64 M: gadget user-input* 2drop t ;
66 GENERIC: children-on ( rect/point gadget -- seq )
68 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     -rot '[ _ _ ((fast-children-on)) ] search drop ;
76 : fast-children-on ( rect axis children -- from to )
77     [ [ rect-loc ] 2dip (fast-children-on) 0 or ]
78     [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
79     3bi ;
81 : inside? ( bounds gadget -- ? )
82     dup visible?>> [ intersects? ] [ 2drop f ] if ;
84 : (pick-up) ( point gadget -- gadget )
85     dupd children-on [ inside? ] with find-last nip ;
87 : pick-up ( point gadget -- child/f )
88     2dup (pick-up) dup
89     [ nip [ rect-loc v- ] keep pick-up ] [ drop nip ] if ;
91 : max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ;
93 : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
95 : each-child ( gadget quot -- )
96     [ children>> ] dip each ; inline
98 ! Selection protocol
99 GENERIC: gadget-selection? ( gadget -- ? )
101 M: gadget gadget-selection? drop f ;
103 GENERIC: gadget-selection ( gadget -- string/f )
105 M: gadget gadget-selection drop f ;
107 ! Text protocol
108 GENERIC: gadget-text* ( gadget -- )
110 GENERIC: gadget-text-separator ( gadget -- str )
112 M: gadget gadget-text-separator
113     orientation>> { 0 1 } = "\n" "" ? ;
115 : gadget-seq-text ( seq gadget -- )
116     gadget-text-separator swap
117     [ dup % ] [ gadget-text* ] interleave drop ;
119 M: gadget gadget-text*
120     dup children>> swap gadget-seq-text ;
122 M: array gadget-text*
123     [ gadget-text* ] each ;
125 : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
127 : invalidate ( gadget -- )
128     \ invalidate >>layout-state drop ;
130 : forget-pref-dim ( gadget -- ) f >>pref-dim drop ;
132 : layout-queue ( -- queue ) \ layout-queue get ;
134 : layout-later ( gadget -- )
135     #! When unit testing gadgets without the UI running, the
136     #! invalid queue is not initialized and we simply ignore
137     #! invalidation requests.
138     layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
140 DEFER: relayout
142 : invalidate* ( gadget -- )
143     \ invalidate* >>layout-state
144     dup forget-pref-dim
145     dup root?>>
146     [ layout-later ] [ parent>> [ relayout ] when* ] if ;
148 : relayout ( gadget -- )
149     dup layout-state>> \ invalidate* eq?
150     [ drop ] [ invalidate* ] if ;
152 : relayout-1 ( gadget -- )
153     dup layout-state>>
154     [ drop ] [ dup invalidate layout-later ] if ;
156 : show-gadget ( gadget -- ) t >>visible? drop ;
157                               
158 : hide-gadget ( gadget -- ) f >>visible? drop ;
160 DEFER: in-layout?
162 GENERIC: dim-changed ( gadget -- )
164 M: gadget dim-changed
165     in-layout? get [ invalidate ] [ invalidate* ] if ;
167 M: gadget (>>dim) ( dim gadget -- )
168     2dup dim>> =
169     [ 2drop ]
170     [ [ nip ] [ call-next-method ] 2bi dim-changed ] if ;
172 GENERIC: pref-dim* ( gadget -- dim )
174 : ?set-gadget-pref-dim ( dim gadget -- )
175     dup layout-state>>
176     [ 2drop ] [ (>>pref-dim) ] if ;
178 : pref-dim ( gadget -- dim )
179     dup pref-dim>> [ ] [
180         [ pref-dim* dup ] keep ?set-gadget-pref-dim
181     ] ?if ;
183 : pref-dims ( gadgets -- seq ) [ pref-dim ] map ;
185 M: gadget pref-dim* rect-dim ;
187 GENERIC: layout* ( gadget -- )
189 M: gadget layout* drop ;
191 : prefer ( gadget -- ) dup pref-dim >>dim drop ;
193 : validate ( gadget -- ) f >>layout-state drop ;
195 : layout ( gadget -- )
196     dup layout-state>> [
197         dup validate
198         dup layout*
199         dup [ layout ] each-child
200     ] when drop ;
202 : graft-queue ( -- dlist ) \ graft-queue get ;
204 : unqueue-graft ( gadget -- )
205     [ graft-node>> graft-queue delete-node ]
206     [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
208 : (queue-graft) ( gadget flags -- )
209     >>graft-state
210     dup graft-queue push-front* >>graft-node drop
211     notify-ui-thread ;
213 : queue-graft ( gadget -- )
214     { f t } (queue-graft) ;
216 : queue-ungraft ( gadget -- )
217     { t f } (queue-graft) ;
219 : graft-later ( gadget -- )
220     dup graft-state>> {
221         { { f t } [ drop ] }
222         { { t t } [ drop ] }
223         { { t f } [ unqueue-graft ] }
224         { { f f } [ queue-graft ] }
225     } case ;
227 : ungraft-later ( gadget -- )
228     dup graft-state>> {
229         { { f f } [ drop ] }
230         { { t f } [ drop ] }
231         { { f t } [ unqueue-graft ] }
232         { { t t } [ queue-ungraft ] }
233     } case ;
235 GENERIC: graft* ( gadget -- )
237 M: gadget graft* drop ;
239 : graft ( gadget -- )
240     dup graft-later [ graft ] each-child ;
242 GENERIC: ungraft* ( gadget -- )
244 M: gadget ungraft* drop ;
246 : ungraft ( gadget -- )
247     dup [ ungraft ] each-child ungraft-later ;
249 : (unparent) ( gadget -- )
250     dup ungraft
251     dup forget-pref-dim
252     f >>parent drop ;
254 : unfocus-gadget ( child gadget -- )
255     [ nip ] [ focus>> eq? ] 2bi [ f >>focus ] when drop ;
257 SYMBOL: in-layout?
259 : not-in-layout ( -- )
260     in-layout? get
261     [ "Cannot add/remove gadgets in layout*" throw ] when ;
263 : unparent ( gadget -- )
264     not-in-layout
265     [
266         dup parent>> dup [
267             over (unparent)
268             [ unfocus-gadget ] 2keep
269             [ children>> delete ] keep
270             relayout
271         ] [
272             2drop
273         ] if
274     ] when* ;
276 : (clear-gadget) ( gadget -- )
277     dup [ (unparent) ] each-child
278     f >>focus f >>children drop ;
280 : clear-gadget ( gadget -- )
281     not-in-layout
282     dup (clear-gadget) relayout ;
284 : ((add-gadget)) ( parent child -- parent )
285     over children>> ?push >>children ;
287 : (add-gadget) ( parent child -- parent )
288     dup unparent
289     over >>parent
290     tuck ((add-gadget))
291     tuck graft-state>> second [ graft ] [ drop  ] if ;
293 : add-gadget ( parent child -- parent )
294     not-in-layout
295     (add-gadget)
296     dup relayout ;
298 : add-gadgets ( parent children -- parent )
299     not-in-layout
300     [ (add-gadget) ] each
301     dup relayout ;
303 : parents ( gadget -- seq )
304     [ parent>> ] follow ;
306 : each-parent ( gadget quot -- ? )
307     [ parents ] dip all? ; inline
309 : find-parent ( gadget quot -- parent )
310     [ parents ] dip find nip ; inline
312 : screen-loc ( gadget -- loc )
313     parents { 0 0 } [ rect-loc v+ ] reduce ;
315 : (screen-rect) ( gadget -- loc ext )
316     dup parent>> [
317         [ rect-extent ] dip (screen-rect)
318         [ [ nip ] [ v+ ] 2bi ] dip [ v+ ] [ vmin ] 2bi*
319     ] [
320         rect-extent
321     ] if* ;
323 : screen-rect ( gadget -- rect )
324     (screen-rect) <extent-rect> ;
326 : child? ( parent child -- ? )
327     {
328         { [ 2dup eq? ] [ 2drop t ] }
329         { [ dup not ] [ 2drop f ] }
330         [ parent>> child? ]
331     } cond ;
333 GENERIC: focusable-child* ( gadget -- child/t )
335 M: gadget focusable-child* drop t ;
337 : focusable-child ( gadget -- child )
338     dup focusable-child*
339     dup t eq? [ drop ] [ nip focusable-child ] if ;
341 GENERIC: request-focus-on ( child gadget -- )
343 M: gadget request-focus-on parent>> request-focus-on ;
345 M: f request-focus-on 2drop ;
347 : request-focus ( gadget -- )
348     [ focusable-child ] keep request-focus-on ;
350 : focus-path ( world -- seq )
351     [ focus>> ] follow ;