-USING: help.syntax help.markup assocs ;
+USING: assocs help.markup help.syntax trees ;
IN: trees.avl
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." } ;
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 } [
! 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
-USING: help.syntax help.markup assocs ;
+USING: assocs help.markup help.syntax trees ;
IN: trees.splay
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." } ;
! 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
! 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 ;
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 )
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." } ;
{ 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
! 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 } ;
: 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* ;
] if
node-left? [
- node [ node-alist, ] [
+ node [ entry, ] [
right>> [ to-key ] dip
end-comparator (node>subalist-right)
] bi
node [
left>> [ from-key ] dip
start-comparator (node>subalist-left)
- ] [ node-alist, ] bi
+ ] [ entry, ] bi
] when
node right>> node-right? [ (node>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?
: 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 ;
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 )
projects / factor.git / commitdiff