Extra/trees changes
Daniel Ehrenberg
parent
d5baea215d
commit
05b76f181f
|
|
@ -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
|
||||
|
||||
[ "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" 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
|
||||
|
|
@ -61,77 +85,37 @@ IN: temporary
|
|||
[ 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> "seven" 7 pick set-at
|
||||
"eight" 8 pick set-at "nine" 9 pick set-at
|
||||
tree-root node-value
|
||||
] 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
|
||||
[ "another eight" ] [
|
||||
<avl> "seven" 7 pick set-at
|
||||
"another eight" 8 pick set-at 8 swap at
|
||||
] 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 ;
|
||||
<avl>
|
||||
"seven" 7 pick set-at
|
||||
"nine" 9 pick set-at
|
||||
"four" 4 pick set-at
|
||||
"replaced four" 4 pick set-at
|
||||
"replaced seven" 7 pick set-at ;
|
||||
|
||||
! 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
|
||||
! test set-at, at, at*
|
||||
[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
|
||||
[ "seven" t ] [ <avl> "seven" 7 pick set-at 7 swap at* ] unit-test
|
||||
[ f f ] [ <avl> "seven" 7 pick set-at 8 swap at* ] unit-test
|
||||
[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
|
||||
[ "replacement" ] [ <avl> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
|
||||
[ "nine" ] [ test-tree 9 swap at ] unit-test
|
||||
[ "replaced four" ] [ test-tree 4 swap at ] unit-test
|
||||
[ "replaced seven" ] [ test-tree 7 swap at ] 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
|
||||
|
|
|
|||
|
|
@ -1,35 +1,20 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel generic math math.functions math.parser namespaces io
|
||||
sequences trees ;
|
||||
USING: combinators kernel generic math math.functions math.parser
|
||||
namespaces io prettyprint.backend sequences trees assocs parser ;
|
||||
IN: trees.avl
|
||||
|
||||
TUPLE: avl-tree ;
|
||||
TUPLE: avl ;
|
||||
|
||||
: <avl-tree> ( -- tree )
|
||||
avl-tree construct-empty <tree> over set-delegate ;
|
||||
INSTANCE: avl assoc
|
||||
|
||||
: <avl> ( -- tree )
|
||||
avl construct-empty <tree> over set-delegate ;
|
||||
|
||||
TUPLE: avl-node balance ;
|
||||
|
||||
: <avl-node> ( value key -- node )
|
||||
<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 ;
|
||||
: <avl-node> ( key value -- node )
|
||||
swap <node> 0 avl-node construct-boa tuck set-delegate ;
|
||||
|
||||
: change-balance ( node amount -- )
|
||||
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
|
||||
} 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? )
|
||||
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 ;
|
||||
M: avl-node set-at ( value key node -- node )
|
||||
[ avl-set drop ] change-root ;
|
||||
|
||||
: delete-select-rotate ( node -- node shorter? )
|
||||
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? )
|
||||
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
|
||||
] if* ;
|
||||
|
|
@ -122,11 +103,8 @@ M: avl-node node-set ( value key node -- node )
|
|||
: 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
|
||||
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* ;
|
||||
|
|
@ -137,7 +115,7 @@ M: avl-node node-set ( value key node -- node )
|
|||
dup leaf? [
|
||||
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 ;
|
||||
|
||||
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 ;
|
||||
|
||||
: (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? )
|
||||
2dup node-key key-side dup zero? [
|
||||
drop nip avl-delete-node t
|
||||
] [
|
||||
[
|
||||
(avl-delete)
|
||||
] with-side
|
||||
[ (avl-delete) ] with-side
|
||||
] 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 )
|
||||
#! deletes until there are no more. not optimal.
|
||||
dupd [ avl-delete nip ] with-scope [
|
||||
node-delete-all
|
||||
] [
|
||||
nip
|
||||
] if ;
|
||||
M: avl new-assoc
|
||||
2drop <avl> ;
|
||||
|
||||
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 ;
|
||||
: >avl ( assoc -- avl )
|
||||
T{ avl T{ tree f f 0 } } assoc-clone-like ;
|
||||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
|
||||
TUPLE: tree root count ;
|
||||
|
|
@ -179,3 +180,13 @@ DEFER: delete-node
|
|||
|
||||
M: tree delete-at
|
||||
[ 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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue