1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
4 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
5 ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
6 ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
7 hashtables io kernel namespaces sequences io.styles strings
8 quotations math opengl combinators math.vectors sorting
9 splitting io.streams.nested assocs ui.gadgets.presentations
10 ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
11 classes.tuple models continuations destructors accessors
12 math.geometry.rect fry ;
16 output current prototype scrolls?
17 selection-color caret mark selecting? ;
19 : clear-selection ( pane -- pane )
22 : add-output ( pane current -- pane )
23 [ >>output ] [ add-gadget ] bi ;
25 : add-current ( pane current -- pane )
26 [ >>current ] [ add-gadget ] bi ;
28 : prepare-line ( pane -- pane )
30 dup prototype>> clone add-current ;
32 : pane-caret&mark ( pane -- caret mark )
33 [ caret>> ] [ mark>> ] bi ;
35 : selected-children ( pane -- seq )
36 [ pane-caret&mark sort-pair ] keep gadget-subtree ;
38 M: pane gadget-selection? pane-caret&mark and ;
40 M: pane gadget-selection ( pane -- string/f )
41 selected-children gadget-text ;
43 : pane-clear ( pane -- )
45 [ output>> clear-incremental ]
46 [ current>> clear-gadget ]
49 : new-pane ( class -- pane )
53 <incremental> add-output
55 selection-color >>selection-color ;
57 : <pane> ( -- pane ) pane new-pane ;
59 GENERIC: draw-selection ( loc obj -- )
61 : if-fits ( rect quot -- )
62 [ clip get over intersects? ] dip [ drop ] if ; inline
64 M: gadget draw-selection ( loc gadget -- )
71 M: node draw-selection ( loc node -- )
72 2dup value>> swap offset-rect [
74 [ value>> rect-loc v+ ] keep
75 children>> [ draw-selection ] with each
79 dup gadget-selection? [
80 dup selection-color>> gl-color
81 origin get over rect-loc v- swap selected-children
82 [ draw-selection ] with each
87 : scroll-pane ( pane -- )
88 dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
90 TUPLE: pane-stream pane ;
92 C: <pane-stream> pane-stream
94 : smash-line ( current -- gadget )
96 { [ dup empty? ] [ 2drop "" <label> ] }
97 { [ dup length 1 = ] [ nip first ] }
101 : smash-pane ( pane -- gadget ) output>> smash-line ;
103 : pane-nl ( pane -- pane )
104 dup current>> dup unparent smash-line
105 over output>> add-incremental
108 : pane-write ( pane seq -- )
110 [ over current>> stream-write ]
113 : pane-format ( style pane seq -- )
115 [ 2over current>> stream-format ]
118 GENERIC: write-gadget ( gadget stream -- )
120 M: pane-stream write-gadget ( gadget pane-stream -- )
121 pane>> current>> swap add-gadget drop ;
123 M: style-stream write-gadget
124 stream>> write-gadget ;
126 : print-gadget ( gadget stream -- )
127 tuck write-gadget stream-nl ;
129 : gadget. ( gadget -- )
130 output-stream get print-gadget ;
133 dup pane>> current>> children>> empty?
134 [ dup stream-nl ] unless drop ;
136 : with-pane ( pane quot -- )
138 over pane-clear [ <pane-stream> ] dip
139 over [ with-output-stream* ] dip ?nl ; inline
141 : make-pane ( quot -- gadget )
142 <pane> [ swap with-pane ] keep smash-pane ; inline
144 : <scrolling-pane> ( -- pane ) <pane> t >>scrolls? ;
146 TUPLE: pane-control < pane quot ;
148 M: pane-control model-changed ( model pane-control -- )
149 [ value>> ] [ dup quot>> ] bi* with-pane ;
151 : <pane-control> ( model quot -- pane )
152 pane-control new-pane
156 : do-pane-stream ( pane-stream quot -- )
157 [ pane>> ] dip keep scroll-pane ; inline
159 M: pane-stream stream-nl
160 [ pane-nl drop ] do-pane-stream ;
162 M: pane-stream stream-write1
163 [ current>> stream-write1 ] do-pane-stream ;
165 M: pane-stream stream-write
166 [ swap string-lines pane-write ] do-pane-stream ;
168 M: pane-stream stream-format
169 [ rot string-lines pane-format ] do-pane-stream ;
171 M: pane-stream dispose drop ;
173 M: pane-stream stream-flush drop ;
175 M: pane-stream make-span-stream
176 swap <style-stream> <ignore-close-stream> ;
180 : apply-style ( style gadget key quot -- style gadget )
181 [ pick at ] dip when* ; inline
183 : apply-foreground-style ( style gadget -- style gadget )
184 foreground [ >>color ] apply-style ;
186 : apply-background-style ( style gadget -- style gadget )
187 background [ solid-interior ] apply-style ;
189 : specified-font ( style -- font )
190 [ font swap at "monospace" or ] keep
191 [ font-style swap at plain or ] keep
192 font-size swap at 12 or 3array ;
194 : apply-font-style ( style gadget -- style gadget )
195 over specified-font >>font ;
197 : apply-presentation-style ( style gadget -- style gadget )
198 presented [ <presentation> ] apply-style ;
200 : style-label ( style gadget -- gadget )
201 apply-foreground-style
202 apply-background-style
204 apply-presentation-style
207 : <styled-label> ( style text -- gadget )
208 <label> style-label ;
212 : apply-wrap-style ( style pane -- style pane )
214 2dup <paragraph> >>prototype drop
215 <paragraph> >>current
218 : apply-border-color-style ( style gadget -- style gadget )
219 border-color [ solid-boundary ] apply-style ;
221 : apply-page-color-style ( style gadget -- style gadget )
222 page-color [ solid-interior ] apply-style ;
224 : apply-path-style ( style gadget -- style gadget )
225 presented-path [ <editable-slot> ] apply-style ;
227 : apply-border-width-style ( style gadget -- style gadget )
228 border-width [ <border> ] apply-style ;
230 : apply-printer-style ( style gadget -- style gadget )
231 presented-printer [ '[ _ make-pane ] >>printer ] apply-style ;
233 : style-pane ( style pane -- pane )
234 apply-border-width-style
235 apply-border-color-style
236 apply-page-color-style
237 apply-presentation-style
242 TUPLE: nested-pane-stream < pane-stream style parent ;
244 : new-nested-pane-stream ( style parent class -- stream )
247 swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
250 : unnest-pane-stream ( stream -- child parent )
253 over pane>> smash-pane style-pane
256 TUPLE: pane-block-stream < nested-pane-stream ;
258 M: pane-block-stream dispose
259 unnest-pane-stream write-gadget ;
261 M: pane-stream make-block-stream
262 pane-block-stream new-nested-pane-stream ;
265 : apply-table-gap-style ( style grid -- style grid )
266 table-gap [ >>gap ] apply-style ;
268 : apply-table-border-style ( style grid -- style grid )
269 table-border [ <grid-lines> >>boundary ]
272 : styled-grid ( style grid -- grid )
275 apply-table-gap-style
276 apply-table-border-style
279 TUPLE: pane-cell-stream < nested-pane-stream ;
281 M: pane-cell-stream dispose ?nl ;
283 M: pane-stream make-cell-stream
284 pane-cell-stream new-nested-pane-stream ;
286 M: pane-stream stream-write-table
288 swap [ [ pane>> smash-pane ] map ] map
293 M: pack dispose drop ;
295 M: paragraph dispose drop ;
297 : gadget-write ( string gadget -- )
299 [ 2drop ] [ <label> text-theme add-gadget drop ] if ;
301 M: pack stream-write gadget-write ;
303 : gadget-bl ( style stream -- )
304 swap " " <word-break-gadget> style-label add-gadget drop ;
306 M: paragraph stream-write
308 [ H{ } over gadget-bl ] [ over gadget-write ] interleave
311 : gadget-write1 ( char gadget -- )
312 [ 1string ] dip stream-write ;
314 M: pack stream-write1 gadget-write1 ;
316 M: paragraph stream-write1
318 [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
320 : gadget-format ( string style stream -- )
322 [ 3drop ] [ <styled-label> add-gadget drop ] if ;
324 M: pack stream-format
327 M: paragraph stream-format
333 [ 2over gadget-format ] interleave
337 : caret>mark ( pane -- pane )
341 GENERIC: sloppy-pick-up* ( loc gadget -- n )
343 M: pack sloppy-pick-up* ( loc gadget -- n )
344 [ orientation>> ] [ children>> ] bi (fast-children-on) ;
346 M: gadget sloppy-pick-up*
347 children>> [ inside? ] with find-last drop ;
352 : wet-and-sloppy ( loc gadget n -- newloc newgadget )
353 swap nth-gadget [ rect-loc v- ] keep ;
355 : sloppy-pick-up ( loc gadget -- path )
356 2dup sloppy-pick-up* dup
357 [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
361 : move-caret ( pane -- pane )
362 dup hand-rel over sloppy-pick-up >>caret
365 : begin-selection ( pane -- )
371 : extend-selection ( pane -- )
376 dup hand-clicked get child? [
378 dup hand-clicked set-global
383 dup dup caret>> gadget-at-path scroll>gadget
386 : end-selection ( pane -- )
389 [ com-copy-selection ] [ request-focus ] bi
394 : select-to-caret ( pane -- )
396 dup mark>> [ caret>mark ] unless
401 : pane-menu ( pane -- ) { com-copy } show-commands-menu ;
404 { T{ button-down } [ begin-selection ] }
405 { T{ button-down f { S+ } 1 } [ select-to-caret ] }
406 { T{ button-up f { S+ } 1 } [ end-selection ] }
407 { T{ button-up } [ end-selection ] }
408 { T{ drag } [ extend-selection ] }
409 { T{ copy-action } [ com-copy ] }
410 { T{ button-down f f 3 } [ pane-menu ] }