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

Extra/trees changes

db4
Daniel Ehrenberg 2007-12-27 13:56:03 -05:00
parent d5baea215d
commit 05b76f181f
3 changed files with 116 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

130
extra/trees/avl/avl-tests.factor
View File

@ -1,10 +1,34 @@
USING: kernel tools.test trees trees.avl math random sequences ; USING: kernel tools.test trees trees.avl math random sequences assocs ;
IN: temporary 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 ] [
[ "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 T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 }
[ "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 [ single-rotate ] go-left
[ "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 [ 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 ] [ "key1" -1 "key2" 0 "key3" 0 ]
[ T{ avl-node T{ node f "key1" f f [ T{ avl-node T{ node f "key1" f f
T{ avl-node T{ node f "key2" f T{ avl-node T{ node f "key2" f
@ -61,77 +85,37 @@ IN: temporary
[ node-left 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 dup node-key swap avl-node-balance ] unit-test
! random testing uncovered this little bugger [ "eight" ] [
[ t t ] [ f "d" T{ avl-node <avl> "seven" 7 pick set-at
T{ node f "e" f "eight" 8 pick set-at "nine" 9 pick set-at
T{ avl-node tree-root node-value
T{ node f "b" f ] unit-test
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" ] [
[ "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> "seven" 7 pick set-at
! [ <avl-tree> "seven" 7 pick tree-insert "another eight" 8 pick set-at 8 swap at
[ t t ] [ <avl-tree> 3 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test ] 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 ! borrowed from tests/bst.factor
: test-tree ( -- tree ) : test-tree ( -- tree )
<avl-tree> <avl>
"seven" 7 pick tree-insert "seven" 7 pick set-at
"nine" 9 pick tree-insert "nine" 9 pick set-at
"four" 4 pick tree-insert "four" 4 pick set-at
"another four" 4 pick tree-insert "replaced four" 4 pick set-at
"replaced seven" 7 pick tree-set ; "replaced seven" 7 pick set-at ;
! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all ! test set-at, at, at*
[ "seven" ] [ <avl-tree> "seven" 7 pick tree-insert 7 swap tree-get ] unit-test [ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
[ "seven" t ] [ <avl-tree> "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test [ "seven" t ] [ <avl> "seven" 7 pick set-at 7 swap at* ] unit-test
[ f f ] [ <avl-tree> "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test [ f f ] [ <avl> "seven" 7 pick set-at 8 swap at* ] unit-test
[ "seven" ] [ <avl-tree> "seven" 7 pick tree-set 7 swap tree-get ] unit-test [ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
[ "replacement" ] [ <avl-tree> "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test [ "replacement" ] [ <avl> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
[ "nine" ] [ test-tree 9 swap tree-get ] unit-test [ "nine" ] [ test-tree 9 swap at ] unit-test
[ t ] [ test-tree 4 swap tree-get-all { "another four" "four" } sequence= ] unit-test [ "replaced four" ] [ test-tree 4 swap at ] unit-test
[ t ] [ test-tree 11 swap tree-get-all empty? ] unit-test [ "replaced seven" ] [ test-tree 7 swap at ] 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
! test delete-at
[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test
[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test
[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test

113
extra/trees/avl/avl.factor
View File

@ -1,35 +1,20 @@
! Copyright (C) 2007 Alex Chapman ! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel generic math math.functions math.parser namespaces io USING: combinators kernel generic math math.functions math.parser
sequences trees ; namespaces io prettyprint.backend sequences trees assocs parser ;
IN: trees.avl IN: trees.avl
TUPLE: avl-tree ; TUPLE: avl ;
: <avl-tree> ( -- tree ) INSTANCE: avl assoc
avl-tree construct-empty <tree> over set-delegate ;
: <avl> ( -- tree )
avl construct-empty <tree> over set-delegate ;
TUPLE: avl-node balance ; TUPLE: avl-node balance ;
: <avl-node> ( value key -- node ) : <avl-node> ( key value -- node )
<node> 0 avl-node construct-boa tuck set-delegate ; swap <node> 0 avl-node construct-boa tuck set-delegate ;
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 -- ) : change-balance ( node amount -- )
over avl-node-balance + swap set-avl-node-balance ; over avl-node-balance + swap set-avl-node-balance ;
@ -65,30 +50,25 @@ M: avl-node valid-avl-node? ( node -- height valid? )
{ [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller
} cond ; } cond ;
DEFER: avl-insert DEFER: avl-set
: (avl-insert) ( value key node -- node taller? )
[ avl-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 ;
: avl-set ( value key node -- node taller? ) : avl-set ( value key node -- node taller? )
2dup node-key key= [ 2dup node-key key= [
-rot pick set-node-key over set-node-value f -rot pick set-node-key over set-node-value f
] [ avl-insert ] if ; ] [ avl-insert ] if ;
: avl-insert-or-set ( value key node -- node taller? ) M: avl-node set-at ( value key node -- node )
"setting" get [ avl-set ] [ avl-insert ] if ; [ avl-set drop ] change-root ;
: (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? ) : delete-select-rotate ( node -- node shorter? )
dup node+link avl-node-balance zero? [ dup node+link avl-node-balance zero? [
@ -114,7 +94,8 @@ M: avl-node node-set ( value key node -- node )
: avl-replace-with-extremity ( to-replace node -- node shorter? ) : avl-replace-with-extremity ( to-replace node -- node shorter? )
dup node-link [ dup node-link [
swapd avl-replace-with-extremity >r over set-node-link r> [ balance-delete ] [ f ] if swapd avl-replace-with-extremity >r over set-node-link r>
[ balance-delete ] [ f ] if
] [ ] [
tuck copy-node-contents node+link t tuck copy-node-contents node+link t
] if* ; ] if* ;
@ -122,11 +103,8 @@ M: avl-node node-set ( value key node -- node )
: replace-with-a-child ( node -- node shorter? ) : replace-with-a-child ( node -- node shorter? )
#! assumes that node is not a leaf, otherwise will recurse forever #! assumes that node is not a leaf, otherwise will recurse forever
dup node-link [ dup node-link [
dupd [ avl-replace-with-extremity ] with-other-side >r over set-node-link r> [ dupd [ avl-replace-with-extremity ] with-other-side
balance-delete >r over set-node-link r> [ balance-delete ] [ f ] if
] [
f
] if
] [ ] [
[ replace-with-a-child ] with-other-side [ replace-with-a-child ] with-other-side
] if* ; ] if* ;
@ -137,7 +115,7 @@ M: avl-node node-set ( value key node -- node )
dup leaf? [ dup leaf? [
drop f t drop f t
] [ ] [
random-side [ replace-with-a-child ] with-side ! random not necessary, just for fun left [ replace-with-a-child ] with-side
] if ; ] if ;
GENERIC: avl-delete ( key node -- node shorter? deleted? ) GENERIC: avl-delete ( key node -- node shorter? deleted? )
@ -145,30 +123,33 @@ GENERIC: avl-delete ( key node -- node shorter? deleted? )
M: f avl-delete ( key f -- f f f ) nip f f ; M: f avl-delete ( key f -- f f f ) nip f f ;
: (avl-delete) ( key node -- node shorter? deleted? ) : (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 ; 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? ) M: avl-node avl-delete ( key node -- node shorter? deleted? )
2dup node-key key-side dup zero? [ 2dup node-key key-side dup zero? [
drop nip avl-delete-node t drop nip avl-delete-node t
] [ ] [
[ [ (avl-delete) ] with-side
(avl-delete)
] with-side
] if ; ] if ;
M: avl-node node-delete ( key node -- node ) avl-delete 2drop ; M: avl delete-at ( key node -- )
[ avl-delete 2drop ] change-root ;
M: avl-node node-delete-all ( key node -- node ) M: avl new-assoc
#! deletes until there are no more. not optimal. 2drop <avl> ;
dupd [ avl-delete nip ] with-scope [
node-delete-all
] [
nip
] if ;
M: avl-node print-node ( depth node -- ) : >avl ( assoc -- avl )
over 1+ over node-right print-node T{ avl T{ tree f f 0 } } assoc-clone-like ;
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 ;
: AVL{
\ } [ >avl ] parse-literal ; parsing
M: avl pprint-delims drop \ AVL{ \ } ;
M: avl >pprint-sequence >alist ;
M: avl pprint-narrow? drop t ;
! When tuple inheritance is used, the following lines won't be necessary
M: avl assoc-size tree-count ;
M: avl clear-assoc delegate clear-assoc ;
M: avl assoc-find >r tree-root r> find-node ;

13
extra/trees/trees.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Alex Chapman ! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic math sequences arrays io namespaces USING: kernel generic math sequences arrays io namespaces
prettyprint.private kernel.private assocs random combinators ; prettyprint.private kernel.private assocs random combinators
parser prettyprint.backend ;
IN: trees IN: trees
TUPLE: tree root count ; TUPLE: tree root count ;
@ -179,3 +180,13 @@ DEFER: delete-node
M: tree delete-at M: tree delete-at
[ delete-bst-node ] change-root ; [ delete-bst-node ] change-root ;
: >tree ( assoc -- bst )
T{ tree f f 0 } assoc-clone-like ;
: TREE{
\ } [ >tree ] parse-literal ; parsing
M: tree pprint-delims drop \ TREE{ \ } ;
M: tree >pprint-sequence >alist ;
M: tree pprint-narrow? drop t ;