From 05b76f181f6671eaec45d146a5ba372a6b6cf16d Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 27 Dec 2007 13:56:03 -0500 Subject: [PATCH] Extra/trees changes --- extra/trees/avl/avl-tests.factor | 130 ++++++++++++++----------------- extra/trees/avl/avl.factor | 113 +++++++++++---------------- extra/trees/trees.factor | 13 +++- 3 files changed, 116 insertions(+), 140 deletions(-) diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index aba97ad043..5cea2c1c35 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -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" ] [ + "seven" 7 pick set-at + "eight" 8 pick set-at "nine" 9 pick set-at + tree-root node-value +] unit-test -[ "eight" ] [ "seven" 7 pick tree-insert "eight" 8 pick tree-insert "nine" 9 pick tree-insert tree-root node-value ] unit-test -[ "another eight" ] [ "seven" 7 pick tree-set "eight" 8 pick tree-set "another eight" 8 pick tree-set 8 swap tree-get ] unit-test -! [ "seven" 7 pick tree-insert -[ t t ] [ 3 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 9 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test ! fails when tree growth isn't terminated after a rebalance -[ t t ] [ 10 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test - -[ t t ] [ 3 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 4 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 5 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 10 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test - -[ t t ] [ 5 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 19 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 30 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 82 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 100 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test +[ "another eight" ] [ + "seven" 7 pick set-at + "another eight" 8 pick set-at 8 swap at +] unit-test ! borrowed from tests/bst.factor : test-tree ( -- 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 ; + + "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" ] [ "seven" 7 pick tree-insert 7 swap tree-get ] unit-test -[ "seven" t ] [ "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test -[ f f ] [ "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test -[ "seven" ] [ "seven" 7 pick tree-set 7 swap tree-get ] unit-test -[ "replacement" ] [ "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 ] [ 5 random-tree test-random-deletions ] unit-test -[ t ] [ 30 random-tree test-random-deletions ] unit-test -[ t ] [ 100 random-tree test-random-deletions ] unit-test +! test set-at, at, at* +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test +[ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "replacement" ] [ "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 diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 654a078a23..03741b5ecd 100644 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -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 ; -: ( -- tree ) - avl-tree construct-empty over set-delegate ; +INSTANCE: avl assoc + +: ( -- tree ) + avl construct-empty over set-delegate ; TUPLE: avl-node balance ; -: ( value key -- node ) - 0 avl-node construct-boa tuck set-delegate ; - -M: avl-tree create-node ( value key tree -- node ) drop ; - -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 ; +: ( key value -- node ) + swap 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 ] [ 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 ] [ 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 ; -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 ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 8c88e6f159..55031f77cb 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -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 ;