From 8a562bc81fe5a427c20a1ee4488256af1b24d713 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 27 Dec 2007 20:16:55 -0500 Subject: [PATCH] Trees on the assoc protocol --- extra/trees/authors.txt | 1 + extra/trees/avl/authors.txt | 2 + extra/trees/avl/avl-docs.factor | 27 ++++++++ extra/trees/avl/avl-tests.factor | 19 +++--- extra/trees/avl/avl.factor | 23 ++++--- extra/trees/avl/summary.txt | 1 + extra/trees/binary/binary-tests.factor | 45 ------------- extra/trees/binary/binary.factor | 88 -------------------------- extra/trees/splay/authors.txt | 2 +- extra/trees/splay/splay-docs.factor | 27 ++++++++ extra/trees/splay/splay.factor | 5 +- extra/trees/summary.txt | 2 +- extra/trees/todo.txt | 2 - extra/trees/trees-docs.factor | 27 ++++++++ extra/trees/trees-tests.factor | 28 ++++++++ extra/trees/trees.factor | 18 +++++- 16 files changed, 156 insertions(+), 161 deletions(-) create mode 100644 extra/trees/avl/authors.txt create mode 100644 extra/trees/avl/avl-docs.factor create mode 100644 extra/trees/avl/summary.txt delete mode 100644 extra/trees/binary/binary-tests.factor delete mode 100644 extra/trees/binary/binary.factor create mode 100644 extra/trees/splay/splay-docs.factor delete mode 100644 extra/trees/todo.txt create mode 100644 extra/trees/trees-docs.factor create mode 100644 extra/trees/trees-tests.factor diff --git a/extra/trees/authors.txt b/extra/trees/authors.txt index e9c193bac7..39c1f37d37 100644 --- a/extra/trees/authors.txt +++ b/extra/trees/authors.txt @@ -1 +1,2 @@ Alex Chapman +Daniel Ehrenberg diff --git a/extra/trees/avl/authors.txt b/extra/trees/avl/authors.txt new file mode 100644 index 0000000000..39c1f37d37 --- /dev/null +++ b/extra/trees/avl/authors.txt @@ -0,0 +1,2 @@ +Alex Chapman +Daniel Ehrenberg diff --git a/extra/trees/avl/avl-docs.factor b/extra/trees/avl/avl-docs.factor new file mode 100644 index 0000000000..12465eec98 --- /dev/null +++ b/extra/trees/avl/avl-docs.factor @@ -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: +{ $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 } +{ $subsection >avl } +{ $subsection POSTPONE: AVL{ } ; + +IN: trees.avl +ABOUT: { "avl" "intro" } diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index 5cea2c1c35..0964ea7e56 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -91,21 +91,22 @@ IN: temporary tree-root node-value ] unit-test -[ "another eight" ] [ +[ "another eight" ] [ ! ERROR! "seven" 7 pick set-at "another eight" 8 pick set-at 8 swap at ] unit-test -! borrowed from tests/bst.factor : test-tree ( -- tree ) - - "seven" 7 pick 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" ] [ "seven" 7 pick set-at 7 swap at ] unit-test [ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test [ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test @@ -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 diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 03741b5ecd..0c4bf5af28 100644 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -52,22 +52,22 @@ TUPLE: avl-node balance ; DEFER: avl-set -: (avl-insert) ( value key node -- node taller? ) - [ avl-set ] [ t ] if* ; - : avl-insert ( value key node -- node taller? ) 2dup node-key key< left right ? [ - [ node-link (avl-insert) ] keep swap + [ 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) ] [ 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 ; +M: avl new-assoc 2drop ; : >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 ; diff --git a/extra/trees/avl/summary.txt b/extra/trees/avl/summary.txt new file mode 100644 index 0000000000..c2360c2ed3 --- /dev/null +++ b/extra/trees/avl/summary.txt @@ -0,0 +1 @@ +Balanced AVL trees diff --git a/extra/trees/binary/binary-tests.factor b/extra/trees/binary/binary-tests.factor deleted file mode 100644 index 7abf2f0da5..0000000000 --- a/extra/trees/binary/binary-tests.factor +++ /dev/null @@ -1,45 +0,0 @@ -USING: trees trees.binary tools.test kernel sequences ; -IN: temporary - -: test-tree ( -- tree ) - - "seven" 7 pick tree-insert - "nine" 9 pick tree-insert - "four" 4 pick tree-insert - "another four" 4 pick tree-insert - "replaced seven" 7 pick tree-set ; - -! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all -[ "seven" ] [ "seven" 7 pick tree-insert 7 swap tree-get ] unit-test -[ "seven" t ] [ "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test -[ f f ] [ "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test -[ "seven" ] [ "seven" 7 pick tree-set 7 swap tree-get ] unit-test -[ "replacement" ] [ "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test -[ "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 ] [ 10 random-tree valid-tree? ] unit-test - diff --git a/extra/trees/binary/binary.factor b/extra/trees/binary/binary.factor deleted file mode 100644 index 5fc7abc636..0000000000 --- a/extra/trees/binary/binary.factor +++ /dev/null @@ -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 ; - -: ( -- tree ) bst construct-empty over set-delegate ; - -TUPLE: bst-node ; - -: ( value key -- node ) - bst-node construct-empty tuck set-delegate ; - -M: bst create-node ( value key tree -- node ) drop ; - -M: bst-node node-insert ( value key node -- node ) - 2dup node-key key-side [ - [ node-link [ node-insert ] [ ] 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 ] [ ] 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 ; - diff --git a/extra/trees/splay/authors.txt b/extra/trees/splay/authors.txt index 09839c9c91..a2c0a7cc80 100644 --- a/extra/trees/splay/authors.txt +++ b/extra/trees/splay/authors.txt @@ -1 +1 @@ -Mackenzie Straight +Mackenzie Straight, Daniel Ehrenberg diff --git a/extra/trees/splay/splay-docs.factor b/extra/trees/splay/splay-docs.factor new file mode 100644 index 0000000000..b621155e73 --- /dev/null +++ b/extra/trees/splay/splay-docs.factor @@ -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: +{ $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 } +{ $subsection >splay } +{ $subsection POSTPONE: SPLAY{ } ; + +IN: trees.splay +ABOUT: { "splay" "intro" } diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index dd40a77501..5f7c50cfb2 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -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 ; diff --git a/extra/trees/summary.txt b/extra/trees/summary.txt index cf7b64c8a1..18ad35db8f 100644 --- a/extra/trees/summary.txt +++ b/extra/trees/summary.txt @@ -1 +1 @@ -Binary search and avl (balanced) trees +Binary search trees diff --git a/extra/trees/todo.txt b/extra/trees/todo.txt deleted file mode 100644 index 7eb295302a..0000000000 --- a/extra/trees/todo.txt +++ /dev/null @@ -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 diff --git a/extra/trees/trees-docs.factor b/extra/trees/trees-docs.factor new file mode 100644 index 0000000000..12bae4bac5 --- /dev/null +++ b/extra/trees/trees-docs.factor @@ -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: +{ $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 } +{ $subsection >tree } +{ $subsection POSTPONE: TREE{ } ; + +IN: trees +ABOUT: { "trees" "intro" } diff --git a/extra/trees/trees-tests.factor b/extra/trees/trees-tests.factor new file mode 100644 index 0000000000..2795b0d5da --- /dev/null +++ b/extra/trees/trees-tests.factor @@ -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" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test +[ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "replacement" ] [ "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test +[ "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 + diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 55031f77cb..971c961cbc 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -79,13 +79,13 @@ M: tree at* ( key tree -- value ? ) drop nip [ set-node-value ] keep ] [ [ - [ node-link [ node-set ] [ ] if* ] keep + [ node-link [ node-set ] [ swap ] if* ] keep [ set-node-link ] keep ] with-side ] if ; M: tree set-at ( value key tree -- ) - [ [ node-set ] [ ] if* ] change-root ; + [ [ node-set ] [ swap ] 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 ; + +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