diff --git a/extra/trees/avl/avl-docs.factor b/extra/trees/avl/avl-docs.factor index 53e40da21e..c1a8ea116b 100644 --- a/extra/trees/avl/avl-docs.factor +++ b/extra/trees/avl/avl-docs.factor @@ -1,4 +1,4 @@ -USING: help.syntax help.markup assocs ; +USING: assocs help.markup help.syntax trees ; IN: trees.avl HELP: AVL{ @@ -12,7 +12,7 @@ HELP: HELP: >avl { $values { "assoc" assoc } { "avl" avl } } -{ $description "Converts any " { $link assoc } " into an AVL tree." } ; +{ $description "Converts any " { $link assoc } " into an AVL tree. If the input assoc is any kind of " { $link tree } ", the elements are added in level order (breadth-first search) to attempt to copy it's shape." } ; 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." } ; diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index a9086e5bf1..65bbdf5cd1 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test trees trees.avl math random sequences -assocs accessors trees.avl.private trees.private ; +assocs accessors trees.avl.private trees.private arrays ; IN: trees.avl.tests { "key1" 0 "key3" "key2" 0 } [ @@ -123,3 +123,7 @@ IN: trees.avl.tests ! test assoc-size { 3 } [ test-tree assoc-size ] unit-test { 2 } [ test-tree 9 over delete-at assoc-size ] unit-test + +! test that converting from a balanced tree doesn't reshape +! the tree +{ t } [ 10 iota >array reverse dup zip >avl dup >avl = ] unit-test diff --git a/extra/trees/splay/splay-docs.factor b/extra/trees/splay/splay-docs.factor index f3f854c03c..4e5338c188 100644 --- a/extra/trees/splay/splay-docs.factor +++ b/extra/trees/splay/splay-docs.factor @@ -1,4 +1,4 @@ -USING: help.syntax help.markup assocs ; +USING: assocs help.markup help.syntax trees ; IN: trees.splay HELP: SPLAY{ @@ -12,7 +12,7 @@ HELP: HELP: >splay { $values { "assoc" assoc } { "tree" splay } } -{ $description "Converts any " { $link assoc } " into an splay tree." } ; +{ $description "Converts any " { $link assoc } " into an splay tree. If the input assoc is any kind of " { $link tree } ", the elements are added in reverse level order (reverse breadth-first search) to attempt to copy it's shape." } ; 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." } ; diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor index b5309ebdad..db4302f5e3 100644 --- a/extra/trees/splay/splay-tests.factor +++ b/extra/trees/splay/splay-tests.factor @@ -49,3 +49,8 @@ IN: trees.splay.tests ! test assoc-size { 3 } [ test-tree assoc-size ] unit-test { 2 } [ test-tree 9 over delete-at assoc-size ] unit-test + +! Test that converting trees doesn't give linked lists +{ + SPLAY{ { 1 1 } { 3 3 } { 2 2 } } +} [ SPLAY{ { 1 1 } { 3 3 } { 2 2 } } >splay ] unit-test diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index 79a4fc2b6b..03ca7aa85d 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators kernel math.order parser -prettyprint.custom trees trees.private typed ; +prettyprint.custom sequences trees trees.private typed ; IN: trees.splay TUPLE: splay < tree ; @@ -131,6 +131,9 @@ M: splay delete-at M: splay new-assoc 2drop ; +M: splay assoc-clone-like + [ dup tree? [ >bfs-alist reverse ] when ] dip call-next-method ; + PRIVATE> : >splay ( assoc -- tree ) diff --git a/extra/trees/trees-docs.factor b/extra/trees/trees-docs.factor index ba8bcac24e..5df07e4ef3 100644 --- a/extra/trees/trees-docs.factor +++ b/extra/trees/trees-docs.factor @@ -12,7 +12,7 @@ HELP: HELP: >tree { $values { "assoc" assoc } { "tree" tree } } -{ $description "Converts any " { $link assoc } " into an unbalanced binary tree." } ; +{ $description "Converts any " { $link assoc } " into an unbalanced binary tree. If the input assoc is any kind of " { $link tree } ", the elements are added in level order (breadth-first search) to copy it's shape." } ; 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." } ; diff --git a/extra/trees/trees-tests.factor b/extra/trees/trees-tests.factor index dcde69ba28..fa1768aadc 100644 --- a/extra/trees/trees-tests.factor +++ b/extra/trees/trees-tests.factor @@ -39,6 +39,18 @@ IN: trees.tests { 4 "four" } } clone ] unit-test +! test that converting from any tree to a basic tree doesn't reshape +! the tree +{ TREE{ + { 7 "seven" } + { 9 "nine" } + { 4 "four" } +} } [ TREE{ + { 7 "seven" } + { 9 "nine" } + { 4 "four" } +} >tree ] unit-test + ! test height { 0 } [ TREE{ } height ] unit-test diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index dafb182575..905ed6d9f1 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators -combinators.short-circuit kernel locals make math math.order -namespaces parser prettyprint.custom random sequences ; +combinators.short-circuit deques dlists kernel locals make math +math.order namespaces parser prettyprint.custom random sequences +vectors ; IN: trees TUPLE: tree root { count integer } ; @@ -122,13 +123,14 @@ M: tree set-at : valid-tree? ( tree -- ? ) root>> valid-node? ; -: node-alist, ( node -- ) - [ key>> ] [ value>> ] bi 2array , ; +: node>entry ( node -- entry ) [ key>> ] [ value>> ] bi 2array ; + +: entry, ( node -- ) node>entry , ; : (node>alist) ( node -- ) [ [ left>> (node>alist) ] - [ node-alist, ] + [ entry, ] [ right>> (node>alist) ] tri ] when* ; @@ -145,7 +147,7 @@ M: tree >alist ] if node-left? [ - node [ node-alist, ] [ + node [ entry, ] [ right>> [ to-key ] dip end-comparator (node>subalist-right) ] bi @@ -160,7 +162,7 @@ M: tree >alist node [ left>> [ from-key ] dip start-comparator (node>subalist-left) - ] [ node-alist, ] bi + ] [ entry, ] bi ] when node right>> node-right? [ (node>alist) ] [ @@ -182,7 +184,7 @@ M: tree >alist ] if ] when - node-right? node-left? and [ node node-alist, ] when + node-right? node-left? and [ node entry, ] when node-left? [ to-key node right>> node-right? @@ -277,8 +279,6 @@ PRIVATE> : last-node ( tree -- node ) root>> dup [ right-extremity ] when ; -: node>entry ( node -- entry ) [ key>> ] [ value>> ] bi 2array ; - PRIVATE> : lower-entry ( key tree -- pair/f ) lower-node dup [ node>entry ] when ; @@ -385,6 +385,25 @@ M: tree new-assoc M: tree clone (clone) [ clone-nodes ] change-root ; +: ?push-children ( node queue -- ) + [ [ left>> ] [ right>> ] bi ] + [ [ over [ push-front ] [ 2drop ] if ] curry bi@ ] bi* ; + +: each-bfs-node ( tree quot: ( ... entry -- ... ) -- ... ) + [ root>> [ push-front ] keep dup ] dip + [ + [ drop node>entry ] prepose + [ ?push-children ] 2bi + ] 2curry slurp-deque ; inline + +: >bfs-alist ( tree -- alist ) + dup assoc-size [ + [ push ] curry each-bfs-node + ] keep ; + +M: tree assoc-clone-like + [ dup tree? [ >bfs-alist ] when ] dip call-next-method ; + PRIVATE> : >tree ( assoc -- tree )