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

Cleanup of math.analysis

db4
Aaron Schaefer 2008-11-06 01:20:08 -05:00
parent c9449cf3f5
commit 636c344eb0
1 changed files with 17 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
extra/math/analysis/analysis.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! Copyright (C) 2008 Doug Coleman, Slava Pestov, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.constants math.functions math.intervals USING: combinators.short-circuit kernel math math.constants math.functions
math.vectors namespaces sequences combinators.short-circuit ; math.vectors sequences ;
IN: math.analysis IN: math.analysis
<PRIVATE <PRIVATE
@ -22,16 +22,16 @@ IN: math.analysis
: (gamma-lanczos6) ( x -- log[gamma[x+1]] ) : (gamma-lanczos6) ( x -- log[gamma[x+1]] )
#! log(gamma(x+1) #! log(gamma(x+1)
[ 0.5 + dup gamma-g6 + dup [ log * ] dip - ] [ 0.5 + dup gamma-g6 + [ log * ] keep - ]
[ 6 gamma-z gamma-p6 v. log ] bi + ; [ 6 gamma-z gamma-p6 v. log ] bi + ;
: gamma-lanczos6 ( x -- gamma[x] ) : gamma-lanczos6 ( x -- gamma[x] )
#! gamma(x) = gamma(x+1) / x #! gamma(x) = gamma(x+1) / x
dup (gamma-lanczos6) exp swap / ; [ (gamma-lanczos6) exp ] keep / ;
: gammaln-lanczos6 ( x -- gammaln[x] ) : gammaln-lanczos6 ( x -- gammaln[x] )
#! log(gamma(x)) = log(gamma(x+1)) - log(x) #! log(gamma(x)) = log(gamma(x+1)) - log(x)
dup (gamma-lanczos6) swap log - ; [ (gamma-lanczos6) ] keep log - ;
: gamma-neg ( gamma[abs[x]] x -- gamma[x] ) : gamma-neg ( gamma[abs[x]] x -- gamma[x] )
dup pi * sin * * pi neg swap / ; inline dup pi * sin * * pi neg swap / ; inline
@ -44,7 +44,7 @@ PRIVATE>
dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [ dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
drop 1./0. drop 1./0.
] [ ] [
dup abs gamma-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if [ abs gamma-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ; ] if ;
: gammaln ( x -- gamma[x] ) : gammaln ( x -- gamma[x] )
@ -53,11 +53,11 @@ PRIVATE>
dup 0 < [ dup 0 < [
drop 1./0. drop 1./0.
] [ ] [
dup abs gammaln-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if [ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ; ] if ;
: nth-root ( n x -- y ) : nth-root ( n x -- y )
[ recip ] dip swap ^ ; swap recip ^ ;
! Forth Scientific Library Algorithm #1 ! Forth Scientific Library Algorithm #1
! !
@ -116,6 +116,6 @@ PRIVATE>
: stirling-fact ( n -- fact ) : stirling-fact ( n -- fact )
[ pi 2 * * sqrt ] [ pi 2 * * sqrt ]
[ dup e / swap ^ ] [ [ e / ] keep ^ ]
[ 12 * recip 1 + ] [ 12 * recip 1+ ] tri * * ;
tri * * ;