steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add undo/redo to documents

db4
Slava Pestov 2009-01-28 00:30:30 -06:00
parent abff1c44f3
commit 33c955775b
7 changed files with 302 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
basis/documents/documents-docs.factor
View File

@ -91,38 +91,6 @@ HELP: clear-doc
{ $description "Removes all text from the document." } { $description "Removes all text from the document." }
{ $side-effects "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" ARTICLE: "documents" "Documents"
{ $subsection document } { $subsection document }
{ $subsection <document> } { $subsection <document> }
@ -138,24 +106,18 @@ ARTICLE: "documents" "Documents"
{ $subsection remove-doc-range } { $subsection remove-doc-range }
"A combinator:" "A combinator:"
{ $subsection each-line } { $subsection each-line }
{ $subsection "document-locs" }
{ $subsection "documents.elements" }
{ $see-also "gadgets-editors" } ; { $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:" "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 +col }
{ $subsection +line } { $subsection +line }
{ $subsection =col } { $subsection =col }
{ $subsection =line } { $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:" "Miscellaneous words for working with locations:"
{ $subsection lines-equal? } { $subsection lines-equal? }
{ $subsection validate-loc } ; { $subsection validate-loc } ;
ABOUT: "documents"

54
basis/documents/documents-tests.factor
View File

@ -1,5 +1,6 @@
IN: documents.tests 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 ! Tests
@ -88,19 +89,44 @@ USING: documents namespaces tools.test make arrays kernel fry ;
"doc" get doc-string "doc" get doc-string
] unit-test ] unit-test
<document> "doc" set ! Undo/redo
"Hello world" "doc" get set-doc-string [ ] [ <document> "d" set ] unit-test
[ { 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, world." "d" get set-doc-string ] unit-test
"Hello\nworld, how are\nyou?" "doc" get set-doc-string
[ { 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 [ ] [ "Goodbye" { 0 0 } { 0 5 } "d" get set-doc-range ] 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, 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

203
basis/documents/documents.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io kernel math models namespaces make USING: accessors arrays io kernel math models namespaces make
sequences strings splitting combinators unicode.categories sequences strings splitting combinators unicode.categories
math.order math.ranges fry ; math.order math.ranges fry locals ;
IN: documents IN: documents
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ; : +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
@ -15,11 +15,21 @@ IN: documents
: lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ; : 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 ) : <document> ( -- document )
V{ "" } clone document new-model V{ "" } clone document new-model
V{ } clone >>locs ; V{ } clone >>locs
dup clear-undo ;
: add-loc ( loc document -- ) locs>> push ; : add-loc ( loc document -- ) locs>> push ;
@ -30,8 +40,11 @@ TUPLE: document < model locs ;
: doc-line ( n document -- string ) value>> nth ; : doc-line ( n document -- string ) value>> nth ;
: line-end ( line# document -- loc )
[ drop ] [ doc-line length ] 2bi 2array ;
: doc-lines ( from to document -- slice ) : doc-lines ( from to document -- slice )
[ 1+ ] dip value>> <slice> ; [ 1+ ] [ value>> ] bi* <slice> ;
: start-on-line ( document from line# -- n1 ) : start-on-line ( document from line# -- n1 )
[ dup first ] dip = [ nip second ] [ 2drop 0 ] if ; [ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
@ -56,16 +69,19 @@ TUPLE: document < model locs ;
[ [ document get ] 2dip end-on-line ] [ [ document get ] 2dip end-on-line ]
2bi* ; 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# -- ) : (doc-range) ( from to line# -- )
[ start/end-on-line ] keep document get doc-line <slice> , ; [ 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 ) : text+loc ( lines loc -- loc )
over [ over [
over length 1 = [ over length 1 = [
@ -84,20 +100,44 @@ TUPLE: document < model locs ;
: loc-col/str ( loc document -- str col ) : loc-col/str ( loc document -- str col )
[ first2 swap ] dip nth swap ; [ 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* tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
pick append-last over prepend-first ; pick append-last over prepend-first ;
: (set-doc-range) ( newlines from to lines -- ) : (set-doc-range) ( new-lines from to lines -- )
[ prepare-insert ] 3keep [ prepare-insert ] 3keep
[ [ first ] bi@ 1+ ] dip [ [ first ] bi@ 1+ ] dip
replace-slice ; 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 document set 2dup [
[ [ (set-doc-range) ] keep ] change-model [ 2dup ] dip (doc-range)
] keep update-locs ; ] 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 -- ) : change-doc-range ( from to document quot -- )
'[ doc-range @ ] 3keep set-doc-range ; inline '[ doc-range @ ] 3keep set-doc-range ; inline
@ -105,26 +145,17 @@ TUPLE: document < model locs ;
: remove-doc-range ( from to document -- ) : remove-doc-range ( from to document -- )
[ "" ] 3dip set-doc-range ; [ "" ] 3dip set-doc-range ;
: last-line# ( document -- line )
value>> length 1- ;
: validate-line ( line document -- line ) : validate-line ( line document -- line )
last-line# min 0 max ; last-line# min 0 max ;
: validate-col ( col line document -- col ) : validate-col ( col line document -- col )
doc-line length min 0 max ; doc-line length min 0 max ;
: line-end ( line# document -- loc )
dupd doc-line length 2array ;
: line-end? ( loc document -- ? ) : line-end? ( loc document -- ? )
[ first2 swap ] dip doc-line length = ; [ first2 swap ] dip doc-line length = ;
: doc-end ( document -- loc )
[ last-line# ] keep line-end ;
: validate-loc ( loc document -- newloc ) : validate-loc ( loc document -- newloc )
over first over value>> length >= [ 2dup [ first ] [ value>> length ] bi* >= [
nip doc-end nip doc-end
] [ ] [
over first 0 < [ over first 0 < [
@ -135,113 +166,33 @@ TUPLE: document < model locs ;
] if ; ] if ;
: doc-string ( document -- str ) : doc-string ( document -- str )
value>> "\n" join ; entire-doc doc-range ;
: set-doc-string ( string document -- ) : set-doc-string ( string document -- )
[ string-lines V{ } like ] dip [ set-model ] keep entire-doc set-doc-range ;
[ doc-end ] [ update-locs ] bi ;
: clear-doc ( document -- ) : clear-doc ( document -- )
"" swap set-doc-string ; [ "" ] dip set-doc-string ;
GENERIC: prev-elt ( loc document elt -- newloc ) <PRIVATE
GENERIC: next-elt ( loc document elt -- newloc )
: prev/next-elt ( loc document elt -- start end ) : undo/redo-edit ( edit document string-quot to-quot -- )
[ prev-elt ] [ next-elt ] 3bi ; '[ [ _ [ from>> ] _ tri ] dip set-doc-range ] with-undo ; inline
: elt-string ( loc document elt -- string ) : undo-edit ( edit document -- )
[ prev/next-elt ] [ drop ] 2bi doc-range ; [ old-string>> ] [ new-to>> ] undo/redo-edit ;
: set-elt-string ( string loc document elt -- ) : redo-edit ( edit document -- )
[ prev/next-elt ] [ drop ] 2bi set-doc-range ; [ 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 ) PRIVATE>
{
{ [ pick { 0 0 } = ] [ 2drop ] }
{ [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
[ call ]
} cond ; inline
: (next-char) ( loc document quot -- loc ) : undo ( document -- )
{ [ undos>> ] [ redos>> ] [ undo-edit ] undo/redo ;
{ [ 2over doc-end = ] [ 2drop ] }
{ [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
[ call ]
} cond ; inline
M: char-elt prev-elt : redo ( document -- )
drop [ drop -1 +col ] (prev-char) ; [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;
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 ;

1
basis/documents/elements/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

50
basis/documents/elements/elements-docs.factor Normal file
View File

@ -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"

21
basis/documents/elements/elements-tests.factor Normal file
View File

@ -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

108
basis/documents/elements/elements.factor Normal file
View File

@ -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 ;