+++ /dev/null
-Alex Chapman
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ;
-
-[ 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
-[ 3 ] [ "this is a test string" <cursortree> 3 <left-cursor> cursor-pos ] unit-test
-[ 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
-[ "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
-[ "this a test string" 5 ] [ "this is a test string" <cursortree> 5 <right-cursor> dup delete> dup delete> dup delete> dup cursor-tree >string swap cursor-pos ] unit-test
-[ "this a test string" 5 ] [ "this is a test string" <cursortree> 8 <right-cursor> dup delete< dup delete< dup delete< dup cursor-tree >string swap cursor-pos ] unit-test
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel gap-buffer generic trees trees.avl-tree math sequences quotations ;
-IN: gap-buffer.cursortree
-
-TUPLE: cursortree cursors ;
-
-: <cursortree> ( seq -- cursortree )
- <gb> cursortree construct-empty tuck set-delegate <avl-tree>
- over set-cursortree-cursors ;
-
-GENERIC: cursortree-gb ( cursortree -- gb )
-M: cursortree cursortree-gb ( cursortree -- gb ) delegate ;
-GENERIC: set-cursortree-gb ( gb cursortree -- )
-M: cursortree set-cursortree-gb ( gb cursortree -- ) set-delegate ;
-
-TUPLE: cursor i tree ;
-TUPLE: left-cursor ;
-TUPLE: right-cursor ;
-
-: cursor-index ( cursor -- i ) cursor-i ; inline
-
-: add-cursor ( cursortree cursor -- ) dup cursor-index rot tree-insert ;
-
-: remove-cursor ( cursortree cursor -- )
- dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ;
-
-: set-cursor-index ( index cursor -- )
- dup cursor-tree over remove-cursor tuck set-cursor-i
- dup cursor-tree cursortree-cursors swap add-cursor ;
-
-GENERIC: cursor-pos ( cursor -- n )
-GENERIC: set-cursor-pos ( n cursor -- )
-M: left-cursor cursor-pos ( cursor -- n ) [ cursor-i 1+ ] keep cursor-tree index>position ;
-M: right-cursor cursor-pos ( cursor -- n ) [ cursor-i ] keep cursor-tree index>position ;
-M: left-cursor set-cursor-pos ( n cursor -- ) >r 1- r> [ cursor-tree position>index ] keep set-cursor-index ;
-M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
-
-: <cursor> ( cursortree -- cursor )
- cursor construct-empty tuck set-cursor-tree ;
-
-: make-cursor ( cursortree pos cursor -- cursor )
- >r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
-
-: <left-cursor> ( cursortree pos -- left-cursor )
- left-cursor construct-empty make-cursor ;
-
-: <right-cursor> ( cursortree pos -- right-cursor )
- right-cursor construct-empty make-cursor ;
-
-: cursor-positions ( cursortree -- seq )
- cursortree-cursors tree-values [ 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 ;
-
-: element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ;
-: element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ;
-
-: at-beginning? ( cursor -- ? ) cursor-pos 0 = ;
-: at-end? ( cursor -- ? ) element@> length = ;
-
-: insert ( obj cursor -- ) element@> insert* ;
-
-: element< ( cursor -- elem ) element@< nth ;
-: element> ( cursor -- elem ) element@> nth ;
-
-: set-element< ( elem cursor -- ) element@< set-nth ;
-: set-element> ( elem cursor -- ) element@> set-nth ;
-
-GENERIC: fix-cursor ( cursortree cursor -- )
-
-M: left-cursor fix-cursor ( cursortree cursor -- )
- >r gb-gap-start 1- r> set-cursor-index ;
-
-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 ;
-
-M: cursortree delete* ( pos cursortree -- )
- tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ;
-
-: delete< ( cursor -- ) element@< delete* ;
-: delete> ( cursor -- ) element@> delete* ;
-
+++ /dev/null
-Collection of 'cursors' representing locations in a gap buffer
+++ /dev/null
-USING: kernel sequences tools.test gap-buffer strings math ;
-
-! test copy-elements
-[ { 0 3 4 3 4 5 } ] [ { 0 1 2 3 4 5 } dup >r -2 3 5 r> copy-elements ] unit-test
-[ { 0 1 2 1 2 5 } ] [ { 0 1 2 3 4 5 } dup >r 2 2 0 r> copy-elements ] unit-test
-[ "01234567856" ] [ "01234567890" dup >r 4 6 4 r> copy-elements ] unit-test
-
-! test sequence protocol (like, length, nth, set-nth)
-[ "gap buffers are cool" ] [ "gap buffers are cool" <gb> "" like ] unit-test
-
-! test move-gap-back-inside
-[ t f ] [ 5 "0123456" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
-[ "0123456" ] [ "0123456" <gb> 5 over move-gap >string ] unit-test
-! test move-gap-forward-inside
-[ t ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test
-[ "I once ate a spaniel" ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 over move-gap >string ] unit-test
-! test move-gap-back-around
-[ f f ] [ 2 "terriers are ok too" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
-[ "terriers are ok too" ] [ "terriers are ok too" <gb> 2 over move-gap >string ] unit-test
-! test move-gap-forward-around
-[ f t ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over position>index swap move-gap-forward? >r move-gap-forward-inside? 2nip r> ] unit-test
-[ "god is nam's best friend" ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over move-gap >string ] unit-test
-
-! test changing buffer contents
-[ "factory" ] [ "factor" <gb> CHAR: y 6 pick insert* >string ] unit-test
-! test inserting multiple elements in different places. buffer should grow
-[ "refractory" ] [ "factor" <gb> CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test
-! test deleting elements. buffer should shrink
-[ "for" ] [ "factor" <gb> 3 [ 1 over delete* ] times >string ] unit-test
-! more testing of nth and set-nth
-[ "raptor" ] [ "factor" <gb> CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test
-
-! test stack/queue operations
-[ "slaughter" ] [ "laughter" <gb> CHAR: s over push-start >string ] unit-test
-[ "pantonio" ] [ "pant" <gb> "onio" over push-end >string ] unit-test
-[ CHAR: f "actor" ] [ "factor" <gb> dup pop-start swap >string ] unit-test
-[ CHAR: s "pant" ] [ "pants" <gb> dup pop-end swap >string ] unit-test
-[ "end this is the " ] [ "this is the end " <gb> 4 over rotate >string ] unit-test
-[ "your jedi training is finished " ] [ "finished your jedi training is " <gb> -9 over rotate >string ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
-! for a good introduction see:
-! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
-USING: kernel arrays sequences sequences.private circular math generic ;
-IN: gap-buffer
-
-! gap-start -- the first element of the gap
-! gap-end -- the first element after the gap
-! expand-factor -- should be > 1
-! min-size -- < 5 is not sensible
-
-TUPLE: gb
- gap-start
- gap-end
- expand-factor
- min-size ;
-
-GENERIC: gb-seq ( gb -- seq )
-GENERIC: set-gb-seq ( seq gb -- )
-M: gb gb-seq ( gb -- seq ) delegate ;
-M: gb set-gb-seq ( seq gb -- ) set-delegate ;
-
-: required-space ( n gb -- n )
- tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
-
-: <gb> ( seq -- gb )
- gb construct-empty
- 5 over set-gb-min-size
- 1.5 over set-gb-expand-factor
- [ >r length r> set-gb-gap-start ] 2keep
- [ swap length over required-space swap set-gb-gap-end ] 2keep
- [
- over length over required-space rot { } like resize-array <circular> swap set-gb-seq
- ] keep ;
-
-M: gb like ( seq gb -- seq ) drop <gb> ;
-
-: gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ;
-
-: buffer-length ( gb -- n ) gb-seq length ;
-
-M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
-
-: position>index ( pos gb -- i )
- 2dup gb-gap-start >= [
- gap-length +
- ] [ drop ] if ;
-
-: index>position ( i gb -- pos )
- 2dup gb-gap-end >= [
- gap-length -
- ] [ drop ] if ;
-
-M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ;
-
-M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ;
-
-M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ;
-
-M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ;
-
-M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ;
-
-M: gb virtual-seq gb-seq ;
-
-INSTANCE: gb virtual-sequence
-
-! ------------- moving the gap -------------------------------
-
-: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
-
-: copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ;
-
-: copy-elements-back ( dst start seq n -- )
- dup 0 > [
- >r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back
- ] [ 3drop drop ] if ;
-
-: copy-elements-forward ( dst start seq n -- )
- dup 0 > [
- >r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward
- ] [ 3drop drop ] if ;
-
-: copy-elements ( dst start end seq -- )
- pick pick > [
- >r dupd - r> swap copy-elements-forward
- ] [
- >r over - r> swap copy-elements-back
- ] if ;
-
-! the gap can be moved either forward or back. Moving the gap 'inside' means
-! moving elements across the gap. Moving the gap 'around' means changing the
-! start of the circular buffer to avoid moving as many elements.
-
-! We decide which method (inside or around) to pick based on the number of
-! elements that will need to be moved. We always try to move as few elements as
-! possible.
-
-: move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ;
-
-: move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ;
-
-: move-gap-back-inside? ( i gb -- i gb ? )
- #! is it cheaper to move the gap inside than around?
- 2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ;
-
-: move-gap-forward-inside? ( i gb -- i gb ? )
- #! is it cheaper to move the gap inside than around?
- 2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ;
-
-: move-gap-forward-inside ( i gb -- )
- [ dup gap-length neg swap gb-gap-end rot ] keep gb-seq copy-elements ;
-
-: move-gap-back-inside ( i gb -- )
- [ dup gap-length swap gb-gap-start 1- rot 1- ] keep gb-seq copy-elements ;
-
-: move-gap-forward-around ( i gb -- )
- 0 over move-gap-back-inside [
- dup buffer-length [
- swap gap-length - neg swap
- ] keep
- ] keep [
- gb-seq copy-elements
- ] keep dup gap-length swap gb-seq change-circular-start ;
-
-: move-gap-back-around ( i gb -- )
- dup buffer-length over move-gap-forward-inside [
- length swap -1
- ] keep [
- gb-seq copy-elements
- ] keep dup length swap gb-seq change-circular-start ;
-
-: move-gap-forward ( i gb -- )
- move-gap-forward-inside? [
- move-gap-forward-inside
- ] [
- move-gap-forward-around
- ] if ;
-
-: move-gap-back ( i gb -- )
- move-gap-back-inside? [
- move-gap-back-inside
- ] [
- move-gap-back-around
- ] if ;
-
-: (move-gap) ( i gb -- )
- move-gap? [
- move-gap-forward? [
- move-gap-forward
- ] [
- move-gap-back
- ] if
- ] [ 2drop ] if ;
-
-: fix-gap ( n gb -- )
- 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
-
-GENERIC: move-gap ( n gb -- )
-
-M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
-
-! ------------ resizing -------------------------------------
-
-: enough-room? ( n gb -- ? )
- #! is there enough room to add 'n' elements to gb?
- tuck length + swap buffer-length <= ;
-
-: set-new-gap-end ( array gb -- )
- [ buffer-length swap length swap - ] keep
- [ gb-gap-end + ] keep set-gb-gap-end ;
-
-: after-gap ( gb -- gb )
- dup gb-seq swap gb-gap-end tail ;
-
-: before-gap ( gb -- gb )
- dup gb-gap-start head ;
-
-: copy-after-gap ( array gb -- )
- #! copy everything after the gap in 'gb' into the end of 'array',
- #! and change 'gb's gap-end to reflect the gap-end in 'array'
- dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> -rot copy ;
-
-: copy-before-gap ( array gb -- )
- #! copy everything before the gap in 'gb' into the start of 'array'
- before-gap 0 rot copy ; ! gap start doesn't change
-
-: resize-buffer ( gb new-size -- )
- f <array> swap 2dup copy-before-gap 2dup copy-after-gap
- >r <circular> r> set-gb-seq ;
-
-: decrease-buffer-size ( gb -- )
- #! the gap is too big, so resize to something sensible
- dup length over required-space resize-buffer ;
-
-: increase-buffer-size ( n gb -- )
- #! increase the buffer to fit at least 'n' more elements
- tuck length + over required-space resize-buffer ;
-
-: gb-too-big? ( gb -- ? )
- dup buffer-length over gb-min-size > [
- dup length over buffer-length rot gb-expand-factor sq / <
- ] [ drop f ] if ;
-
-: ?decrease ( gb -- )
- dup gb-too-big? [
- decrease-buffer-size
- ] [ drop ] if ;
-
-: ensure-room ( n gb -- )
- #! ensure that ther will be enough room for 'n' more elements
- 2dup enough-room? [ 2drop ] [
- increase-buffer-size
- ] if ;
-
-! ------- editing operations ---------------
-
-GENERIC# insert* 2 ( seq position gb -- )
-
-: prepare-insert ( seq position gb -- seq gb )
- tuck move-gap over length over ensure-room ;
-
-: insert-elements ( seq gb -- )
- dup gb-gap-start swap gb-seq copy ;
-
-: increment-gap-start ( gb n -- )
- over gb-gap-start + swap set-gb-gap-start ;
-
-! generic dispatch identifies numbers as sequences before numbers...
-! M: number insert* ( elem position gb -- ) >r >r 1array r> r> insert* ;
-: number-insert ( num position gb -- ) >r >r 1array r> r> insert* ;
-
-M: sequence insert* ( seq position gb -- )
- pick number? [
- number-insert
- ] [
- prepare-insert [ insert-elements ] 2keep swap length increment-gap-start
- ] if ;
-
-: (delete*) ( gb -- )
- dup gb-gap-end 1+ over set-gb-gap-end ?decrease ;
-
-GENERIC: delete* ( pos gb -- )
-
-M: gb delete* ( position gb -- )
- tuck move-gap (delete*) ;
-
-! -------- stack/queue operations -----------
-
-: push-start ( obj gb -- ) 0 swap insert* ;
-
-: push-end ( obj gb -- ) [ length ] keep insert* ;
-
-: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
-
-: pop-start ( gb -- elem ) 0 swap pop-elem ;
-
-: pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ;
-
-: rotate ( n gb -- )
- dup length 1 > [
- swap dup 0 > [
- [ dup [ pop-end ] keep push-start ]
- ] [
- neg [ dup [ pop-start ] keep push-end ]
- ] if times drop
- ] [ 2drop ] if ;
-
+++ /dev/null
-Gap buffer data structure
+++ /dev/null
-collections sequences
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: kernel test trees math sequences ;
-IN: temporary
-
-[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } [ single-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } [ select-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 } [ single-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 } [ select-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
-[ "key1" -1 "key2" 0 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f f
- T{ avl-node T{ node f "key2" f
- T{ avl-node T{ node f "key3" } 1 } }
- -1 } }
- 2 } [ double-rotate ] go-left
- [ node-left dup node-key swap avl-node-balance ] keep
- [ node-right dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" 0 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f f
- T{ avl-node T{ node f "key2" f
- T{ avl-node T{ node f "key3" } 0 } }
- -1 } }
- 2 } [ double-rotate ] go-left
- [ node-left dup node-key swap avl-node-balance ] keep
- [ node-right dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" 1 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f f
- T{ avl-node T{ node f "key2" f
- T{ avl-node T{ node f "key3" } -1 } }
- -1 } }
- 2 } [ double-rotate ] go-left
- [ node-left dup node-key swap avl-node-balance ] keep
- [ node-right dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-
-[ "key1" 1 "key2" 0 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f
- T{ avl-node T{ node f "key2" f f
- T{ avl-node T{ node f "key3" } -1 } }
- 1 } }
- -2 } [ double-rotate ] go-right
- [ node-right dup node-key swap avl-node-balance ] keep
- [ node-left dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" 0 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f
- T{ avl-node T{ node f "key2" f f
- T{ avl-node T{ node f "key3" } 0 } }
- 1 } }
- -2 } [ double-rotate ] go-right
- [ node-right dup node-key swap avl-node-balance ] keep
- [ node-left dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" -1 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f
- T{ avl-node T{ node f "key2" f f
- T{ avl-node T{ node f "key3" } 1 } }
- 1 } }
- -2 } [ double-rotate ] go-right
- [ node-right dup node-key swap avl-node-balance ] keep
- [ node-left dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-
-! random testing uncovered this little bugger
-[ t t ] [ f "d" T{ avl-node
- T{ node f "e" f
- T{ avl-node
- T{ node f "b" f
- T{ avl-node T{ node f "a" } 0 }
- T{ avl-node T{ node f "c" f } 0 }
- 0 }
- 0 }
- T{ avl-node T{ node f "f" } 0 } }
- -1 } node-set dup valid-avl-node? nip swap valid-node? ] unit-test
-
-[ "eight" ] [ <avl-tree> "seven" 7 pick tree-insert "eight" 8 pick tree-insert "nine" 9 pick tree-insert tree-root node-value ] unit-test
-[ "another eight" ] [ <avl-tree> "seven" 7 pick tree-set "eight" 8 pick tree-set "another eight" 8 pick tree-set 8 swap tree-get ] unit-test
-! [ <avl-tree> "seven" 7 pick tree-insert
-[ t t ] [ <avl-tree> 3 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 9 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test ! fails when tree growth isn't terminated after a rebalance
-[ t t ] [ <avl-tree> 10 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-
-[ t t ] [ <avl-tree> 3 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 4 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 5 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 10 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-
-[ t t ] [ <avl-tree> 5 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 19 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 30 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 82 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 100 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-
-! borrowed from tests/bst.factor
-: test-tree ( -- tree )
- <avl-tree>
- "seven" 7 pick tree-insert
- "nine" 9 pick tree-insert
- "four" 4 pick tree-insert
- "another four" 4 pick tree-insert
- "replaced seven" 7 pick tree-set ;
-
-! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all
-[ "seven" ] [ <avl-tree> "seven" 7 pick tree-insert 7 swap tree-get ] unit-test
-[ "seven" t ] [ <avl-tree> "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test
-[ f f ] [ <avl-tree> "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test
-[ "seven" ] [ <avl-tree> "seven" 7 pick tree-set 7 swap tree-get ] unit-test
-[ "replacement" ] [ <avl-tree> "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 9 swap tree-get ] unit-test
-[ t ] [ test-tree 4 swap tree-get-all { "another four" "four" } sequence= ] unit-test
-[ t ] [ test-tree 11 swap tree-get-all empty? ] unit-test
-[ t ] [ test-tree 7 swap tree-get-all { "replaced seven" } sequence= ] unit-test
-
-! test tree-delete
-[ f ] [ test-tree 9 over tree-delete 9 swap tree-get ] unit-test
-[ "replaced seven" ] [ test-tree 9 over tree-delete 7 swap tree-get ] unit-test
-[ f ] [ test-tree 4 over tree-delete-all 4 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete 9 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete-all 9 swap tree-get ] unit-test
-
-: test-random-deletions ( tree -- ? )
- #! deletes one node at random from the tree, checking avl and tree
- #! properties after each deletion, until the tree is empty
- dup stump? [
- drop t
- ] [
- dup tree-keys random over tree-delete dup valid-avl-tree? over valid-tree? and [
- test-random-deletions
- ] [
- dup print-tree
- ] if
- ] if ;
-
-[ t ] [ <avl-tree> 5 random-tree test-random-deletions ] unit-test
-[ t ] [ <avl-tree> 30 random-tree test-random-deletions ] unit-test
-[ t ] [ <avl-tree> 100 random-tree test-random-deletions ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic math namespaces io sequences ;
-IN: trees
-
-TUPLE: avl-tree ;
-
-C: avl-tree ( -- tree )
- <tree> over set-delegate ;
-
-TUPLE: avl-node balance ;
-
-C: avl-node ( value key -- node )
- >r <node> r> tuck set-delegate
- 0 over set-avl-node-balance ;
-
-M: avl-tree create-node ( value key tree -- node ) drop <avl-node> ;
-
-GENERIC: valid-avl-node? ( obj -- height valid? )
-
-M: f valid-avl-node? ( f -- height valid? ) drop 0 t ;
-
-: check-balance ( node left-height right-height -- node height valid? )
- 2dup max 1+ >r swap - over avl-node-balance = r> swap ;
-
-M: avl-node valid-avl-node? ( node -- height valid? )
- #! check that this avl node has the right balance marked, and that it isn't unbalanced.
- dup node-left valid-avl-node? >r over node-right valid-avl-node? >r
- check-balance r> r> and and
- rot avl-node-balance abs 2 < and ;
-
-: valid-avl-tree? ( tree -- valid? ) tree-root valid-avl-node? nip ;
-
-: change-balance ( node amount -- )
- over avl-node-balance + swap set-avl-node-balance ;
-
-: rotate ( node -- node )
- dup node+link dup node-link pick set-node+link tuck set-node-link ;
-
-: single-rotate ( node -- node )
- 0 over set-avl-node-balance 0 over node+link set-avl-node-balance rotate ;
-
-: pick-balances ( a node -- balance balance )
- avl-node-balance {
- { [ dup zero? ] [ 2drop 0 0 ] }
- { [ over = ] [ neg 0 ] }
- { [ t ] [ 0 swap ] }
- } cond ;
-
-: double-rotate ( node -- node )
- [
- node+link [
- node-link current-side get neg over pick-balances rot 0 swap set-avl-node-balance
- ] keep set-avl-node-balance
- ] keep tuck set-avl-node-balance
- dup node+link [ rotate ] with-other-side over set-node+link rotate ;
-
-: select-rotate ( node -- node )
- dup node+link avl-node-balance current-side get = [ double-rotate ] [ single-rotate ] if ;
-
-: balance-insert ( node -- node taller? )
- dup avl-node-balance {
- { [ dup zero? ] [ drop f ] }
- { [ dup abs 2 = ] [ sgn neg [ select-rotate ] with-side f ] }
- { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller
- } cond ;
-
-DEFER: avl-insert
-
-: avl-set ( value key node -- node taller? )
- 2dup node-key key= [
- -rot pick set-node-key over set-node-value f
- ] [ avl-insert ] if ;
-
-: avl-insert-or-set ( value key node -- node taller? )
- "setting" get [ avl-set ] [ avl-insert ] if ;
-
-: (avl-insert) ( value key node -- node taller? )
- [ avl-insert-or-set ] [ <avl-node> t ] if* ;
-
-: avl-insert ( value key node -- node taller? )
- 2dup node-key key< left right ? [
- [ node-link (avl-insert) ] keep swap
- >r tuck set-node-link r> [ dup current-side get change-balance balance-insert ] [ f ] if
- ] with-side ;
-
-M: avl-node node-insert ( value key node -- node )
- [ f "setting" set avl-insert-or-set ] with-scope drop ;
-
-M: avl-node node-set ( value key node -- node )
- [ t "setting" set avl-insert-or-set ] with-scope drop ;
-
-: delete-select-rotate ( node -- node shorter? )
- dup node+link avl-node-balance zero? [
- current-side get neg over set-avl-node-balance
- current-side get over node+link set-avl-node-balance rotate f
- ] [
- select-rotate t
- ] if ;
-
-: rebalance-delete ( node -- node shorter? )
- dup avl-node-balance {
- { [ dup zero? ] [ drop t ] }
- { [ dup abs 2 = ] [ sgn neg [ delete-select-rotate ] with-side ] }
- { [ drop t ] [ f ] } ! balance is -1 or 1, tree is not shorter
- } cond ;
-
-: balance-delete ( node -- node shorter? )
- current-side get over avl-node-balance {
- { [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
- { [ dupd = ] [ drop 0 over set-avl-node-balance t ] }
- { [ t ] [ dupd neg change-balance rebalance-delete ] }
- } cond ;
-
-: avl-replace-with-extremity ( to-replace node -- node shorter? )
- dup node-link [
- swapd avl-replace-with-extremity >r over set-node-link r> [ balance-delete ] [ f ] if
- ] [
- tuck copy-node-contents node+link t
- ] if* ;
-
-: replace-with-a-child ( node -- node shorter? )
- #! assumes that node is not a leaf, otherwise will recurse forever
- dup node-link [
- dupd [ avl-replace-with-extremity ] with-other-side >r over set-node-link r> [
- balance-delete
- ] [
- f
- ] if
- ] [
- [ replace-with-a-child ] with-other-side
- ] if* ;
-
-: avl-delete-node ( node -- node shorter? )
- #! delete this node, returning its replacement, and whether this subtree is
- #! shorter as a result
- dup leaf? [
- drop f t
- ] [
- random-side [ replace-with-a-child ] with-side ! random not necessary, just for fun
- ] if ;
-
-GENERIC: avl-delete ( key node -- node shorter? deleted? )
-
-M: f avl-delete ( key f -- f f f ) nip f f ;
-
-: (avl-delete) ( key node -- node shorter? deleted? )
- tuck node-link avl-delete >r >r over set-node-link r> [ balance-delete r> ] [ f r> ] if ;
-
-M: avl-node avl-delete ( key node -- node shorter? deleted? )
- 2dup node-key key-side dup zero? [
- drop nip avl-delete-node t
- ] [
- [
- (avl-delete)
- ] with-side
- ] if ;
-
-M: avl-node node-delete ( key node -- node ) avl-delete 2drop ;
-
-M: avl-node node-delete-all ( key node -- node )
- #! deletes until there are no more. not optimal.
- dupd [ avl-delete nip ] with-scope [
- node-delete-all
- ] [
- nip
- ] if ;
-
-M: avl-node print-node ( depth node -- )
- over 1+ over node-right print-node
- over [ drop " " write ] each
- dup avl-node-balance number>string write " " write dup node-key number>string print
- >r 1+ r> node-left print-node ;
-
+++ /dev/null
-USING: trees test kernel sequences ;
-IN: temporary
-
-: test-tree ( -- tree )
- <bst>
- "seven" 7 pick tree-insert
- "nine" 9 pick tree-insert
- "four" 4 pick tree-insert
- "another four" 4 pick tree-insert
- "replaced seven" 7 pick tree-set ;
-
-! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all
-[ "seven" ] [ <bst> "seven" 7 pick tree-insert 7 swap tree-get ] unit-test
-[ "seven" t ] [ <bst> "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test
-[ f f ] [ <bst> "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test
-[ "seven" ] [ <bst> "seven" 7 pick tree-set 7 swap tree-get ] unit-test
-[ "replacement" ] [ <bst> "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test
-[ "four" ] [ test-tree 4 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 9 swap tree-get ] unit-test
-[ t ] [ test-tree 4 swap tree-get-all { "another four" "four" } sequence= ] unit-test
-[ t ] [ test-tree 11 swap tree-get-all empty? ] unit-test
-[ t ] [ test-tree 7 swap tree-get-all { "replaced seven" } sequence= ] unit-test
-
-! test tree-delete
-[ f ] [ test-tree 9 over tree-delete 9 swap tree-get ] unit-test
-[ "replaced seven" ] [ test-tree 9 over tree-delete 7 swap tree-get ] unit-test
-[ "four" ] [ test-tree 9 over tree-delete 4 swap tree-get ] unit-test
-! TODO: sometimes this shows up as "another four" because of randomisation
-! [ "nine" "four" ] [ test-tree 7 over tree-delete 9 over tree-get 4 rot tree-get ] unit-test
-! [ "another four" ] [ test-tree 4 over tree-delete 4 swap tree-get ] unit-test
-[ f ] [ test-tree 4 over tree-delete-all 4 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete 9 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete-all 9 swap tree-get ] unit-test
-
-! test valid-node?
-[ t ] [ T{ node f 0 } valid-node? ] unit-test
-[ t ] [ T{ node f 0 f T{ node f -1 } } valid-node? ] unit-test
-[ t ] [ T{ node f 0 f f T{ node f 1 } } valid-node? ] unit-test
-[ t ] [ T{ node f 0 f T{ node f -1 } T{ node f 1 } } valid-node? ] unit-test
-[ f ] [ T{ node f 0 f T{ node f 1 } } valid-node? ] unit-test
-[ f ] [ T{ node f 0 f f T{ node f -1 } } valid-node? ] unit-test
-
-! random testing
-[ t ] [ <bst> 10 random-tree valid-tree? ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic math ;
-IN: trees
-
-TUPLE: bst ;
-
-C: bst ( -- tree ) <tree> over set-delegate ;
-
-TUPLE: bst-node ;
-
-C: bst-node ( value key -- node ) >r <node> r> tuck set-delegate ;
-
-M: bst create-node ( value key tree -- node ) drop <bst-node> ;
-
-M: bst-node node-insert ( value key node -- node )
- 2dup node-key key-side [
- [ node-link [ node-insert ] [ <bst-node> ] if* ] keep tuck set-node-link
- ] with-side ;
-
-M: bst-node node-set ( value key node -- node )
- 2dup node-key key-side dup 0 = [
- drop nip [ set-node-value ] keep
- ] [
- [ [ node-link [ node-set ] [ <bst-node> ] if* ] keep tuck set-node-link ] with-side
- ] if ;
-
-DEFER: delete-node
-
-: (prune-extremity) ( parent node -- new-extremity )
- dup node-link [
- rot drop (prune-extremity)
- ] [
- tuck delete-node swap set-node-link
- ] if* ;
-
-: prune-extremity ( node -- new-extremity )
- #! remove and return the leftmost or rightmost child of this node.
- #! assumes at least one child
- dup node-link (prune-extremity) ;
-
-: replace-with-child ( node -- node )
- dup dup node-link copy-node-contents dup node-link delete-node over set-node-link ;
-
-: replace-with-extremity ( node -- node )
- dup node-link dup node+link [
- ! predecessor/successor is not the immediate child
- [ prune-extremity ] with-other-side dupd copy-node-contents
- ] [
- ! node-link is the predecessor/successor
- drop replace-with-child
- ] if ;
-
-: delete-node-with-two-children ( node -- node )
- #! randomised to minimise tree unbalancing
- random-side [ replace-with-extremity ] with-side ;
-
-: delete-node ( node -- node )
- #! delete this node, returning its replacement
- dup node-left [
- dup node-right [
- delete-node-with-two-children
- ] [
- node-left ! left but no right
- ] if
- ] [
- dup node-right [
- node-right ! right but not left
- ] [
- drop f ! no children
- ] if
- ] if ;
-
-M: bst-node node-delete ( key node -- node )
- 2dup node-key key-side dup zero? [
- drop nip delete-node
- ] [
- [ tuck node-link node-delete over set-node-link ] with-side
- ] if ;
-
-M: bst-node node-delete-all ( key node -- node )
- 2dup node-key key-side dup zero? [
- drop delete-node node-delete-all
- ] [
- [ tuck node-link node-delete-all over set-node-link ] with-side
- ] if ;
-
+++ /dev/null
-Binary search and avl (balanced) trees
+++ /dev/null
-collections trees
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic math sequences arrays io namespaces kernel-internals ;
-IN: trees
-
-TUPLE: tree root ;
-
-C: tree ( -- tree ) ;
-
-TUPLE: node key value left right ;
-
-C: node ( value key -- node )
- [ set-node-key ] keep
- [ set-node-value ] keep
- f over 2dup set-node-left set-node-right ;
-
-SYMBOL: current-side
-
-: left -1 ; inline
-: right 1 ; inline
-
-: go-left? ( -- ? ) current-side get left = ;
-
-: node-link@ ( -- ? quot quot ) go-left? [ node-left ] [ node-right ] ; inline
-: set-node-link@ ( -- ? quot quot ) go-left? [ set-node-left ] [ set-node-right ] ; inline
-
-: node-link ( node -- child ) node-link@ if ;
-: set-node-link ( child node -- ) set-node-link@ if ;
-: node+link ( node -- child ) node-link@ swap if ;
-: set-node+link ( child node -- ) set-node-link@ swap if ;
-
-: with-side ( side quot -- ) H{ } clone >n swap current-side set call ndrop ; inline
-: with-other-side ( quot -- ) current-side get neg swap with-side ; inline
-: go-left ( quot -- ) left swap with-side ; inline
-: go-right ( quot -- ) right swap with-side ; inline
-
-GENERIC: create-node ( value key tree -- node )
-
-GENERIC: copy-node-contents ( new old -- )
-
-M: node copy-node-contents ( new old -- )
- #! copy old's key and value into new (keeping children and parent)
- dup node-key pick set-node-key node-value swap set-node-value ;
-
-M: tree create-node ( value key tree -- node ) drop <node> ;
-
-: key-side ( k1 k2 -- side )
- #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
- <=> sgn ;
-
-: key< ( k1 k2 -- ? ) <=> 0 < ;
-: key> ( k1 k2 -- ? ) <=> 0 > ;
-: key= ( k1 k2 -- ? ) <=> zero? ;
-
-: random-side ( -- side ) left right 2array random ;
-
-: choose-branch ( key node -- key node-left/right )
- 2dup node-key key-side [ node-link ] with-side ;
-
-GENERIC: node-get ( key node -- value )
-
-: tree-get ( key tree -- value ) tree-root node-get ;
-
-M: node node-get ( key node -- value )
- 2dup node-key key= [
- nip node-value
- ] [
- choose-branch node-get
- ] if ;
-
-M: f node-get ( key f -- f ) nip ;
-
-GENERIC: node-get* ( key node -- value ? )
-
-: tree-get* ( key tree -- value ? ) tree-root node-get* ;
-
-M: node node-get* ( key node -- value ? )
- 2dup node-key key= [
- nip node-value t
- ] [
- choose-branch node-get*
- ] if ;
-
-M: f node-get* ( key f -- f f ) nip f ;
-
-GENERIC: node-get-all ( key node -- seq )
-
-: tree-get-all ( key tree -- seq ) tree-root node-get-all ;
-
-M: f node-get-all ( key f -- V{} ) 2drop V{ } clone ;
-
-M: node node-get-all ( key node -- seq )
- 2dup node-key key= [
- ! duplicate keys are stored to the right because of choose-branch
- 2dup node-right node-get-all >r nip node-value r> tuck push
- ] [
- choose-branch node-get-all
- ] if ;
-
-GENERIC: node-insert ( value key node -- node ) ! can add duplicates
-
-: tree-insert ( value key tree -- )
- [ dup tree-root [ nip node-insert ] [ create-node ] if* ] keep set-tree-root ;
-
-GENERIC: node-set ( value key node -- node )
- #! note that this only sets the first node with this key. if more than one
- #! has been inserted then the others won't be modified. (should they be deleted?)
-
-: tree-set ( value key tree -- )
- [ dup tree-root [ nip node-set ] [ create-node ] if* ] keep set-tree-root ;
-
-GENERIC: node-delete ( key node -- node )
-
-: tree-delete ( key tree -- )
- [ tree-root node-delete ] keep set-tree-root ;
-
-GENERIC: node-delete-all ( key node -- node )
-
-M: f node-delete-all ( key f -- f ) nip ;
-
-: tree-delete-all ( key tree -- )
- [ tree-root node-delete-all ] keep set-tree-root ;
-
-: node-map-link ( node quot -- node )
- over node-link swap call over set-node-link ;
-
-: node-map ( node quot -- node )
- over [
- tuck [ node-map-link ] go-left over call swap [ node-map-link ] go-right
- ] [
- drop
- ] if ;
-
-: tree-map ( tree quot -- )
- #! apply quot to each element of the tree, in order
- over tree-root swap node-map swap set-tree-root ;
-
-: node>node-seq ( node -- seq )
- dup [
- dup node-left node>node-seq over 1array rot node-right node>node-seq 3append
- ] when ;
-
-: tree>node-seq ( tree -- seq )
- tree-root node>node-seq ;
-
-: tree-keys ( tree -- keys )
- tree>node-seq [ node-key ] map ;
-
-: tree-values ( tree -- values )
- tree>node-seq [ node-value ] map ;
-
-: leaf? ( node -- ? )
- dup node-left swap node-right or not ;
-
-GENERIC: valid-node? ( node -- ? )
-
-M: f valid-node? ( f -- t ) not ;
-
-M: node valid-node? ( node -- ? )
- dup dup node-left [ node-key swap node-key key< ] when* >r
- dup dup node-right [ node-key swap node-key key> ] when* r> and swap
- dup node-left valid-node? swap node-right valid-node? and and ;
-
-: valid-tree? ( tree -- ? ) tree-root valid-node? ;
-
-DEFER: print-tree
-
-: random-tree ( tree size -- tree )
- [ most-positive-fixnum random pick tree-set ] each ;
-
-: increasing-tree ( tree size -- tree )
- [ dup pick tree-set ] each ;
-
-: decreasing-tree ( tree size -- tree )
- reverse increasing-tree ;
-
-GENERIC: print-node ( depth node -- )
-
-M: f print-node ( depth f -- ) 2drop ;
-
-M: node print-node ( depth node -- )
- ! not pretty, but ok for debugging
- over 1+ over node-right print-node
- over [ drop " " write ] each dup node-key number>string print
- >r 1+ r> node-left print-node ;
-
-: print-tree ( tree -- )
- tree-root 1 swap print-node ;
-
-: stump? ( tree -- ? )
- #! is this tree empty?
- tree-root not ;
-
--- /dev/null
+Alex Chapman
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ;
+
+[ 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
+[ 3 ] [ "this is a test string" <cursortree> 3 <left-cursor> cursor-pos ] unit-test
+[ 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
+[ "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
+[ "this a test string" 5 ] [ "this is a test string" <cursortree> 5 <right-cursor> dup delete> dup delete> dup delete> dup cursor-tree >string swap cursor-pos ] unit-test
+[ "this a test string" 5 ] [ "this is a test string" <cursortree> 8 <right-cursor> dup delete< dup delete< dup delete< dup cursor-tree >string swap cursor-pos ] unit-test
--- /dev/null
+! Copyright (C) 2007 Alex Chapman All Rights Reserved.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel gap-buffer generic trees trees.avl-tree math sequences quotations ;
+IN: gap-buffer.cursortree
+
+TUPLE: cursortree cursors ;
+
+: <cursortree> ( seq -- cursortree )
+ <gb> cursortree construct-empty tuck set-delegate <avl-tree>
+ over set-cursortree-cursors ;
+
+GENERIC: cursortree-gb ( cursortree -- gb )
+M: cursortree cursortree-gb ( cursortree -- gb ) delegate ;
+GENERIC: set-cursortree-gb ( gb cursortree -- )
+M: cursortree set-cursortree-gb ( gb cursortree -- ) set-delegate ;
+
+TUPLE: cursor i tree ;
+TUPLE: left-cursor ;
+TUPLE: right-cursor ;
+
+: cursor-index ( cursor -- i ) cursor-i ; inline
+
+: add-cursor ( cursortree cursor -- ) dup cursor-index rot tree-insert ;
+
+: remove-cursor ( cursortree cursor -- )
+ dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ;
+
+: set-cursor-index ( index cursor -- )
+ dup cursor-tree over remove-cursor tuck set-cursor-i
+ dup cursor-tree cursortree-cursors swap add-cursor ;
+
+GENERIC: cursor-pos ( cursor -- n )
+GENERIC: set-cursor-pos ( n cursor -- )
+M: left-cursor cursor-pos ( cursor -- n ) [ cursor-i 1+ ] keep cursor-tree index>position ;
+M: right-cursor cursor-pos ( cursor -- n ) [ cursor-i ] keep cursor-tree index>position ;
+M: left-cursor set-cursor-pos ( n cursor -- ) >r 1- r> [ cursor-tree position>index ] keep set-cursor-index ;
+M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
+
+: <cursor> ( cursortree -- cursor )
+ cursor construct-empty tuck set-cursor-tree ;
+
+: make-cursor ( cursortree pos cursor -- cursor )
+ >r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
+
+: <left-cursor> ( cursortree pos -- left-cursor )
+ left-cursor construct-empty make-cursor ;
+
+: <right-cursor> ( cursortree pos -- right-cursor )
+ right-cursor construct-empty make-cursor ;
+
+: cursor-positions ( cursortree -- seq )
+ cursortree-cursors tree-values [ 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 ;
+
+: element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ;
+: element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ;
+
+: at-beginning? ( cursor -- ? ) cursor-pos 0 = ;
+: at-end? ( cursor -- ? ) element@> length = ;
+
+: insert ( obj cursor -- ) element@> insert* ;
+
+: element< ( cursor -- elem ) element@< nth ;
+: element> ( cursor -- elem ) element@> nth ;
+
+: set-element< ( elem cursor -- ) element@< set-nth ;
+: set-element> ( elem cursor -- ) element@> set-nth ;
+
+GENERIC: fix-cursor ( cursortree cursor -- )
+
+M: left-cursor fix-cursor ( cursortree cursor -- )
+ >r gb-gap-start 1- r> set-cursor-index ;
+
+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 ;
+
+M: cursortree delete* ( pos cursortree -- )
+ tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ;
+
+: delete< ( cursor -- ) element@< delete* ;
+: delete> ( cursor -- ) element@> delete* ;
+
--- /dev/null
+Collection of 'cursors' representing locations in a gap buffer
--- /dev/null
+USING: kernel sequences tools.test gap-buffer strings math ;
+
+! test copy-elements
+[ { 0 3 4 3 4 5 } ] [ { 0 1 2 3 4 5 } dup >r -2 3 5 r> copy-elements ] unit-test
+[ { 0 1 2 1 2 5 } ] [ { 0 1 2 3 4 5 } dup >r 2 2 0 r> copy-elements ] unit-test
+[ "01234567856" ] [ "01234567890" dup >r 4 6 4 r> copy-elements ] unit-test
+
+! test sequence protocol (like, length, nth, set-nth)
+[ "gap buffers are cool" ] [ "gap buffers are cool" <gb> "" like ] unit-test
+
+! test move-gap-back-inside
+[ t f ] [ 5 "0123456" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
+[ "0123456" ] [ "0123456" <gb> 5 over move-gap >string ] unit-test
+! test move-gap-forward-inside
+[ t ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test
+[ "I once ate a spaniel" ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 over move-gap >string ] unit-test
+! test move-gap-back-around
+[ f f ] [ 2 "terriers are ok too" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
+[ "terriers are ok too" ] [ "terriers are ok too" <gb> 2 over move-gap >string ] unit-test
+! test move-gap-forward-around
+[ f t ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over position>index swap move-gap-forward? >r move-gap-forward-inside? 2nip r> ] unit-test
+[ "god is nam's best friend" ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over move-gap >string ] unit-test
+
+! test changing buffer contents
+[ "factory" ] [ "factor" <gb> CHAR: y 6 pick insert* >string ] unit-test
+! test inserting multiple elements in different places. buffer should grow
+[ "refractory" ] [ "factor" <gb> CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test
+! test deleting elements. buffer should shrink
+[ "for" ] [ "factor" <gb> 3 [ 1 over delete* ] times >string ] unit-test
+! more testing of nth and set-nth
+[ "raptor" ] [ "factor" <gb> CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test
+
+! test stack/queue operations
+[ "slaughter" ] [ "laughter" <gb> CHAR: s over push-start >string ] unit-test
+[ "pantonio" ] [ "pant" <gb> "onio" over push-end >string ] unit-test
+[ CHAR: f "actor" ] [ "factor" <gb> dup pop-start swap >string ] unit-test
+[ CHAR: s "pant" ] [ "pants" <gb> dup pop-end swap >string ] unit-test
+[ "end this is the " ] [ "this is the end " <gb> 4 over rotate >string ] unit-test
+[ "your jedi training is finished " ] [ "finished your jedi training is " <gb> -9 over rotate >string ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Alex Chapman All Rights Reserved.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
+! for a good introduction see:
+! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
+USING: kernel arrays sequences sequences.private circular math generic ;
+IN: gap-buffer
+
+! gap-start -- the first element of the gap
+! gap-end -- the first element after the gap
+! expand-factor -- should be > 1
+! min-size -- < 5 is not sensible
+
+TUPLE: gb
+ gap-start
+ gap-end
+ expand-factor
+ min-size ;
+
+GENERIC: gb-seq ( gb -- seq )
+GENERIC: set-gb-seq ( seq gb -- )
+M: gb gb-seq ( gb -- seq ) delegate ;
+M: gb set-gb-seq ( seq gb -- ) set-delegate ;
+
+: required-space ( n gb -- n )
+ tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
+
+: <gb> ( seq -- gb )
+ gb construct-empty
+ 5 over set-gb-min-size
+ 1.5 over set-gb-expand-factor
+ [ >r length r> set-gb-gap-start ] 2keep
+ [ swap length over required-space swap set-gb-gap-end ] 2keep
+ [
+ over length over required-space rot { } like resize-array <circular> swap set-gb-seq
+ ] keep ;
+
+M: gb like ( seq gb -- seq ) drop <gb> ;
+
+: gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ;
+
+: buffer-length ( gb -- n ) gb-seq length ;
+
+M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
+
+: position>index ( pos gb -- i )
+ 2dup gb-gap-start >= [
+ gap-length +
+ ] [ drop ] if ;
+
+: index>position ( i gb -- pos )
+ 2dup gb-gap-end >= [
+ gap-length -
+ ] [ drop ] if ;
+
+M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ;
+
+M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ;
+
+M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ;
+
+M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ;
+
+M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ;
+
+M: gb virtual-seq gb-seq ;
+
+INSTANCE: gb virtual-sequence
+
+! ------------- moving the gap -------------------------------
+
+: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
+
+: copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ;
+
+: copy-elements-back ( dst start seq n -- )
+ dup 0 > [
+ >r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back
+ ] [ 3drop drop ] if ;
+
+: copy-elements-forward ( dst start seq n -- )
+ dup 0 > [
+ >r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward
+ ] [ 3drop drop ] if ;
+
+: copy-elements ( dst start end seq -- )
+ pick pick > [
+ >r dupd - r> swap copy-elements-forward
+ ] [
+ >r over - r> swap copy-elements-back
+ ] if ;
+
+! the gap can be moved either forward or back. Moving the gap 'inside' means
+! moving elements across the gap. Moving the gap 'around' means changing the
+! start of the circular buffer to avoid moving as many elements.
+
+! We decide which method (inside or around) to pick based on the number of
+! elements that will need to be moved. We always try to move as few elements as
+! possible.
+
+: move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ;
+
+: move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ;
+
+: move-gap-back-inside? ( i gb -- i gb ? )
+ #! is it cheaper to move the gap inside than around?
+ 2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ;
+
+: move-gap-forward-inside? ( i gb -- i gb ? )
+ #! is it cheaper to move the gap inside than around?
+ 2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ;
+
+: move-gap-forward-inside ( i gb -- )
+ [ dup gap-length neg swap gb-gap-end rot ] keep gb-seq copy-elements ;
+
+: move-gap-back-inside ( i gb -- )
+ [ dup gap-length swap gb-gap-start 1- rot 1- ] keep gb-seq copy-elements ;
+
+: move-gap-forward-around ( i gb -- )
+ 0 over move-gap-back-inside [
+ dup buffer-length [
+ swap gap-length - neg swap
+ ] keep
+ ] keep [
+ gb-seq copy-elements
+ ] keep dup gap-length swap gb-seq change-circular-start ;
+
+: move-gap-back-around ( i gb -- )
+ dup buffer-length over move-gap-forward-inside [
+ length swap -1
+ ] keep [
+ gb-seq copy-elements
+ ] keep dup length swap gb-seq change-circular-start ;
+
+: move-gap-forward ( i gb -- )
+ move-gap-forward-inside? [
+ move-gap-forward-inside
+ ] [
+ move-gap-forward-around
+ ] if ;
+
+: move-gap-back ( i gb -- )
+ move-gap-back-inside? [
+ move-gap-back-inside
+ ] [
+ move-gap-back-around
+ ] if ;
+
+: (move-gap) ( i gb -- )
+ move-gap? [
+ move-gap-forward? [
+ move-gap-forward
+ ] [
+ move-gap-back
+ ] if
+ ] [ 2drop ] if ;
+
+: fix-gap ( n gb -- )
+ 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
+
+GENERIC: move-gap ( n gb -- )
+
+M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
+
+! ------------ resizing -------------------------------------
+
+: enough-room? ( n gb -- ? )
+ #! is there enough room to add 'n' elements to gb?
+ tuck length + swap buffer-length <= ;
+
+: set-new-gap-end ( array gb -- )
+ [ buffer-length swap length swap - ] keep
+ [ gb-gap-end + ] keep set-gb-gap-end ;
+
+: after-gap ( gb -- gb )
+ dup gb-seq swap gb-gap-end tail ;
+
+: before-gap ( gb -- gb )
+ dup gb-gap-start head ;
+
+: copy-after-gap ( array gb -- )
+ #! copy everything after the gap in 'gb' into the end of 'array',
+ #! and change 'gb's gap-end to reflect the gap-end in 'array'
+ dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> -rot copy ;
+
+: copy-before-gap ( array gb -- )
+ #! copy everything before the gap in 'gb' into the start of 'array'
+ before-gap 0 rot copy ; ! gap start doesn't change
+
+: resize-buffer ( gb new-size -- )
+ f <array> swap 2dup copy-before-gap 2dup copy-after-gap
+ >r <circular> r> set-gb-seq ;
+
+: decrease-buffer-size ( gb -- )
+ #! the gap is too big, so resize to something sensible
+ dup length over required-space resize-buffer ;
+
+: increase-buffer-size ( n gb -- )
+ #! increase the buffer to fit at least 'n' more elements
+ tuck length + over required-space resize-buffer ;
+
+: gb-too-big? ( gb -- ? )
+ dup buffer-length over gb-min-size > [
+ dup length over buffer-length rot gb-expand-factor sq / <
+ ] [ drop f ] if ;
+
+: ?decrease ( gb -- )
+ dup gb-too-big? [
+ decrease-buffer-size
+ ] [ drop ] if ;
+
+: ensure-room ( n gb -- )
+ #! ensure that ther will be enough room for 'n' more elements
+ 2dup enough-room? [ 2drop ] [
+ increase-buffer-size
+ ] if ;
+
+! ------- editing operations ---------------
+
+GENERIC# insert* 2 ( seq position gb -- )
+
+: prepare-insert ( seq position gb -- seq gb )
+ tuck move-gap over length over ensure-room ;
+
+: insert-elements ( seq gb -- )
+ dup gb-gap-start swap gb-seq copy ;
+
+: increment-gap-start ( gb n -- )
+ over gb-gap-start + swap set-gb-gap-start ;
+
+! generic dispatch identifies numbers as sequences before numbers...
+! M: number insert* ( elem position gb -- ) >r >r 1array r> r> insert* ;
+: number-insert ( num position gb -- ) >r >r 1array r> r> insert* ;
+
+M: sequence insert* ( seq position gb -- )
+ pick number? [
+ number-insert
+ ] [
+ prepare-insert [ insert-elements ] 2keep swap length increment-gap-start
+ ] if ;
+
+: (delete*) ( gb -- )
+ dup gb-gap-end 1+ over set-gb-gap-end ?decrease ;
+
+GENERIC: delete* ( pos gb -- )
+
+M: gb delete* ( position gb -- )
+ tuck move-gap (delete*) ;
+
+! -------- stack/queue operations -----------
+
+: push-start ( obj gb -- ) 0 swap insert* ;
+
+: push-end ( obj gb -- ) [ length ] keep insert* ;
+
+: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
+
+: pop-start ( gb -- elem ) 0 swap pop-elem ;
+
+: pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ;
+
+: rotate ( n gb -- )
+ dup length 1 > [
+ swap dup 0 > [
+ [ dup [ pop-end ] keep push-start ]
+ ] [
+ neg [ dup [ pop-start ] keep push-end ]
+ ] if times drop
+ ] [ 2drop ] if ;
+
--- /dev/null
+Gap buffer data structure
--- /dev/null
+collections sequences
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: kernel test trees math sequences ;
+IN: temporary
+
+[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } [ single-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
+[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } [ select-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
+[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 } [ single-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
+[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 } [ select-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
+[ "key1" -1 "key2" 0 "key3" 0 ]
+[ T{ avl-node T{ node f "key1" f f
+ T{ avl-node T{ node f "key2" f
+ T{ avl-node T{ node f "key3" } 1 } }
+ -1 } }
+ 2 } [ double-rotate ] go-left
+ [ node-left dup node-key swap avl-node-balance ] keep
+ [ node-right dup node-key swap avl-node-balance ] keep
+ dup node-key swap avl-node-balance ] unit-test
+[ "key1" 0 "key2" 0 "key3" 0 ]
+[ T{ avl-node T{ node f "key1" f f
+ T{ avl-node T{ node f "key2" f
+ T{ avl-node T{ node f "key3" } 0 } }
+ -1 } }
+ 2 } [ double-rotate ] go-left
+ [ node-left dup node-key swap avl-node-balance ] keep
+ [ node-right dup node-key swap avl-node-balance ] keep
+ dup node-key swap avl-node-balance ] unit-test
+[ "key1" 0 "key2" 1 "key3" 0 ]
+[ T{ avl-node T{ node f "key1" f f
+ T{ avl-node T{ node f "key2" f
+ T{ avl-node T{ node f "key3" } -1 } }
+ -1 } }
+ 2 } [ double-rotate ] go-left
+ [ node-left dup node-key swap avl-node-balance ] keep
+ [ node-right dup node-key swap avl-node-balance ] keep
+ dup node-key swap avl-node-balance ] unit-test
+
+[ "key1" 1 "key2" 0 "key3" 0 ]
+[ T{ avl-node T{ node f "key1" f
+ T{ avl-node T{ node f "key2" f f
+ T{ avl-node T{ node f "key3" } -1 } }
+ 1 } }
+ -2 } [ double-rotate ] go-right
+ [ node-right dup node-key swap avl-node-balance ] keep
+ [ node-left dup node-key swap avl-node-balance ] keep
+ dup node-key swap avl-node-balance ] unit-test
+[ "key1" 0 "key2" 0 "key3" 0 ]
+[ T{ avl-node T{ node f "key1" f
+ T{ avl-node T{ node f "key2" f f
+ T{ avl-node T{ node f "key3" } 0 } }
+ 1 } }
+ -2 } [ double-rotate ] go-right
+ [ node-right dup node-key swap avl-node-balance ] keep
+ [ node-left dup node-key swap avl-node-balance ] keep
+ dup node-key swap avl-node-balance ] unit-test
+[ "key1" 0 "key2" -1 "key3" 0 ]
+[ T{ avl-node T{ node f "key1" f
+ T{ avl-node T{ node f "key2" f f
+ T{ avl-node T{ node f "key3" } 1 } }
+ 1 } }
+ -2 } [ double-rotate ] go-right
+ [ node-right dup node-key swap avl-node-balance ] keep
+ [ node-left dup node-key swap avl-node-balance ] keep
+ dup node-key swap avl-node-balance ] unit-test
+
+! random testing uncovered this little bugger
+[ t t ] [ f "d" T{ avl-node
+ T{ node f "e" f
+ T{ avl-node
+ T{ node f "b" f
+ T{ avl-node T{ node f "a" } 0 }
+ T{ avl-node T{ node f "c" f } 0 }
+ 0 }
+ 0 }
+ T{ avl-node T{ node f "f" } 0 } }
+ -1 } node-set dup valid-avl-node? nip swap valid-node? ] unit-test
+
+[ "eight" ] [ <avl-tree> "seven" 7 pick tree-insert "eight" 8 pick tree-insert "nine" 9 pick tree-insert tree-root node-value ] unit-test
+[ "another eight" ] [ <avl-tree> "seven" 7 pick tree-set "eight" 8 pick tree-set "another eight" 8 pick tree-set 8 swap tree-get ] unit-test
+! [ <avl-tree> "seven" 7 pick tree-insert
+[ t t ] [ <avl-tree> 3 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+[ t t ] [ <avl-tree> 9 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test ! fails when tree growth isn't terminated after a rebalance
+[ t t ] [ <avl-tree> 10 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+
+[ t t ] [ <avl-tree> 3 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+[ t t ] [ <avl-tree> 4 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+[ t t ] [ <avl-tree> 5 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+[ t t ] [ <avl-tree> 10 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+
+[ t t ] [ <avl-tree> 5 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+[ t t ] [ <avl-tree> 19 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+[ t t ] [ <avl-tree> 30 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+[ t t ] [ <avl-tree> 82 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+[ t t ] [ <avl-tree> 100 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+
+! borrowed from tests/bst.factor
+: test-tree ( -- tree )
+ <avl-tree>
+ "seven" 7 pick tree-insert
+ "nine" 9 pick tree-insert
+ "four" 4 pick tree-insert
+ "another four" 4 pick tree-insert
+ "replaced seven" 7 pick tree-set ;
+
+! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all
+[ "seven" ] [ <avl-tree> "seven" 7 pick tree-insert 7 swap tree-get ] unit-test
+[ "seven" t ] [ <avl-tree> "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test
+[ f f ] [ <avl-tree> "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test
+[ "seven" ] [ <avl-tree> "seven" 7 pick tree-set 7 swap tree-get ] unit-test
+[ "replacement" ] [ <avl-tree> "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test
+[ "nine" ] [ test-tree 9 swap tree-get ] unit-test
+[ t ] [ test-tree 4 swap tree-get-all { "another four" "four" } sequence= ] unit-test
+[ t ] [ test-tree 11 swap tree-get-all empty? ] unit-test
+[ t ] [ test-tree 7 swap tree-get-all { "replaced seven" } sequence= ] unit-test
+
+! test tree-delete
+[ f ] [ test-tree 9 over tree-delete 9 swap tree-get ] unit-test
+[ "replaced seven" ] [ test-tree 9 over tree-delete 7 swap tree-get ] unit-test
+[ f ] [ test-tree 4 over tree-delete-all 4 swap tree-get ] unit-test
+[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete 9 swap tree-get ] unit-test
+[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete-all 9 swap tree-get ] unit-test
+
+: test-random-deletions ( tree -- ? )
+ #! deletes one node at random from the tree, checking avl and tree
+ #! properties after each deletion, until the tree is empty
+ dup stump? [
+ drop t
+ ] [
+ dup tree-keys random over tree-delete dup valid-avl-tree? over valid-tree? and [
+ test-random-deletions
+ ] [
+ dup print-tree
+ ] if
+ ] if ;
+
+[ t ] [ <avl-tree> 5 random-tree test-random-deletions ] unit-test
+[ t ] [ <avl-tree> 30 random-tree test-random-deletions ] unit-test
+[ t ] [ <avl-tree> 100 random-tree test-random-deletions ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel generic math namespaces io sequences ;
+IN: trees
+
+TUPLE: avl-tree ;
+
+C: avl-tree ( -- tree )
+ <tree> over set-delegate ;
+
+TUPLE: avl-node balance ;
+
+C: avl-node ( value key -- node )
+ >r <node> r> tuck set-delegate
+ 0 over set-avl-node-balance ;
+
+M: avl-tree create-node ( value key tree -- node ) drop <avl-node> ;
+
+GENERIC: valid-avl-node? ( obj -- height valid? )
+
+M: f valid-avl-node? ( f -- height valid? ) drop 0 t ;
+
+: check-balance ( node left-height right-height -- node height valid? )
+ 2dup max 1+ >r swap - over avl-node-balance = r> swap ;
+
+M: avl-node valid-avl-node? ( node -- height valid? )
+ #! check that this avl node has the right balance marked, and that it isn't unbalanced.
+ dup node-left valid-avl-node? >r over node-right valid-avl-node? >r
+ check-balance r> r> and and
+ rot avl-node-balance abs 2 < and ;
+
+: valid-avl-tree? ( tree -- valid? ) tree-root valid-avl-node? nip ;
+
+: change-balance ( node amount -- )
+ over avl-node-balance + swap set-avl-node-balance ;
+
+: rotate ( node -- node )
+ dup node+link dup node-link pick set-node+link tuck set-node-link ;
+
+: single-rotate ( node -- node )
+ 0 over set-avl-node-balance 0 over node+link set-avl-node-balance rotate ;
+
+: pick-balances ( a node -- balance balance )
+ avl-node-balance {
+ { [ dup zero? ] [ 2drop 0 0 ] }
+ { [ over = ] [ neg 0 ] }
+ { [ t ] [ 0 swap ] }
+ } cond ;
+
+: double-rotate ( node -- node )
+ [
+ node+link [
+ node-link current-side get neg over pick-balances rot 0 swap set-avl-node-balance
+ ] keep set-avl-node-balance
+ ] keep tuck set-avl-node-balance
+ dup node+link [ rotate ] with-other-side over set-node+link rotate ;
+
+: select-rotate ( node -- node )
+ dup node+link avl-node-balance current-side get = [ double-rotate ] [ single-rotate ] if ;
+
+: balance-insert ( node -- node taller? )
+ dup avl-node-balance {
+ { [ dup zero? ] [ drop f ] }
+ { [ dup abs 2 = ] [ sgn neg [ select-rotate ] with-side f ] }
+ { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller
+ } cond ;
+
+DEFER: avl-insert
+
+: avl-set ( value key node -- node taller? )
+ 2dup node-key key= [
+ -rot pick set-node-key over set-node-value f
+ ] [ avl-insert ] if ;
+
+: avl-insert-or-set ( value key node -- node taller? )
+ "setting" get [ avl-set ] [ avl-insert ] if ;
+
+: (avl-insert) ( value key node -- node taller? )
+ [ avl-insert-or-set ] [ <avl-node> t ] if* ;
+
+: avl-insert ( value key node -- node taller? )
+ 2dup node-key key< left right ? [
+ [ node-link (avl-insert) ] keep swap
+ >r tuck set-node-link r> [ dup current-side get change-balance balance-insert ] [ f ] if
+ ] with-side ;
+
+M: avl-node node-insert ( value key node -- node )
+ [ f "setting" set avl-insert-or-set ] with-scope drop ;
+
+M: avl-node node-set ( value key node -- node )
+ [ t "setting" set avl-insert-or-set ] with-scope drop ;
+
+: delete-select-rotate ( node -- node shorter? )
+ dup node+link avl-node-balance zero? [
+ current-side get neg over set-avl-node-balance
+ current-side get over node+link set-avl-node-balance rotate f
+ ] [
+ select-rotate t
+ ] if ;
+
+: rebalance-delete ( node -- node shorter? )
+ dup avl-node-balance {
+ { [ dup zero? ] [ drop t ] }
+ { [ dup abs 2 = ] [ sgn neg [ delete-select-rotate ] with-side ] }
+ { [ drop t ] [ f ] } ! balance is -1 or 1, tree is not shorter
+ } cond ;
+
+: balance-delete ( node -- node shorter? )
+ current-side get over avl-node-balance {
+ { [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
+ { [ dupd = ] [ drop 0 over set-avl-node-balance t ] }
+ { [ t ] [ dupd neg change-balance rebalance-delete ] }
+ } cond ;
+
+: avl-replace-with-extremity ( to-replace node -- node shorter? )
+ dup node-link [
+ swapd avl-replace-with-extremity >r over set-node-link r> [ balance-delete ] [ f ] if
+ ] [
+ tuck copy-node-contents node+link t
+ ] if* ;
+
+: replace-with-a-child ( node -- node shorter? )
+ #! assumes that node is not a leaf, otherwise will recurse forever
+ dup node-link [
+ dupd [ avl-replace-with-extremity ] with-other-side >r over set-node-link r> [
+ balance-delete
+ ] [
+ f
+ ] if
+ ] [
+ [ replace-with-a-child ] with-other-side
+ ] if* ;
+
+: avl-delete-node ( node -- node shorter? )
+ #! delete this node, returning its replacement, and whether this subtree is
+ #! shorter as a result
+ dup leaf? [
+ drop f t
+ ] [
+ random-side [ replace-with-a-child ] with-side ! random not necessary, just for fun
+ ] if ;
+
+GENERIC: avl-delete ( key node -- node shorter? deleted? )
+
+M: f avl-delete ( key f -- f f f ) nip f f ;
+
+: (avl-delete) ( key node -- node shorter? deleted? )
+ tuck node-link avl-delete >r >r over set-node-link r> [ balance-delete r> ] [ f r> ] if ;
+
+M: avl-node avl-delete ( key node -- node shorter? deleted? )
+ 2dup node-key key-side dup zero? [
+ drop nip avl-delete-node t
+ ] [
+ [
+ (avl-delete)
+ ] with-side
+ ] if ;
+
+M: avl-node node-delete ( key node -- node ) avl-delete 2drop ;
+
+M: avl-node node-delete-all ( key node -- node )
+ #! deletes until there are no more. not optimal.
+ dupd [ avl-delete nip ] with-scope [
+ node-delete-all
+ ] [
+ nip
+ ] if ;
+
+M: avl-node print-node ( depth node -- )
+ over 1+ over node-right print-node
+ over [ drop " " write ] each
+ dup avl-node-balance number>string write " " write dup node-key number>string print
+ >r 1+ r> node-left print-node ;
+
--- /dev/null
+USING: trees test kernel sequences ;
+IN: temporary
+
+: test-tree ( -- tree )
+ <bst>
+ "seven" 7 pick tree-insert
+ "nine" 9 pick tree-insert
+ "four" 4 pick tree-insert
+ "another four" 4 pick tree-insert
+ "replaced seven" 7 pick tree-set ;
+
+! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all
+[ "seven" ] [ <bst> "seven" 7 pick tree-insert 7 swap tree-get ] unit-test
+[ "seven" t ] [ <bst> "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test
+[ f f ] [ <bst> "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test
+[ "seven" ] [ <bst> "seven" 7 pick tree-set 7 swap tree-get ] unit-test
+[ "replacement" ] [ <bst> "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test
+[ "four" ] [ test-tree 4 swap tree-get ] unit-test
+[ "nine" ] [ test-tree 9 swap tree-get ] unit-test
+[ t ] [ test-tree 4 swap tree-get-all { "another four" "four" } sequence= ] unit-test
+[ t ] [ test-tree 11 swap tree-get-all empty? ] unit-test
+[ t ] [ test-tree 7 swap tree-get-all { "replaced seven" } sequence= ] unit-test
+
+! test tree-delete
+[ f ] [ test-tree 9 over tree-delete 9 swap tree-get ] unit-test
+[ "replaced seven" ] [ test-tree 9 over tree-delete 7 swap tree-get ] unit-test
+[ "four" ] [ test-tree 9 over tree-delete 4 swap tree-get ] unit-test
+! TODO: sometimes this shows up as "another four" because of randomisation
+! [ "nine" "four" ] [ test-tree 7 over tree-delete 9 over tree-get 4 rot tree-get ] unit-test
+! [ "another four" ] [ test-tree 4 over tree-delete 4 swap tree-get ] unit-test
+[ f ] [ test-tree 4 over tree-delete-all 4 swap tree-get ] unit-test
+[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete 9 swap tree-get ] unit-test
+[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete-all 9 swap tree-get ] unit-test
+
+! test valid-node?
+[ t ] [ T{ node f 0 } valid-node? ] unit-test
+[ t ] [ T{ node f 0 f T{ node f -1 } } valid-node? ] unit-test
+[ t ] [ T{ node f 0 f f T{ node f 1 } } valid-node? ] unit-test
+[ t ] [ T{ node f 0 f T{ node f -1 } T{ node f 1 } } valid-node? ] unit-test
+[ f ] [ T{ node f 0 f T{ node f 1 } } valid-node? ] unit-test
+[ f ] [ T{ node f 0 f f T{ node f -1 } } valid-node? ] unit-test
+
+! random testing
+[ t ] [ <bst> 10 random-tree valid-tree? ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel generic math ;
+IN: trees
+
+TUPLE: bst ;
+
+C: bst ( -- tree ) <tree> over set-delegate ;
+
+TUPLE: bst-node ;
+
+C: bst-node ( value key -- node ) >r <node> r> tuck set-delegate ;
+
+M: bst create-node ( value key tree -- node ) drop <bst-node> ;
+
+M: bst-node node-insert ( value key node -- node )
+ 2dup node-key key-side [
+ [ node-link [ node-insert ] [ <bst-node> ] if* ] keep tuck set-node-link
+ ] with-side ;
+
+M: bst-node node-set ( value key node -- node )
+ 2dup node-key key-side dup 0 = [
+ drop nip [ set-node-value ] keep
+ ] [
+ [ [ node-link [ node-set ] [ <bst-node> ] if* ] keep tuck set-node-link ] with-side
+ ] if ;
+
+DEFER: delete-node
+
+: (prune-extremity) ( parent node -- new-extremity )
+ dup node-link [
+ rot drop (prune-extremity)
+ ] [
+ tuck delete-node swap set-node-link
+ ] if* ;
+
+: prune-extremity ( node -- new-extremity )
+ #! remove and return the leftmost or rightmost child of this node.
+ #! assumes at least one child
+ dup node-link (prune-extremity) ;
+
+: replace-with-child ( node -- node )
+ dup dup node-link copy-node-contents dup node-link delete-node over set-node-link ;
+
+: replace-with-extremity ( node -- node )
+ dup node-link dup node+link [
+ ! predecessor/successor is not the immediate child
+ [ prune-extremity ] with-other-side dupd copy-node-contents
+ ] [
+ ! node-link is the predecessor/successor
+ drop replace-with-child
+ ] if ;
+
+: delete-node-with-two-children ( node -- node )
+ #! randomised to minimise tree unbalancing
+ random-side [ replace-with-extremity ] with-side ;
+
+: delete-node ( node -- node )
+ #! delete this node, returning its replacement
+ dup node-left [
+ dup node-right [
+ delete-node-with-two-children
+ ] [
+ node-left ! left but no right
+ ] if
+ ] [
+ dup node-right [
+ node-right ! right but not left
+ ] [
+ drop f ! no children
+ ] if
+ ] if ;
+
+M: bst-node node-delete ( key node -- node )
+ 2dup node-key key-side dup zero? [
+ drop nip delete-node
+ ] [
+ [ tuck node-link node-delete over set-node-link ] with-side
+ ] if ;
+
+M: bst-node node-delete-all ( key node -- node )
+ 2dup node-key key-side dup zero? [
+ drop delete-node node-delete-all
+ ] [
+ [ tuck node-link node-delete-all over set-node-link ] with-side
+ ] if ;
+
--- /dev/null
+Binary search and avl (balanced) trees
--- /dev/null
+collections trees
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel generic math sequences arrays io namespaces kernel-internals ;
+IN: trees
+
+TUPLE: tree root ;
+
+C: tree ( -- tree ) ;
+
+TUPLE: node key value left right ;
+
+C: node ( value key -- node )
+ [ set-node-key ] keep
+ [ set-node-value ] keep
+ f over 2dup set-node-left set-node-right ;
+
+SYMBOL: current-side
+
+: left -1 ; inline
+: right 1 ; inline
+
+: go-left? ( -- ? ) current-side get left = ;
+
+: node-link@ ( -- ? quot quot ) go-left? [ node-left ] [ node-right ] ; inline
+: set-node-link@ ( -- ? quot quot ) go-left? [ set-node-left ] [ set-node-right ] ; inline
+
+: node-link ( node -- child ) node-link@ if ;
+: set-node-link ( child node -- ) set-node-link@ if ;
+: node+link ( node -- child ) node-link@ swap if ;
+: set-node+link ( child node -- ) set-node-link@ swap if ;
+
+: with-side ( side quot -- ) H{ } clone >n swap current-side set call ndrop ; inline
+: with-other-side ( quot -- ) current-side get neg swap with-side ; inline
+: go-left ( quot -- ) left swap with-side ; inline
+: go-right ( quot -- ) right swap with-side ; inline
+
+GENERIC: create-node ( value key tree -- node )
+
+GENERIC: copy-node-contents ( new old -- )
+
+M: node copy-node-contents ( new old -- )
+ #! copy old's key and value into new (keeping children and parent)
+ dup node-key pick set-node-key node-value swap set-node-value ;
+
+M: tree create-node ( value key tree -- node ) drop <node> ;
+
+: key-side ( k1 k2 -- side )
+ #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
+ <=> sgn ;
+
+: key< ( k1 k2 -- ? ) <=> 0 < ;
+: key> ( k1 k2 -- ? ) <=> 0 > ;
+: key= ( k1 k2 -- ? ) <=> zero? ;
+
+: random-side ( -- side ) left right 2array random ;
+
+: choose-branch ( key node -- key node-left/right )
+ 2dup node-key key-side [ node-link ] with-side ;
+
+GENERIC: node-get ( key node -- value )
+
+: tree-get ( key tree -- value ) tree-root node-get ;
+
+M: node node-get ( key node -- value )
+ 2dup node-key key= [
+ nip node-value
+ ] [
+ choose-branch node-get
+ ] if ;
+
+M: f node-get ( key f -- f ) nip ;
+
+GENERIC: node-get* ( key node -- value ? )
+
+: tree-get* ( key tree -- value ? ) tree-root node-get* ;
+
+M: node node-get* ( key node -- value ? )
+ 2dup node-key key= [
+ nip node-value t
+ ] [
+ choose-branch node-get*
+ ] if ;
+
+M: f node-get* ( key f -- f f ) nip f ;
+
+GENERIC: node-get-all ( key node -- seq )
+
+: tree-get-all ( key tree -- seq ) tree-root node-get-all ;
+
+M: f node-get-all ( key f -- V{} ) 2drop V{ } clone ;
+
+M: node node-get-all ( key node -- seq )
+ 2dup node-key key= [
+ ! duplicate keys are stored to the right because of choose-branch
+ 2dup node-right node-get-all >r nip node-value r> tuck push
+ ] [
+ choose-branch node-get-all
+ ] if ;
+
+GENERIC: node-insert ( value key node -- node ) ! can add duplicates
+
+: tree-insert ( value key tree -- )
+ [ dup tree-root [ nip node-insert ] [ create-node ] if* ] keep set-tree-root ;
+
+GENERIC: node-set ( value key node -- node )
+ #! note that this only sets the first node with this key. if more than one
+ #! has been inserted then the others won't be modified. (should they be deleted?)
+
+: tree-set ( value key tree -- )
+ [ dup tree-root [ nip node-set ] [ create-node ] if* ] keep set-tree-root ;
+
+GENERIC: node-delete ( key node -- node )
+
+: tree-delete ( key tree -- )
+ [ tree-root node-delete ] keep set-tree-root ;
+
+GENERIC: node-delete-all ( key node -- node )
+
+M: f node-delete-all ( key f -- f ) nip ;
+
+: tree-delete-all ( key tree -- )
+ [ tree-root node-delete-all ] keep set-tree-root ;
+
+: node-map-link ( node quot -- node )
+ over node-link swap call over set-node-link ;
+
+: node-map ( node quot -- node )
+ over [
+ tuck [ node-map-link ] go-left over call swap [ node-map-link ] go-right
+ ] [
+ drop
+ ] if ;
+
+: tree-map ( tree quot -- )
+ #! apply quot to each element of the tree, in order
+ over tree-root swap node-map swap set-tree-root ;
+
+: node>node-seq ( node -- seq )
+ dup [
+ dup node-left node>node-seq over 1array rot node-right node>node-seq 3append
+ ] when ;
+
+: tree>node-seq ( tree -- seq )
+ tree-root node>node-seq ;
+
+: tree-keys ( tree -- keys )
+ tree>node-seq [ node-key ] map ;
+
+: tree-values ( tree -- values )
+ tree>node-seq [ node-value ] map ;
+
+: leaf? ( node -- ? )
+ dup node-left swap node-right or not ;
+
+GENERIC: valid-node? ( node -- ? )
+
+M: f valid-node? ( f -- t ) not ;
+
+M: node valid-node? ( node -- ? )
+ dup dup node-left [ node-key swap node-key key< ] when* >r
+ dup dup node-right [ node-key swap node-key key> ] when* r> and swap
+ dup node-left valid-node? swap node-right valid-node? and and ;
+
+: valid-tree? ( tree -- ? ) tree-root valid-node? ;
+
+DEFER: print-tree
+
+: random-tree ( tree size -- tree )
+ [ most-positive-fixnum random pick tree-set ] each ;
+
+: increasing-tree ( tree size -- tree )
+ [ dup pick tree-set ] each ;
+
+: decreasing-tree ( tree size -- tree )
+ reverse increasing-tree ;
+
+GENERIC: print-node ( depth node -- )
+
+M: f print-node ( depth f -- ) 2drop ;
+
+M: node print-node ( depth node -- )
+ ! not pretty, but ok for debugging
+ over 1+ over node-right print-node
+ over [ drop " " write ] each dup node-key number>string print
+ >r 1+ r> node-left print-node ;
+
+: print-tree ( tree -- )
+ tree-root 1 swap print-node ;
+
+: stump? ( tree -- ? )
+ #! is this tree empty?
+ tree-root not ;
+
projects / factor.git / commitdiff