From 51b5ec84f623f473bff3e25fab87334e5d863526 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Mon, 5 May 2008 01:54:56 -0500
Subject: [PATCH 1/2] Modernizing the trees library
---
extra/trees/avl/avl-tests.factor | 62 +++++++++++++++-----------------
extra/trees/avl/avl.factor | 62 +++++++++++++++++---------------
extra/trees/splay/splay.factor | 8 ++---
extra/trees/trees.factor | 45 +++++++++++------------
4 files changed, 86 insertions(+), 91 deletions(-)
mode change 100644 => 100755 extra/trees/avl/avl-tests.factor
mode change 100644 => 100755 extra/trees/splay/splay.factor
diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor
old mode 100644
new mode 100755
index 570125cb45..5cb6606ce4
--- a/extra/trees/avl/avl-tests.factor
+++ b/extra/trees/avl/avl-tests.factor
@@ -2,85 +2,79 @@ USING: kernel tools.test trees trees.avl math random sequences assocs ;
IN: trees.avl.tests
[ "key1" 0 "key2" 0 ] [
- T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 }
+ 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 T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 }
+ 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 T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 }
+ 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 T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 }
+ 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 T{ node f "key1" f f
- T{ avl-node T{ node f "key2" f
- T{ avl-node T{ node f "key3" } 1 } }
- -1 } }
- 2 } [ double-rotate ] go-left
+[ 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 T{ node f "key1" f f
- T{ avl-node T{ node f "key2" f
- T{ avl-node T{ node f "key3" } 0 } }
- -1 } }
- 2 } [ double-rotate ] go-left
+[ 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 T{ node f "key1" f f
- T{ avl-node T{ node f "key2" f
- T{ avl-node T{ node f "key3" } -1 } }
- -1 } }
- 2 } [ double-rotate ] go-left
+[ 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 T{ node f "key1" f
- T{ avl-node T{ node f "key2" f f
- T{ avl-node T{ node f "key3" } -1 } }
- 1 } }
- -2 } [ double-rotate ] go-right
+[ 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 T{ node f "key1" f
- T{ avl-node T{ node f "key2" f f
- T{ avl-node T{ node f "key3" } 0 } }
- 1 } }
- -2 } [ double-rotate ] go-right
+[ 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 T{ node f "key1" f
- T{ avl-node T{ node f "key2" f f
- T{ avl-node T{ node f "key3" } 1 } }
- 1 } }
- -2 } [ double-rotate ] go-right
+[ 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
diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor
index 3a37ec5fc7..866e035a21 100755
--- a/extra/trees/avl/avl.factor
+++ b/extra/trees/avl/avl.factor
@@ -1,33 +1,34 @@
! 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
-math.order ;
+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 ;
-
-INSTANCE: avl tree-mixin
+TUPLE: avl < tree ;
: <avl> ( -- tree )
- avl construct-tree ;
+ avl new-tree ;
-TUPLE: avl-node balance ;
+TUPLE: avl-node < node balance ;
: <avl-node> ( key value -- node )
- swap <node> 0 avl-node boa tuck set-delegate ;
+ avl-node new-node
+ 0 >>balance ;
-: change-balance ( node amount -- )
- over avl-node-balance + swap set-avl-node-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 ;
+ dup node+link dup node-link pick set-node+link
+ tuck set-node-link ;
: single-rotate ( node -- node )
- 0 over set-avl-node-balance 0 over node+link set-avl-node-balance rotate ;
+ 0 over (>>balance) 0 over node+link
+ (>>balance) rotate ;
: pick-balances ( a node -- balance balance )
- avl-node-balance {
+ balance>> {
{ [ dup zero? ] [ 2drop 0 0 ] }
{ [ over = ] [ neg 0 ] }
[ 0 swap ]
@@ -36,18 +37,22 @@ TUPLE: avl-node balance ;
: double-rotate ( node -- node )
[
node+link [
- node-link current-side get neg over pick-balances rot 0 swap set-avl-node-balance
- ] keep set-avl-node-balance
- ] keep tuck set-avl-node-balance
- dup node+link [ rotate ] with-other-side over set-node+link rotate ;
+ 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 avl-node-balance current-side get = [ double-rotate ] [ single-rotate ] if ;
+ 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 ] }
+ { [ dup abs 2 = ]
+ [ sgn neg [ select-rotate ] with-side f ] }
{ [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller
} cond ;
@@ -57,7 +62,8 @@ DEFER: avl-set
2dup node-key before? left right ? [
[ node-link avl-set ] keep swap
>r tuck set-node-link r>
- [ dup current-side get change-balance balance-insert ] [ f ] if
+ [ dup current-side get increase-balance balance-insert ]
+ [ f ] if
] with-side ;
: (avl-set) ( value key node -- node taller? )
@@ -66,10 +72,10 @@ DEFER: avl-set
] [ avl-insert ] if ;
: avl-set ( value key node -- node taller? )
- [ (avl-set) ] [ <avl-node> t ] if* ;
+ [ (avl-set) ] [ swap <avl-node> t ] if* ;
M: avl set-at ( value key node -- node )
- [ avl-set drop ] change-root ;
+ [ avl-set drop ] change-root drop ;
: delete-select-rotate ( node -- node shorter? )
dup node+link avl-node-balance zero? [
@@ -87,10 +93,10 @@ M: avl set-at ( value key node -- node )
} cond ;
: balance-delete ( node -- node shorter? )
- current-side get over avl-node-balance {
+ current-side get over balance>> {
{ [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
- { [ dupd = ] [ drop 0 over set-avl-node-balance t ] }
- [ dupd neg change-balance rebalance-delete ]
+ { [ dupd = ] [ drop 0 >>balance t ] }
+ [ dupd neg increase-balance rebalance-delete ]
} cond ;
: avl-replace-with-extremity ( to-replace node -- node shorter? )
@@ -135,12 +141,12 @@ M: avl-node avl-delete ( key node -- node shorter? deleted? )
] if ;
M: avl delete-at ( key node -- )
- [ avl-delete 2drop ] change-root ;
+ [ avl-delete 2drop ] change-root drop ;
M: avl new-assoc 2drop <avl> ;
: >avl ( assoc -- avl )
- T{ avl T{ tree f f 0 } } assoc-clone-like ;
+ T{ avl f f 0 } assoc-clone-like ;
M: avl assoc-like
drop dup avl? [ >avl ] unless ;
diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor
old mode 100644
new mode 100755
index 8931db3a10..ef5fcf8ca6
--- a/extra/trees/splay/splay.factor
+++ b/extra/trees/splay/splay.factor
@@ -4,12 +4,10 @@ USING: arrays kernel math namespaces sequences assocs parser
prettyprint.backend trees generic math.order ;
IN: trees.splay
-TUPLE: splay ;
+TUPLE: splay < tree ;
: <splay> ( -- tree )
- \ splay construct-tree ;
-
-INSTANCE: splay tree-mixin
+ \ splay new-tree ;
: rotate-right ( node -- node )
dup node-left
@@ -131,7 +129,7 @@ M: splay new-assoc
2drop <splay> ;
: >splay ( assoc -- tree )
- T{ splay T{ tree f f 0 } } assoc-clone-like ;
+ T{ splay f f 0 } assoc-clone-like ;
: SPLAY{
\ } [ >splay ] parse-literal ; parsing
diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor
index 3cad81e447..3b0ab01666 100755
--- a/extra/trees/trees.factor
+++ b/extra/trees/trees.factor
@@ -5,23 +5,25 @@ prettyprint.private kernel.private assocs random combinators
parser prettyprint.backend math.order accessors ;
IN: trees
-MIXIN: tree-mixin
-
TUPLE: tree root count ;
+: new-tree ( class -- tree )
+ new
+ f >>root
+ 0 >>count ; inline
+
: <tree> ( -- tree )
- f 0 tree boa ;
+ tree new-tree ;
-: construct-tree ( class -- tree )
- new <tree> over set-delegate ; inline
-
-INSTANCE: tree tree-mixin
-
-INSTANCE: tree-mixin assoc
+INSTANCE: tree assoc
TUPLE: node key value left right ;
+
+: new-node ( key value class -- node )
+ new swap >>value swap >>key ;
+
: <node> ( key value -- node )
- f f node boa ;
+ node new-node ;
SYMBOL: current-side
@@ -57,9 +59,6 @@ SYMBOL: current-side
: go-left ( quot -- ) left swap with-side ; inline
: go-right ( quot -- ) right swap with-side ; inline
-: change-root ( tree quot -- )
- swap [ root>> swap call ] keep set-tree-root ; inline
-
: leaf? ( node -- ? )
[ left>> ] [ right>> ] bi or not ;
@@ -91,7 +90,7 @@ M: tree at* ( key tree -- value ? )
] if ;
M: tree set-at ( value key tree -- )
- [ [ node-set ] [ swap <node> ] if* ] change-root ;
+ [ [ node-set ] [ swap <node> ] if* ] change-root drop ;
: valid-node? ( node -- ? )
[
@@ -117,10 +116,10 @@ M: tree set-at ( value key tree -- )
[ >r right>> r> find-node ]
} cond ; inline
-M: tree-mixin assoc-find ( tree quot -- key value ? )
+M: tree assoc-find ( tree quot -- key value ? )
>r root>> r> find-node ;
-M: tree-mixin clear-assoc
+M: tree clear-assoc
0 >>count
f >>root drop ;
@@ -182,7 +181,7 @@ DEFER: delete-node
] if ;
M: tree delete-at
- [ delete-bst-node ] change-root ;
+ [ delete-bst-node ] change-root drop ;
M: tree new-assoc
2drop <tree> ;
@@ -192,14 +191,12 @@ M: tree clone dup assoc-clone-like ;
: >tree ( assoc -- tree )
T{ tree f f 0 } assoc-clone-like ;
-M: tree-mixin assoc-like drop dup tree? [ >tree ] unless ;
+M: tree assoc-like drop dup tree? [ >tree ] unless ;
: TREE{
\ } [ >tree ] parse-literal ; parsing
-
+
M: tree pprint-delims drop \ TREE{ \ } ;
-
-M: tree-mixin assoc-size count>> ;
-M: tree-mixin clone dup assoc-clone-like ;
-M: tree-mixin >pprint-sequence >alist ;
-M: tree-mixin pprint-narrow? drop t ;
+M: tree assoc-size count>> ;
+M: tree >pprint-sequence >alist ;
+M: tree pprint-narrow? drop t ;
From 4a9b5d2127abb5d53ee1b0bda10e00432ffcfdd3 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Mon, 5 May 2008 03:48:20 -0500
Subject: [PATCH 2/2] Interval trees
---
extra/trees/interval/authors.txt | 1 +
extra/trees/interval/interval-tests.factor | 21 +++++++++++
extra/trees/interval/interval.factor | 42 ++++++++++++++++++++++
extra/trees/interval/summary.txt | 1 +
4 files changed, 65 insertions(+)
create mode 100755 extra/trees/interval/authors.txt
create mode 100755 extra/trees/interval/interval-tests.factor
create mode 100755 extra/trees/interval/interval.factor
create mode 100755 extra/trees/interval/summary.txt
diff --git a/extra/trees/interval/authors.txt b/extra/trees/interval/authors.txt
new file mode 100755
index 0000000000..504363d316
--- /dev/null
+++ b/extra/trees/interval/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/extra/trees/interval/interval-tests.factor b/extra/trees/interval/interval-tests.factor
new file mode 100755
index 0000000000..ef3cf08895
--- /dev/null
+++ b/extra/trees/interval/interval-tests.factor
@@ -0,0 +1,21 @@
+USING: kernel namespaces trees.avl trees.interval tools.test ;
+IN: trees.interval.test
+
+SYMBOL: test
+
+<avl> test set
+
+[ f ] [ 2 test get interval-at ] unit-test
+[ ] [ 2 1 test get add-single ] unit-test
+[ 2 ] [ 1 test get interval-at ] unit-test
+[ f ] [ 2 test get interval-at ] unit-test
+[ f ] [ 0 test get interval-at ] unit-test
+
+[ ] [ 3 4 8 test get add-range ] unit-test
+[ 3 ] [ 5 test get interval-at ] unit-test
+[ 3 ] [ 8 test get interval-at ] unit-test
+[ 3 ] [ 4 test get interval-at ] unit-test
+[ f ] [ 9 test get interval-at ] unit-test
+[ 2 ] [ 1 test get interval-at ] unit-test
+[ f ] [ 2 test get interval-at ] unit-test
+[ f ] [ 0 test get interval-at ] unit-test
diff --git a/extra/trees/interval/interval.factor b/extra/trees/interval/interval.factor
new file mode 100755
index 0000000000..9b3b4a4c6c
--- /dev/null
+++ b/extra/trees/interval/interval.factor
@@ -0,0 +1,42 @@
+! Copyright (c) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: trees trees.avl kernel math accessors math.intervals
+math.order assocs ;
+IN: trees.interval
+
+TUPLE: int-node interval max-under value ;
+: <int-node> ( value start end -- int-node )
+ [ [a,b] ] keep rot int-node boa ;
+
+: interval-choose-branch ( key node -- key left/right )
+ dup left>> [
+ max-under>> pick >= [ left>> ] [ right>> ] if
+ ] [ right>> ] if* ;
+
+: (interval-at*) ( key node -- value ? )
+ [
+ 2dup value>> interval>> interval-contains?
+ [ nip value>> value>> t ]
+ [ interval-choose-branch (interval-at*) ] if
+ ] [ drop f f ] if* ;
+
+: interval-at* ( key tree -- value ? )
+ root>> (interval-at*) ;
+
+: interval-at ( key tree -- value ) interval-at* drop ;
+: interval-key? ( key tree -- ? ) interval-at* nip ;
+
+: update-max-under ( max key node -- )
+ ! The outer conditional shouldn't be necessary
+ [
+ 2dup key>> = [ 3drop ] [
+ [ nip value>> [ max ] change-max-under drop ]
+ [ choose-branch update-max-under ] 3bi
+ ] if
+ ] [ 2drop ] if* ;
+
+: add-range ( value start end tree -- )
+ [ >r over >r <int-node> r> r> set-at ]
+ [ root>> swapd update-max-under ] 3bi ;
+
+: add-single ( value key tree -- ) dupd add-range ;
diff --git a/extra/trees/interval/summary.txt b/extra/trees/interval/summary.txt
new file mode 100755
index 0000000000..e4f4ad152f
--- /dev/null
+++ b/extra/trees/interval/summary.txt
@@ -0,0 +1 @@
+Interval trees for disjoint closed ranges