130 lines
3.4 KiB
Factor
130 lines
3.4 KiB
Factor
! 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
|
|
strings 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 )
|
|
V{ "" } clone <model> over set-delegate
|
|
V{ } clone over set-document-locs ;
|
|
|
|
: add-loc document-locs push ;
|
|
|
|
: remove-loc document-locs delete ;
|
|
|
|
: update-locs ( loc document -- )
|
|
document-locs [ set-model* ] each-with ;
|
|
|
|
: 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# -- )
|
|
[ 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 ;
|
|
|
|
: text+loc ( lines loc -- loc )
|
|
over >r over length 1 = [
|
|
nip first2
|
|
] [
|
|
first swap length 1- + 0
|
|
] if r> peek length + 2array ;
|
|
|
|
: prepend-first ( str seq -- )
|
|
0 swap [ append ] change-nth ;
|
|
|
|
: append-last ( str seq -- )
|
|
[ length 1- ] keep [ swap append ] change-nth ;
|
|
|
|
: loc-col/str ( loc document -- str col )
|
|
>r first2 swap r> nth swap ;
|
|
|
|
: prepare-insert ( newinput startloc endloc lines -- newinput )
|
|
tuck loc-col/str tail-slice >r loc-col/str head-slice r>
|
|
pick append-last over prepend-first ;
|
|
|
|
: (set-doc-range) ( newlines startloc endloc lines -- newlines )
|
|
[ prepare-insert ] 3keep
|
|
>r [ first ] 2apply 1+ r>
|
|
replace-slice ;
|
|
|
|
: set-doc-range ( str startloc endloc document -- )
|
|
[
|
|
>r >r >r "\n" split r> [ text+loc ] 2keep r> r>
|
|
[ (set-doc-range) ] change-model
|
|
] 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 ;
|
|
|
|
: doc-text ( document -- str )
|
|
model-value "\n" join ;
|
|
|
|
: set-doc-lines ( seq document -- )
|
|
[ set-model ] keep dup doc-end swap update-locs ;
|
|
|
|
: set-doc-text ( string document -- )
|
|
>r "\n" split r> set-doc-lines ;
|
|
|
|
: clear-doc ( document -- )
|
|
"" swap set-doc-text ;
|