trees, attempt to keep shape during conersions

char-rename
Jon Harper 2017-01-25 19:26:22 +01:00 committed by John Benediktsson
parent d800d026de
commit 7ed6379633
8 changed files with 60 additions and 17 deletions

View File

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

View File

@ -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

View File

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

View File

@ -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

View File

@ -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 )

View File

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

View File

@ -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

View File

@ -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 )