Multi-line text editor gadget
slava
parent
8f42c4b655
commit
9a7b1402b2
|
|
@ -200,6 +200,8 @@ sequences vectors words ;
|
|||
"/library/ui/gadgets/panes.factor"
|
||||
"/library/ui/gadgets/books.factor"
|
||||
"/library/ui/gadgets/outliner.factor"
|
||||
"/library/ui/text/document.factor"
|
||||
"/library/ui/text/editor.factor"
|
||||
"/library/ui/ui.factor"
|
||||
"/library/ui/gadgets/presentations.factor"
|
||||
"/library/ui/tools/listener.factor"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,60 @@
|
|||
IN: temporary
|
||||
USING: gadgets-text namespaces test ;
|
||||
|
||||
! Tests
|
||||
|
||||
[ { 10 4 } ] [ { "a" } { 10 3 } text+loc ] unit-test
|
||||
[ { 10 4 } ] [ { "a" } { 10 3 } text+loc ] unit-test
|
||||
|
||||
[ { 2 0 } ] [
|
||||
<document> "doc" set
|
||||
"Hello world,\nhow are you?\nMore text"
|
||||
"doc" get set-doc-text
|
||||
{ 10 0 } "doc" get validate-loc
|
||||
] unit-test
|
||||
|
||||
[ { 1 12 } ] [
|
||||
<document> "doc" set
|
||||
"Hello world,\nhow are you?\nMore text"
|
||||
"doc" get set-doc-text
|
||||
{ 1 20 } "doc" get validate-loc
|
||||
] unit-test
|
||||
|
||||
[ " world,\nhow are you?\nMore" ] [
|
||||
<document> "doc" set
|
||||
"Hello world,\nhow are you?\nMore text"
|
||||
"doc" get set-doc-text
|
||||
{ 0 5 } { 2 4 } "doc" get doc-range
|
||||
] unit-test
|
||||
|
||||
[ "Hello world,\nhow you?\nMore text" ] [
|
||||
<document> "doc" set
|
||||
"Hello world,\nhow are you?\nMore text"
|
||||
"doc" get set-doc-text
|
||||
{ 1 3 } { 1 7 } "doc" get remove-doc-range
|
||||
"doc" get doc-text
|
||||
] unit-test
|
||||
|
||||
[ "Hello world,\nhow text" ] [
|
||||
<document> "doc" set
|
||||
"Hello world,\nhow are you?\nMore text"
|
||||
"doc" get set-doc-text
|
||||
{ 1 3 } { 2 4 } "doc" get remove-doc-range
|
||||
"doc" get doc-text
|
||||
] unit-test
|
||||
|
||||
[ "Hello world,\nhow you?\nMore text" ] [
|
||||
<document> "doc" set
|
||||
"Hello world,\nhow are you?\nMore text"
|
||||
"doc" get set-doc-text
|
||||
"" { 1 3 } { 1 7 } "doc" get set-doc-range
|
||||
"doc" get doc-text
|
||||
] unit-test
|
||||
|
||||
[ "Hello world,\nhow text" ] [
|
||||
<document> "doc" set
|
||||
"Hello world,\nhow are you?\nMore text"
|
||||
"doc" get set-doc-text
|
||||
"" { 1 3 } { 2 4 } "doc" get set-doc-range
|
||||
"doc" get doc-text
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,158 @@
|
|||
! Copyright (C) 2006 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-text
|
||||
USING: arrays generic io kernel math models namespaces sequences
|
||||
test ;
|
||||
|
||||
: +col ( loc n -- loc ) >r first2 r> + 2array ;
|
||||
|
||||
: +line ( loc n -- loc ) >r first2 swap r> + swap 2array ;
|
||||
|
||||
: =col ( n loc -- loc ) first swap 2array ;
|
||||
|
||||
: =line ( n loc -- loc ) second 2array ;
|
||||
|
||||
: lines-equal? ( loc loc -- n ) [ first ] 2apply number= ;
|
||||
|
||||
TUPLE: document locs ;
|
||||
|
||||
C: document ( -- document )
|
||||
{ "" } <model> over set-delegate
|
||||
V{ } clone over set-document-locs ;
|
||||
|
||||
: add-loc document-locs push ;
|
||||
|
||||
: remove-loc document-locs delete ;
|
||||
|
||||
: doc-text ( document -- str )
|
||||
model-value "\n" join ;
|
||||
|
||||
: set-doc-text ( string document -- )
|
||||
>r <string-reader> lines r> set-model ;
|
||||
|
||||
: doc-line ( line# document -- str ) model-value nth ;
|
||||
|
||||
: doc-lines ( from# to# document -- slice )
|
||||
>r 1+ r> model-value <slice> ;
|
||||
|
||||
: start-on-line ( document from line# -- n1 )
|
||||
>r dup first r> = [
|
||||
nip second
|
||||
] [
|
||||
2drop 0
|
||||
] if ;
|
||||
|
||||
: end-on-line ( document to line# -- n2 )
|
||||
over first over = [
|
||||
drop second nip
|
||||
] [
|
||||
nip swap doc-line length
|
||||
] if ;
|
||||
|
||||
: each-line ( startloc endloc quot -- )
|
||||
pick pick = [
|
||||
3drop
|
||||
] [
|
||||
>r [ first ] 2apply 1+ dup <slice> r> each
|
||||
] if ; inline
|
||||
|
||||
: start/end-on-line ( startloc endloc line# -- n1 n2 )
|
||||
tuck >r >r document get -rot start-on-line r> r>
|
||||
document get -rot end-on-line ;
|
||||
|
||||
: (doc-range) ( startloc endloc line# -- str )
|
||||
[ start/end-on-line ] keep document get doc-line <slice> , ;
|
||||
|
||||
: doc-range ( startloc endloc document -- str )
|
||||
[
|
||||
document set 2dup [
|
||||
>r 2dup r> (doc-range)
|
||||
] each-line 2drop
|
||||
] { } make "\n" join ;
|
||||
|
||||
: replace-columns ( str start# end# line# document -- )
|
||||
[
|
||||
[ swap [ replace-slice ] change-nth ] keep
|
||||
] change-model ;
|
||||
|
||||
: set-on-1 ( lines startloc endloc document -- )
|
||||
>r >r >r first r> second r> first2 swap r> replace-columns ;
|
||||
|
||||
: loc-col/str ( loc lines -- col str )
|
||||
>r first2 swap r> nth ;
|
||||
|
||||
: merge-lines ( lines startloc endloc lines -- str )
|
||||
#! Start line from 0 to start col + end line from end col
|
||||
#! to length
|
||||
tuck loc-col/str tail-slice
|
||||
>r loc-col/str head-slice
|
||||
swap first r> append3 ;
|
||||
|
||||
: set-on>1pre ( str startloc endloc lines -- )
|
||||
[ merge-lines 1array ] 3keep
|
||||
>r [ first ] 2apply 1+ r> replace-slice ;
|
||||
|
||||
: set-on>1 ( str startloc endloc document -- )
|
||||
[ set-on>1pre ] change-model ;
|
||||
|
||||
: text+loc ( lines loc -- loc )
|
||||
over >r over length 1 = [
|
||||
nip first2
|
||||
] [
|
||||
first swap length 1- + 0
|
||||
] if r> peek length + 2array ;
|
||||
|
||||
: update-locs ( loc document -- )
|
||||
document-locs [ set-model ] each-with ;
|
||||
|
||||
: set-doc-range ( str startloc endloc document -- )
|
||||
[
|
||||
>r >r >r "\n" split r> [ text+loc ] 2keep r> r>
|
||||
pick pick lines-equal? [ set-on-1 ] [ set-on>1 ] if
|
||||
] keep update-locs ;
|
||||
|
||||
: remove-doc-range ( startloc endloc document -- )
|
||||
>r >r >r "" r> r> r> set-doc-range ;
|
||||
|
||||
: validate-line ( line document -- line )
|
||||
model-value length 1- min 0 max ;
|
||||
|
||||
: validate-col ( col line document -- col )
|
||||
doc-line length min 0 max ;
|
||||
|
||||
: validate-loc ( loc document -- loc )
|
||||
>r first2 swap r> [ validate-line ] keep
|
||||
>r tuck r> validate-col 2array ;
|
||||
|
||||
: line-end ( line# document -- loc )
|
||||
dupd doc-line length 2array ;
|
||||
|
||||
: line-end? ( loc document -- ? )
|
||||
>r first2 swap r> doc-line length = ;
|
||||
|
||||
: doc-end ( document -- loc )
|
||||
model-value dup length 1- swap peek length 2array ;
|
||||
|
||||
GENERIC: prev-elt ( loc document elt -- loc )
|
||||
GENERIC: next-elt ( loc document elt -- loc )
|
||||
|
||||
TUPLE: char-elt ;
|
||||
|
||||
M: char-elt prev-elt
|
||||
drop {
|
||||
{ [ over { 0 0 } = ] [ drop ] }
|
||||
{ [ over second zero? ] [ >r first 1- r> line-end ] }
|
||||
{ [ t ] [ drop -1 +col ] }
|
||||
} cond ;
|
||||
|
||||
M: char-elt next-elt
|
||||
drop {
|
||||
{ [ 2dup doc-end = ] [ drop ] }
|
||||
{ [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
|
||||
{ [ t ] [ drop 1 +col ] }
|
||||
} cond ;
|
||||
|
||||
TUPLE: line-elt ;
|
||||
|
||||
M: line-elt prev-elt 2drop -1 +line ;
|
||||
M: line-elt next-elt 2drop 1 +line ;
|
||||
|
|
@ -0,0 +1,302 @@
|
|||
! Copyright (C) 2006 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-text
|
||||
USING: arrays errors freetype gadgets gadgets-borders
|
||||
gadgets-buttons gadgets-frames gadgets-labels gadgets-scrolling
|
||||
gadgets-theme io kernel math models namespaces opengl sequences
|
||||
strings styles ;
|
||||
|
||||
TUPLE: editor
|
||||
document
|
||||
font color caret-color selection-color
|
||||
caret mark
|
||||
focused? ;
|
||||
|
||||
: editor-theme ( editor -- )
|
||||
{ 0.0 0.0 0.0 1.0 } over set-editor-color
|
||||
{ 1.0 0.0 0.0 1.0 } over set-editor-caret-color
|
||||
{ 0.8 0.8 1.0 1.0 } over set-editor-selection-color
|
||||
{ "monospace" plain 12 } swap set-editor-font ;
|
||||
|
||||
TUPLE: action-relayout-1 editor ;
|
||||
|
||||
M: action-relayout-1 model-changed
|
||||
#! Caret changed
|
||||
action-relayout-1-editor relayout-1 ;
|
||||
|
||||
: init-editor-models ( editor -- )
|
||||
dup <action-relayout-1> over editor-caret add-connection
|
||||
dup <action-relayout-1> swap editor-mark add-connection ;
|
||||
|
||||
C: editor ( document -- editor )
|
||||
dup delegate>gadget
|
||||
<document> over set-editor-document
|
||||
{ 0 0 } <model> over set-editor-caret
|
||||
{ 0 0 } <model> over set-editor-mark
|
||||
dup init-editor-models
|
||||
dup editor-theme ;
|
||||
|
||||
: activate-editor-model ( editor model -- )
|
||||
dup activate-model swap editor-document add-loc ;
|
||||
|
||||
: deactivate-editor-model ( editor model -- )
|
||||
dup deactivate-model swap editor-document remove-loc ;
|
||||
|
||||
M: editor graft* ( editor -- )
|
||||
dup
|
||||
dup editor-caret activate-editor-model
|
||||
dup editor-mark activate-editor-model ;
|
||||
|
||||
M: editor ungraft* ( editor -- )
|
||||
dup
|
||||
dup editor-caret deactivate-editor-model
|
||||
dup editor-mark deactivate-editor-model ;
|
||||
|
||||
M: editor model-changed ( editor -- )
|
||||
#! Document changed
|
||||
relayout ;
|
||||
|
||||
: editor-caret* editor-caret model-value ;
|
||||
|
||||
: editor-mark* editor-mark model-value ;
|
||||
|
||||
: change-caret ( editor quot -- )
|
||||
over >r >r dup editor-caret* swap editor-document r> call r>
|
||||
[ editor-document validate-loc ] keep
|
||||
editor-caret set-model ; inline
|
||||
|
||||
: mark>caret ( editor -- )
|
||||
dup editor-caret* swap editor-mark set-model ;
|
||||
|
||||
: change-caret&mark ( editor quot -- )
|
||||
over >r change-caret r> mark>caret ; inline
|
||||
|
||||
: editor-lines ( editor -- seq )
|
||||
editor-document model-value ;
|
||||
|
||||
: editor-line ( n editor -- str ) editor-lines nth ;
|
||||
|
||||
: editor-font* ( editor -- font ) editor-font lookup-font ;
|
||||
|
||||
: line-height ( editor -- n )
|
||||
editor-font* font-height ;
|
||||
|
||||
: run-char-widths ( str editor -- wlist )
|
||||
#! List of x co-ordinates of each character.
|
||||
editor-font* swap >array [ char-width ] map-with
|
||||
dup 0 [ + ] accumulate swap 2 v/n v+ ;
|
||||
|
||||
: x>offset ( x line# editor -- col# )
|
||||
[ editor-line ] keep
|
||||
over >r run-char-widths [ <= ] find-with drop dup -1 =
|
||||
[ drop r> length ] [ r> drop ] if ;
|
||||
|
||||
: y>line ( y editor -- line# )
|
||||
[ line-height / >fixnum ] keep editor-lines length 1- min ;
|
||||
|
||||
: set-caret-y ( y editor -- )
|
||||
[ y>line ] keep [ drop =line ] change-caret&mark ;
|
||||
|
||||
: point>loc ( point editor -- loc )
|
||||
over second over y>line [
|
||||
>r >r first r> r> swap x>offset
|
||||
] keep swap 2array ;
|
||||
|
||||
: click-loc ( editor model -- )
|
||||
>r [ hand-rel ] keep point>loc r> set-model ;
|
||||
|
||||
: focus-editor ( editor -- )
|
||||
t over set-editor-focused? relayout-1 ;
|
||||
|
||||
: unfocus-editor ( editor -- )
|
||||
f over set-editor-focused? relayout-1 ;
|
||||
|
||||
: (offset>x) ( font col# str -- x )
|
||||
head-slice string-width ;
|
||||
|
||||
: offset>x ( col# line# editor -- x )
|
||||
[ editor-line ] keep editor-font* -rot (offset>x) ;
|
||||
|
||||
: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ;
|
||||
|
||||
: (draw-caret) ( loc editor -- )
|
||||
dup editor-caret-color gl-color
|
||||
[ loc>x ] keep line-height dupd 2array >r 0 2array r>
|
||||
gl-line ;
|
||||
|
||||
: draw-caret ( n editor -- )
|
||||
{
|
||||
{ [ dup editor-focused? not ] [ ] }
|
||||
{ [ 2dup editor-caret* first = not ] [ ] }
|
||||
{ [ t ] [ dup editor-caret* over (draw-caret) ] }
|
||||
} cond 2drop ;
|
||||
|
||||
: translate-lines ( n -- )
|
||||
editor get line-height * 0.0 swap 0.0 glTranslated ;
|
||||
|
||||
: draw-line ( str n -- )
|
||||
editor get draw-caret
|
||||
editor get editor-color gl-color
|
||||
>r editor get editor-font r> draw-string ;
|
||||
|
||||
: with-editor ( editor quot -- )
|
||||
[
|
||||
swap dup editor-document document set editor set call
|
||||
] with-scope ; inline
|
||||
|
||||
: draw-lines ( editor -- )
|
||||
GL_MODELVIEW [
|
||||
editor get editor-lines dup length
|
||||
[ draw-line 1 translate-lines ] 2each
|
||||
] do-matrix ;
|
||||
|
||||
: selection-start/end ( editor -- start end )
|
||||
dup editor-mark* swap editor-caret*
|
||||
2dup <=> 0 > [ swap ] when ;
|
||||
|
||||
: (draw-selection) ( x1 x2 -- )
|
||||
2dup = [ 2 + ] when
|
||||
0.0 swap editor get line-height glRectd ;
|
||||
|
||||
: draw-selected-line ( start end n -- )
|
||||
[ start/end-on-line ] keep tuck
|
||||
>r >r editor get offset>x r> r>
|
||||
editor get offset>x
|
||||
(draw-selection) ;
|
||||
|
||||
: translate>selection-start ( start -- )
|
||||
first translate-lines ;
|
||||
|
||||
: draw-selection ( -- )
|
||||
GL_MODELVIEW [
|
||||
editor get
|
||||
dup editor-selection-color gl-color
|
||||
selection-start/end
|
||||
over translate>selection-start
|
||||
2dup [
|
||||
>r 2dup r> draw-selected-line 1 translate-lines
|
||||
] each-line 2drop
|
||||
] do-matrix ;
|
||||
|
||||
M: editor draw-gadget* ( gadget -- )
|
||||
[ draw-selection draw-lines ] with-editor ;
|
||||
|
||||
: line>y ( lines# editor -- y )
|
||||
line-height * ;
|
||||
|
||||
: editor-height ( editor -- n )
|
||||
[ editor-lines length ] keep line>y ;
|
||||
|
||||
: editor-width ( editor -- n )
|
||||
0 swap dup editor-font* swap editor-lines
|
||||
[ string-width max ] each-with ;
|
||||
|
||||
M: editor pref-dim* ( editor -- dim )
|
||||
dup editor-width swap editor-height 2array ;
|
||||
|
||||
: editor-selection? ( editor -- ? )
|
||||
selection-start/end = not ;
|
||||
|
||||
: editor-selection ( editor -- str )
|
||||
[ selection-start/end ] keep editor-document doc-range ;
|
||||
|
||||
: remove-editor-selection ( editor -- )
|
||||
[ selection-start/end ] keep editor-document
|
||||
remove-doc-range ;
|
||||
|
||||
: editor-mouse-down ( editor -- )
|
||||
dup request-focus
|
||||
dup
|
||||
dup editor-caret click-loc
|
||||
dup editor-mark click-loc ;
|
||||
|
||||
: editor-mouse-drag ( editor -- )
|
||||
dup editor-caret click-loc ;
|
||||
|
||||
: editor-copy ( editor clipboard -- )
|
||||
over editor-selection? [
|
||||
>r editor-selection r> set-clipboard-contents
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: editor-cut ( editor clipboard -- )
|
||||
dupd editor-copy remove-editor-selection ;
|
||||
|
||||
: remove-at-caret ( editor quot -- | quot: caret editor -- from to )
|
||||
over >r >r dup editor-caret* swap editor-document
|
||||
r> call r> editor-document remove-doc-range ; inline
|
||||
|
||||
: editor-delete ( editor -- )
|
||||
dup editor-selection? [
|
||||
remove-editor-selection
|
||||
] [
|
||||
[ dupd T{ char-elt } next-elt ] remove-at-caret
|
||||
] if ;
|
||||
|
||||
: editor-backspace ( editor -- )
|
||||
dup editor-selection? [
|
||||
remove-editor-selection
|
||||
] [
|
||||
[ dupd T{ char-elt } prev-elt swap ] remove-at-caret
|
||||
] if ;
|
||||
|
||||
: editor-select-prev ( editor elt -- )
|
||||
swap [ rot prev-elt ] change-caret ;
|
||||
|
||||
: editor-prev ( editor elt -- )
|
||||
dupd editor-select-prev mark>caret ;
|
||||
|
||||
: editor-select-next ( editor elt -- )
|
||||
swap [ rot next-elt ] change-caret ;
|
||||
|
||||
: editor-next ( editor elt -- )
|
||||
dupd editor-select-next mark>caret ;
|
||||
|
||||
: editor-select-home ( editor -- )
|
||||
[ drop 0 swap =col ] change-caret ;
|
||||
|
||||
: editor-home ( editor -- )
|
||||
dup editor-select-home mark>caret ;
|
||||
|
||||
: editor-select-end ( editor -- )
|
||||
[ >r first r> line-end ] change-caret ;
|
||||
|
||||
: editor-end ( editor -- )
|
||||
dup editor-select-end mark>caret ;
|
||||
|
||||
: editor-select-all ( editor -- )
|
||||
{ 0 0 } over editor-caret set-model
|
||||
dup editor-document doc-end swap editor-mark set-model ;
|
||||
|
||||
M: editor gadget-gestures
|
||||
drop H{
|
||||
{ T{ button-down } [ editor-mouse-down ] }
|
||||
{ T{ drag } [ editor-mouse-drag ] }
|
||||
{ T{ gain-focus } [ focus-editor ] }
|
||||
{ T{ lose-focus } [ unfocus-editor ] }
|
||||
{ T{ paste-action } [ clipboard get paste-clipboard ] }
|
||||
{ T{ button-up f 2 } [ selection get paste-clipboard ] }
|
||||
{ T{ copy-action } [ clipboard get editor-copy ] }
|
||||
{ T{ button-up } [ selection get editor-copy ] }
|
||||
{ T{ cut-action } [ clipboard get editor-cut ] }
|
||||
{ T{ delete-action } [ remove-editor-selection ] }
|
||||
{ T{ select-all-action } [ editor-select-all ] }
|
||||
{ T{ key-down f f "LEFT" } [ T{ char-elt } editor-prev ] }
|
||||
{ T{ key-down f f "RIGHT" } [ T{ char-elt } editor-next ] }
|
||||
{ T{ key-down f f "UP" } [ T{ line-elt } editor-prev ] }
|
||||
{ T{ key-down f f "DOWN" } [ T{ line-elt } editor-next ] }
|
||||
{ T{ key-down f { S+ } "LEFT" } [ T{ char-elt } editor-select-prev ] }
|
||||
{ T{ key-down f { S+ } "RIGHT" } [ T{ char-elt } editor-select-next ] }
|
||||
{ T{ key-down f { S+ } "UP" } [ T{ line-elt } editor-select-prev ] }
|
||||
{ T{ key-down f { S+ } "DOWN" } [ T{ line-elt } editor-select-next ] }
|
||||
{ T{ key-down f f "HOME" } [ editor-home ] }
|
||||
{ T{ key-down f f "END" } [ editor-end ] }
|
||||
{ T{ key-down f { S+ } "HOME" } [ editor-select-home ] }
|
||||
{ T{ key-down f { S+ } "END" } [ editor-select-end ] }
|
||||
{ T{ key-down f f "DELETE" } [ editor-delete ] }
|
||||
{ T{ key-down f f "BACKSPACE" } [ editor-backspace ] }
|
||||
} ;
|
||||
|
||||
M: editor user-input* ( str editor -- ? )
|
||||
[ selection-start/end ] keep editor-document set-doc-range t ;
|
||||
Loading…
Reference in New Issue