From 33a1a269f529e036e6058653ba590e4964d1d638 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 4 Mar 2009 16:02:40 -0600 Subject: [PATCH] delete unmaintained trees --- unmaintained/trees/authors.txt | 2 - unmaintained/trees/avl/authors.txt | 2 - unmaintained/trees/avl/avl-docs.factor | 27 --- unmaintained/trees/avl/avl-tests.factor | 116 ------------ unmaintained/trees/avl/avl.factor | 157 ---------------- unmaintained/trees/avl/summary.txt | 1 - unmaintained/trees/avl/tags.txt | 1 - unmaintained/trees/splay/authors.txt | 2 - unmaintained/trees/splay/splay-docs.factor | 27 --- unmaintained/trees/splay/splay-tests.factor | 33 ---- unmaintained/trees/splay/splay.factor | 140 -------------- unmaintained/trees/splay/summary.txt | 1 - unmaintained/trees/splay/tags.txt | 2 - unmaintained/trees/summary.txt | 1 - unmaintained/trees/tags.txt | 2 - unmaintained/trees/trees-docs.factor | 28 --- unmaintained/trees/trees-tests.factor | 28 --- unmaintained/trees/trees.factor | 194 -------------------- 18 files changed, 764 deletions(-) delete mode 100644 unmaintained/trees/authors.txt delete mode 100644 unmaintained/trees/avl/authors.txt delete mode 100644 unmaintained/trees/avl/avl-docs.factor delete mode 100755 unmaintained/trees/avl/avl-tests.factor delete mode 100755 unmaintained/trees/avl/avl.factor delete mode 100644 unmaintained/trees/avl/summary.txt delete mode 100644 unmaintained/trees/avl/tags.txt delete mode 100644 unmaintained/trees/splay/authors.txt delete mode 100644 unmaintained/trees/splay/splay-docs.factor delete mode 100644 unmaintained/trees/splay/splay-tests.factor delete mode 100755 unmaintained/trees/splay/splay.factor delete mode 100644 unmaintained/trees/splay/summary.txt delete mode 100644 unmaintained/trees/splay/tags.txt delete mode 100644 unmaintained/trees/summary.txt delete mode 100644 unmaintained/trees/tags.txt delete mode 100644 unmaintained/trees/trees-docs.factor delete mode 100644 unmaintained/trees/trees-tests.factor delete mode 100755 unmaintained/trees/trees.factor diff --git a/unmaintained/trees/authors.txt b/unmaintained/trees/authors.txt deleted file mode 100644 index 39c1f37d37..0000000000 --- a/unmaintained/trees/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Alex Chapman -Daniel Ehrenberg diff --git a/unmaintained/trees/avl/authors.txt b/unmaintained/trees/avl/authors.txt deleted file mode 100644 index 39c1f37d37..0000000000 --- a/unmaintained/trees/avl/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Alex Chapman -Daniel Ehrenberg diff --git a/unmaintained/trees/avl/avl-docs.factor b/unmaintained/trees/avl/avl-docs.factor deleted file mode 100644 index 46f647470a..0000000000 --- a/unmaintained/trees/avl/avl-docs.factor +++ /dev/null @@ -1,27 +0,0 @@ -USING: help.syntax help.markup assocs ; -IN: trees.avl - -HELP: AVL{ -{ $syntax "AVL{ { key value }... }" } -{ $values { "key" "a key" } { "value" "a value" } } -{ $description "Literal syntax for an AVL tree." } ; - -HELP: -{ $values { "tree" avl } } -{ $description "Creates an empty AVL tree" } ; - -HELP: >avl -{ $values { "assoc" assoc } { "avl" avl } } -{ $description "Converts any " { $link assoc } " into an AVL tree." } ; - -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." } ; - -ARTICLE: { "avl" "intro" } "AVL trees" -"This is a library for AVL trees, with logarithmic time storage and retrieval operations. These trees conform to the assoc protocol." -{ $subsection avl } -{ $subsection } -{ $subsection >avl } -{ $subsection POSTPONE: AVL{ } ; - -ABOUT: { "avl" "intro" } diff --git a/unmaintained/trees/avl/avl-tests.factor b/unmaintained/trees/avl/avl-tests.factor deleted file mode 100755 index 5cb6606ce4..0000000000 --- a/unmaintained/trees/avl/avl-tests.factor +++ /dev/null @@ -1,116 +0,0 @@ -USING: kernel tools.test trees trees.avl math random sequences assocs ; -IN: trees.avl.tests - -[ "key1" 0 "key2" 0 ] [ - T{ avl-node f "key1" f f T{ avl-node f "key2" f f 1 } 2 } - [ single-rotate ] go-left - [ node-left dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance -] unit-test - -[ "key1" 0 "key2" 0 ] [ - T{ avl-node f "key1" f f T{ avl-node f "key2" f f f 1 } 2 } - [ select-rotate ] go-left - [ node-left dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance -] unit-test - -[ "key1" 0 "key2" 0 ] [ - T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 } - [ single-rotate ] go-right - [ node-right dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance -] unit-test - -[ "key1" 0 "key2" 0 ] [ - T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 } - [ select-rotate ] go-right - [ node-right dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance -] unit-test - -[ "key1" -1 "key2" 0 "key3" 0 ] -[ T{ avl-node f "key1" f f - T{ avl-node f "key2" f - T{ avl-node f "key3" f f f 1 } f -1 } 2 } - [ double-rotate ] go-left - [ node-left dup node-key swap avl-node-balance ] keep - [ node-right dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" 0 "key3" 0 ] -[ T{ avl-node f "key1" f f - T{ avl-node f "key2" f - T{ avl-node f "key3" f f f 0 } f -1 } 2 } - [ double-rotate ] go-left - [ node-left dup node-key swap avl-node-balance ] keep - [ node-right dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" 1 "key3" 0 ] -[ T{ avl-node f "key1" f f - T{ avl-node f "key2" f - T{ avl-node f "key3" f f f -1 } f -1 } 2 } - [ double-rotate ] go-left - [ node-left dup node-key swap avl-node-balance ] keep - [ node-right dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test - -[ "key1" 1 "key2" 0 "key3" 0 ] -[ T{ avl-node f "key1" f - T{ avl-node f "key2" f f - T{ avl-node f "key3" f f f -1 } 1 } f -2 } - [ double-rotate ] go-right - [ node-right dup node-key swap avl-node-balance ] keep - [ node-left dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" 0 "key3" 0 ] -[ T{ avl-node f "key1" f - T{ avl-node f "key2" f f - T{ avl-node f "key3" f f f 0 } 1 } f -2 } - [ double-rotate ] go-right - [ node-right dup node-key swap avl-node-balance ] keep - [ node-left dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" -1 "key3" 0 ] -[ T{ avl-node f "key1" f - T{ avl-node f "key2" f f - T{ avl-node f "key3" f f f 1 } 1 } f -2 } - [ double-rotate ] go-right - [ node-right dup node-key swap avl-node-balance ] keep - [ node-left dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test - -[ "eight" ] [ - "seven" 7 pick set-at - "eight" 8 pick set-at "nine" 9 pick set-at - tree-root node-value -] unit-test - -[ "another eight" ] [ ! ERROR! - "seven" 7 pick set-at - "another eight" 8 pick set-at 8 swap at -] unit-test - -: test-tree ( -- tree ) - AVL{ - { 7 "seven" } - { 9 "nine" } - { 4 "four" } - { 4 "replaced four" } - { 7 "replaced seven" } - } clone ; - -! test set-at, at, at* -[ t ] [ test-tree avl? ] unit-test -[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test -[ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test -[ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test -[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test -[ "replacement" ] [ "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test -[ "nine" ] [ test-tree 9 swap at ] unit-test -[ "replaced four" ] [ test-tree 4 swap at ] unit-test -[ "replaced seven" ] [ test-tree 7 swap at ] unit-test - -! test delete-at--all errors! -[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test -[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test -[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test diff --git a/unmaintained/trees/avl/avl.factor b/unmaintained/trees/avl/avl.factor deleted file mode 100755 index 866e035a21..0000000000 --- a/unmaintained/trees/avl/avl.factor +++ /dev/null @@ -1,157 +0,0 @@ -! Copyright (C) 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel generic math math.functions -math.parser namespaces io prettyprint.backend sequences trees -assocs parser accessors math.order ; -IN: trees.avl - -TUPLE: avl < tree ; - -: ( -- tree ) - avl new-tree ; - -TUPLE: avl-node < node balance ; - -: ( key value -- node ) - avl-node new-node - 0 >>balance ; - -: increase-balance ( node amount -- ) - swap [ + ] change-balance drop ; - -: rotate ( node -- node ) - dup node+link dup node-link pick set-node+link - tuck set-node-link ; - -: single-rotate ( node -- node ) - 0 over (>>balance) 0 over node+link - (>>balance) rotate ; - -: pick-balances ( a node -- balance balance ) - balance>> { - { [ dup zero? ] [ 2drop 0 0 ] } - { [ over = ] [ neg 0 ] } - [ 0 swap ] - } cond ; - -: double-rotate ( node -- node ) - [ - node+link [ - node-link current-side get neg - over pick-balances rot 0 swap (>>balance) - ] keep (>>balance) - ] keep swap >>balance - dup node+link [ rotate ] with-other-side - over set-node+link rotate ; - -: select-rotate ( node -- node ) - dup node+link balance>> current-side get = - [ double-rotate ] [ single-rotate ] if ; - -: balance-insert ( node -- node taller? ) - dup avl-node-balance { - { [ dup zero? ] [ drop f ] } - { [ dup abs 2 = ] - [ sgn neg [ select-rotate ] with-side f ] } - { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller - } cond ; - -DEFER: avl-set - -: avl-insert ( value key node -- node taller? ) - 2dup node-key before? left right ? [ - [ node-link avl-set ] keep swap - >r tuck set-node-link r> - [ dup current-side get increase-balance balance-insert ] - [ f ] if - ] with-side ; - -: (avl-set) ( value key node -- node taller? ) - 2dup node-key = [ - -rot pick set-node-key over set-node-value f - ] [ avl-insert ] if ; - -: avl-set ( value key node -- node taller? ) - [ (avl-set) ] [ swap t ] if* ; - -M: avl set-at ( value key node -- node ) - [ avl-set drop ] change-root drop ; - -: delete-select-rotate ( node -- node shorter? ) - dup node+link avl-node-balance zero? [ - current-side get neg over set-avl-node-balance - current-side get over node+link set-avl-node-balance rotate f - ] [ - select-rotate t - ] if ; - -: rebalance-delete ( node -- node shorter? ) - dup avl-node-balance { - { [ dup zero? ] [ drop t ] } - { [ dup abs 2 = ] [ sgn neg [ delete-select-rotate ] with-side ] } - { [ drop t ] [ f ] } ! balance is -1 or 1, tree is not shorter - } cond ; - -: balance-delete ( node -- node shorter? ) - current-side get over balance>> { - { [ dup zero? ] [ drop neg over set-avl-node-balance f ] } - { [ dupd = ] [ drop 0 >>balance t ] } - [ dupd neg increase-balance rebalance-delete ] - } cond ; - -: avl-replace-with-extremity ( to-replace node -- node shorter? ) - dup node-link [ - swapd avl-replace-with-extremity >r over set-node-link r> - [ balance-delete ] [ f ] if - ] [ - tuck copy-node-contents node+link t - ] if* ; - -: replace-with-a-child ( node -- node shorter? ) - #! assumes that node is not a leaf, otherwise will recurse forever - dup node-link [ - dupd [ avl-replace-with-extremity ] with-other-side - >r over set-node-link r> [ balance-delete ] [ f ] if - ] [ - [ replace-with-a-child ] with-other-side - ] if* ; - -: avl-delete-node ( node -- node shorter? ) - #! delete this node, returning its replacement, and whether this subtree is - #! shorter as a result - dup leaf? [ - drop f t - ] [ - left [ replace-with-a-child ] with-side - ] if ; - -GENERIC: avl-delete ( key node -- node shorter? deleted? ) - -M: f avl-delete ( key f -- f f f ) nip f f ; - -: (avl-delete) ( key node -- node shorter? deleted? ) - tuck node-link avl-delete >r >r over set-node-link r> - [ balance-delete r> ] [ f r> ] if ; - -M: avl-node avl-delete ( key node -- node shorter? deleted? ) - 2dup node-key key-side dup zero? [ - drop nip avl-delete-node t - ] [ - [ (avl-delete) ] with-side - ] if ; - -M: avl delete-at ( key node -- ) - [ avl-delete 2drop ] change-root drop ; - -M: avl new-assoc 2drop ; - -: >avl ( assoc -- avl ) - T{ avl f f 0 } assoc-clone-like ; - -M: avl assoc-like - drop dup avl? [ >avl ] unless ; - -: AVL{ - \ } [ >avl ] parse-literal ; parsing - -M: avl pprint-delims drop \ AVL{ \ } ; diff --git a/unmaintained/trees/avl/summary.txt b/unmaintained/trees/avl/summary.txt deleted file mode 100644 index c2360c2ed3..0000000000 --- a/unmaintained/trees/avl/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Balanced AVL trees diff --git a/unmaintained/trees/avl/tags.txt b/unmaintained/trees/avl/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/unmaintained/trees/avl/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/unmaintained/trees/splay/authors.txt b/unmaintained/trees/splay/authors.txt deleted file mode 100644 index 06a7cfb215..0000000000 --- a/unmaintained/trees/splay/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Mackenzie Straight -Daniel Ehrenberg diff --git a/unmaintained/trees/splay/splay-docs.factor b/unmaintained/trees/splay/splay-docs.factor deleted file mode 100644 index 253d3f4aec..0000000000 --- a/unmaintained/trees/splay/splay-docs.factor +++ /dev/null @@ -1,27 +0,0 @@ -USING: help.syntax help.markup assocs ; -IN: trees.splay - -HELP: SPLAY{ -{ $syntax "SPLAY{ { key value }... }" } -{ $values { "key" "a key" } { "value" "a value" } } -{ $description "Literal syntax for an splay tree." } ; - -HELP: -{ $values { "tree" splay } } -{ $description "Creates an empty splay tree" } ; - -HELP: >splay -{ $values { "assoc" assoc } { "tree" splay } } -{ $description "Converts any " { $link assoc } " into an splay tree." } ; - -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." } ; - -ARTICLE: { "splay" "intro" } "Splay trees" -"This is a library 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 trees conform to the assoc protocol." -{ $subsection splay } -{ $subsection } -{ $subsection >splay } -{ $subsection POSTPONE: SPLAY{ } ; - -ABOUT: { "splay" "intro" } diff --git a/unmaintained/trees/splay/splay-tests.factor b/unmaintained/trees/splay/splay-tests.factor deleted file mode 100644 index e54e3cd538..0000000000 --- a/unmaintained/trees/splay/splay-tests.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (c) 2005 Mackenzie Straight. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test trees.splay math namespaces assocs -sequences random sets ; -IN: trees.splay.tests - -: randomize-numeric-splay-tree ( splay-tree -- ) - 100 [ drop 100 random swap at drop ] with each ; - -: make-numeric-splay-tree ( n -- splay-tree ) - [ [ conjoin ] curry each ] keep ; - -[ t ] [ - 100 make-numeric-splay-tree dup randomize-numeric-splay-tree - [ [ drop , ] assoc-each ] { } make [ < ] monotonic? -] unit-test - -[ 10 ] [ 10 make-numeric-splay-tree keys length ] unit-test -[ 10 ] [ 10 make-numeric-splay-tree values length ] unit-test - -[ f ] [ f 4 pick set-at 4 swap at ] unit-test - -! Ensure that f can be a value -[ t ] [ f 4 pick set-at 4 swap key? ] unit-test - -[ -{ { 1 "a" } { 2 "b" } { 3 "c" } { 4 "d" } { 5 "e" } { 6 "f" } } -] [ -{ - { 4 "d" } { 5 "e" } { 6 "f" } - { 1 "a" } { 2 "b" } { 3 "c" } -} >splay >alist -] unit-test diff --git a/unmaintained/trees/splay/splay.factor b/unmaintained/trees/splay/splay.factor deleted file mode 100755 index 923df4b6e3..0000000000 --- a/unmaintained/trees/splay/splay.factor +++ /dev/null @@ -1,140 +0,0 @@ -! Copyright (c) 2005 Mackenzie Straight. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math namespaces sequences assocs parser -prettyprint.backend trees generic math.order ; -IN: trees.splay - -TUPLE: splay < tree ; - -: ( -- tree ) - \ splay new-tree ; - -: rotate-right ( node -- node ) - dup node-left - [ node-right swap set-node-left ] 2keep - [ set-node-right ] keep ; - -: rotate-left ( node -- node ) - dup node-right - [ node-left swap set-node-right ] 2keep - [ set-node-left ] keep ; - -: link-right ( left right key node -- left right key node ) - swap >r [ swap set-node-left ] 2keep - nip dup node-left r> swap ; - -: link-left ( left right key node -- left right key node ) - swap >r rot [ set-node-right ] 2keep - drop dup node-right swapd r> swap ; - -: cmp ( key node -- obj node -1/0/1 ) - 2dup node-key key-side ; - -: lcmp ( key node -- obj node -1/0/1 ) - 2dup node-left node-key key-side ; - -: rcmp ( key node -- obj node -1/0/1 ) - 2dup node-right node-key key-side ; - -DEFER: (splay) - -: splay-left ( left right key node -- left right key node ) - dup node-left [ - lcmp 0 < [ rotate-right ] when - dup node-left [ link-right (splay) ] when - ] when ; - -: splay-right ( left right key node -- left right key node ) - dup node-right [ - rcmp 0 > [ rotate-left ] when - dup node-right [ link-left (splay) ] when - ] when ; - -: (splay) ( left right key node -- left right key node ) - cmp dup 0 < - [ drop splay-left ] [ 0 > [ splay-right ] when ] if ; - -: assemble ( head left right node -- root ) - [ node-right swap set-node-left ] keep - [ node-left swap set-node-right ] keep - [ swap node-left swap set-node-right ] 2keep - [ swap node-right swap set-node-left ] keep ; - -: splay-at ( key node -- node ) - >r >r T{ node } clone dup dup r> r> - (splay) nip assemble ; - -: splay ( key tree -- ) - [ tree-root splay-at ] keep set-tree-root ; - -: splay-split ( key tree -- node node ) - 2dup splay tree-root cmp 0 < [ - nip dup node-left swap f over set-node-left - ] [ - nip dup node-right swap f over set-node-right swap - ] if ; - -: get-splay ( key tree -- node ? ) - 2dup splay tree-root cmp 0 = [ - nip t - ] [ - 2drop f f - ] if ; - -: get-largest ( node -- node ) - dup [ dup node-right [ nip get-largest ] when* ] when ; - -: splay-largest ( node -- node ) - dup [ dup get-largest node-key swap splay-at ] when ; - -: splay-join ( n2 n1 -- node ) - splay-largest [ - [ set-node-right ] keep - ] [ - drop f - ] if* ; - -: remove-splay ( key tree -- ) - tuck get-splay nip [ - dup dec-count - dup node-right swap node-left splay-join - swap set-tree-root - ] [ drop ] if* ; - -: set-splay ( value key tree -- ) - 2dup get-splay [ 2nip set-node-value ] [ - drop dup inc-count - 2dup splay-split rot - >r >r swapd r> node boa r> set-tree-root - ] if ; - -: new-root ( value key tree -- ) - [ 1 swap set-tree-count ] keep - >r swap r> set-tree-root ; - -M: splay set-at ( value key tree -- ) - dup tree-root [ set-splay ] [ new-root ] if ; - -M: splay at* ( key tree -- value ? ) - dup tree-root [ - get-splay >r dup [ node-value ] when r> - ] [ - 2drop f f - ] if ; - -M: splay delete-at ( key tree -- ) - dup tree-root [ remove-splay ] [ 2drop ] if ; - -M: splay new-assoc - 2drop ; - -: >splay ( assoc -- tree ) - T{ splay f f 0 } assoc-clone-like ; - -: SPLAY{ - \ } [ >splay ] parse-literal ; parsing - -M: splay assoc-like - drop dup splay? [ >splay ] unless ; - -M: splay pprint-delims drop \ SPLAY{ \ } ; diff --git a/unmaintained/trees/splay/summary.txt b/unmaintained/trees/splay/summary.txt deleted file mode 100644 index 46391bbd28..0000000000 --- a/unmaintained/trees/splay/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Splay trees diff --git a/unmaintained/trees/splay/tags.txt b/unmaintained/trees/splay/tags.txt deleted file mode 100644 index fb6cea7147..0000000000 --- a/unmaintained/trees/splay/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -collections -trees diff --git a/unmaintained/trees/summary.txt b/unmaintained/trees/summary.txt deleted file mode 100644 index 18ad35db8f..0000000000 --- a/unmaintained/trees/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Binary search trees diff --git a/unmaintained/trees/tags.txt b/unmaintained/trees/tags.txt deleted file mode 100644 index fb6cea7147..0000000000 --- a/unmaintained/trees/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -collections -trees diff --git a/unmaintained/trees/trees-docs.factor b/unmaintained/trees/trees-docs.factor deleted file mode 100644 index df04f1cb40..0000000000 --- a/unmaintained/trees/trees-docs.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: help.syntax help.markup assocs ; -IN: trees - -HELP: TREE{ -{ $syntax "TREE{ { key value }... }" } -{ $values { "key" "a key" } { "value" "a value" } } -{ $description "Literal syntax for an unbalanced tree." } ; - -HELP: -{ $values { "tree" tree } } -{ $description "Creates an empty unbalanced binary tree" } ; - -HELP: >tree -{ $values { "assoc" assoc } { "tree" tree } } -{ $description "Converts any " { $link assoc } " into an unbalanced binary tree." } ; - -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." } ; - -ARTICLE: { "trees" "intro" } "Binary search trees" -"This is a library for unbalanced binary search trees. It is not intended to be used directly in most situations but rather as a base class for new trees, because performance can degrade to linear time storage/retrieval by the number of keys. These binary search trees conform to the assoc protocol." -{ $subsection tree } -{ $subsection } -{ $subsection >tree } -{ $subsection POSTPONE: TREE{ } ; - -IN: trees -ABOUT: { "trees" "intro" } diff --git a/unmaintained/trees/trees-tests.factor b/unmaintained/trees/trees-tests.factor deleted file mode 100644 index fd26b37c70..0000000000 --- a/unmaintained/trees/trees-tests.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: trees assocs tools.test kernel sequences ; -IN: trees.tests - -: test-tree ( -- tree ) - TREE{ - { 7 "seven" } - { 9 "nine" } - { 4 "four" } - { 4 "replaced four" } - { 7 "replaced seven" } - } clone ; - -! test set-at, at, at* -[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test -[ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test -[ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test -[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test -[ "replacement" ] [ "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test -[ "replaced four" ] [ test-tree 4 swap at ] unit-test -[ "nine" ] [ test-tree 9 swap at ] unit-test - -! test delete-at -[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test -[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test -[ "replaced four" ] [ test-tree 9 over delete-at 4 swap at ] unit-test -[ "nine" "replaced four" ] [ test-tree 7 over delete-at 9 over at 4 rot at ] unit-test -[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test - diff --git a/unmaintained/trees/trees.factor b/unmaintained/trees/trees.factor deleted file mode 100755 index d22dfdb7f1..0000000000 --- a/unmaintained/trees/trees.factor +++ /dev/null @@ -1,194 +0,0 @@ -! Copyright (C) 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: kernel generic math sequences arrays io namespaces -prettyprint.private kernel.private assocs random combinators -parser prettyprint.backend math.order accessors ; -IN: trees - -TUPLE: tree root count ; - -: new-tree ( class -- tree ) - new - f >>root - 0 >>count ; inline - -: ( -- tree ) - tree new-tree ; - -INSTANCE: tree assoc - -TUPLE: node key value left right ; - -: new-node ( key value class -- node ) - new swap >>value swap >>key ; - -: ( key value -- node ) - node new-node ; - -SYMBOL: current-side - -: left ( -- symbol ) -1 ; inline -: right ( -- symbol ) 1 ; inline - -: key-side ( k1 k2 -- n ) - <=> { - { +lt+ [ -1 ] } - { +eq+ [ 0 ] } - { +gt+ [ 1 ] } - } case ; - -: go-left? ( -- ? ) current-side get left eq? ; - -: inc-count ( tree -- ) [ 1+ ] change-count drop ; - -: dec-count ( tree -- ) [ 1- ] change-count drop ; - -: node-link@ ( node ? -- node ) - go-left? xor [ left>> ] [ right>> ] if ; -: set-node-link@ ( left parent ? -- ) - go-left? xor [ set-node-left ] [ set-node-right ] if ; - -: node-link ( node -- child ) f node-link@ ; -: set-node-link ( child node -- ) f set-node-link@ ; -: node+link ( node -- child ) t node-link@ ; -: set-node+link ( child node -- ) t set-node-link@ ; - -: with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline -: with-other-side ( quot -- ) - current-side get neg swap with-side ; inline -: go-left ( quot -- ) left swap with-side ; inline -: go-right ( quot -- ) right swap with-side ; inline - -: leaf? ( node -- ? ) - [ left>> ] [ right>> ] bi or not ; - -: random-side ( -- side ) left right 2array random ; - -: choose-branch ( key node -- key node-left/right ) - 2dup node-key key-side [ node-link ] with-side ; - -: node-at* ( key node -- value ? ) - [ - 2dup node-key = [ - nip node-value t - ] [ - choose-branch node-at* - ] if - ] [ drop f f ] if* ; - -M: tree at* ( key tree -- value ? ) - root>> node-at* ; - -: node-set ( value key node -- node ) - 2dup key>> key-side dup 0 eq? [ - drop nip swap >>value - ] [ - [ - [ node-link [ node-set ] [ swap ] if* ] keep - [ set-node-link ] keep - ] with-side - ] if ; - -M: tree set-at ( value key tree -- ) - [ [ node-set ] [ swap ] if* ] change-root drop ; - -: valid-node? ( node -- ? ) - [ - dup dup left>> [ node-key swap node-key before? ] when* >r - dup dup right>> [ node-key swap node-key after? ] when* r> and swap - dup left>> valid-node? swap right>> valid-node? and and - ] [ t ] if* ; - -: valid-tree? ( tree -- ? ) root>> valid-node? ; - -: (node>alist) ( node -- ) - [ - [ left>> (node>alist) ] - [ [ node-key ] [ node-value ] bi 2array , ] - [ right>> (node>alist) ] - tri - ] when* ; - -M: tree >alist [ root>> (node>alist) ] { } make ; - -M: tree clear-assoc - 0 >>count - f >>root drop ; - -: copy-node-contents ( new old -- ) - dup node-key pick set-node-key node-value swap set-node-value ; - -! Deletion -DEFER: delete-node - -: (prune-extremity) ( parent node -- new-extremity ) - dup node-link [ - rot drop (prune-extremity) - ] [ - tuck delete-node swap set-node-link - ] if* ; - -: prune-extremity ( node -- new-extremity ) - #! remove and return the leftmost or rightmost child of this node. - #! assumes at least one child - dup node-link (prune-extremity) ; - -: replace-with-child ( node -- node ) - dup dup node-link copy-node-contents dup node-link delete-node over set-node-link ; - -: replace-with-extremity ( node -- node ) - dup node-link dup node+link [ - ! predecessor/successor is not the immediate child - [ prune-extremity ] with-other-side dupd copy-node-contents - ] [ - ! node-link is the predecessor/successor - drop replace-with-child - ] if ; - -: delete-node-with-two-children ( node -- node ) - #! randomised to minimise tree unbalancing - random-side [ replace-with-extremity ] with-side ; - -: delete-node ( node -- node ) - #! delete this node, returning its replacement - dup left>> [ - dup right>> [ - delete-node-with-two-children - ] [ - left>> ! left but no right - ] if - ] [ - dup right>> [ - right>> ! right but not left - ] [ - drop f ! no children - ] if - ] if ; - -: delete-bst-node ( key node -- node ) - 2dup node-key key-side dup 0 eq? [ - drop nip delete-node - ] [ - [ tuck node-link delete-bst-node over set-node-link ] with-side - ] if ; - -M: tree delete-at - [ delete-bst-node ] change-root drop ; - -M: tree new-assoc - 2drop ; - -M: tree clone dup assoc-clone-like ; - -: >tree ( assoc -- tree ) - T{ tree f f 0 } assoc-clone-like ; - -M: tree assoc-like drop dup tree? [ >tree ] unless ; - -: TREE{ - \ } [ >tree ] parse-literal ; parsing - -M: tree pprint-delims drop \ TREE{ \ } ; -M: tree assoc-size count>> ; -M: tree >pprint-sequence >alist ; -M: tree pprint-narrow? drop t ;