Merge branch 'trees'
Daniel Ehrenberg
commit
f536b4c057
|
|
@ -1 +1,2 @@
|
|||
Alex Chapman
|
||||
Daniel Ehrenberg
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
Alex Chapman
|
||||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
USING: help.syntax help.markup trees.avl assocs ;
|
||||
|
||||
HELP: AVL{
|
||||
{ $syntax "AVL{ { key value }... }" }
|
||||
{ $values { "key" "a key" } { "value" "a value" } }
|
||||
{ $description "Literal syntax for an AVL tree." } ;
|
||||
|
||||
HELP: <avl>
|
||||
{ $values { "tree" avl } }
|
||||
{ $description "Creates an empty AVL tree" } ;
|
||||
|
||||
HELP: >avl
|
||||
{ $values { "assoc" assoc } { "avl" avl } }
|
||||
{ $description "Converts any " { $link assoc } " into an AVL tree." } ;
|
||||
|
||||
HELP: avl
|
||||
{ $class-description "This is the class for AVL trees. These conform to the assoc protocol and have efficient (logarithmic time) storage and retrieval operations." } ;
|
||||
|
||||
ARTICLE: { "avl" "intro" } "AVL trees"
|
||||
"This is a library for AVL trees, with logarithmic time storage and retrieval operations. These trees conform to the assoc protocol."
|
||||
{ $subsection avl }
|
||||
{ $subsection <avl> }
|
||||
{ $subsection >avl }
|
||||
{ $subsection POSTPONE: AVL{ } ;
|
||||
|
||||
IN: trees.avl
|
||||
ABOUT: { "avl" "intro" }
|
||||
|
|
@ -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,38 @@ 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
|
||||
[ "another eight" ] [ ! ERROR!
|
||||
<avl> "seven" 7 pick set-at
|
||||
"another eight" 8 pick set-at 8 swap at
|
||||
] 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 ;
|
||||
AVL{
|
||||
{ 7 "seven" }
|
||||
{ 9 "nine" }
|
||||
{ 4 "four" }
|
||||
{ 4 "replaced four" }
|
||||
{ 7 "replaced seven" }
|
||||
} clone ;
|
||||
|
||||
! 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*
|
||||
[ t ] [ test-tree avl? ] unit-test
|
||||
[ "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--all errors!
|
||||
[ 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-set ( value key node -- node taller? )
|
||||
: avl-insert ( value key node -- node taller? )
|
||||
2dup node-key key< left right ? [
|
||||
[ node-link avl-set ] 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-set ( value key node -- node taller? )
|
||||
[ (avl-set) ] [ <avl-node> t ] 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 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,36 @@ 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 ;
|
||||
|
||||
M: avl assoc-like
|
||||
drop dup avl? [ >avl ] unless ;
|
||||
|
||||
: AVL{
|
||||
\ } [ >avl ] parse-literal ; parsing
|
||||
|
||||
M: avl pprint-delims drop \ AVL{ \ } ;
|
||||
|
||||
! 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 ;
|
||||
M: avl clone dup assoc-clone-like ;
|
||||
M: avl >pprint-sequence >alist ;
|
||||
M: avl pprint-narrow? drop t ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Balanced AVL trees
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
USING: trees trees.binary tools.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
|
||||
|
||||
|
|
@ -1,88 +0,0 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel generic math trees ;
|
||||
IN: trees.binary
|
||||
|
||||
TUPLE: bst ;
|
||||
|
||||
: <bst> ( -- tree ) bst construct-empty <tree> over set-delegate ;
|
||||
|
||||
TUPLE: bst-node ;
|
||||
|
||||
: <bst-node> ( value key -- node )
|
||||
<node> bst-node construct-empty 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 ;
|
||||
|
||||
|
|
@ -1 +1 @@
|
|||
Mackenzie Straight
|
||||
Mackenzie Straight, Daniel Ehrenberg
|
||||
|
|
|
|||
|
|
@ -0,0 +1,27 @@
|
|||
USING: help.syntax help.markup trees.splay assocs ;
|
||||
|
||||
HELP: SPLAY{
|
||||
{ $syntax "SPLAY{ { key value }... }" }
|
||||
{ $values { "key" "a key" } { "value" "a value" } }
|
||||
{ $description "Literal syntax for an splay tree." } ;
|
||||
|
||||
HELP: <splay>
|
||||
{ $values { "tree" splay } }
|
||||
{ $description "Creates an empty splay tree" } ;
|
||||
|
||||
HELP: >splay
|
||||
{ $values { "assoc" assoc } { "splay" splay } }
|
||||
{ $description "Converts any " { $link assoc } " into an splay tree." } ;
|
||||
|
||||
HELP: splay
|
||||
{ $class-description "This is the class for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These conform to the assoc protocol." } ;
|
||||
|
||||
ARTICLE: { "splay" "intro" } "Splay trees"
|
||||
"This is a library for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These trees conform to the assoc protocol."
|
||||
{ $subsection splay }
|
||||
{ $subsection <splay> }
|
||||
{ $subsection >splay }
|
||||
{ $subsection POSTPONE: SPLAY{ } ;
|
||||
|
||||
IN: trees.splay
|
||||
ABOUT: { "splay" "intro" }
|
||||
|
|
@ -8,7 +8,7 @@ IN: temporary
|
|||
100 [ drop 100 random swap at drop ] curry* each ;
|
||||
|
||||
: make-numeric-splay-tree ( n -- splay-tree )
|
||||
dup <splay-tree> -rot [ pick set-at ] 2each ;
|
||||
<splay> [ [ dupd set-at ] curry each ] keep ;
|
||||
|
||||
[ t ] [
|
||||
100 make-numeric-splay-tree dup randomize-numeric-splay-tree
|
||||
|
|
@ -18,10 +18,10 @@ IN: temporary
|
|||
[ 10 ] [ 10 make-numeric-splay-tree keys length ] unit-test
|
||||
[ 10 ] [ 10 make-numeric-splay-tree values length ] unit-test
|
||||
|
||||
[ f ] [ <splay-tree> f 4 pick set-at 4 swap at ] unit-test
|
||||
[ f ] [ <splay> f 4 pick set-at 4 swap at ] unit-test
|
||||
|
||||
! Ensure that f can be a value
|
||||
[ t ] [ <splay-tree> f 4 pick set-at 4 swap key? ] unit-test
|
||||
[ t ] [ <splay> f 4 pick set-at 4 swap key? ] unit-test
|
||||
|
||||
[
|
||||
{ { 1 "a" } { 2 "b" } { 3 "c" } { 4 "d" } { 5 "e" } { 6 "f" } }
|
||||
|
|
@ -29,5 +29,5 @@ IN: temporary
|
|||
{
|
||||
{ 4 "d" } { 5 "e" } { 6 "f" }
|
||||
{ 1 "a" } { 2 "b" } { 3 "c" }
|
||||
} >splay-tree >alist
|
||||
} >splay >alist
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,59 +1,56 @@
|
|||
! Copyright (c) 2005 Mackenzie Straight.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math combinators assocs parser ;
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: arrays kernel math namespaces sequences assocs parser
|
||||
prettyprint.backend trees generic ;
|
||||
IN: trees.splay
|
||||
|
||||
TUPLE: splay-tree r count ;
|
||||
INSTANCE: splay-tree assoc
|
||||
TUPLE: splay ;
|
||||
|
||||
: <splay-tree> ( -- splay-tree )
|
||||
0 { set-splay-tree-count } splay-tree construct ;
|
||||
: <splay> ( -- splay-tree )
|
||||
\ splay construct-empty
|
||||
<tree> over set-delegate ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: splay-node v k l r ;
|
||||
|
||||
C: <splay-node> splay-node
|
||||
INSTANCE: splay assoc
|
||||
|
||||
: rotate-right ( node -- node )
|
||||
dup splay-node-l
|
||||
[ splay-node-r swap set-splay-node-l ] 2keep
|
||||
[ set-splay-node-r ] keep ;
|
||||
dup node-left
|
||||
[ node-right swap set-node-left ] 2keep
|
||||
[ set-node-right ] keep ;
|
||||
|
||||
: rotate-left ( node -- node )
|
||||
dup splay-node-r
|
||||
[ splay-node-l swap set-splay-node-r ] 2keep
|
||||
[ set-splay-node-l ] keep ;
|
||||
dup node-right
|
||||
[ node-left swap set-node-right ] 2keep
|
||||
[ set-node-left ] keep ;
|
||||
|
||||
: link-right ( left right key node -- left right key node )
|
||||
swap >r [ swap set-splay-node-l ] 2keep
|
||||
nip dup splay-node-l r> swap ;
|
||||
swap >r [ swap set-node-left ] 2keep
|
||||
nip dup node-left r> swap ;
|
||||
|
||||
: link-left ( left right key node -- left right key node )
|
||||
swap >r rot [ set-splay-node-r ] 2keep
|
||||
drop dup splay-node-r swapd r> swap ;
|
||||
swap >r rot [ set-node-right ] 2keep
|
||||
drop dup node-right swapd r> swap ;
|
||||
|
||||
: cmp ( key node -- obj node -1/0/1 )
|
||||
2dup splay-node-k <=> ;
|
||||
2dup node-key <=> ;
|
||||
|
||||
: lcmp ( key node -- obj node -1/0/1 )
|
||||
2dup splay-node-l splay-node-k <=> ;
|
||||
2dup node-left node-key <=> ;
|
||||
|
||||
: rcmp ( key node -- obj node -1/0/1 )
|
||||
2dup splay-node-r splay-node-k <=> ;
|
||||
2dup node-right node-key <=> ;
|
||||
|
||||
DEFER: (splay)
|
||||
|
||||
: splay-left ( left right key node -- left right key node )
|
||||
dup splay-node-l [
|
||||
dup node-left [
|
||||
lcmp 0 < [ rotate-right ] when
|
||||
dup splay-node-l [ link-right (splay) ] when
|
||||
dup node-left [ link-right (splay) ] when
|
||||
] when ;
|
||||
|
||||
: splay-right ( left right key node -- left right key node )
|
||||
dup splay-node-r [
|
||||
dup node-right [
|
||||
rcmp 0 > [ rotate-left ] when
|
||||
dup splay-node-r [ link-left (splay) ] when
|
||||
dup node-right [ link-left (splay) ] when
|
||||
] when ;
|
||||
|
||||
: (splay) ( left right key node -- left right key node )
|
||||
|
|
@ -61,118 +58,96 @@ DEFER: (splay)
|
|||
[ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
|
||||
|
||||
: assemble ( head left right node -- root )
|
||||
[ splay-node-r swap set-splay-node-l ] keep
|
||||
[ splay-node-l swap set-splay-node-r ] keep
|
||||
[ swap splay-node-l swap set-splay-node-r ] 2keep
|
||||
[ swap splay-node-r swap set-splay-node-l ] keep ;
|
||||
[ node-right swap set-node-left ] keep
|
||||
[ node-left swap set-node-right ] keep
|
||||
[ swap node-left swap set-node-right ] 2keep
|
||||
[ swap node-right swap set-node-left ] keep ;
|
||||
|
||||
: splay-at ( key node -- node )
|
||||
>r >r T{ splay-node } clone dup dup r> r>
|
||||
>r >r T{ node } clone dup dup r> r>
|
||||
(splay) nip assemble ;
|
||||
|
||||
: splay ( key tree -- )
|
||||
[ splay-tree-r splay-at ] keep set-splay-tree-r ;
|
||||
[ tree-root splay-at ] keep set-tree-root ;
|
||||
|
||||
: splay-split ( key tree -- node node )
|
||||
2dup splay splay-tree-r cmp 0 < [
|
||||
nip dup splay-node-l swap f over set-splay-node-l
|
||||
2dup splay tree-root cmp 0 < [
|
||||
nip dup node-left swap f over set-node-left
|
||||
] [
|
||||
nip dup splay-node-r swap f over set-splay-node-r swap
|
||||
nip dup node-right swap f over set-node-right swap
|
||||
] if ;
|
||||
|
||||
: (get-splay) ( key tree -- node ? )
|
||||
2dup splay splay-tree-r cmp 0 = [
|
||||
: get-splay ( key tree -- node ? )
|
||||
2dup splay tree-root cmp 0 = [
|
||||
nip t
|
||||
] [
|
||||
2drop f f
|
||||
] if ;
|
||||
|
||||
: get-largest ( node -- node )
|
||||
dup [ dup splay-node-r [ nip get-largest ] when* ] when ;
|
||||
dup [ dup node-right [ nip get-largest ] when* ] when ;
|
||||
|
||||
: splay-largest
|
||||
dup [ dup get-largest splay-node-k swap splay-at ] when ;
|
||||
dup [ dup get-largest node-key swap splay-at ] when ;
|
||||
|
||||
: splay-join ( n2 n1 -- node )
|
||||
splay-largest [
|
||||
[ set-splay-node-r ] keep
|
||||
[ set-node-right ] keep
|
||||
] [
|
||||
drop f
|
||||
] if* ;
|
||||
|
||||
: (remove-splay) ( key tree -- )
|
||||
tuck (get-splay) nip [
|
||||
dup splay-tree-count 1- over set-splay-tree-count
|
||||
dup splay-node-r swap splay-node-l splay-join
|
||||
swap set-splay-tree-r
|
||||
: remove-splay ( key tree -- )
|
||||
tuck get-splay nip [
|
||||
dup dec-count
|
||||
dup node-right swap node-left splay-join
|
||||
swap set-tree-root
|
||||
] [ drop ] if* ;
|
||||
|
||||
: (set-splay) ( value key tree -- )
|
||||
2dup (get-splay) [ 2nip set-splay-node-v ] [
|
||||
drop dup splay-tree-count 1+ over set-splay-tree-count
|
||||
: set-splay ( value key tree -- )
|
||||
2dup get-splay [ 2nip set-node-value ] [
|
||||
drop dup inc-count
|
||||
2dup splay-split rot
|
||||
>r <splay-node> r> set-splay-tree-r
|
||||
>r >r swapd r> node construct-boa r> set-tree-root
|
||||
] if ;
|
||||
|
||||
: new-root ( value key tree -- )
|
||||
[ 1 swap set-splay-tree-count ] keep
|
||||
>r f f <splay-node> r> set-splay-tree-r ;
|
||||
[ 1 swap set-tree-count ] keep
|
||||
>r swap <node> r> set-tree-root ;
|
||||
|
||||
: splay-call ( splay-node call -- )
|
||||
>r [ splay-node-k ] keep splay-node-v r> call ; inline
|
||||
|
||||
: (splay-tree-traverse) ( splay-node quot -- key value ? )
|
||||
{
|
||||
{ [ over not ] [ 2drop f f f ] }
|
||||
{ [ [
|
||||
>r splay-node-l r> (splay-tree-traverse)
|
||||
] 2keep rot ]
|
||||
[ 2drop t ] }
|
||||
{ [ >r 2nip r> [ splay-call ] 2keep rot ]
|
||||
[ drop [ splay-node-k ] keep splay-node-v t ] }
|
||||
{ [ t ] [ >r splay-node-r r> (splay-tree-traverse) ] }
|
||||
} cond ; inline
|
||||
M: splay set-at ( value key tree -- )
|
||||
dup tree-root [ set-splay ] [ new-root ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: splay-tree assoc-find ( splay-tree quot -- key value ? )
|
||||
#! quot: ( k v -- ? )
|
||||
#! Not tail recursive so will fail on large splay trees.
|
||||
>r splay-tree-r r> (splay-tree-traverse) ;
|
||||
|
||||
M: splay-tree set-at ( value key tree -- )
|
||||
dup splay-tree-r [ (set-splay) ] [ new-root ] if ;
|
||||
|
||||
M: splay-tree at* ( key tree -- value ? )
|
||||
dup splay-tree-r [
|
||||
(get-splay) >r dup [ splay-node-v ] when r>
|
||||
M: splay at* ( key tree -- value ? )
|
||||
dup tree-root [
|
||||
get-splay >r dup [ node-value ] when r>
|
||||
] [
|
||||
2drop f f
|
||||
] if ;
|
||||
|
||||
M: splay-tree delete-at ( key tree -- )
|
||||
dup splay-tree-r [ (remove-splay) ] [ 2drop ] if ;
|
||||
M: splay delete-at ( key tree -- )
|
||||
dup tree-root [ remove-splay ] [ 2drop ] if ;
|
||||
|
||||
M: splay-tree new-assoc
|
||||
2drop <splay-tree> ;
|
||||
M: splay new-assoc
|
||||
2drop <splay> ;
|
||||
|
||||
: >splay-tree ( assoc -- splay-tree )
|
||||
T{ splay-tree f f 0 } assoc-clone-like ;
|
||||
: >splay ( assoc -- splay-tree )
|
||||
T{ splay T{ tree f f 0 } } assoc-clone-like ;
|
||||
|
||||
: S{
|
||||
\ } [ >splay-tree ] parse-literal ; parsing
|
||||
: SPLAY{
|
||||
\ } [ >splay ] parse-literal ; parsing
|
||||
|
||||
M: splay-tree assoc-like
|
||||
drop dup splay-tree? [ >splay-tree ] unless ;
|
||||
M: splay assoc-like
|
||||
drop dup splay? [
|
||||
dup tree? [ <splay> tuck set-delegate ] [ >splay ] if
|
||||
] unless ;
|
||||
|
||||
M: splay-tree clear-assoc
|
||||
0 over set-splay-tree-count
|
||||
f swap set-splay-tree-r ;
|
||||
M: splay pprint-delims drop \ SPLAY{ \ } ;
|
||||
|
||||
M: splay-tree assoc-size
|
||||
splay-tree-count ;
|
||||
|
||||
USE: prettyprint.backend
|
||||
M: splay-tree pprint-delims drop \ S{ \ } ;
|
||||
M: splay-tree >pprint-sequence >alist ;
|
||||
M: splay-tree pprint-narrow? drop t ;
|
||||
! When tuple inheritance is used, the following lines won't be necessary
|
||||
M: splay assoc-size tree-count ;
|
||||
M: splay clear-assoc delegate clear-assoc ;
|
||||
M: splay assoc-find >r tree-root r> find-node ;
|
||||
M: splay clone dup assoc-clone-like ;
|
||||
M: splay >pprint-sequence >alist ;
|
||||
M: splay pprint-narrow? drop t ;
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
Binary search and avl (balanced) trees
|
||||
Binary search trees
|
||||
|
|
|
|||
|
|
@ -1,2 +0,0 @@
|
|||
- Make trees.splay use the same tree protocol as trees.binary and trees.avl
|
||||
- Make all trees follow the assoc protocol
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
USING: help.syntax help.markup trees assocs ;
|
||||
|
||||
HELP: TREE{
|
||||
{ $syntax "TREE{ { key value }... }" }
|
||||
{ $values { "key" "a key" } { "value" "a value" } }
|
||||
{ $description "Literal syntax for an unbalanced tree." } ;
|
||||
|
||||
HELP: <tree>
|
||||
{ $values { "tree" tree } }
|
||||
{ $description "Creates an empty unbalanced binary tree" } ;
|
||||
|
||||
HELP: >tree
|
||||
{ $values { "assoc" assoc } { "tree" tree } }
|
||||
{ $description "Converts any " { $link assoc } " into an unbalanced binary tree." } ;
|
||||
|
||||
HELP: tree
|
||||
{ $class-description "This is the class for unbalanced binary search trees. It is not usually intended to be used directly but rather as a basis for other trees." } ;
|
||||
|
||||
ARTICLE: { "trees" "intro" } "Binary search trees"
|
||||
"This is a library for unbalanced binary search trees. It is not intended to be used directly in most situations but rather as a base class for new trees, because performance can degrade to linear time storage/retrieval by the number of keys. These binary search trees conform to the assoc protocol."
|
||||
{ $subsection tree }
|
||||
{ $subsection <tree> }
|
||||
{ $subsection >tree }
|
||||
{ $subsection POSTPONE: TREE{ } ;
|
||||
|
||||
IN: trees
|
||||
ABOUT: { "trees" "intro" }
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
USING: trees assocs tools.test kernel sequences ;
|
||||
IN: temporary
|
||||
|
||||
: test-tree ( -- tree )
|
||||
TREE{
|
||||
{ 7 "seven" }
|
||||
{ 9 "nine" }
|
||||
{ 4 "four" }
|
||||
{ 4 "replaced four" }
|
||||
{ 7 "replaced seven" }
|
||||
} clone ;
|
||||
|
||||
! test set-at, at, at*
|
||||
[ "seven" ] [ <tree> "seven" 7 pick set-at 7 swap at ] unit-test
|
||||
[ "seven" t ] [ <tree> "seven" 7 pick set-at 7 swap at* ] unit-test
|
||||
[ f f ] [ <tree> "seven" 7 pick set-at 8 swap at* ] unit-test
|
||||
[ "seven" ] [ <tree> "seven" 7 pick set-at 7 swap at ] unit-test
|
||||
[ "replacement" ] [ <tree> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
|
||||
[ "replaced four" ] [ test-tree 4 swap at ] unit-test
|
||||
[ "nine" ] [ test-tree 9 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
|
||||
[ "replaced four" ] [ test-tree 9 over delete-at 4 swap at ] unit-test
|
||||
[ "nine" "replaced four" ] [ test-tree 7 over delete-at 9 over at 4 rot at ] unit-test
|
||||
[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test
|
||||
|
||||
|
|
@ -1,17 +1,19 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel generic math math.parser sequences arrays io namespaces
|
||||
namespaces.private random layouts ;
|
||||
USING: kernel generic math sequences arrays io namespaces
|
||||
prettyprint.private kernel.private assocs random combinators
|
||||
parser prettyprint.backend ;
|
||||
IN: trees
|
||||
|
||||
TUPLE: tree root ;
|
||||
TUPLE: tree root count ;
|
||||
: <tree> ( -- tree )
|
||||
f 0 tree construct-boa ;
|
||||
|
||||
: <tree> ( -- tree ) tree construct-empty ;
|
||||
INSTANCE: tree assoc
|
||||
|
||||
TUPLE: node key value left right ;
|
||||
|
||||
: <node> ( value key -- node )
|
||||
swap f f node construct-boa ;
|
||||
: <node> ( key value -- node )
|
||||
f f node construct-boa ;
|
||||
|
||||
SYMBOL: current-side
|
||||
|
||||
|
|
@ -20,28 +22,32 @@ SYMBOL: current-side
|
|||
|
||||
: 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
|
||||
: inc-count ( tree -- )
|
||||
dup tree-count 1+ swap set-tree-count ;
|
||||
|
||||
: 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 ;
|
||||
: dec-count ( tree -- )
|
||||
dup tree-count 1- swap set-tree-count ;
|
||||
|
||||
: with-side ( side quot -- ) H{ } clone >n swap current-side set call ndrop ; inline
|
||||
: node-link@ ( node ? -- node )
|
||||
go-left? xor [ node-left ] [ node-right ] if ;
|
||||
: set-node-link@ ( left parent ? -- )
|
||||
go-left? xor [ set-node-left ] [ set-node-right ] if ;
|
||||
|
||||
: node-link ( node -- child ) f node-link@ ;
|
||||
: set-node-link ( child node -- ) f set-node-link@ ;
|
||||
: node+link ( node -- child ) t node-link@ ;
|
||||
: set-node+link ( child node -- ) t set-node-link@ ;
|
||||
|
||||
: with-side ( side quot -- ) [ swap current-side set call ] with-scope ; 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 )
|
||||
: change-root ( tree quot -- )
|
||||
swap [ tree-root swap call ] keep set-tree-root ; inline
|
||||
|
||||
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> ;
|
||||
: leaf? ( node -- ? )
|
||||
dup node-left swap node-right or not ;
|
||||
|
||||
: key-side ( k1 k2 -- side )
|
||||
#! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
|
||||
|
|
@ -56,137 +62,143 @@ M: tree create-node ( value key tree -- node ) drop <node> ;
|
|||
: choose-branch ( key node -- key node-left/right )
|
||||
2dup node-key key-side [ node-link ] with-side ;
|
||||
|
||||
GENERIC: node-get ( key node -- value )
|
||||
: node-at* ( key node -- value ? )
|
||||
[
|
||||
2dup node-key key= [
|
||||
nip node-value t
|
||||
] [
|
||||
choose-branch node-at*
|
||||
] if
|
||||
] [ drop f f ] if* ;
|
||||
|
||||
: tree-get ( key tree -- value ) tree-root node-get ;
|
||||
M: tree at* ( key tree -- value ? )
|
||||
tree-root node-at* ;
|
||||
|
||||
M: node node-get ( key node -- value )
|
||||
2dup node-key key= [
|
||||
nip node-value
|
||||
: node-set ( value key node -- node )
|
||||
2dup node-key key-side dup zero? [
|
||||
drop nip [ set-node-value ] keep
|
||||
] [
|
||||
choose-branch node-get
|
||||
[
|
||||
[ node-link [ node-set ] [ swap <node> ] if* ] keep
|
||||
[ set-node-link ] keep
|
||||
] with-side
|
||||
] if ;
|
||||
|
||||
M: f node-get ( key f -- f ) nip ;
|
||||
M: tree set-at ( value key tree -- )
|
||||
[ [ node-set ] [ swap <node> ] if* ] change-root ;
|
||||
|
||||
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-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
|
||||
] [ t ] if* ;
|
||||
|
||||
: valid-tree? ( tree -- ? ) tree-root valid-node? ;
|
||||
|
||||
DEFER: print-tree
|
||||
: tree-call ( node call -- )
|
||||
>r [ node-key ] keep node-value r> call ; inline
|
||||
|
||||
: find-node ( node quot -- key value ? )
|
||||
{
|
||||
{ [ over not ] [ 2drop f f f ] }
|
||||
{ [ [
|
||||
>r node-left r> find-node
|
||||
] 2keep rot ]
|
||||
[ 2drop t ] }
|
||||
{ [ >r 2nip r> [ tree-call ] 2keep rot ]
|
||||
[ drop [ node-key ] keep node-value t ] }
|
||||
{ [ t ] [ >r node-right r> find-node ] }
|
||||
} cond ; inline
|
||||
|
||||
: random-tree ( tree size -- tree )
|
||||
[ most-positive-fixnum random pick tree-set ] each ;
|
||||
M: tree assoc-find ( tree quot -- key value ? )
|
||||
>r tree-root r> find-node ;
|
||||
|
||||
: increasing-tree ( tree size -- tree )
|
||||
[ dup pick tree-set ] each ;
|
||||
M: tree clear-assoc
|
||||
0 over set-tree-count
|
||||
f swap set-tree-root ;
|
||||
|
||||
: decreasing-tree ( tree size -- tree )
|
||||
reverse increasing-tree ;
|
||||
M: tree assoc-size
|
||||
tree-count ;
|
||||
|
||||
GENERIC: print-node ( depth node -- )
|
||||
: copy-node-contents ( new old -- )
|
||||
dup node-key pick set-node-key node-value swap set-node-value ;
|
||||
|
||||
M: f print-node ( depth f -- ) 2drop ;
|
||||
! Deletion
|
||||
DEFER: delete-node
|
||||
|
||||
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 ;
|
||||
: (prune-extremity) ( parent node -- new-extremity )
|
||||
dup node-link [
|
||||
rot drop (prune-extremity)
|
||||
] [
|
||||
tuck delete-node swap set-node-link
|
||||
] if* ;
|
||||
|
||||
: print-tree ( tree -- )
|
||||
tree-root 1 swap print-node ;
|
||||
: 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) ;
|
||||
|
||||
: stump? ( tree -- ? )
|
||||
#! is this tree empty?
|
||||
tree-root not ;
|
||||
: 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 ;
|
||||
|
||||
: delete-bst-node ( key node -- node )
|
||||
2dup node-key key-side dup zero? [
|
||||
drop nip delete-node
|
||||
] [
|
||||
[ tuck node-link delete-bst-node over set-node-link ] with-side
|
||||
] if ;
|
||||
|
||||
M: tree delete-at
|
||||
[ delete-bst-node ] change-root ;
|
||||
|
||||
M: tree new-assoc
|
||||
2drop <tree> ;
|
||||
|
||||
M: tree clone dup assoc-clone-like ;
|
||||
|
||||
: >tree ( assoc -- tree )
|
||||
T{ tree f f 0 } assoc-clone-like ;
|
||||
|
||||
GENERIC: tree-assoc-like ( assoc -- tree )
|
||||
M: tuple tree-assoc-like ! will need changes for tuple inheritance
|
||||
dup delegate dup tree? [ nip ] [ drop >tree ] if ;
|
||||
M: tree tree-assoc-like ;
|
||||
M: assoc tree-assoc-like >tree ;
|
||||
M: tree assoc-like drop tree-assoc-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