steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Removed some crap group-map stuff

cvs
Doug Coleman 2005-11-17 00:41:27 +00:00
parent e5ea678b53
commit 40d531679a
1 changed files with 6 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
contrib/math/numerical-integration.factor
View File

@ -1,9 +1,7 @@
IN: math-contrib
USING: kernel sequences errors namespaces math lists vectors ;
SYMBOL: step-size .01 step-size set
SYMBOL: num-steps 180 num-steps set ! simpsons
USING: kernel sequences errors namespaces math lists vectors errors prettyprint ;
USING: io inspector ;
: setup-range ( from to -- frange )
step-size get swap <frange> ;
@ -18,6 +16,7 @@ SYMBOL: num-steps 180 num-steps set ! simpsons
[ + 2 / step-size get * ] 2map sum ;
SYMBOL: num-steps 180 num-steps set ! simpsons
: setup-simpson-range ( from to -- frange )
[ swap - num-steps get /f ] 2keep swapd <frange> ;
@ -25,23 +24,10 @@ SYMBOL: num-steps 180 num-steps set ! simpsons
length 2 / V{ 1 4 } clone swap 2 -
[ { 2 4 } append ] times { 1 } append ;
! take elements n at a time and apply the quotation, forming a new seq
: group-map ( seq n quot -- seq )
pick length pick /
[ [ >r pick pick r> -rot pick over * [ + ] keep swap rot <slice> pick call
, ] repeat ] { } make 2nip nip ;
: nths ( n seq -- seq )
2dup length 0 -rot <frange> dup decrement-length [ over nth ] map 2nip ;
! broken
! take a set of every nth element and apply the quotation, forming a new seq
! { 1 2 3 4 5 6 } 3 [ sum ] -> { 1 4 } { 2 5 } { 3 6 } -> { 5 7 9 }
! : skip-map ( seq n quot -- seq )
! pick length pick / [ 1+ >r pick r> swap dupd nths 1- ] repeat ;
: integrate-simpson ( from to f -- x )
>r setup-simpson-range r> dupd map dup generate-simpson-weights
[ * ] 2map sum swap [ third ] keep first - 6 / * ;
: quadrature ( from to f -- x )
integrate-simpson ;