From b01b14c0e230b0855d0d56b2326e8edbe0313a2c Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Mon, 6 May 2013 08:59:02 -0700
Subject: [PATCH] math.statistics: change cum-mean to use v/.

---
 basis/math/combinatorics/combinatorics.factor | 66 +++++++++++++++++++
 basis/math/statistics/statistics.factor       |  4 +-
 2 files changed, 68 insertions(+), 2 deletions(-)

diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor
index 7136982e1b..482c0a92c0 100644
--- a/basis/math/combinatorics/combinatorics.factor
+++ b/basis/math/combinatorics/combinatorics.factor
@@ -17,6 +17,72 @@ IN: math.combinatorics
 
 PRIVATE>
 
+<PRIVATE
+
+: (binary-reduce2) ( ... seq start quot: ( ... elt1 elt2 -- ... newelt ) from length -- ... value )
+    #! We can't use case here since combinators depends on
+    #! sequences
+    dup 4 < [
+        integer>fixnum {
+            [ 2drop nip ]
+            [ 2nip swap nth-unsafe ]
+            [ -rot [ drop swap nth2-unsafe ] dip call ]
+            [ -rot [ drop swap nth3-unsafe ] dip bi@ ]
+        } dispatch
+    ] [
+        [ 2/ ] [ over - ] bi [ 2dup + ] dip
+        [ (binary-reduce) ] [ 2curry ] curry 2bi@
+        pick [
+            [ 3curry ] bi-curry@ 3bi
+            [ call ] dip swap [ call ] dip
+        ] dip call
+    ] if ; inline recursive
+
+PRIVATE>
+
+: binary-reduce2 ( ... seq start quot: ( ... elt1 elt2 -- ... newelt ) -- ... value )
+    pick length 0 max 0 swap (binary-reduce2) ; inline
+
+GENERIC: sum2 ( seq -- n )
+M: object sum2 0 [ + ] binary-reduce2 ;
+
+GENERIC: sum3 ( seq -- n )
+M: object sum3 0 [ + ] binary-reduce ;
+
+: product2 ( seq -- n )
+    0 swap 1 [
+        dup even? [ 2/ * [ 1 + ] dip ] [ * ] if
+    ] binary-reduce2 swap shift ;
+
+TUPLE: factorials n length ;
+: <factorials> ( n -- factorials )
+    dup dup odd? [ 1 + ] when 2/ factorials boa ; inline
+M: factorials length length>> ; inline
+M: factorials nth-unsafe
+    n>> swap [ - ] keep 1 + 2dup = [ drop ] [ * ] if ; inline
+INSTANCE: factorials sequence
+
+: factorial-product ( n -- n! )
+    dup 1 > [ [1,b] product2 ] [ drop 1 ] if ;
+
+: factorial1 ( n -- n! )
+    dup 1 > [
+        [ 0 1 ] dip [ dup 1 > ] [
+            [ dup even? [ 2/ [ 1 + ] 2dip ] when * ]
+            [ 1 - ] bi
+        ] while drop swap shift
+    ] [ drop 1 ] if ;
+
+: factorial0 ( n -- n! )
+    dup 1 > [ [1,b] product ] [ drop 1 ] if ;
+
+:: factorial2 ( n -- n! )
+    n n n [ 2 - dup 1 > ] [
+        [ + [ * ] keep ] keep
+    ] while nip 1 = [ n 1 + 2/ * ] when ;
+
+! http://www.luschny.de/math/factorial/scala/FactorialScalaCsharp.htm
+
 MEMO: factorial ( n -- n! )
     dup 1 > [ [1,b] product ] [ drop 1 ] if ;
 
diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor
index 65606c9e46..10245675f1 100644
--- a/basis/math/statistics/statistics.factor
+++ b/basis/math/statistics/statistics.factor
@@ -350,9 +350,9 @@ ALIAS: std sample-std
 
 : cum-product ( seq -- seq' )
     1 [ * ] cum-map ;
-    
+
 : cum-mean ( seq -- seq' )
-    [ cum-sum ] [ length [1,b] ] bi [ / ] 2map ;    
+    [ cum-sum ] [ length [1,b] ] bi v/ ;
 
 : cum-count ( seq quot -- seq' )
     [ 0 ] dip '[ _ call [ 1 + ] when ] cum-map ; inline