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

Merge http://littledan.onigirihouse.com/factor

db4
Doug Coleman 2007-12-28 11:04:44 -06:00
parent c1c9f5eddd c936895160
commit 67fe34ba88
18 changed files with 457 additions and 524 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
extra/sequences/deep/deep.factor
View File

@ -5,11 +5,10 @@ IN: sequences.deep
! All traversal goes in postorder ! All traversal goes in postorder
GENERIC: branch? ( object -- ? ) : branch? ( object -- ? )
M: sequence branch? drop t ; dup sequence? [
M: string branch? drop f ; dup string? swap number? or not
M: number branch? drop f ; ] [ drop f ] if ;
M: object branch? drop f ;
: deep-each ( obj quot -- ) : deep-each ( obj quot -- )
[ call ] 2keep over branch? [ call ] 2keep over branch?

1
extra/trees/authors.txt
View File

@ -1 +1,2 @@
Alex Chapman Alex Chapman
Daniel Ehrenberg

2
extra/trees/avl/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Alex Chapman
Daniel Ehrenberg

27
extra/trees/avl/avl-docs.factor Normal file
View File

@ -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" }

133
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,38 @@ 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" ] [ ! ERROR!
[ "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
: test-tree ( -- tree ) : test-tree ( -- tree )
<avl-tree> AVL{
"seven" 7 pick tree-insert { 7 "seven" }
"nine" 9 pick tree-insert { 9 "nine" }
"four" 4 pick tree-insert { 4 "four" }
"another four" 4 pick tree-insert { 4 "replaced four" }
"replaced seven" 7 pick tree-set ; { 7 "replaced seven" }
} clone ;
! 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 [ t ] [ test-tree avl? ] unit-test
[ "seven" t ] [ <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
[ f f ] [ <avl-tree> "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test [ "seven" t ] [ <avl> "seven" 7 pick set-at 7 swap at* ] unit-test
[ "seven" ] [ <avl-tree> "seven" 7 pick tree-set 7 swap tree-get ] unit-test [ f f ] [ <avl> "seven" 7 pick set-at 8 swap at* ] unit-test
[ "replacement" ] [ <avl-tree> "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test [ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
[ "nine" ] [ test-tree 9 swap tree-get ] unit-test [ "replacement" ] [ <avl> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
[ t ] [ test-tree 4 swap tree-get-all { "another four" "four" } sequence= ] unit-test [ "nine" ] [ test-tree 9 swap at ] unit-test
[ t ] [ test-tree 11 swap tree-get-all empty? ] unit-test [ "replaced four" ] [ test-tree 4 swap at ] unit-test
[ t ] [ test-tree 7 swap tree-get-all { "replaced seven" } sequence= ] unit-test [ "replaced seven" ] [ test-tree 7 swap at ] 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--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

116
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-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= [ 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? ) : avl-set ( value key node -- node taller? )
"setting" get [ avl-set ] [ avl-insert ] if ; [ (avl-set) ] [ <avl-node> t ] if* ;
: (avl-insert) ( value key node -- node taller? ) M: avl set-at ( value key node -- node )
[ avl-insert-or-set ] [ <avl-node> t ] if* ; [ avl-set drop ] change-root ;
: 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,36 @@ 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 2drop <avl> ;
#! deletes until there are no more. not optimal.
dupd [ avl-delete nip ] with-scope [
node-delete-all
] [
nip
] if ;
M: avl-node print-node ( depth node -- ) : >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 ;
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 ;

1
extra/trees/avl/summary.txt Normal file
View File

@ -0,0 +1 @@
Balanced AVL trees

45
extra/trees/binary/binary-tests.factor
View File

@ -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

88
extra/trees/binary/binary.factor
View File

@ -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 ;

2
extra/trees/splay/authors.txt
View File

@ -1 +1 @@
Mackenzie Straight Mackenzie Straight, Daniel Ehrenberg

27
extra/trees/splay/splay-docs.factor Normal file
View File

@ -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
extra/trees/splay/splay-tests.factor
View File

@ -8,7 +8,7 @@ IN: temporary
100 [ drop 100 random swap at drop ] curry* each ; 100 [ drop 100 random swap at drop ] curry* each ;
: make-numeric-splay-tree ( n -- splay-tree ) : make-numeric-splay-tree ( n -- splay-tree )
dup <splay-tree> -rot [ pick set-at ] 2each ; <splay> [ [ dupd set-at ] curry each ] keep ;
[ t ] [ [ t ] [
100 make-numeric-splay-tree dup randomize-numeric-splay-tree 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 keys length ] unit-test
[ 10 ] [ 10 make-numeric-splay-tree values 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 ! 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" } } { { 1 "a" } { 2 "b" } { 3 "c" } { 4 "d" } { 5 "e" } { 6 "f" } }
@ -29,5 +29,5 @@ IN: temporary
{ {
{ 4 "d" } { 5 "e" } { 6 "f" } { 4 "d" } { 5 "e" } { 6 "f" }
{ 1 "a" } { 2 "b" } { 3 "c" } { 1 "a" } { 2 "b" } { 3 "c" }
} >splay-tree >alist } >splay >alist
] unit-test ] unit-test

175
extra/trees/splay/splay.factor
View File

@ -1,59 +1,56 @@
! Copyright (c) 2005 Mackenzie Straight. ! Copyright (c) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
USING: kernel math combinators assocs parser ; USING: arrays kernel math namespaces sequences assocs parser
prettyprint.backend trees generic ;
IN: trees.splay IN: trees.splay
TUPLE: splay-tree r count ; TUPLE: splay ;
INSTANCE: splay-tree assoc
: <splay-tree> ( -- splay-tree ) : <splay> ( -- splay-tree )
0 { set-splay-tree-count } splay-tree construct ; \ splay construct-empty
<tree> over set-delegate ;
<PRIVATE INSTANCE: splay assoc
TUPLE: splay-node v k l r ;
C: <splay-node> splay-node
: rotate-right ( node -- node ) : rotate-right ( node -- node )
dup splay-node-l dup node-left
[ splay-node-r swap set-splay-node-l ] 2keep [ node-right swap set-node-left ] 2keep
[ set-splay-node-r ] keep ; [ set-node-right ] keep ;
: rotate-left ( node -- node ) : rotate-left ( node -- node )
dup splay-node-r dup node-right
[ splay-node-l swap set-splay-node-r ] 2keep [ node-left swap set-node-right ] 2keep
[ set-splay-node-l ] keep ; [ set-node-left ] keep ;
: link-right ( left right key node -- left right key node ) : link-right ( left right key node -- left right key node )
swap >r [ swap set-splay-node-l ] 2keep swap >r [ swap set-node-left ] 2keep
nip dup splay-node-l r> swap ; nip dup node-left r> swap ;
: link-left ( left right key node -- left right key node ) : link-left ( left right key node -- left right key node )
swap >r rot [ set-splay-node-r ] 2keep swap >r rot [ set-node-right ] 2keep
drop dup splay-node-r swapd r> swap ; drop dup node-right swapd r> swap ;
: cmp ( key node -- obj node -1/0/1 ) : cmp ( key node -- obj node -1/0/1 )
2dup splay-node-k <=> ; 2dup node-key <=> ;
: lcmp ( key node -- obj node -1/0/1 ) : 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 ) : rcmp ( key node -- obj node -1/0/1 )
2dup splay-node-r splay-node-k <=> ; 2dup node-right node-key <=> ;
DEFER: (splay) DEFER: (splay)
: splay-left ( left right key node -- left right key node ) : splay-left ( left right key node -- left right key node )
dup splay-node-l [ dup node-left [
lcmp 0 < [ rotate-right ] when lcmp 0 < [ rotate-right ] when
dup splay-node-l [ link-right (splay) ] when dup node-left [ link-right (splay) ] when
] when ; ] when ;
: splay-right ( left right key node -- left right key node ) : splay-right ( left right key node -- left right key node )
dup splay-node-r [ dup node-right [
rcmp 0 > [ rotate-left ] when rcmp 0 > [ rotate-left ] when
dup splay-node-r [ link-left (splay) ] when dup node-right [ link-left (splay) ] when
] when ; ] when ;
: (splay) ( left right key node -- left right key node ) : (splay) ( left right key node -- left right key node )
@ -61,118 +58,96 @@ DEFER: (splay)
[ drop splay-left ] [ 0 > [ splay-right ] when ] if ; [ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
: assemble ( head left right node -- root ) : assemble ( head left right node -- root )
[ splay-node-r swap set-splay-node-l ] keep [ node-right swap set-node-left ] keep
[ splay-node-l swap set-splay-node-r ] keep [ node-left swap set-node-right ] keep
[ swap splay-node-l swap set-splay-node-r ] 2keep [ swap node-left swap set-node-right ] 2keep
[ swap splay-node-r swap set-splay-node-l ] keep ; [ swap node-right swap set-node-left ] keep ;
: splay-at ( key node -- node ) : 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) nip assemble ;
: splay ( key tree -- ) : 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 ) : splay-split ( key tree -- node node )
2dup splay splay-tree-r cmp 0 < [ 2dup splay tree-root cmp 0 < [
nip dup splay-node-l swap f over set-splay-node-l 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 ; ] if ;
: (get-splay) ( key tree -- node ? ) : get-splay ( key tree -- node ? )
2dup splay splay-tree-r cmp 0 = [ 2dup splay tree-root cmp 0 = [
nip t nip t
] [ ] [
2drop f f 2drop f f
] if ; ] if ;
: get-largest ( node -- node ) : 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 : 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-join ( n2 n1 -- node )
splay-largest [ splay-largest [
[ set-splay-node-r ] keep [ set-node-right ] keep
] [ ] [
drop f drop f
] if* ; ] if* ;
: (remove-splay) ( key tree -- ) : remove-splay ( key tree -- )
tuck (get-splay) nip [ tuck get-splay nip [
dup splay-tree-count 1- over set-splay-tree-count dup dec-count
dup splay-node-r swap splay-node-l splay-join dup node-right swap node-left splay-join
swap set-splay-tree-r swap set-tree-root
] [ drop ] if* ; ] [ drop ] if* ;
: (set-splay) ( value key tree -- ) : set-splay ( value key tree -- )
2dup (get-splay) [ 2nip set-splay-node-v ] [ 2dup get-splay [ 2nip set-node-value ] [
drop dup splay-tree-count 1+ over set-splay-tree-count drop dup inc-count
2dup splay-split rot 2dup splay-split rot
>r <splay-node> r> set-splay-tree-r >r >r swapd r> node construct-boa r> set-tree-root
] if ; ] if ;
: new-root ( value key tree -- ) : new-root ( value key tree -- )
[ 1 swap set-splay-tree-count ] keep [ 1 swap set-tree-count ] keep
>r f f <splay-node> r> set-splay-tree-r ; >r swap <node> r> set-tree-root ;
: splay-call ( splay-node call -- ) M: splay set-at ( value key tree -- )
>r [ splay-node-k ] keep splay-node-v r> call ; inline dup tree-root [ set-splay ] [ new-root ] if ;
: (splay-tree-traverse) ( splay-node quot -- key value ? ) M: splay at* ( key tree -- value ? )
{ dup tree-root [
{ [ over not ] [ 2drop f f f ] } get-splay >r dup [ node-value ] when r>
{ [ [
>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
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>
] [ ] [
2drop f f 2drop f f
] if ; ] if ;
M: splay-tree delete-at ( key tree -- ) M: splay delete-at ( key tree -- )
dup splay-tree-r [ (remove-splay) ] [ 2drop ] if ; dup tree-root [ remove-splay ] [ 2drop ] if ;
M: splay-tree new-assoc M: splay new-assoc
2drop <splay-tree> ; 2drop <splay> ;
: >splay-tree ( assoc -- splay-tree ) : >splay ( assoc -- splay-tree )
T{ splay-tree f f 0 } assoc-clone-like ; T{ splay T{ tree f f 0 } } assoc-clone-like ;
: S{ : SPLAY{
\ } [ >splay-tree ] parse-literal ; parsing \ } [ >splay ] parse-literal ; parsing
M: splay-tree assoc-like M: splay assoc-like
drop dup splay-tree? [ >splay-tree ] unless ; drop dup splay? [
dup tree? [ <splay> tuck set-delegate ] [ >splay ] if
] unless ;
M: splay-tree clear-assoc M: splay pprint-delims drop \ SPLAY{ \ } ;
0 over set-splay-tree-count
f swap set-splay-tree-r ;
M: splay-tree assoc-size ! When tuple inheritance is used, the following lines won't be necessary
splay-tree-count ; M: splay assoc-size tree-count ;
M: splay clear-assoc delegate clear-assoc ;
USE: prettyprint.backend M: splay assoc-find >r tree-root r> find-node ;
M: splay-tree pprint-delims drop \ S{ \ } ; M: splay clone dup assoc-clone-like ;
M: splay-tree >pprint-sequence >alist ; M: splay >pprint-sequence >alist ;
M: splay-tree pprint-narrow? drop t ; M: splay pprint-narrow? drop t ;

2
extra/trees/summary.txt
View File

@ -1 +1 @@
Binary search and avl (balanced) trees Binary search trees

2
extra/trees/todo.txt
View File

@ -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

27
extra/trees/trees-docs.factor Normal file
View File

@ -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" }

28
extra/trees/trees-tests.factor Normal file
View File

@ -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

278
extra/trees/trees.factor
View File

@ -1,17 +1,19 @@
! 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 math.parser sequences arrays io namespaces USING: kernel generic math sequences arrays io namespaces
namespaces.private random layouts ; prettyprint.private kernel.private assocs random combinators
parser prettyprint.backend ;
IN: trees 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 ; TUPLE: node key value left right ;
: <node> ( key value -- node )
: <node> ( value key -- node ) f f node construct-boa ;
swap f f node construct-boa ;
SYMBOL: current-side SYMBOL: current-side
@ -20,28 +22,32 @@ SYMBOL: current-side
: go-left? ( -- ? ) current-side get left = ; : go-left? ( -- ? ) current-side get left = ;
: node-link@ ( -- ? quot quot ) go-left? [ node-left ] [ node-right ] ; inline : inc-count ( tree -- )
: set-node-link@ ( -- ? quot quot ) go-left? [ set-node-left ] [ set-node-right ] ; inline dup tree-count 1+ swap set-tree-count ;
: node-link ( node -- child ) node-link@ if ; : dec-count ( tree -- )
: set-node-link ( child node -- ) set-node-link@ if ; dup tree-count 1- swap set-tree-count ;
: node+link ( node -- child ) node-link@ swap if ;
: set-node+link ( child node -- ) set-node-link@ swap if ;
: with-side ( side quot -- ) H{ } clone >n swap current-side set call ndrop ; inline : 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 : with-other-side ( quot -- ) current-side get neg swap with-side ; inline
: go-left ( quot -- ) left swap with-side ; inline : go-left ( quot -- ) left swap with-side ; inline
: go-right ( quot -- ) right 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 -- ) : leaf? ( node -- ? )
dup node-left swap node-right or not ;
M: node copy-node-contents ( new old -- )
#! copy old's key and value into new (keeping children and parent)
dup node-key pick set-node-key node-value swap set-node-value ;
M: tree create-node ( value key tree -- node ) drop <node> ;
: key-side ( k1 k2 -- side ) : key-side ( k1 k2 -- side )
#! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2 #! 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 ) : choose-branch ( key node -- key node-left/right )
2dup node-key key-side [ node-link ] with-side ; 2dup node-key key-side [ node-link ] with-side ;
GENERIC: node-get ( key node -- value ) : node-at* ( key node -- value ? )
[
: tree-get ( key tree -- value ) tree-root node-get ;
M: node node-get ( key node -- value )
2dup node-key key= [
nip node-value
] [
choose-branch node-get
] if ;
M: f node-get ( key f -- f ) nip ;
GENERIC: node-get* ( key node -- value ? )
: tree-get* ( key tree -- value ? ) tree-root node-get* ;
M: node node-get* ( key node -- value ? )
2dup node-key key= [ 2dup node-key key= [
nip node-value t nip node-value t
] [ ] [
choose-branch node-get* choose-branch node-at*
] if ; ] if
] [ drop f f ] if* ;
M: f node-get* ( key f -- f f ) nip f ; M: tree at* ( key tree -- value ? )
tree-root node-at* ;
GENERIC: node-get-all ( key node -- seq ) : node-set ( value key node -- node )
2dup node-key key-side dup zero? [
: tree-get-all ( key tree -- seq ) tree-root node-get-all ; drop nip [ set-node-value ] keep
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 [
[ node-link [ node-set ] [ swap <node> ] if* ] keep
[ set-node-link ] keep
] with-side
] if ; ] if ;
GENERIC: node-insert ( value key node -- node ) ! can add duplicates M: tree set-at ( value key tree -- )
[ [ node-set ] [ swap <node> ] if* ] change-root ;
: tree-insert ( value key tree -- ) : valid-node? ( node -- ? )
[ 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-left [ node-key swap node-key key< ] when* >r
dup dup node-right [ node-key swap node-key key> ] when* r> and swap 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 ; dup node-left valid-node? swap node-right valid-node? and and
] [ t ] if* ;
: valid-tree? ( tree -- ? ) tree-root valid-node? ; : valid-tree? ( tree -- ? ) tree-root valid-node? ;
DEFER: print-tree : tree-call ( node call -- )
>r [ node-key ] keep node-value r> call ; inline
: random-tree ( tree size -- tree ) : find-node ( node quot -- key value ? )
[ most-positive-fixnum random pick tree-set ] each ; {
{ [ 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
: increasing-tree ( tree size -- tree ) M: tree assoc-find ( tree quot -- key value ? )
[ dup pick tree-set ] each ; >r tree-root r> find-node ;
: decreasing-tree ( tree size -- tree ) M: tree clear-assoc
reverse increasing-tree ; 0 over set-tree-count
f swap set-tree-root ;
GENERIC: print-node ( depth node -- ) M: tree assoc-size
tree-count ;
M: f print-node ( depth f -- ) 2drop ; : copy-node-contents ( new old -- )
dup node-key pick set-node-key node-value swap set-node-value ;
M: node print-node ( depth node -- ) ! Deletion
! not pretty, but ok for debugging DEFER: delete-node
over 1+ over node-right print-node
over [ drop " " write ] each dup node-key number>string print
>r 1+ r> node-left print-node ;
: print-tree ( tree -- ) : (prune-extremity) ( parent node -- new-extremity )
tree-root 1 swap print-node ; dup node-link [
rot drop (prune-extremity)
] [
tuck delete-node swap set-node-link
] if* ;
: stump? ( tree -- ? ) : prune-extremity ( node -- new-extremity )
#! is this tree empty? #! remove and return the leftmost or rightmost child of this node.
tree-root not ; #! 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 ;
: 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 ;