1 ! Copyright (C) 2006, 2008 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays documents kernel math models
4 namespaces locals fry make opengl opengl.gl sequences strings
5 io.styles math.vectors sorting colors combinators assocs
6 math.order fry calendar alarms ui.clipboards ui.commands
7 ui.gadgets ui.gadgets.borders ui.gadgets.buttons
8 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
9 ui.gadgets.menus ui.gadgets.wrappers ui.render ui.gestures
11 IN: ui.gadgets.editors
13 TUPLE: editor < gadget
14 font color caret-color selection-color
16 focused? blink blink-alarm ;
18 : <loc> ( -- loc ) { 0 0 } <model> ;
20 : init-editor-locs ( editor -- editor )
24 : editor-theme ( editor -- editor )
27 selection-color >>selection-color
28 monospace-font >>font ; inline
30 : new-editor ( class -- editor )
36 : <editor> ( -- editor )
39 : activate-editor-model ( editor model -- )
42 swap model>> add-loc ;
44 : deactivate-editor-model ( editor model -- )
45 2dup remove-connection
47 swap model>> remove-loc ;
49 : blink-caret ( editor -- )
50 [ not ] change-blink relayout-1 ;
52 SYMBOL: blink-interval
54 750 milliseconds blink-interval set-global
56 : stop-blinking ( editor -- )
57 [ [ cancel-alarm ] when* f ] change-blink-alarm drop ;
59 : start-blinking ( editor -- )
62 dup '[ _ blink-caret ] blink-interval get every
66 : restart-blinking ( editor -- )
75 dup caret>> activate-editor-model
76 dup mark>> activate-editor-model ;
81 dup caret>> deactivate-editor-model
82 dup mark>> deactivate-editor-model ;
84 : editor-caret* ( editor -- loc ) caret>> value>> ;
86 : editor-mark* ( editor -- loc ) mark>> value>> ;
88 : set-caret ( loc editor -- )
89 [ model>> validate-loc ] keep
92 : change-caret ( editor quot -- )
93 [ [ [ editor-caret* ] [ model>> ] bi ] dip call ] [ drop ] 2bi
96 : mark>caret ( editor -- )
97 [ editor-caret* ] [ mark>> ] bi set-model ;
99 : change-caret&mark ( editor quot -- )
100 [ change-caret ] [ drop mark>caret ] 2bi ; inline
102 : editor-line ( n editor -- str ) control-value nth ;
104 : editor-font* ( editor -- font ) font>> open-font ;
106 : line-height ( editor -- n )
107 editor-font* "" string-height ;
109 : y>line ( y editor -- line# )
112 :: point>loc ( point editor -- loc )
113 point second editor y>line {
114 { [ dup 0 < ] [ drop { 0 0 } ] }
115 { [ dup editor model>> last-line# > ] [ drop editor model>> doc-end ] }
125 : clicked-loc ( editor -- loc )
126 [ hand-rel ] keep point>loc ;
128 : click-loc ( editor model -- )
129 [ clicked-loc ] dip set-model ;
131 : focus-editor ( editor -- )
136 : unfocus-editor ( editor -- )
141 : offset>x ( col# line# editor -- x )
142 [ editor-line ] keep editor-font* spin head-slice string-width ;
144 : loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ;
146 : line>y ( lines# editor -- y )
149 : caret-loc ( editor -- loc )
150 [ editor-caret* ] keep
151 [ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
153 : caret-dim ( editor -- dim )
154 line-height 0 swap 2array ;
156 : scroll>caret ( editor -- )
157 dup graft-state>> second [
159 [ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
164 editor get [ focused?>> ] [ blink>> ] bi and [
166 [ caret-color>> gl-color ]
168 dup caret-loc origin get v+
169 swap caret-dim over v+
174 : line-translation ( n -- loc )
175 editor get line-height * 0.0 swap 2array ;
177 : translate-lines ( n -- )
178 line-translation gl-translate ;
180 : draw-line ( editor str -- )
181 [ font>> ] dip { 0 0 } draw-string ;
183 : first-visible-line ( editor -- n )
185 [ clip get rect-loc second origin get second - ] dip
187 ] keep model>> validate-line ;
189 : last-visible-line ( editor -- n )
191 [ clip get rect-extent nip second origin get second - ] dip
193 ] keep model>> validate-line 1+ ;
195 : with-editor ( editor quot -- )
198 dup first-visible-line \ first-visible-line set
199 dup last-visible-line \ last-visible-line set
200 dup model>> document set
203 ] with-scope ; inline
205 : visible-lines ( editor -- seq )
206 [ \ first-visible-line get \ last-visible-line get ] dip
207 control-value <slice> ;
209 : with-editor-translation ( n quot -- )
210 [ line-translation origin get v+ ] dip with-translation ;
214 \ first-visible-line get [
215 editor get dup color>> gl-color
217 [ draw-line 1 translate-lines ] with each
218 ] with-editor-translation ;
220 : selection-start/end ( editor -- start end )
221 [ editor-mark* ] [ editor-caret* ] bi sort-pair ;
223 : (draw-selection) ( x1 x2 -- )
226 [ 0.0 2array ] [ editor get line-height 2array ] bi*
227 swap [ gl-fill-rect ] with-translation ;
229 : draw-selected-line ( start end n -- )
230 [ start/end-on-line ] keep
231 tuck [ editor get offset>x ] 2bi@
234 : draw-selection ( -- )
235 editor get selection-color>> gl-color
236 editor get selection-start/end
243 ] with-editor-translation ;
245 M: editor draw-gadget*
246 [ draw-selection draw-lines draw-caret ] with-editor ;
249 dup editor-font* swap control-value text-dim ;
251 : contents-changed ( model editor -- )
253 over caret>> [ over validate-loc ] (change-model)
254 over mark>> [ over validate-loc ] (change-model)
257 : caret/mark-changed ( model editor -- )
258 nip [ restart-blinking ] [ scroll>caret ] bi ;
260 M: editor model-changed
262 { [ 2dup model>> eq? ] [ contents-changed ] }
263 { [ 2dup caret>> eq? ] [ caret/mark-changed ] }
264 { [ 2dup mark>> eq? ] [ caret/mark-changed ] }
267 M: editor gadget-selection?
268 selection-start/end = not ;
270 M: editor gadget-selection
271 [ selection-start/end ] keep model>> doc-range ;
273 : remove-selection ( editor -- )
274 [ selection-start/end ] keep model>> remove-doc-range ;
276 M: editor user-input*
277 [ selection-start/end ] keep model>> set-doc-range t ;
279 : editor-string ( editor -- string )
282 : set-editor-string ( string editor -- )
283 model>> set-doc-string ;
285 M: editor gadget-text* editor-string % ;
287 : extend-selection ( editor -- )
290 dup caret>> click-loc ;
292 : mouse-elt ( -- element )
294 { 1 T{ one-char-elt } }
295 { 2 T{ one-word-elt } }
296 } at T{ one-line-elt } or ;
298 : drag-direction? ( loc editor -- ? )
299 editor-mark* before? ;
301 : drag-selection-caret ( loc editor element -- loc )
303 [ drag-direction? ] 2keep model>>
304 ] dip prev/next-elt ? ;
306 : drag-selection-mark ( loc editor element -- loc )
308 [ drag-direction? not ] keep
309 [ editor-mark* ] [ model>> ] bi
310 ] dip prev/next-elt ? ;
312 : drag-caret&mark ( editor -- caret mark )
313 dup clicked-loc swap mouse-elt
314 [ drag-selection-caret ] 3keep
315 drag-selection-mark ;
317 : drag-selection ( editor -- )
319 pick mark>> set-model
320 swap caret>> set-model ;
322 : editor-cut ( editor clipboard -- )
323 dupd gadget-copy remove-selection ;
325 : delete/backspace ( editor quot -- )
326 over gadget-selection? [
327 drop remove-selection
329 [ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
334 : editor-delete ( editor elt -- )
335 '[ dupd _ next-elt ] delete/backspace ;
337 : editor-backspace ( editor elt -- )
338 '[ over [ _ prev-elt ] dip ] delete/backspace ;
340 : editor-select-prev ( editor elt -- )
341 '[ _ prev-elt ] change-caret ;
343 : editor-prev ( editor elt -- )
344 dupd editor-select-prev mark>caret ;
346 : editor-select-next ( editor elt -- )
347 '[ _ next-elt ] change-caret ;
349 : editor-next ( editor elt -- )
350 dupd editor-select-next mark>caret ;
352 : editor-select ( from to editor -- )
353 tuck caret>> set-model mark>> set-model ;
355 : select-elt ( editor elt -- )
356 [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
359 : start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
361 : end-of-document ( editor -- ) T{ doc-elt } editor-next ;
363 : position-caret ( editor -- )
364 mouse-elt dup T{ one-char-elt } =
365 [ drop dup extend-selection dup mark>> click-loc ]
368 : insert-newline ( editor -- ) "\n" swap user-input* drop ;
370 : delete-next-character ( editor -- )
371 T{ char-elt } editor-delete ;
373 : delete-previous-character ( editor -- )
374 T{ char-elt } editor-backspace ;
376 : delete-previous-word ( editor -- )
377 T{ word-elt } editor-delete ;
379 : delete-next-word ( editor -- )
380 T{ word-elt } editor-backspace ;
382 : delete-to-start-of-line ( editor -- )
383 T{ one-line-elt } editor-delete ;
385 : delete-to-end-of-line ( editor -- )
386 T{ one-line-elt } editor-backspace ;
389 { T{ key-down f f "DELETE" } delete-next-character }
390 { T{ key-down f { S+ } "DELETE" } delete-next-character }
391 { T{ key-down f f "BACKSPACE" } delete-previous-character }
392 { T{ key-down f { S+ } "BACKSPACE" } delete-previous-character }
393 { T{ key-down f { C+ } "DELETE" } delete-previous-word }
394 { T{ key-down f { C+ } "BACKSPACE" } delete-next-word }
395 { T{ key-down f { A+ } "DELETE" } delete-to-start-of-line }
396 { T{ key-down f { A+ } "BACKSPACE" } delete-to-end-of-line }
399 : paste ( editor -- ) clipboard get paste-clipboard ;
401 : paste-selection ( editor -- ) selection get paste-clipboard ;
403 : cut ( editor -- ) clipboard get editor-cut ;
405 editor "clipboard" f {
406 { T{ paste-action } paste }
407 { T{ button-up f f 2 } paste-selection }
408 { T{ copy-action } com-copy }
409 { T{ button-up } com-copy-selection }
410 { T{ cut-action } cut }
413 : previous-character ( editor -- )
414 dup gadget-selection? [
415 dup selection-start/end drop
416 over set-caret mark>caret
418 T{ char-elt } editor-prev
421 : next-character ( editor -- )
422 dup gadget-selection? [
423 dup selection-start/end nip
424 over set-caret mark>caret
426 T{ char-elt } editor-next
429 : previous-line ( editor -- ) T{ line-elt } editor-prev ;
431 : next-line ( editor -- ) T{ line-elt } editor-next ;
433 : previous-word ( editor -- ) T{ word-elt } editor-prev ;
435 : next-word ( editor -- ) T{ word-elt } editor-next ;
437 : start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
439 : end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
441 editor "caret-motion" f {
442 { T{ button-down } position-caret }
443 { T{ key-down f f "LEFT" } previous-character }
444 { T{ key-down f f "RIGHT" } next-character }
445 { T{ key-down f f "UP" } previous-line }
446 { T{ key-down f f "DOWN" } next-line }
447 { T{ key-down f { C+ } "LEFT" } previous-word }
448 { T{ key-down f { C+ } "RIGHT" } next-word }
449 { T{ key-down f f "HOME" } start-of-line }
450 { T{ key-down f f "END" } end-of-line }
451 { T{ key-down f { C+ } "HOME" } start-of-document }
452 { T{ key-down f { C+ } "END" } end-of-document }
455 : select-all ( editor -- ) T{ doc-elt } select-elt ;
457 : select-line ( editor -- ) T{ one-line-elt } select-elt ;
459 : select-word ( editor -- ) T{ one-word-elt } select-elt ;
461 : selected-word ( editor -- string )
462 dup gadget-selection?
463 [ dup select-word ] unless
466 : select-previous-character ( editor -- )
467 T{ char-elt } editor-select-prev ;
469 : select-next-character ( editor -- )
470 T{ char-elt } editor-select-next ;
472 : select-previous-line ( editor -- )
473 T{ line-elt } editor-select-prev ;
475 : select-next-line ( editor -- )
476 T{ line-elt } editor-select-next ;
478 : select-previous-word ( editor -- )
479 T{ word-elt } editor-select-prev ;
481 : select-next-word ( editor -- )
482 T{ word-elt } editor-select-next ;
484 : select-start-of-line ( editor -- )
485 T{ one-line-elt } editor-select-prev ;
487 : select-end-of-line ( editor -- )
488 T{ one-line-elt } editor-select-next ;
490 : select-start-of-document ( editor -- )
491 T{ doc-elt } editor-select-prev ;
493 : select-end-of-document ( editor -- )
494 T{ doc-elt } editor-select-next ;
496 editor "selection" f {
497 { T{ button-down f { S+ } 1 } extend-selection }
498 { T{ drag } drag-selection }
499 { T{ gain-focus } focus-editor }
500 { T{ lose-focus } unfocus-editor }
501 { T{ delete-action } remove-selection }
502 { T{ select-all-action } select-all }
503 { T{ key-down f { C+ } "l" } select-line }
504 { T{ key-down f { S+ } "LEFT" } select-previous-character }
505 { T{ key-down f { S+ } "RIGHT" } select-next-character }
506 { T{ key-down f { S+ } "UP" } select-previous-line }
507 { T{ key-down f { S+ } "DOWN" } select-next-line }
508 { T{ key-down f { S+ C+ } "LEFT" } select-previous-word }
509 { T{ key-down f { S+ C+ } "RIGHT" } select-next-word }
510 { T{ key-down f { S+ } "HOME" } select-start-of-line }
511 { T{ key-down f { S+ } "END" } select-end-of-line }
512 { T{ key-down f { S+ C+ } "HOME" } select-start-of-document }
513 { T{ key-down f { S+ C+ } "END" } select-end-of-document }
516 : editor-menu ( editor -- )
517 { cut com-copy paste } show-commands-menu ;
520 { T{ button-down f f 3 } editor-menu }
524 TUPLE: multiline-editor < editor ;
526 : <multiline-editor> ( -- editor )
527 multiline-editor new-editor ;
529 multiline-editor "general" f {
530 { T{ key-down f f "RET" } insert-newline }
531 { T{ key-down f { S+ } "RET" } insert-newline }
532 { T{ key-down f f "ENTER" } insert-newline }
535 TUPLE: source-editor < multiline-editor ;
537 : <source-editor> ( -- editor )
538 source-editor new-editor ;
540 ! Fields wrap an editor and edit an external model
541 TUPLE: field < wrapper field-model editor ;
543 : field-theme ( gadget -- gadget )
544 gray <solid> >>boundary ; inline
546 : <field-border> ( gadget -- border )
551 : <field> ( model -- gadget )
552 <editor> dup <field-border> field new-wrapper
557 [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
558 [ dup editor>> model>> add-connection ]
562 dup editor>> model>> remove-connection ;
564 M: field model-changed
565 nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;