Merge branch 'master' of git://factorcode.org/git/littledan

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

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 ;

extra/trees/interval/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

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

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 ;

extra/trees/interval/summary.txt

@@ -0,0 +1 @@
+Interval trees for disjoint closed ranges

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

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 ;