commit cee747192e710e667d9223df31110c6a0680ab6c
parent 44c92f54304aa6ce406afc0a317159fcf4c77557
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Wed, 15 Feb 2023 18:44:10 -0500
text/ed: store lines in Array instead of a LL
It simplifies the current code as well as developments to come.
Diffstat:
4 files changed, 65 insertions(+), 88 deletions(-)
diff --git a/fs/lib/array.fs b/fs/lib/array.fs
@@ -14,7 +14,8 @@ struct[ Array
over * dup malloc here >r , 0 , swap , , r> ;
: _' ( idx self -- a ) bi ptr | elemsz rot * + ;
- : _#bounds ( idx self -- ) cnt >= if abort" array bounds error" then ;
+ : _inbounds? ( idx self -- f ) cnt < ;
+ : _#bounds _inbounds? not if abort" array bounds error" then ;
: :' ( idx self -- a ) 2dup _#bounds _' ;
: _'end ( self -- a ) bi cnt | _' ;
: :@ ( idx self -- n ) :' @ ;
@@ -28,17 +29,19 @@ struct[ Array
2dup _?alloc dup _'end ( cnt self a )
rot> to+ cnt ( a ) ;
: :insert ( cnt idx self -- a ) >r \ V1=self
- dup V1 _#bounds ( cnt idx )
- V1 :' >r dup V1 elemsz * V2 + ( cnt dst ) \ V2=src
- V1 _'end V2 - ( cnt dst u )
- V2 rot> move- ( cnt )
- V1 to+ cnt r> rdrop ( a ) ;
+ dup V1 _inbounds? if ( cnt idx )
+ V1 :' >r dup V1 elemsz * V2 + ( cnt dst ) \ V2=src
+ V1 _'end V2 - ( cnt dst u )
+ V2 rot> move- ( cnt )
+ V1 to+ cnt r> rdrop ( a )
+ else drop r> :append then ;
: :delete ( cnt idx self -- ) >r \ V1=self
- dup V1 _#bounds
- 2dup + V1 cnt < if ( cnt idx )
- V1 :' dup >r over V1 elemsz * + ( cnt src ) \ V2=dst
- V1 _'end over - ( cnt src u )
- r> swap move ( cnt )
- neg r> to+ cnt
- else nip r> to cnt then ( ) ;
+ dup V1 _inbounds? if
+ 2dup + V1 cnt < if ( cnt idx )
+ V1 :' dup >r over V1 elemsz * + ( cnt src ) \ V2=dst
+ V1 _'end over - ( cnt src u )
+ r> swap move ( cnt )
+ neg r> to+ cnt
+ else nip r> to cnt then
+ else 2drop rdrop then ( ) ;
]struct
diff --git a/fs/tests/text/ed.fs b/fs/tests/text/ed.fs
@@ -16,6 +16,8 @@ S" with some text\n ^\n1 / 17" #s=
S" be\n ^\n8 / 17" #s=
5 capture l-
S" (oh well maybe grow)\n ^\n3 / 17" #s=
+capture f maybe
+S" (oh well maybe grow)\n ^\n3 / 17" #s=
capture eol
S" (oh well maybe grow)\n ^\n3 / 17" #s=
capture bol
diff --git a/fs/text/ed.fs b/fs/text/ed.fs
@@ -1,7 +1,7 @@
?f<< /lib/arena.fs
+?f<< /lib/array.fs
?f<< /lib/fmt.fs
?f<< /lib/str.fs
-?f<< /lib/ll.fs
: nspcs ( n -- ) for spc> next ;
@@ -12,67 +12,55 @@ struct[ Mark
here Mark SZ allot0 structbind Mark mark
struct[ Line
- sfield _next
sfield cnt
sfield ptr
-
- : :range ( line -- a u ) dup ptr swap cnt ;
-
- : :itern ( n line -- iter-n line )
- llitern ?dup if llidx swap else llidx 1- llprev then ;
+ : :range ( line -- a u ) bi ptr | cnt ;
+ : :print ( line -- ) :range rtype nl> ;
]struct
extends IO struct[ Edbuf
sfield buf
sfield lines
- sfield sel
sfield lpos
sfield cpos
- : _updatelpos ( self -- )
- 0 over to lpos dup lines begin ( self line )
- over sel over <> while ( self line )
- over 1 swap to+ lpos llnext repeat ( self line ) 2drop ;
+ : :line lines Array :' ;
+ : :linecnt lines Array cnt ;
+ : :sel bi lpos | lines Array :' ;
create _findstr STR_MAXSZ allot0
: :findnext ( self -- ) >r \ V1=self
- _findstr V1 cpos 1+ V1 sel Line :range rtrimleft [str]? ( idx )
- dup 0< if drop V1 sel llnext begin ( line ) \ search following lines
- ?dup while ( line )
- _findstr over Line :range [str]? dup 0< while ( line -1 )
- drop llnext repeat ( line idx )
- V1 to cpos V1 to sel V1 _updatelpos then rdrop ( )
+ _findstr V1 cpos 1+ V1 :sel Line :range rtrimleft [str]? ( idx )
+ dup 0< if drop V1 lpos 1+ V1 :linecnt for2 ( ) \ search following lines
+ _findstr i V1 :line Line :range [str]? dup 0>= if ( idx )
+ V1 to cpos i V1 to lpos break then ( -1 ) drop next then ( ) rdrop
else ( idx ) 1+ r> to+ cpos then ;
: :find ( str self -- ) swap _findstr strmove :findnext ;
- : _newline ( self -- line )
- Line SZ swap buf Arena :allot dup Line SZ 0 fill ;
-
- : _sel$ ( self -- ) 0 over to lpos dup lines swap to sel ;
+ : _sel$ ( self -- ) 0 swap to lpos ;
: _sel$$ ( self -- ) 0 over to cpos _sel$ ;
- : _cbounds ( self -- ) dup cpos over sel Line cnt min swap to cpos ;
- : _sel! ( line self -- ) tuck to sel _cbounds ;
- : :godown ( n self -- )
- over not if 2drop exit then ( n self )
- tuck sel Line :itern ( self n line )
- rot tuck _sel! to+ lpos ;
-
- : _eol? ( self -- f ) dup cpos swap sel Line cnt = ;
- : _eof? ( self -- f ) dup sel llnext not swap _eol? and ;
+ : _cbounds ( self -- ) bi+ cpos | :sel Line cnt min swap to cpos ;
+ : _lbounds ( idx self -- idx ) :linecnt 1- min ;
+ : :go ( idx self -- ) tuck _lbounds over to lpos _cbounds ;
+ : :godown ( n self -- ) tuck lpos + swap :go ;
+ : _eol? ( self -- f ) bi cpos | :sel Line cnt = ;
+ : :lastline? bi lpos | :linecnt 1- = ;
+ : _eof? ( self -- f ) bi :lastline? | _eol? and ;
create _lf LF c,
: _readbuf ( n self -- a? read-n ) >r ( n ) \ V1=self
r@ _eof? if rdrop drop 0 exit then
- r@ _eol? if
- drop 1 r@ :godown 0 r> to cpos _lf 1 exit then
- r@ sel Line cnt r@ cpos - ( n1 n2 )
- r@ sel Line ptr r@ cpos + ( n1 n2 a )
+ r@ _eol? if drop 1 r@ :godown 0 r> to cpos _lf 1 exit then
+ r@ :sel Line cnt r@ cpos - ( n1 n2 )
+ r@ :sel Line ptr r@ cpos + ( n1 n2 a )
rot> min dup r> to+ cpos ;
- : :appendline ( self -- )
- dup _newline over sel llinsert 1 swap :godown ;
+ : _newline ( idx self -- )
+ 2dup 1 rot> lines Array :insert ( a ) Line SZ 0 fill ( idx self ) :go ;
+ : :appendline ( self -- ) bi lpos 1+ | _newline ;
+ : :insertline ( self -- ) bi lpos | _newline ;
- : _writeline ( a u self -- ) dup >r sel >r dup >r \ V1=self V2=sel V3=u
+ : _writeline ( a u self -- ) dup >r :sel >r dup >r \ V1=self V2=sel V3=u
V2 Line cnt over + V1 buf Arena :ensure ( a u new-a )
V1 cpos if
V2 Line ptr V1 cpos V1 buf Arena :move drop then ( a u new-a )
@@ -89,53 +77,37 @@ extends IO struct[ Edbuf
nip tuck r@ _writeline 1+ ( written-n )
r> :appendline then ;
- : :empty ( self -- )
- dup buf Arena :reset
- dup _newline over to lines _sel$$ ;
+ : _ensureline ( self -- )
+ dup :linecnt not if
+ 1 over lines Array :append ( self a )
+ Line SZ 0 fill ( self ) _sel$$
+ else drop then ;
+
+ : :dellines ( n self -- ) tuck bi lpos | lines Array :delete _ensureline ;
+ : :empty ( self -- ) 0 over lines to Array cnt _ensureline ;
: :new ( -- edbuf )
- Arena :new here ( arena edbuf )
+ Arena :new Line SZ $200 Array :new here ( arena lines edbuf ) >r
0 ( putback ) , ['] _readbuf , ['] _writebuf , ['] drop , ['] :empty ,
- swap ( arena ) , 0 ( lines ) , 0 ( sel ) , 0 ( lpos ) , 0 ( cpos ) ,
- dup :empty ;
-
- : :linecnt ( self -- cnt ) lines llcnt ;
+ swap ( arena ) , ( lines ) , 0 ( lpos ) , 0 ( cpos ) ,
+ r> dup :empty ;
: :goleft ( n self -- ) dup cpos rot - max0 swap to cpos ;
: :goright ( n self -- ) dup cpos rot + over to cpos _cbounds ;
- : :go ( n self -- ) dup _sel$ :godown ;
- : :goup ( n self -- ) dup lpos rot - max0 swap :go ;
-
- : :insertline ( self -- )
- dup lpos if
- 1 over :goup :appendline
- else
- dup _newline over to' lines llinsert ( self )
- dup lines over _sel! _cbounds then ;
-
- : _print ( line -- )
- dup Line ptr swap Line cnt rtype nl> ;
+ : :goup ( n self -- ) swap neg swap :godown ;
: :print ( n self -- ) >r \ V1=self
- V1 sel swap for ( line )
- dup _print llnext dup not if 1 to i then next drop rdrop ;
+ V1 lpos V1 :linecnt for2 i V1 :line Line :print next rdrop ;
: :cprint ( self -- )
- dup sel _print cpos nspcs '^' emit nl> ;
+ dup :sel Line :print cpos nspcs '^' emit nl> ;
- : :delchars ( n self -- ) dup >r sel >r \ V1=self V2=sel
+ : :delchars ( n self -- ) dup >r :sel >r \ V1=self V2=sel
V2 Line cnt V1 cpos - min ( bounded-n ) ?dup if
V2 Line ptr V1 cpos + 2dup + ( n dst src )
swap V2 Line cnt V1 cpos - move ( n )
neg V2 to+ Line cnt then rdrop rdrop ;
- : :dellines ( n self -- )
- 2dup :linecnt 1- min not if 2drop exit then >r \ V1=self
- V1 sel V1 to' lines llfind drop llprev swap ( delpoint n )
- V1 sel llitern ( delpoint tgt )
- tuck swap ( tgt tgt prev ) ! ( tgt )
- ?dup not if V1 lines llend then r> _sel! ;
-
: :mark! ( self -- ) dup lpos to mark lpos cpos to mark cpos ;
]struct
diff --git a/fs/text/ged.fs b/fs/text/ged.fs
@@ -24,13 +24,13 @@ grid COLS grid LINES * 1- const _maxpos
edbuf lpos grid COLS * edbuf cpos + _scrpos
?swap for2 1 i grid :highlight next ;
-: _spitpage ( fromline -- )
- 0 swap _height for ( lineno line )
- dup if over grid COLS * over _spitline else over grid :clrline then
- dup if llnext then swap 1+ swap next 2drop ;
+: _spitpage ( fromidx -- )
+ 0 _height for2 ( fromidx )
+ dup i + dup edbuf :linecnt < if ( fromidx idx )
+ i grid COLS * swap edbuf :line _spitline else i grid :clrline then
+ next drop ;
-: _top! ( lineno -- )
- dup to _top edbuf lines Line :itern nip _spitpage ;
+: _top! ( lineno -- ) dup to _top _spitpage ;
: _reframe ( -- )
_top edbuf lpos tuck > if _top! else ( lpos )
