diff --git a/extra/gap-buffer/cursortree/cursortree-tests.factor b/extra/gap-buffer/cursortree/cursortree-tests.factor index 36b5efd7fa..2b3ff69c97 100644 --- a/extra/gap-buffer/cursortree/cursortree-tests.factor +++ b/extra/gap-buffer/cursortree/cursortree-tests.factor @@ -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" 0 at-beginning? ] unit-test [ t ] [ "this is a test string" dup length 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" 3 element< ] unit-test [ CHAR: s ] [ "this is a test string" 3 element> ] unit-test [ t ] [ "this is a test string" 3 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" 3 8 over set-cursor-pos dup 1array swap cursor-tree cursortree-cursors tree-values sequence= ] unit-test +[ 0 ] [ "this is a test string" dup dup 3 remove-cursor cursors length ] unit-test +[ t ] [ "this is a test string" 3 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" 8 "no longer " over insert cursor-tree >string ] unit-test [ "refactor" ] [ "factor" 0 CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test [ "refactor" ] [ "factor" 0 CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test diff --git a/extra/gap-buffer/cursortree/cursortree.factor b/extra/gap-buffer/cursortree/cursortree.factor index e056cc8dee..fb2abf1c3d 100644 --- a/extra/gap-buffer/cursortree/cursortree.factor +++ b/extra/gap-buffer/cursortree/cursortree.factor @@ -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 : ( 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 ; diff --git a/extra/gap-buffer/gap-buffer.factor b/extra/gap-buffer/gap-buffer.factor index 99051ea678..3d78204d3f 100644 --- a/extra/gap-buffer/gap-buffer.factor +++ b/extra/gap-buffer/gap-buffer.factor @@ -44,15 +44,36 @@ M: gb like ( seq gb -- seq ) drop ; 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>index ( pos gb -- i ) - 2dup gb-gap-start >= [ - gap-length + - ] [ drop ] if ; + 2dup valid-position? [ + 2dup gb-gap-start >= [ + gap-length + + ] [ drop ] if + ] [ + throw + ] if ; + +TUPLE: index-out-of-bounds index gap-buffer ; +C: 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 + ] [ + 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 ;