trees, attempt to keep shape during conersions

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: <avl>
 
 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." } ;

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

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: <splay>
 
 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." } ;

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

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 <splay> ;
 
+M: splay assoc-clone-like
+    [ dup tree? [ >bfs-alist reverse ] when ] dip call-next-method ;
+
 PRIVATE>
 
 : >splay ( assoc -- tree )

extra/trees/trees-docs.factor

@@ -12,7 +12,7 @@ HELP: <tree>
 
 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." } ;

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
 

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>> <dlist> [ push-front ] keep dup ] dip
+    [
+        [ drop node>entry ] prepose
+        [ ?push-children ] 2bi
+    ] 2curry slurp-deque ; inline
+
+: >bfs-alist ( tree -- alist )
+    dup assoc-size <vector> [
+        [ push ] curry each-bfs-node
+    ] keep ;
+
+M: tree assoc-clone-like
+    [ dup tree? [ >bfs-alist ] when ] dip call-next-method ;
+
 PRIVATE>
 
 : >tree ( assoc -- tree )