




[UNDEFINED] float [IF]









































[UNDEFINED] floats [IF]
[UNDEFINED] um* [IF]





















[UNDEFINED] um/mod [IF]
[UNDEFINED] d+ [IF]




[UNDEFINED] d+ [IF]
[UNDEFINED] 2over [IF]



[UNDEFINED] 2OVER [IF]
: 2! SWAP OVER ! CELL+ ! ;
: 2@ DUP CELL+ @ SWAP @ ;
: 2OVER 2>R 2DUP 2R> 2SWAP ;
: 2ROT 2>R 2SWAP 2R> 2SWAP ;
[THEN]

[THEN]
[UNDEFINED] highbit [IF]



[UNDEFINED] 10K [IF]
10000 constant 10K
[THEN]

[UNDEFINED] unit-bits [IF]
8 constant unit-bits
[THEN]

[UNDEFINED] char-bits [IF]
unit-bits /char * constant char-bits
[THEN]

[UNDEFINED] cell-bits [IF]
unit-bits /cell * constant cell-bits
[THEN]

[UNDEFINED] highbit [IF]
(error) constant highbit
[THEN]

[UNDEFINED] lowbits [IF]
max-n constant lowbits
[THEN]

[UNDEFINED] NULL [IF]
-1 constant NULL
[THEN]
[THEN]

0 constant u>d
aka drop d>u

: 0. 0 dup ;
: signs? xor highbit and ;
: u< 2dup signs? if nip else - then 0< ;
: u> swap u< ;
: d+ >r rot over + dup >r u> if 1+ then r> swap r> + ;
: d2* 2dup d+ ;
: dnegate invert swap invert swap 1 0 d+ ;
: d- dnegate d+ ;
: d< d- nip 0< ;
: d+- 0< if dnegate then ;
: dabs dup d+- ;
: d2/ >r 2/ r@ 1 and if highbit or else lowbits and then r> 2/ ;
: du< rot 2dup = if 2drop u< else u> nip nip then ;
: d= d- or 0= ;
: d0< nip 0< ;
: d0= or 0= ;
: dmax 2over 2over d< if 2swap then 2drop ;
: dmin 2over 2over d< 0= if 2swap then 2drop ;
[THEN]

[THEN]

[UNDEFINED] CELL-BITS [IF]




[UNDEFINED] 10K [IF]
10000 constant 10K
[THEN]

[UNDEFINED] unit-bits [IF]
8 constant unit-bits
[THEN]

[UNDEFINED] char-bits [IF]
unit-bits /char * constant char-bits
[THEN]

[UNDEFINED] cell-bits [IF]
unit-bits /cell * constant cell-bits
[THEN]

[UNDEFINED] highbit [IF]
(error) constant highbit
[THEN]

[UNDEFINED] lowbits [IF]
max-n constant lowbits
[THEN]

[UNDEFINED] NULL [IF]
-1 constant NULL
[THEN]

[THEN]

: d2*+
over highbit and >r >r 2dup d+ r> u>d d+ r>
;

: um/mod
0 swap CELL-BITS 1+ 0
do >r over r@ u< 0= or if r@ - 1 else 0 then d2*+ r> loop
drop swap 1 rshift or swap
;

: fm/mod
dup >r dup 0< if negate >r dnegate r> then
over 0< if tuck + swap then um/mod
r> 0< if swap negate swap then
;

: sm/rem
over >r dup >r abs -rot
dabs rot um/mod
r> r@ xor 0< if negate then
r> 0< if swap negate swap then
;

: um*
>r 0 swap
CELL-BITS 0 do 0 over 0< if invert then j and d2*+ drop loop
r> drop
;

: m*
2dup signs? >r
abs swap abs um*
r> if dnegate then
;

: m*/
>r 0 over 0< if invert then >r abs -rot 0 over 0< if invert then r> xor r>
swap >r >r dabs rot tuck um* 2swap um* swap >r 0 d+ r> -rot r@ um/mod -rot
r> um/mod nip swap r> if dnegate then
;

: m+ 0 over 0< if invert then d+ ;
: mu* swap over * >r um* r> + ;
: mu/mod >r 0 r@ um/mod r> swap >r um/mod r> ;
: ud* >r swap >r over over um* rot r> * + rot r> * + ;

aka ud* d*
[DEFINED] 4TH# [IF] hide d2*+ [THEN]
[THEN]
[THEN]

[UNDEFINED] FLOATING-STACK [IF]
16 CONSTANT FLOATING-STACK
[THEN]

[IGNORE] FALIGN
[IGNORE] FALIGNED






3 CELLS CONSTANT c/float
c/float NEGATE CONSTANT -c/float
c/float CONSTANT FLOAT
c/float +CONSTANT FLOAT+
c/float *CONSTANT FLOATS

VARIABLE sigdigits
VARIABLE fsp

FLOATING-STACK FLOATS ARRAY fstak
FLOAT 2 * ARRAY ftemp

CELL-BITS 1- 602 * 1000 / CONSTANT maxdigits

max-n CONSTANT &unsign
(error) CONSTANT &sign
&sign 2 / &sign + CONSTANT &esign
&esign [SIGN] 1 [=] [NOT] [IF] [ABORT] [THEN]





VARIABLE ferror



0 enum FE.NOERRORS
enum FE.DIVBYZERO
enum FE.OVERFLOW
enum FE.UNDERFLOW
enum FE.INVALID
constant FE.INEXACT

: ud2/
D2/ &unsign AND ;

: frshift
SWAP 0 MAX CELL-BITS 2 * MIN
>R DUP 2@ R> 0 ?DO ud2/ LOOP ROT 2! ;

: exp>sign
DUP &unsign AND
DUP &esign AND 2* OR
SWAP &sign AND ;

: sign>exp
SWAP &unsign AND OR ;

: t2*
D2* ROT DUP 0< 1 AND >R 2* ROT ROT R> 0 D+ ;

: t2/
OVER 1 AND 0 SWAP IF INVERT THEN &sign AND >R D2/ ROT
1 RSHIFT R> OR ROT ROT ;

: t+
2>R >R ROT 0 R> 0 D+ 0 2R> D+
ROT >R D+ R> ROT ROT ;

: tneg
0<> >R 2DUP OR 0<> R> AND IF DNEGATE -1 ELSE 0 THEN ;

: lstemp
ftemp 6 CELLS + 0
6 0 ?DO >R -1 CELLS +
DUP @ 0 D2* SWAP R> +
ROT TUCK ! SWAP
LOOP 2DROP ;

: *norm
>R BEGIN DUP 0< 0=
WHILE t2* R> 1- >R
REPEAT 2DUP AND 1+ IF &sign 0 0 t+ THEN
ROT DROP R> ;

: longdiv
0 0 ftemp 2!
CELL-BITS 2 * 1+
0 ?DO 2OVER 2OVER DU<
IF 0
ELSE 2DUP 2>R D- 2R> 1
THEN 0 ftemp 2@ D2* D+ ftemp 2!
2SWAP D2* 2SWAP
LOOP DU< 0= 1 AND 0
ftemp 2@ D+ ;



: 'm1 fsp @ 3 CELLS - ;
: 'm2 fsp @ 6 CELLS - ;
: 'm3 fsp @ 9 CELLS - ;
: 'e1 fsp @ 1 CELLS - ;
: 'e2 fsp @ 4 CELLS - ;
: fmove c/float smove ;
: m1get 'm1 fmove ;
: m1sto 'm1 SWAP fmove ;
: expx1 'e1 @ exp>sign ;
: expx2 'e2 @ exp>sign ;
: ftemp' ftemp 2 CELLS + ;
: >exp1 sign>exp 'e1 ! ;
: fshift expx1 >R + R> >exp1 ;



: normalize
'm1 2@ 2DUP OR
IF 0 ROT ROT expx1 >R *norm
R> >exp1 'm1 2!
ELSE 2DROP
THEN ;




: F2* 1 fshift ;
: F2/ -1 fshift ;
: PRECISION sigdigits @ ;
: SET-PRECISION maxdigits MIN sigdigits ! ;
: FCLEAR fstak fsp ! FE.NOERRORS ferror ! ;
: FDEPTH fsp @ fstak - c/float / ;
: FDUP c/float fsp +! 'm2 m1get ;
: FDROP -c/float fsp +! ;
: FNEGATE 'e1 @ &sign XOR 'e1 ! ;
: D>F FDUP DUP 0< IF DNEGATE &sign ELSE 0 THEN
'e1 ! 'm1 2! normalize ;
: F>D expx1 >R DUP 1- 0<
IF NEGATE &unsign AND 'm1 frshift 'm1 2@ R> IF DNEGATE THEN
ELSE R> 2DROP -1 &unsign FE.OVERFLOW ferror !
THEN FDROP ;
: S>F DUP ABS U>D ROT 0< IF DNEGATE THEN D>F ;
: F>S F>D 2DUP D0< >R DABS D>U R> IF NEGATE THEN ;
: FLOAT>EXP normalize F2* 'm1 2@ ud2/ expx1 SWAP >R D+- R> FDROP ;
: EXP>FLOAT FDUP OVER &sign AND >R >R DABS 'm1 2! R> R> >exp1 normalize ;
: F@ FDUP m1get ;
: F! m1sto FDROP ;
: FSIGN? 'e1 @ 0< ;
: F0<> 'm1 2@ OR 0<> FDROP ;
: F0= F0<> 0= ;
: F0< FSIGN? F0<> AND ;
: F0> FSIGN? 0= F0<> AND ;
: FABS FSIGN? IF FNEGATE THEN ;
: FSWAP
'm1 ftemp fmove 'm2 m1get ftemp 'm2 fmove ;
: FOVER
c/float fsp +! 'm3 m1get ;
: FPICK
c/float fsp +! 2 + -c/float * fsp @ + m1get ;
: FNIP FSWAP FDROP ;
: FROT
'm3 ftemp fmove 'm2 'm3 c/float 2 * smove ftemp m1get ;
: F+
FDUP F0= IF FDROP EXIT THEN
FOVER F0= IF FNIP EXIT THEN
expx1 >R expx2 >R - DUP 0<
IF NEGATE 'm1 frshift 0
ELSE DUP 'm2 frshift
THEN 'e2 @ +
'm2 2@ R> tneg
'm1 2@ R> tneg
t+ DUP >R
DUP IF t2/ IF DNEGATE THEN 'm2 2! 1+
ELSE DROP 'm2 2!
THEN R> &sign AND sign>exp 'e2 !
FDROP normalize ;

: F-
FNEGATE F+ ;

: F<
F- F0< ;

: F=
F- F0= ;

: FLOOR FDUP F0< FDUP F>D D>F FOVER F- F0= 0= AND F>D ROT
IF 1 U>D DNEGATE D+ THEN D>F ;

: FROUND
expx1 >R NEGATE 1- 'm1 frshift
'm1 2@ 1 U>D D+ SWAP -2 AND SWAP
'm1 2! -1 R> >exp1 normalize ;

: FMIN FOVER FOVER F<
IF FDROP ELSE FNIP THEN ;

: FMAX FOVER FOVER F<
IF FNIP ELSE FDROP THEN ;

: F*
'm1 2@ 'm2 2@
OVER >R ftemp' 2!
OVER >R ftemp 2!
R> R> OR

IF FTEMP CELL+ @ FTEMP' CELL+ @ UM* &sign 0 D+ NIP
FTEMP @ FTEMP' @ UM*
FTEMP CELL+ @ FTEMP' @ UM* 0 t+
FTEMP @ FTEMP' CELL+ @ UM* 0 t+
ELSE 0 ftemp @ ftemp' @ UM*
THEN 2DUP OR >R >R OVER R> R> ROT OR
IF expx1 >R expx2 >R + CELL-BITS 2 * + *norm
R> R> XOR sign>exp 'e2 !
ELSE DROP
THEN 'm2 2! FDROP ;

: F/
FDUP F0=
IF FDROP -1 -1 'm1 2! FE.DIVBYZERO ferror !
'e1 @ &sign AND &esign 1- OR 'e1 !
ELSE 'm2 2@ 'm1 2@
DU< 0= IF 1 'm2 frshift F2/ THEN
'm1 CELL+ @
IF 'm2 2@ ud2/ 'm1 2@ ud2/ longdiv
ELSE 0 'm2 2@ 'm1 @ DUP >R UM/MOD
ROT ROT R@ UM/MOD ROT ROT R> 1 RSHIFT U>
IF 1 U>D D+ THEN
THEN expx2 >R expx1 >R - CELL-BITS 2 * -
>R 'm2 2! R> R> R> XOR sign>exp 'E2 !
FDROP
THEN ;

: F~
FDUP F0<
IF FABS FOVER FABS 3 FPICK FABS F+ F*
FROT FROT F- FABS FSWAP F<
ELSE FDUP F0=
IF FDROP 'e1 @ 0< 'e2 @ 0< = F- F0= AND
ELSE FROT FROT F- FABS FSWAP F<
THEN
THEN ;

: FSQRT
expx1 IF drop FE.INVALID ferror ! EXIT THEN
DUP 1 AND DUP >R +
2/ CELL-BITS - 0 >exp1
ftemp 6 BOUNDS DO 0 I ! LOOP
'm1 2@
R> IF ud2/ THEN
ftemp 2 CELLS + 2!
0 0 CELL-BITS 2 *
0 ?DO lstemp lstemp
D2*
2DUP D2* ftemp 2@ D<
IF ftemp 2@ 2OVER D2* 1 U>D D+ D-
ftemp 2!
1 U>D D+
THEN
LOOP 'm1 2! normalize ;







: fsplit

>R expx1 NIP FABS
FDUP F>D 2DUP D>F F-
2 0 R> 0 ?DO D2* 2DUP D2* D2* D+ LOOP
D>F F* F>D 1 U>D D+ ud2/ ;

[DEFINED] 4TH# [IF]
hide c/float
hide -c/float
hide sigdigits
hide fstak
hide ftemp
hide &unsign
hide &sign
hide &esign
hide ud2/
hide frshift
hide exp>sign
hide sign>exp
hide t2*
hide t2/
hide t+
hide tneg
hide lstemp
hide *norm
hide longdiv
hide 'm1
hide 'm2
hide 'm3
hide 'e1
hide 'e2
hide fmove
hide m1get
hide m1sto
hide expx1
hide expx2
hide ftemp'
hide >exp1
hide fshift
hide normalize
[THEN]
[THEN]











[UNDEFINED] >float [IF]
[UNDEFINED] fsplit [IF] [ABORT] [THEN]
[UNDEFINED] d# [IF]



[UNDEFINED] num>char [IF]
[UNDEFINED] mu/mod [IF]





















[UNDEFINED] um/mod [IF]
[UNDEFINED] d+ [IF]




[UNDEFINED] d+ [IF]
[UNDEFINED] 2over [IF]



[UNDEFINED] 2OVER [IF]
: 2! SWAP OVER ! CELL+ ! ;
: 2@ DUP CELL+ @ SWAP @ ;
: 2OVER 2>R 2DUP 2R> 2SWAP ;
: 2ROT 2>R 2SWAP 2R> 2SWAP ;
[THEN]

[THEN]
[UNDEFINED] highbit [IF]



[UNDEFINED] 10K [IF]
10000 constant 10K
[THEN]

[UNDEFINED] unit-bits [IF]
8 constant unit-bits
[THEN]

[UNDEFINED] char-bits [IF]
unit-bits /char * constant char-bits
[THEN]

[UNDEFINED] cell-bits [IF]
unit-bits /cell * constant cell-bits
[THEN]

[UNDEFINED] highbit [IF]
(error) constant highbit
[THEN]

[UNDEFINED] lowbits [IF]
max-n constant lowbits
[THEN]

[UNDEFINED] NULL [IF]
-1 constant NULL
[THEN]
[THEN]

0 constant u>d
aka drop d>u

: 0. 0 dup ;
: signs? xor highbit and ;
: u< 2dup signs? if nip else - then 0< ;
: u> swap u< ;
: d+ >r rot over + dup >r u> if 1+ then r> swap r> + ;
: d2* 2dup d+ ;
: dnegate invert swap invert swap 1 0 d+ ;
: d- dnegate d+ ;
: d< d- nip 0< ;
: d+- 0< if dnegate then ;
: dabs dup d+- ;
: d2/ >r 2/ r@ 1 and if highbit or else lowbits and then r> 2/ ;
: du< rot 2dup = if 2drop u< else u> nip nip then ;
: d= d- or 0= ;
: d0< nip 0< ;
: d0= or 0= ;
: dmax 2over 2over d< if 2swap then 2drop ;
: dmin 2over 2over d< 0= if 2swap then 2drop ;
[THEN]

[THEN]

[UNDEFINED] CELL-BITS [IF]




[UNDEFINED] 10K [IF]
10000 constant 10K
[THEN]

[UNDEFINED] unit-bits [IF]
8 constant unit-bits
[THEN]

[UNDEFINED] char-bits [IF]
unit-bits /char * constant char-bits
[THEN]

[UNDEFINED] cell-bits [IF]
unit-bits /cell * constant cell-bits
[THEN]

[UNDEFINED] highbit [IF]
(error) constant highbit
[THEN]

[UNDEFINED] lowbits [IF]
max-n constant lowbits
[THEN]

[UNDEFINED] NULL [IF]
-1 constant NULL
[THEN]

[THEN]

: d2*+
over highbit and >r >r 2dup d+ r> u>d d+ r>
;

: um/mod
0 swap CELL-BITS 1+ 0
do >r over r@ u< 0= or if r@ - 1 else 0 then d2*+ r> loop
drop swap 1 rshift or swap
;

: fm/mod
dup >r dup 0< if negate >r dnegate r> then
over 0< if tuck + swap then um/mod
r> 0< if swap negate swap then
;

: sm/rem
over >r dup >r abs -rot
dabs rot um/mod
r> r@ xor 0< if negate then
r> 0< if swap negate swap then
;

: um*
>r 0 swap
CELL-BITS 0 do 0 over 0< if invert then j and d2*+ drop loop
r> drop
;

: m*
2dup signs? >r
abs swap abs um*
r> if dnegate then
;

: m*/
>r 0 over 0< if invert then >r abs -rot 0 over 0< if invert then r> xor r>
swap >r >r dabs rot tuck um* 2swap um* swap >r 0 d+ r> -rot r@ um/mod -rot
r> um/mod nip swap r> if dnegate then
;

: m+ 0 over 0< if invert then d+ ;
: mu* swap over * >r um* r> + ;
: mu/mod >r 0 r@ um/mod r> swap >r um/mod r> ;
: ud* >r swap >r over over um* rot r> * + rot r> * + ;

aka ud* d*
[DEFINED] 4TH# [IF] hide d2*+ [THEN]
[THEN]
[THEN]

/hold 2 * constant /dhold
/dhold string dholdbuf
dholdbuf /dhold + constant dholdend
variable hld

: num>char dup 9 > if 7 + then 48 + ;
: dhold hld -1 over +! @ c! ;
: <d# dholdend hld ! ;
: d#> 2drop hld @ dholdend over - ;
: dsign rot 0< if 45 dhold then ;
: d# base @ mu/mod rot num>char dhold ;
: d#s begin d# 2dup or 0= until ;

[DEFINED] 4TH# [IF]
hide hld
hide dholdbuf
hide dholdend
[THEN]
[THEN]
[THEN]






: (F.)

<d# FDEPTH 1- 0< IF 0 0 EXIT THEN
PRECISION fsplit
PRECISION 0 ?DO d# LOOP D+
PRECISION IF 46 dhold THEN
d#s dsign d#> ;

: F. (F.) PRECISION 1+ MIN TYPE SPACE ;
: R. (F.) TYPE SPACE ;

: (E.)
>R FDUP FABS 0
BEGIN FDUP 1 S>F F<
WHILE OVER - R@ S>F F*
REPEAT
BEGIN FDUP R@ S>F F< 0=
WHILE OVER + R@ S>F F/
REPEAT R> DROP NIP
FSWAP F0< IF FNEGATE THEN
(F.) TYPE
DUP ABS S>D <# #S SIGN
69 HOLD #> TYPE SPACE ;

: FS. 1 10 (E.) ;
: FE. 3 1000 (E.) ;



: fsign
OVER C@ OVER IF DUP
45 = IF DROP CHOP -1 EXIT ELSE
43 = IF CHOP THEN THEN
ELSE DROP THEN 0
;

variable flgood

: fdigit?
DUP 0<> >R
OVER C@ 48 - DUP 0< OVER 9 > OR 0=
R> AND DUP
IF 2SWAP CHOP 2SWAP
1 flgood +!
THEN ;

: flint
BEGIN fdigit?
WHILE 10 S>F F* S>F F+
REPEAT DROP ;

: flexp
OVER C@ 68 -
-34 AND 0=
flgood @ 1 <> AND
IF CHOP fsign >R 0 >R
BEGIN fdigit?
WHILE R> 10 * + >R
REPEAT DROP R> R>
IF 0 ?DO 10 S>F F/ LOOP
ELSE 0 ?DO 10 S>F F* LOOP
THEN
THEN DUP
IF 0 flgood !
THEN ;

: flfrac
CHOP 1 S>F
BEGIN fdigit?
WHILE 10 S>F F/
FDUP S>F F*
FROT F+ FSWAP
REPEAT FDROP DROP DUP
IF flexp
THEN ;

: >FLOAT

-TRAILING 0 S>F
fsign >R 1 flgood !
flint DUP
IF OVER C@ 46 =
IF flfrac ELSE flexp THEN
THEN 2DROP
R> IF FNEGATE THEN
flgood @ IF true ELSE FDROP false THEN
;

: S>FLOAT >FLOAT 0= ABORT" Bad float" ;

: F.S FDEPTH BEGIN DUP IF DUP THEN WHILE 1- DUP FPICK F. REPEAT CR ;

[DEFINED] 4TH# [IF]
hide fsplit
hide fsign
hide flgood
hide fdigit?
hide flint
hide flexp
hide flfrac
[THEN]
[THEN]

[THEN]


















[UNDEFINED] fbeta.cdf [IF]
[UNDEFINED] gammaln [IF]







[UNDEFINED] fbeta [IF]
[UNDEFINED] fln [IF]























[UNDEFINED] fln [IF]
[UNDEFINED] s>float [IF] [ABORT] [THEN]
[UNDEFINED] frexp [IF]



[UNDEFINED] frexp [IF]
[UNDEFINED] float>exp [IF] [ABORT] [THEN]
: LDEXP >R float>exp R> + exp>float ;
: FREXP float>exp CELL-BITS 2 * 1- TUCK + >R NEGATE exp>float R> ;
[THEN]
[THEN]
fclear

float array Ln10 s" 2.302585092994045684018" s>float Ln10 f! does> f@ ;

float array _Ln2Hi s" 6.93147180369123816490e-01" s>float _Ln2Hi f!
float array _Ln2Lo s" 1.90821492927058770002e-10" s>float _Ln2Lo f!

float array _L1 s" 6.666666666666735130e-01" s>float _L1 f!
float array _L2 s" 3.999999999940941908e-01" s>float _L2 f!
float array _L3 s" 2.857142874366239149e-01" s>float _L3 f!
float array _L4 s" 2.222219843214978396e-01" s>float _L4 f!
float array _L5 s" 1.818357216161805012e-01" s>float _L5 f!
float array _L6 s" 1.531383769920937332e-01" s>float _L6 f!
float array _L7 s" 1.479819860511658591e-01" s>float _L7 f!

: (t1)
_L7 f@ fover f*
_L5 f@ f+ fover f*
_L3 f@ f+ fover f*
_L1 f@ f+ frot f*
;

: (t2)
_L6 f@ fover f*
_L4 f@ f+ fover f*
_L2 f@ f+ f*
;

: fln
fdup f0> 0= if FE.INVALID ferror ! exit then
frexp fdup 2 s>f fsqrt f2/ f< if f2* 1- then s>f fdup
_Ln2Hi f@ f* fswap
_Ln2Lo f@ f* frot 1 s>f f-

fswap fover
fdup fdup f* f2/
fswap fdup 2 s>f f+ f/
fdup fdup f*
fdup fdup f*
(t1) fswap (t2) f+
frot fswap fover f+
frot f*
frot f+ f-
fswap f- f-
;

: flog fln Ln10 f/ ;
[DEFINED] 4TH# [IF]
hide _Ln2Hi
hide _Ln2Lo
hide _L1
hide _L2
hide _L3
hide _L4
hide _L5
hide _L6
hide _L7
hide (t1)
hide (t2)
[THEN]
[THEN]
[THEN]
[UNDEFINED] me>f [IF]






[UNDEFINED] me>f [IF]
[DEFINED] ZenFP [IF] [IGNORE] me>f [ELSE]
[UNDEFINED] float [IF] [ABORT] [THEN]
: u>f u>d d>f ;
: f**2 fdup f* ;
: 1/f 1 u>f fswap f/ ;

create f10** 10 , 100 , 10000 , 100000000 ,
does>
over 9 > if
swap 9 - swap 1 u>f 4 bounds
do dup if dup 1 and if i @c u>f f* then 2/ else leave then loop
drop 1000000000 u>f f* exit
then drop 1 swap 0 ?do 10 * loop u>f
;

: me>f dup 0< if 1 u>f abs f10** f/ else f10** then s>f f* ;
[THEN]
[THEN]
[THEN]

6 floats array _L

s" 76.18009172947146" s>float _L 0 floats + f!
s" -86.50532032941677" s>float _L 1 floats + f!
s" 24.01409824083091" s>float _L 2 floats + f!
s" -1.231739572450155" s>float _L 3 floats + f!
s" 0.1208650973866179e-2" s>float _L 4 floats + f!
s" -0.5395239384953e-5" s>float _L 5 floats + f!

: gammaln
fdup f0> 0= if FE.INVALID ferror ! exit then
190015 -15 me>f 1 u>f f+ fover
6 0 do 1 u>f f+ _L i floats + f@ fover f/ frot f+ fswap loop fdrop
fover fdup 55 -1 me>f f+ fdup fln
frot 1 u>f 2 u>f f/ f+ f* f- fnegate fswap
746310005 -16 me>f 25066282 -7 me>f f+ f* frot f/ fln f+
;

[DEFINED] 4TH# [IF]
hide _L
[THEN]
[THEN]
[THEN]
[UNDEFINED] fexp [IF]







[UNDEFINED] fexp [IF]
[UNDEFINED] fpow [IF]



[UNDEFINED] fpow [IF]
[UNDEFINED] float [IF] [ABORT] [THEN]
[DEFINED] ZenFP [IF] [ABORT] [THEN]
: fpow
dup
if dup 1 = if drop else 2 /mod fdup fdup f* recurse fswap recurse f* then
else drop fdrop 1 s>f
then
;
[THEN]
[THEN]
[UNDEFINED] e [IF]



[UNDEFINED] PI [IF]
[UNDEFINED] S>FLOAT [IF] [ABORT] [THEN]
[UNDEFINED] ZenFP [IF] fclear [THEN]
FLOAT array PI s" 3.1415926535897932384626433832795" s>float PI f! DOES> f@ ;
FLOAT array E s" 2.7182818284590452353602874713527" s>float E f! DOES> f@ ;
[THEN]
[THEN]

fclear





float array _P0 s" 1.40494759056359379684565" s>float _P0 f!
float array _P1 s" 1.66666666666666019037e-01" s>float _P1 f!
float array _P2 s" -2.77777777770155933842e-03" s>float _P2 f!
float array _P3 s" 6.61375632143793436117e-05" s>float _P3 f!
float array _P4 s" -1.65339022054652515390e-06" s>float _P4 f!
float array _P5 s" 4.13813679705723846039e-08" s>float _P5 f!











: (R1)
fdup fdup f*
_P5 f@ fover f*
_P4 f@ f+ fover f*
_P3 f@ f+ fover f*
_P2 f@ f+ fover f*
_P1 f@ f+ f* f-
;

: (reduce)
17 s>f 50 s>f f/ fswap
begin fover fover f< while fover f- frot _P0 f@ f* frot frot repeat fnip
;

: fexp
fdup f0< >r fabs fdup f>s e dup fpow fswap s>f f-
(reduce) fdup (R1) fover fover f* fswap 2 s>f fswap f- f/ f+ 1 s>f f+
f* r> if 1 s>f fswap f/ then
;

[DEFINED] 4TH# [IF]
hide _P0
hide _P1
hide _P2
hide _P3
hide _P4
hide _P5
hide (R1)
hide (reduce)
[THEN]
[THEN]
[THEN]

float array _beta
float array _xx
float array _pp
float array _qq
float array _psq
float array _cx
float array _ai
float array _rx
float array _acu
float array _term

1 -15 me>f _acu f!

[DEFINED] debug-betacdf [IF]
: ~ ." beta =" _beta f@ f. cr
." xx   =" _xx f@ f. cr
." pp   =" _pp f@ f. cr
." qq   =" _qq f@ f. cr
." psq  =" _psq f@ f. cr
." cx   =" _cx f@ f. cr
." ai   =" _ai f@ f. cr
." rx   =" _rx f@ f. cr
." acu  =" _acu f@ f. cr
." term =" _term f@ f. cr
;
[THEN]

: fbeta.cdf
fdup f0< fdup f0= or fover f0< fover f0= or or
if fdrop fdrop FE.INVALID ferror ! exit then

fover fover f+ _beta f! fover fover _qq f! _pp f!
gammaln fswap gammaln f+ _beta f@ gammaln f- _beta f!
_pp f@ _qq f@ frot

fdup f0< 1 u>f fover f< or
if fdrop fdrop FE.INVALID ferror ! exit then

fdup f0= 1 u>f fover f= or
1 u>f fover f- _cx f! frot frot
if fdrop fdrop exit then

fover fover f+ _psq f! frot frot
fover _psq f@ f* fover fswap f< dup

if
_cx f@ _xx f! _qq f! _cx f! _pp f!
else
_pp f! _xx f! _qq f!
then

1 u>f fdup _term f! fdup _ai f!
_qq f@ fdup _cx f@ _psq f@ f* f+ f>d
_xx f@ 2dup d0= 0= if _cx f@ f/ then
_rx f! fover f-

begin
_term dup f@ f* _rx f@ f* _pp f@ _ai f@ f+ f/ fdup f!
fswap fover f+ fswap fabs
_acu f@ fover f< fover _acu f@ f* fover f< or
while
fdrop 1 u>d d- _ai dup f@ 1 u>f f+ f! 2dup d0<
if
_psq dup f@ fdup 1 u>f f+ f!
else
_qq f@ _ai f@ f- 2dup d0= if _xx f@ _rx f! then
then
repeat 2drop fdrop

_xx f@ fln _pp f@ f* _cx f@ fln _qq f@ 1 u>f f- f* f+ _beta f@ f- fexp f*
_pp f@ f/ if 1 u>f fswap f- then
;

: fbetain fbeta.cdf _beta f@ fexp f* ;

[DEFINED] 4TH# [IF]
hide _beta
hide _xx
hide _pp
hide _qq
hide _psq
hide _cx
hide _ai
hide _rx
hide _acu
hide _term
[THEN]
[THEN]


fclear 100 set-precision

." Calculated (fbetain)" 9 emit 9 emit ." Tabulated " cr cr
s" 0.01" s>float s" 0.5" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0.200334842323119592691"
s>float f. cr
s" 0.1" s>float s" 0.5" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0.6435011087932843868028"
s>float f. cr
s" 1" s>float s" 0.5" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 3.141592653589793238463"
s>float f. cr
s" 0" s>float s" 1" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0"
s>float f. cr
s" 0.01" s>float s" 1" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0.01002512578676009053104"
s>float f. cr
s" 0.1" s>float s" 1" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0.1026334038989724008007"
s>float f. cr
s" 0.5" s>float s" 1" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0.5857864376269049511983"
s>float f. cr
s" 0.5" s>float s" 1" s>float s" 1" s>float fbetain f. 9 emit 9 emit s" 0.5"
s>float f. cr
s" 0.1" s>float s" 2" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.00466666666666666666667"
s>float f. cr
s" 0.2" s>float s" 2" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.01733333333333333333333"
s>float f. cr
s" 0.3" s>float s" 2" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.036"
s>float f. cr
s" 0.4" s>float s" 2" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.05866666666666666666667"
s>float f. cr
s" 0.5" s>float s" 2" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.0833333333333333333333"
s>float f. cr
s" 0.6" s>float s" 2" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.108"
s>float f. cr
s" 0.7" s>float s" 2" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.1306666666666666666667"
s>float f. cr
s" 0.8" s>float s" 2" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.149333333333333333333"
s>float f. cr
s" 0.9" s>float s" 2" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.162"
s>float f. cr
s" 0.5" s>float s" 5.5" s>float s" 5" s>float fbetain fs. 9 emit s" 4.835128128962753031186E-4"
s>float fs. cr
s" 0.9" s>float s" 10" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0.08606325015757300966498"
s>float f. cr
s" 0.5" s>float s" 10" s>float s" 5" s>float fbetain fs. 9 emit s" 8.96930218219280719281E-6"
s>float fs. cr
s" 1" s>float s" 10" s>float s" 5" s>float fbetain fs. 9 emit s" 9.99000999000999001E-5"
s>float fs. cr
s" 0.5" s>float s" 10" s>float s" 10" s>float fbetain fs. 9 emit s" 5.41254411223451471129E-7"
s>float fs. cr
s" 0.8" s>float s" 20" s>float s" 5" s>float fbetain fs. 9 emit s" 2.1639249470994688584E-6"
s>float fs. cr
s" 0.6" s>float s" 20" s>float s" 10" s>float fbetain fs. 9 emit s" 1.071799815562617758717E-9"
s>float fs. cr
s" 0.8" s>float s" 20" s>float s" 10" s>float fbetain fs. 9 emit s" 4.7465601998989890638E-9"
s>float fs. cr
s" 0.5" s>float s" 20" s>float s" 20" s>float fbetain fs. 9 emit s" 3.62722227596242201843E-13"
s>float fs. cr
s" 0.6" s>float s" 20" s>float s" 20" s>float fbetain fs. 9 emit s" 6.514065870190490256E-13"
s>float fs. cr
s" 0.7" s>float s" 30" s>float s" 10" s>float fbetain fs. 9 emit s" 3.52546397647583772331E-11"
s>float fs. cr
s" 0.8" s>float s" 30" s>float s" 10" s>float fbetain fs. 9 emit s" 1.1933087577077924988E-10"
s>float fs. cr
s" 0.7" s>float s" 40" s>float s" 20" s>float fbetain fs. 9 emit s" 1.2527510093313245975E-17"
s>float fs. cr
s" 0.1" s>float s" 1" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0.1026334038989724008007"
s>float f. cr
s" 0.2" s>float s" 1" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0.211145618000168242872"
s>float f. cr
s" 0.3" s>float s" 1" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0.3266799469318489040437"
s>float f. cr
s" 0.4" s>float s" 1" s>float s" 0.5" s>float fbetain f. 9 emit 9 emit s" 0.4508066615170332459283"
s>float f. cr
s" 0.2" s>float s" 1" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.18"
s>float f. cr
s" 0.2" s>float s" 1" s>float s" 3" s>float fbetain f. 9 emit 9 emit s" 0.1626666666666666666667"
s>float f. cr
s" 0.2" s>float s" 1" s>float s" 4" s>float fbetain f. 9 emit 9 emit s" 0.1476"
s>float f. cr
s" 0.2" s>float s" 1" s>float s" 5" s>float fbetain f. 9 emit 9 emit s" 0.134464"
s>float f. cr
s" 0.3" s>float s" 2" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.036"
s>float f. cr
s" 0.3" s>float s" 3" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.006975"
s>float f. cr
s" 0.3" s>float s" 4" s>float s" 2" s>float fbetain f. 9 emit 9 emit s" 0.001539"
s>float f. cr
s" 0.3" s>float s" 5" s>float s" 2" s>float fbetain fs. 9 emit s" 3.645E-4"
s>float fs. cr
