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

Trees on the assoc protocol

db4
Daniel Ehrenberg 2007-12-27 20:16:55 -05:00
parent 05b76f181f
commit 8a562bc81f
16 changed files with 156 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
extra/trees/authors.txt
View File

@ -1 +1,2 @@
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" }

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

@ -91,21 +91,22 @@ IN: temporary
tree-root node-value
] unit-test
[ "another eight" ] [
[ "another eight" ] [ ! ERROR!
<avl> "seven" 7 pick set-at
"another eight" 8 pick set-at 8 swap at
] unit-test
! borrowed from tests/bst.factor
: test-tree ( -- tree )
<avl>
"seven" 7 pick set-at
"nine" 9 pick set-at
"four" 4 pick set-at
"replaced four" 4 pick set-at
"replaced seven" 7 pick set-at ;
AVL{
{ 7 "seven" }
{ 9 "nine" }
{ 4 "four" }
{ 4 "replaced four" }
{ 7 "replaced seven" }
} clone ;
! 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
@ -115,7 +116,7 @@ IN: temporary
[ "replaced four" ] [ test-tree 4 swap at ] unit-test
[ "replaced seven" ] [ test-tree 7 swap at ] unit-test
! test delete-at
! 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

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

@ -52,22 +52,22 @@ TUPLE: avl-node balance ;
DEFER: avl-set
: (avl-insert) ( value key node -- node taller? )
[ avl-set ] [ <avl-node> t ] if* ;
: avl-insert ( value key node -- node taller? )
2dup node-key key< left right ? [
[ node-link (avl-insert) ] keep swap
[ 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? )
: (avl-set) ( value key node -- node taller? )
2dup node-key key= [
-rot pick set-node-key over set-node-value f
] [ avl-insert ] if ;
M: avl-node set-at ( value key node -- node )
: avl-set ( value key node -- node taller? )
[ (avl-set) ] [ <avl-node> t ] if* ;
M: avl set-at ( value key node -- node )
[ avl-set drop ] change-root ;
: delete-select-rotate ( node -- node shorter? )
@ -136,20 +136,23 @@ M: avl-node avl-delete ( key node -- node shorter? deleted? )
M: avl delete-at ( key node -- )
[ avl-delete 2drop ] change-root ;
M: avl new-assoc
2drop <avl> ;
M: avl new-assoc 2drop <avl> ;
: >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{ \ } ;
M: avl >pprint-sequence >alist ;
M: avl pprint-narrow? drop t ;
! When tuple inheritance is used, the following lines won't be necessary
M: avl assoc-size tree-count ;
M: avl clear-assoc delegate clear-assoc ;
M: avl assoc-find >r tree-root r> find-node ;
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" }

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

@ -143,10 +143,11 @@ M: splay assoc-like
] unless ;
M: splay pprint-delims drop \ SPLAY{ \ } ;
M: splay >pprint-sequence >alist ;
M: splay 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 ;

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

18
extra/trees/trees.factor
View File

@ -79,13 +79,13 @@ M: tree at* ( key tree -- value ? )
drop nip [ set-node-value ] keep
] [
[
[ node-link [ node-set ] [ <node> ] if* ] keep
[ node-link [ node-set ] [ swap <node> ] if* ] keep
[ set-node-link ] keep
] with-side
] if ;
M: tree set-at ( value key tree -- )
[ [ node-set ] [ <node> ] if* ] change-root ;
[ [ node-set ] [ swap <node> ] if* ] change-root ;
: valid-node? ( node -- ? )
[
@ -181,9 +181,21 @@ DEFER: delete-node
M: tree delete-at
[ delete-bst-node ] change-root ;
: >tree ( assoc -- bst )
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