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

fixed gap-buffer and cursortree

db4
Alex Chapman 2008-03-12 13:35:48 +11:00
parent e95097dbdf
commit 2f505f85d1
3 changed files with 44 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
extra/gap-buffer/cursortree/cursortree-tests.factor
View File

@ -1,4 +1,6 @@
USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ;
USING: assocs kernel gap-buffer.cursortree tools.test sequences trees
arrays strings ;
IN: gap-buffer.cursortree.tests
[ t ] [ "this is a test string" <cursortree> 0 <left-cursor> at-beginning? ] unit-test
[ t ] [ "this is a test string" <cursortree> dup length <left-cursor> at-end? ] unit-test
@ -6,7 +8,8 @@ USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ;
[ CHAR: i ] [ "this is a test string" <cursortree> 3 <left-cursor> element< ] unit-test
[ CHAR: s ] [ "this is a test string" <cursortree> 3 <left-cursor> element> ] unit-test
[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> CHAR: a over set-element< CHAR: t over set-element> cursor-tree "that is a test string" sequence= ] unit-test
[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> 8 over set-cursor-pos dup 1array swap cursor-tree cursortree-cursors tree-values sequence= ] unit-test
[ 0 ] [ "this is a test string" <cursortree> dup dup 3 <left-cursor> remove-cursor cursors length ] unit-test
[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> 8 over set-cursor-pos dup 1array swap cursor-tree cursors sequence= ] unit-test
[ "this is no longer a test string" ] [ "this is a test string" <cursortree> 8 <left-cursor> "no longer " over insert cursor-tree >string ] unit-test
[ "refactor" ] [ "factor" <cursortree> 0 <left-cursor> CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test
[ "refactor" ] [ "factor" <cursortree> 0 <right-cursor> CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test

19
extra/gap-buffer/cursortree/cursortree.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007 Alex Chapman All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel gap-buffer generic trees trees.avl math sequences quotations ;
USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math
sequences quotations ;
IN: gap-buffer.cursortree
TUPLE: cursortree cursors ;
@ -18,13 +19,12 @@ TUPLE: cursor i tree ;
TUPLE: left-cursor ;
TUPLE: right-cursor ;
: cursor-index ( cursor -- i ) cursor-i ; inline
: cursor-index ( cursor -- i ) cursor-i ;
: add-cursor ( cursortree cursor -- ) dup cursor-index rot avl-insert ;
: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ;
: remove-cursor ( cursortree cursor -- )
cursor-index swap delete-at ;
! dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ;
tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;
: set-cursor-index ( index cursor -- )
dup cursor-tree over remove-cursor tuck set-cursor-i
@ -49,14 +49,17 @@ M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] ke
: <right-cursor> ( cursortree pos -- right-cursor )
right-cursor construct-empty make-cursor ;
: cursors ( cursortree -- seq )
cursortree-cursors values concat ;
: cursor-positions ( cursortree -- seq )
cursortree-cursors tree-values [ cursor-pos ] map ;
cursors [ cursor-pos ] map ;
M: cursortree move-gap ( n cursortree -- )
#! Get the position of each cursor before the move, then re-set the
#! position afterwards. This will update any changed cursor indices.
dup cursor-positions >r tuck cursortree-gb move-gap
cursortree-cursors tree-values r> swap [ set-cursor-pos ] 2each ;
cursors r> swap [ set-cursor-pos ] 2each ;
: element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ;
: element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ;
@ -81,7 +84,7 @@ M: right-cursor fix-cursor ( cursortree cursor -- )
>r gb-gap-end r> set-cursor-index ;
: fix-cursors ( old-gap-end cursortree -- )
tuck cursortree-cursors tree-get-all [ fix-cursor ] curry* each ;
tuck cursortree-cursors at [ fix-cursor ] with each ;
M: cursortree delete* ( pos cursortree -- )
tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ;

34
extra/gap-buffer/gap-buffer.factor
View File

@ -44,15 +44,36 @@ M: gb like ( seq gb -- seq ) drop <gb> ;
M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
: valid-position? ( pos gb -- ? )
#! one element past the end of the buffer is a valid position when we're inserting
length -1 swap between? ;
: valid-index? ( i gb -- ? )
buffer-length -1 swap between? ;
TUPLE: position-out-of-bounds position gap-buffer ;
C: <position-out-of-bounds> position-out-of-bounds
: position>index ( pos gb -- i )
2dup gb-gap-start >= [
gap-length +
] [ drop ] if ;
2dup valid-position? [
2dup gb-gap-start >= [
gap-length +
] [ drop ] if
] [
<position-out-of-bounds> throw
] if ;
TUPLE: index-out-of-bounds index gap-buffer ;
C: <index-out-of-bounds> index-out-of-bounds
: index>position ( i gb -- pos )
2dup gb-gap-end >= [
gap-length -
] [ drop ] if ;
2dup valid-index? [
2dup gb-gap-end >= [
gap-length -
] [ drop ] if
] [
<index-out-of-bounds> throw
] if ;
M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ;
@ -159,6 +180,7 @@ INSTANCE: gb virtual-sequence
: fix-gap ( n gb -- )
2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
! moving the gap to position 5 means that the element in position 5 will be immediately after the gap
GENERIC: move-gap ( n gb -- )
M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;