trees, attempt to keep shape during conersions
parent
d800d026de
commit
7ed6379633
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
Loading…
Reference in New Issue