From 9def7af3f5d9857214a46527775a87fade682208 Mon Sep 17 00:00:00 2001
From: erg <erg@trifocus.net>
Date: Wed, 15 Nov 2006 18:36:57 +0000
Subject: [PATCH] refactor various contrib/math

---
 contrib/math/numerical-integration.factor | 18 +++++++-------
 contrib/math/utils.factor                 | 29 +++++++----------------
 2 files changed, 17 insertions(+), 30 deletions(-)

diff --git a/contrib/math/numerical-integration.factor b/contrib/math/numerical-integration.factor
index 9153dd53c6..2e237ed3bc 100644
--- a/contrib/math/numerical-integration.factor
+++ b/contrib/math/numerical-integration.factor
@@ -2,30 +2,28 @@ IN: math-contrib
 USING: kernel sequences errors namespaces math vectors errors prettyprint io tools ;
 
 : setup-range ( from to -- frange )
-    step-size get swap <frange> ;
+    >r step-size get r> <frange-no-endpt> ;
 
 : integrate-rect ( from to f -- x )
-    >r setup-range dup decrement-length r>
-    [ step-size get * ] append map sum ;
+    >r setup-range r>
+    [ step-size get * + ] append >r 0 r> reduce ;
 
 : integrate-trap ( from to f -- x )
     >r setup-range r>
     map dup 1 tail >r >vector dup pop drop r>
     [ + 2 / step-size get * ] 2map sum ;
 
-
-SYMBOL: num-steps 180 num-steps set ! simpsons
+SYMBOL: num-steps 180 num-steps set-global
 : setup-simpson-range ( from to -- frange )
     [ swap - num-steps get /f ] 2keep swapd <frange> ;
 
 : generate-simpson-weights ( seq -- seq )
-    length 2 / V{ 1 4 } clone swap 2 -
-    [ { 2 4 } append ] times { 1 } append ;
+    [ { 1 4 } % length 2 / 2 - [ { 2 4 } % ] times 1 , ] { } make ;
 
 : integrate-simpson ( from to f -- x )
     >r setup-simpson-range r> dupd map dup generate-simpson-weights
-    [ * ] 2map sum swap [ third ] keep first - 6 / * ; 
+    0 [ * + ] 2reduce swap [ third ] keep first - 6 / * ; 
 
 
-: quadrature ( from to f -- x )
-    integrate-simpson ;
+: quadrature ( from to f -- x ) integrate-simpson ;
+
diff --git a/contrib/math/utils.factor b/contrib/math/utils.factor
index 57f6e37c34..e12a5ed2b2 100644
--- a/contrib/math/utils.factor
+++ b/contrib/math/utils.factor
@@ -63,33 +63,21 @@ TUPLE: frange from step length ;
 
 C: frange ( from step to -- seq )
     #! example: 0 .01 10 <frange> >array
-    >r pick - swap [ / ceiling 1+ ] keep -rot swapd r> 
-    [ set-frange-length ] keep
+    >r pick - swap [ / ceiling 1+ >bignum ] keep r> 
     [ set-frange-step ] keep
+    [ set-frange-length ] keep
     [ set-frange-from ] keep ;
 
-: decrement-length ( frange -- )
-    [ frange-length 1- ] keep set-frange-length ;
+: <frange-no-endpt> ( from step to -- seq )
+    over - <frange> ;
 
-: <frange-no-endpt> ( from step length -- seq )
-    <frange> dup decrement-length ;
-
-M: frange length ( frange -- n )
-    frange-length ;
-
-: increment-start ( frange -- )
-    [ [ frange-from ] keep frange-step + ] keep set-frange-from ;
+M: frange length ( frange -- n ) frange-length ;
+M: frange nth ( n frange -- obj ) [ frange-step * ] keep frange-from + ;
 
 : frange-range ( frange -- range )
     [ frange-step ] keep frange-length 1- * ;
 
-M: frange nth ( n frange -- obj )
-    [ frange-step * ] keep frange-from + ;
-
-! : pivot ( left right index seq -- )
-    ! [ nth ] keep [ exchange ] 3keep ;
-
-SYMBOL: step-size .01 step-size set  ! base on arguments
+SYMBOL: step-size .01 step-size set-global  ! TODO: base on arguments
 : (limit) ( count diff quot -- x quot )
     pick 10 > [ "Not converging fast enough" throw ] when
     [ call ] keep >r 2dup swap - 0 < [ "not converging" throw ] when
@@ -97,7 +85,8 @@ SYMBOL: step-size .01 step-size set  ! base on arguments
     swap [ step-size [ 2 / ] change rot 1+ -rot (limit) ] unless ;
 
 : limit ( quot -- x )
-    .1 step-size set [ call ] keep step-size [ 2 / ] change 0 -rot (limit) 2drop ;
+    .1 step-size set [ call ] keep
+    step-size [ 2 / ] change 0 -rot (limit) 2drop ;
 
 : nth-rand ( seq -- elem ) [ length random-int ] keep nth ;