Add undo/redo to documents
Slava Pestov
parent
abff1c44f3
commit
33c955775b
|
|
@ -91,38 +91,6 @@ HELP: clear-doc
|
|||
{ $description "Removes all text from the document." }
|
||||
{ $side-effects "document" } ;
|
||||
|
||||
HELP: prev-elt
|
||||
{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
|
||||
{ $contract "Outputs the location of the first occurrence of the element prior to " { $snippet "loc" } "." } ;
|
||||
|
||||
{ prev-elt next-elt } related-words
|
||||
|
||||
HELP: next-elt
|
||||
{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
|
||||
{ $contract "Outputs the location of the first occurrence of the element following " { $snippet "loc" } "." } ;
|
||||
|
||||
HELP: char-elt
|
||||
{ $class-description "An element representing a single character." } ;
|
||||
|
||||
HELP: one-word-elt
|
||||
{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the word at the current location." } ;
|
||||
|
||||
{ one-word-elt word-elt } related-words
|
||||
|
||||
HELP: word-elt
|
||||
{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next word from the current location." } ;
|
||||
|
||||
HELP: one-line-elt
|
||||
{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the line at the current location." } ;
|
||||
|
||||
{ one-line-elt line-elt } related-words
|
||||
|
||||
HELP: line-elt
|
||||
{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next line from the current location." } ;
|
||||
|
||||
HELP: doc-elt
|
||||
{ $class-description "An element representing the entire document. The " { $link prev-elt } " word outputs the start of the document and the " { $link next-elt } " word outputs the end of the document." } ;
|
||||
|
||||
ARTICLE: "documents" "Documents"
|
||||
{ $subsection document }
|
||||
{ $subsection <document> }
|
||||
|
|
@ -138,24 +106,18 @@ ARTICLE: "documents" "Documents"
|
|||
{ $subsection remove-doc-range }
|
||||
"A combinator:"
|
||||
{ $subsection each-line }
|
||||
{ $subsection "document-locs" }
|
||||
{ $subsection "documents.elements" }
|
||||
{ $see-also "gadgets-editors" } ;
|
||||
|
||||
ARTICLE: "document-locs-elts" "Locations and elements"
|
||||
ARTICLE: "document-locs" "Document locations"
|
||||
"Locations in the document are represented as a line/column number pair, with both indices being zero-based. There are some words for manipulating locations:"
|
||||
{ $subsection +col }
|
||||
{ $subsection +line }
|
||||
{ $subsection =col }
|
||||
{ $subsection =line }
|
||||
"New locations can be created out of existing ones by finding the start or end of a document element nearest to a given location."
|
||||
{ $subsection prev-elt }
|
||||
{ $subsection next-elt }
|
||||
"The different types of document elements correspond to the standard editing taxonomy:"
|
||||
{ $subsection char-elt }
|
||||
{ $subsection one-word-elt }
|
||||
{ $subsection word-elt }
|
||||
{ $subsection one-line-elt }
|
||||
{ $subsection line-elt }
|
||||
{ $subsection doc-elt }
|
||||
"Miscellaneous words for working with locations:"
|
||||
{ $subsection lines-equal? }
|
||||
{ $subsection validate-loc } ;
|
||||
|
||||
ABOUT: "documents"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
IN: documents.tests
|
||||
USING: documents namespaces tools.test make arrays kernel fry ;
|
||||
USING: documents documents.private accessors sequences
|
||||
namespaces tools.test make arrays kernel fry ;
|
||||
|
||||
! Tests
|
||||
|
||||
|
|
@ -88,19 +89,44 @@ USING: documents namespaces tools.test make arrays kernel fry ;
|
|||
"doc" get doc-string
|
||||
] unit-test
|
||||
|
||||
<document> "doc" set
|
||||
"Hello world" "doc" get set-doc-string
|
||||
[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
|
||||
! Undo/redo
|
||||
[ ] [ <document> "d" set ] unit-test
|
||||
|
||||
<document> "doc" set
|
||||
"Hello\nworld, how are\nyou?" "doc" get set-doc-string
|
||||
[ ] [ "Hello, world." "d" get set-doc-string ] unit-test
|
||||
|
||||
[ { 2 4 } ] [ "doc" get doc-end ] unit-test
|
||||
[
|
||||
T{ edit
|
||||
{ old-string "" }
|
||||
{ new-string "Hello, world." }
|
||||
{ from { 0 0 } }
|
||||
{ old-to { 0 0 } }
|
||||
{ new-to { 0 13 } }
|
||||
}
|
||||
] [ "d" get undos>> first ] unit-test
|
||||
|
||||
[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
|
||||
[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
|
||||
[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
|
||||
[ ] [ "Goodbye" { 0 0 } { 0 5 } "d" get set-doc-range ] unit-test
|
||||
|
||||
[ "Goodbye, world." ] [ "d" get doc-string ] unit-test
|
||||
|
||||
[ ] [ "cruel " { 0 9 } { 0 9 } "d" get set-doc-range ] unit-test
|
||||
|
||||
[ 3 ] [ "d" get undos>> length ] unit-test
|
||||
|
||||
[ "Goodbye, cruel world." ] [ "d" get doc-string ] unit-test
|
||||
|
||||
[ "" { 0 9 } { 0 15 } ] [
|
||||
"d" get undos>> peek
|
||||
[ old-string>> ] [ from>> ] [ new-to>> ] tri
|
||||
] unit-test
|
||||
|
||||
[ ] [ "d" get undo ] unit-test
|
||||
|
||||
[ "Goodbye, world." ] [ "d" get doc-string ] unit-test
|
||||
|
||||
[ ] [ "d" get undo ] unit-test
|
||||
|
||||
[ "Hello, world." ] [ "d" get doc-string ] unit-test
|
||||
|
||||
[ ] [ "d" get redo ] unit-test
|
||||
|
||||
[ "Goodbye, world." ] [ "d" get doc-string ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays io kernel math models namespaces make
|
||||
sequences strings splitting combinators unicode.categories
|
||||
math.order math.ranges fry ;
|
||||
math.order math.ranges fry locals ;
|
||||
IN: documents
|
||||
|
||||
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
|
||||
|
|
@ -15,11 +15,21 @@ IN: documents
|
|||
|
||||
: lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
|
||||
|
||||
TUPLE: document < model locs ;
|
||||
TUPLE: edit old-string new-string from old-to new-to ;
|
||||
|
||||
C: <edit> edit
|
||||
|
||||
TUPLE: document < model locs undos redos inside-undo? ;
|
||||
|
||||
: clear-undo ( document -- )
|
||||
V{ } clone >>undos
|
||||
V{ } clone >>redos
|
||||
drop ;
|
||||
|
||||
: <document> ( -- document )
|
||||
V{ "" } clone document new-model
|
||||
V{ } clone >>locs ;
|
||||
V{ } clone >>locs
|
||||
dup clear-undo ;
|
||||
|
||||
: add-loc ( loc document -- ) locs>> push ;
|
||||
|
||||
|
|
@ -30,8 +40,11 @@ TUPLE: document < model locs ;
|
|||
|
||||
: doc-line ( n document -- string ) value>> nth ;
|
||||
|
||||
: line-end ( line# document -- loc )
|
||||
[ drop ] [ doc-line length ] 2bi 2array ;
|
||||
|
||||
: doc-lines ( from to document -- slice )
|
||||
[ 1+ ] dip value>> <slice> ;
|
||||
[ 1+ ] [ value>> ] bi* <slice> ;
|
||||
|
||||
: start-on-line ( document from line# -- n1 )
|
||||
[ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
|
||||
|
|
@ -56,16 +69,19 @@ TUPLE: document < model locs ;
|
|||
[ [ document get ] 2dip end-on-line ]
|
||||
2bi* ;
|
||||
|
||||
: last-line# ( document -- line )
|
||||
value>> length 1- ;
|
||||
|
||||
CONSTANT: doc-start { 0 0 }
|
||||
|
||||
: doc-end ( document -- loc )
|
||||
[ last-line# ] keep line-end ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (doc-range) ( from to line# -- )
|
||||
[ start/end-on-line ] keep document get doc-line <slice> , ;
|
||||
|
||||
: doc-range ( from to document -- string )
|
||||
[
|
||||
document set 2dup [
|
||||
[ 2dup ] dip (doc-range)
|
||||
] each-line 2drop
|
||||
] { } make "\n" join ;
|
||||
|
||||
: text+loc ( lines loc -- loc )
|
||||
over [
|
||||
over length 1 = [
|
||||
|
|
@ -84,20 +100,44 @@ TUPLE: document < model locs ;
|
|||
: loc-col/str ( loc document -- str col )
|
||||
[ first2 swap ] dip nth swap ;
|
||||
|
||||
: prepare-insert ( newinput from to lines -- newinput )
|
||||
: prepare-insert ( new-lines from to lines -- new-lines )
|
||||
tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
|
||||
pick append-last over prepend-first ;
|
||||
|
||||
: (set-doc-range) ( newlines from to lines -- )
|
||||
: (set-doc-range) ( new-lines from to lines -- )
|
||||
[ prepare-insert ] 3keep
|
||||
[ [ first ] bi@ 1+ ] dip
|
||||
replace-slice ;
|
||||
|
||||
: set-doc-range ( string from to document -- )
|
||||
: entire-doc ( document -- start end document )
|
||||
[ [ doc-start ] dip doc-end ] keep ;
|
||||
|
||||
: with-undo ( document quot: ( document -- ) -- )
|
||||
[ t >>inside-undo? ] dip keep f >>inside-undo? drop ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: doc-range ( from to document -- string )
|
||||
[
|
||||
[ [ string-lines ] dip [ text+loc ] 2keep ] 2dip
|
||||
[ [ (set-doc-range) ] keep ] change-model
|
||||
] keep update-locs ;
|
||||
document set 2dup [
|
||||
[ 2dup ] dip (doc-range)
|
||||
] each-line 2drop
|
||||
] { } make "\n" join ;
|
||||
|
||||
: add-undo ( edit document -- )
|
||||
dup inside-undo?>> [ 2drop ] [
|
||||
[ undos>> push ] keep
|
||||
redos>> delete-all
|
||||
] if ;
|
||||
|
||||
:: set-doc-range ( string from to document -- )
|
||||
string string-lines :> new-lines
|
||||
new-lines from text+loc :> new-to
|
||||
from to document doc-range :> old-string
|
||||
old-string string from to new-to <edit> document add-undo
|
||||
new-lines from to document value>> (set-doc-range)
|
||||
document notify-connections
|
||||
new-to document update-locs ;
|
||||
|
||||
: change-doc-range ( from to document quot -- )
|
||||
'[ doc-range @ ] 3keep set-doc-range ; inline
|
||||
|
|
@ -105,26 +145,17 @@ TUPLE: document < model locs ;
|
|||
: remove-doc-range ( from to document -- )
|
||||
[ "" ] 3dip set-doc-range ;
|
||||
|
||||
: last-line# ( document -- line )
|
||||
value>> length 1- ;
|
||||
|
||||
: validate-line ( line document -- line )
|
||||
last-line# min 0 max ;
|
||||
|
||||
: validate-col ( col line document -- col )
|
||||
doc-line length min 0 max ;
|
||||
|
||||
: line-end ( line# document -- loc )
|
||||
dupd doc-line length 2array ;
|
||||
|
||||
: line-end? ( loc document -- ? )
|
||||
[ first2 swap ] dip doc-line length = ;
|
||||
|
||||
: doc-end ( document -- loc )
|
||||
[ last-line# ] keep line-end ;
|
||||
|
||||
: validate-loc ( loc document -- newloc )
|
||||
over first over value>> length >= [
|
||||
2dup [ first ] [ value>> length ] bi* >= [
|
||||
nip doc-end
|
||||
] [
|
||||
over first 0 < [
|
||||
|
|
@ -135,113 +166,33 @@ TUPLE: document < model locs ;
|
|||
] if ;
|
||||
|
||||
: doc-string ( document -- str )
|
||||
value>> "\n" join ;
|
||||
entire-doc doc-range ;
|
||||
|
||||
: set-doc-string ( string document -- )
|
||||
[ string-lines V{ } like ] dip [ set-model ] keep
|
||||
[ doc-end ] [ update-locs ] bi ;
|
||||
entire-doc set-doc-range ;
|
||||
|
||||
: clear-doc ( document -- )
|
||||
"" swap set-doc-string ;
|
||||
[ "" ] dip set-doc-string ;
|
||||
|
||||
GENERIC: prev-elt ( loc document elt -- newloc )
|
||||
GENERIC: next-elt ( loc document elt -- newloc )
|
||||
<PRIVATE
|
||||
|
||||
: prev/next-elt ( loc document elt -- start end )
|
||||
[ prev-elt ] [ next-elt ] 3bi ;
|
||||
: undo/redo-edit ( edit document string-quot to-quot -- )
|
||||
'[ [ _ [ from>> ] _ tri ] dip set-doc-range ] with-undo ; inline
|
||||
|
||||
: elt-string ( loc document elt -- string )
|
||||
[ prev/next-elt ] [ drop ] 2bi doc-range ;
|
||||
: undo-edit ( edit document -- )
|
||||
[ old-string>> ] [ new-to>> ] undo/redo-edit ;
|
||||
|
||||
: set-elt-string ( string loc document elt -- )
|
||||
[ prev/next-elt ] [ drop ] 2bi set-doc-range ;
|
||||
: redo-edit ( edit document -- )
|
||||
[ new-string>> ] [ old-to>> ] undo/redo-edit ;
|
||||
|
||||
SINGLETON: char-elt
|
||||
: undo/redo ( document source-quot dest-quot do-quot -- )
|
||||
[ dupd call [ drop ] ] 2dip
|
||||
'[ pop swap [ @ push ] _ 2bi ] if-empty ; inline
|
||||
|
||||
: (prev-char) ( loc document quot -- loc )
|
||||
{
|
||||
{ [ pick { 0 0 } = ] [ 2drop ] }
|
||||
{ [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
|
||||
[ call ]
|
||||
} cond ; inline
|
||||
PRIVATE>
|
||||
|
||||
: (next-char) ( loc document quot -- loc )
|
||||
{
|
||||
{ [ 2over doc-end = ] [ 2drop ] }
|
||||
{ [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
|
||||
[ call ]
|
||||
} cond ; inline
|
||||
: undo ( document -- )
|
||||
[ undos>> ] [ redos>> ] [ undo-edit ] undo/redo ;
|
||||
|
||||
M: char-elt prev-elt
|
||||
drop [ drop -1 +col ] (prev-char) ;
|
||||
|
||||
M: char-elt next-elt
|
||||
drop [ drop 1 +col ] (next-char) ;
|
||||
|
||||
SINGLETON: one-char-elt
|
||||
|
||||
M: one-char-elt prev-elt 2drop ;
|
||||
|
||||
M: one-char-elt next-elt 2drop ;
|
||||
|
||||
: (word-elt) ( loc document quot -- loc )
|
||||
pick [
|
||||
[ [ first2 swap ] dip doc-line ] dip call
|
||||
] dip =col ; inline
|
||||
|
||||
: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
|
||||
|
||||
: break-detector ( ? -- quot )
|
||||
'[ blank? _ xor ] ; inline
|
||||
|
||||
: (prev-word) ( ? col str -- col )
|
||||
rot break-detector find-last-from drop ?1+ ;
|
||||
|
||||
: (next-word) ( ? col str -- col )
|
||||
[ rot break-detector find-from drop ] keep
|
||||
over not [ nip length ] [ drop ] if ;
|
||||
|
||||
SINGLETON: one-word-elt
|
||||
|
||||
M: one-word-elt prev-elt
|
||||
drop
|
||||
[ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
|
||||
|
||||
M: one-word-elt next-elt
|
||||
drop
|
||||
[ [ f ] 2dip (next-word) ] (word-elt) ;
|
||||
|
||||
SINGLETON: word-elt
|
||||
|
||||
M: word-elt prev-elt
|
||||
drop
|
||||
[ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
|
||||
(prev-char) ;
|
||||
|
||||
M: word-elt next-elt
|
||||
drop
|
||||
[ [ ((word-elt)) (next-word) ] (word-elt) ]
|
||||
(next-char) ;
|
||||
|
||||
SINGLETON: one-line-elt
|
||||
|
||||
M: one-line-elt prev-elt
|
||||
2drop first 0 2array ;
|
||||
|
||||
M: one-line-elt next-elt
|
||||
drop [ first dup ] dip doc-line length 2array ;
|
||||
|
||||
SINGLETON: line-elt
|
||||
|
||||
M: line-elt prev-elt
|
||||
2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
|
||||
|
||||
M: line-elt next-elt
|
||||
drop over first over last-line# number=
|
||||
[ nip doc-end ] [ drop 1 +line ] if ;
|
||||
|
||||
SINGLETON: doc-elt
|
||||
|
||||
M: doc-elt prev-elt 3drop { 0 0 } ;
|
||||
|
||||
M: doc-elt next-elt drop nip doc-end ;
|
||||
: redo ( document -- )
|
||||
[ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
USING: help.markup help.syntax documents ;
|
||||
IN: documents.elements
|
||||
|
||||
HELP: prev-elt
|
||||
{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
|
||||
{ $contract "Outputs the location of the first occurrence of the element prior to " { $snippet "loc" } "." } ;
|
||||
|
||||
{ prev-elt next-elt } related-words
|
||||
|
||||
HELP: next-elt
|
||||
{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
|
||||
{ $contract "Outputs the location of the first occurrence of the element following " { $snippet "loc" } "." } ;
|
||||
|
||||
HELP: char-elt
|
||||
{ $class-description "An element representing a single character." } ;
|
||||
|
||||
HELP: one-word-elt
|
||||
{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the word at the current location." } ;
|
||||
|
||||
{ one-word-elt word-elt } related-words
|
||||
|
||||
HELP: word-elt
|
||||
{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next word from the current location." } ;
|
||||
|
||||
HELP: one-line-elt
|
||||
{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the line at the current location." } ;
|
||||
|
||||
{ one-line-elt line-elt } related-words
|
||||
|
||||
HELP: line-elt
|
||||
{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next line from the current location." } ;
|
||||
|
||||
HELP: doc-elt
|
||||
{ $class-description "An element representing the entire document. The " { $link prev-elt } " word outputs the start of the document and the " { $link next-elt } " word outputs the end of the document." } ;
|
||||
|
||||
ARTICLE: "documents.elements" "Document elements"
|
||||
"Document elements, defined in the " { $vocab-link "documents.elements" } " vocabulary, overlay a hierarchy of structure on top of the flat sequence of characters presented by the document."
|
||||
$nl
|
||||
"The different types of document elements correspond to the standard editing taxonomy:"
|
||||
{ $subsection char-elt }
|
||||
{ $subsection one-word-elt }
|
||||
{ $subsection word-elt }
|
||||
{ $subsection one-line-elt }
|
||||
{ $subsection line-elt }
|
||||
{ $subsection doc-elt }
|
||||
"New locations can be created out of existing ones by finding the start or end of a document element nearest to a given location."
|
||||
{ $subsection prev-elt }
|
||||
{ $subsection next-elt } ;
|
||||
|
||||
ABOUT: "documents.elements"
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test namespaces documents documents.elements ;
|
||||
IN: document.elements.tests
|
||||
|
||||
<document> "doc" set
|
||||
"Hello world" "doc" get set-doc-string
|
||||
[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
|
||||
|
||||
<document> "doc" set
|
||||
"Hello\nworld, how are\nyou?" "doc" get set-doc-string
|
||||
|
||||
[ { 2 4 } ] [ "doc" get doc-end ] unit-test
|
||||
|
||||
[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
|
||||
[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
|
||||
[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
|
||||
|
|
@ -0,0 +1,108 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators documents fry kernel math sequences
|
||||
unicode.categories ;
|
||||
IN: documents.elements
|
||||
|
||||
GENERIC: prev-elt ( loc document elt -- newloc )
|
||||
GENERIC: next-elt ( loc document elt -- newloc )
|
||||
|
||||
: prev/next-elt ( loc document elt -- start end )
|
||||
[ prev-elt ] [ next-elt ] 3bi ;
|
||||
|
||||
: elt-string ( loc document elt -- string )
|
||||
[ prev/next-elt ] [ drop ] 2bi doc-range ;
|
||||
|
||||
: set-elt-string ( string loc document elt -- )
|
||||
[ prev/next-elt ] [ drop ] 2bi set-doc-range ;
|
||||
|
||||
SINGLETON: char-elt
|
||||
|
||||
: (prev-char) ( loc document quot -- loc )
|
||||
{
|
||||
{ [ pick { 0 0 } = ] [ 2drop ] }
|
||||
{ [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
|
||||
[ call ]
|
||||
} cond ; inline
|
||||
|
||||
: (next-char) ( loc document quot -- loc )
|
||||
{
|
||||
{ [ 2over doc-end = ] [ 2drop ] }
|
||||
{ [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
|
||||
[ call ]
|
||||
} cond ; inline
|
||||
|
||||
M: char-elt prev-elt
|
||||
drop [ drop -1 +col ] (prev-char) ;
|
||||
|
||||
M: char-elt next-elt
|
||||
drop [ drop 1 +col ] (next-char) ;
|
||||
|
||||
SINGLETON: one-char-elt
|
||||
|
||||
M: one-char-elt prev-elt 2drop ;
|
||||
|
||||
M: one-char-elt next-elt 2drop ;
|
||||
|
||||
: (word-elt) ( loc document quot -- loc )
|
||||
pick [
|
||||
[ [ first2 swap ] dip doc-line ] dip call
|
||||
] dip =col ; inline
|
||||
|
||||
: ((word-elt)) ( n seq -- ? n seq )
|
||||
[ ?nth blank? ] 2keep ;
|
||||
|
||||
: break-detector ( ? -- quot )
|
||||
'[ blank? _ xor ] ; inline
|
||||
|
||||
: (prev-word) ( ? col str -- col )
|
||||
rot break-detector find-last-from drop ?1+ ;
|
||||
|
||||
: (next-word) ( ? col str -- col )
|
||||
[ rot break-detector find-from drop ] keep
|
||||
over not [ nip length ] [ drop ] if ;
|
||||
|
||||
SINGLETON: one-word-elt
|
||||
|
||||
M: one-word-elt prev-elt
|
||||
drop
|
||||
[ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
|
||||
|
||||
M: one-word-elt next-elt
|
||||
drop
|
||||
[ [ f ] 2dip (next-word) ] (word-elt) ;
|
||||
|
||||
SINGLETON: word-elt
|
||||
|
||||
M: word-elt prev-elt
|
||||
drop
|
||||
[ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
|
||||
(prev-char) ;
|
||||
|
||||
M: word-elt next-elt
|
||||
drop
|
||||
[ [ ((word-elt)) (next-word) ] (word-elt) ]
|
||||
(next-char) ;
|
||||
|
||||
SINGLETON: one-line-elt
|
||||
|
||||
M: one-line-elt prev-elt
|
||||
2drop first 0 2array ;
|
||||
|
||||
M: one-line-elt next-elt
|
||||
drop [ first dup ] dip doc-line length 2array ;
|
||||
|
||||
SINGLETON: line-elt
|
||||
|
||||
M: line-elt prev-elt
|
||||
2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
|
||||
|
||||
M: line-elt next-elt
|
||||
drop over first over last-line# number=
|
||||
[ nip doc-end ] [ drop 1 +line ] if ;
|
||||
|
||||
SINGLETON: doc-elt
|
||||
|
||||
M: doc-elt prev-elt 3drop { 0 0 } ;
|
||||
|
||||
M: doc-elt next-elt drop nip doc-end ;
|
||||
Loading…
Reference in New Issue