Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
6756613b29
|
|
@ -8,6 +8,8 @@ UNION: value-type array struct-type ;
|
|||
|
||||
M: array c-type ;
|
||||
|
||||
M: array c-type-class drop object ;
|
||||
|
||||
M: array heap-size unclip heap-size [ * ] reduce ;
|
||||
|
||||
M: array c-type-align first c-type-align ;
|
||||
|
|
|
|||
|
|
@ -13,13 +13,15 @@ DEFER: *char
|
|||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
TUPLE: c-type
|
||||
class
|
||||
boxer boxer-quot unboxer unboxer-quot
|
||||
getter setter
|
||||
reg-class size align stack-align? ;
|
||||
|
||||
: new-c-type ( class -- type )
|
||||
new
|
||||
int-regs >>reg-class ;
|
||||
int-regs >>reg-class
|
||||
object >>class ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
\ c-type new-c-type ;
|
||||
|
|
@ -63,6 +65,12 @@ M: string c-type ( name -- type )
|
|||
] ?if
|
||||
] if ;
|
||||
|
||||
GENERIC: c-type-class ( name -- class )
|
||||
|
||||
M: c-type c-type-class class>> ;
|
||||
|
||||
M: string c-type-class c-type c-type-class ;
|
||||
|
||||
GENERIC: c-type-boxer ( name -- boxer )
|
||||
|
||||
M: c-type c-type-boxer boxer>> ;
|
||||
|
|
@ -306,6 +314,7 @@ M: long-long-type box-return ( type -- )
|
|||
|
||||
[
|
||||
<c-type>
|
||||
c-ptr >>class
|
||||
[ alien-cell ] >>getter
|
||||
[ set-alien-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
|
|
@ -315,6 +324,7 @@ M: long-long-type box-return ( type -- )
|
|||
"void*" define-primitive-type
|
||||
|
||||
<long-long-type>
|
||||
integer >>class
|
||||
[ alien-signed-8 ] >>getter
|
||||
[ set-alien-signed-8 ] >>setter
|
||||
8 >>size
|
||||
|
|
@ -324,6 +334,7 @@ M: long-long-type box-return ( type -- )
|
|||
"longlong" define-primitive-type
|
||||
|
||||
<long-long-type>
|
||||
integer >>class
|
||||
[ alien-unsigned-8 ] >>getter
|
||||
[ set-alien-unsigned-8 ] >>setter
|
||||
8 >>size
|
||||
|
|
@ -333,6 +344,7 @@ M: long-long-type box-return ( type -- )
|
|||
"ulonglong" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
[ alien-signed-cell ] >>getter
|
||||
[ set-alien-signed-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
|
|
@ -342,6 +354,7 @@ M: long-long-type box-return ( type -- )
|
|||
"long" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
[ alien-unsigned-cell ] >>getter
|
||||
[ set-alien-unsigned-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
|
|
@ -351,6 +364,7 @@ M: long-long-type box-return ( type -- )
|
|||
"ulong" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
[ alien-signed-4 ] >>getter
|
||||
[ set-alien-signed-4 ] >>setter
|
||||
4 >>size
|
||||
|
|
@ -360,6 +374,7 @@ M: long-long-type box-return ( type -- )
|
|||
"int" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
[ alien-unsigned-4 ] >>getter
|
||||
[ set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
|
|
@ -369,6 +384,7 @@ M: long-long-type box-return ( type -- )
|
|||
"uint" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
[ alien-signed-2 ] >>getter
|
||||
[ set-alien-signed-2 ] >>setter
|
||||
2 >>size
|
||||
|
|
@ -378,6 +394,7 @@ M: long-long-type box-return ( type -- )
|
|||
"short" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
[ alien-unsigned-2 ] >>getter
|
||||
[ set-alien-unsigned-2 ] >>setter
|
||||
2 >>size
|
||||
|
|
@ -387,6 +404,7 @@ M: long-long-type box-return ( type -- )
|
|||
"ushort" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
[ alien-signed-1 ] >>getter
|
||||
[ set-alien-signed-1 ] >>setter
|
||||
1 >>size
|
||||
|
|
@ -396,6 +414,7 @@ M: long-long-type box-return ( type -- )
|
|||
"char" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
[ alien-unsigned-1 ] >>getter
|
||||
[ set-alien-unsigned-1 ] >>setter
|
||||
1 >>size
|
||||
|
|
@ -414,6 +433,7 @@ M: long-long-type box-return ( type -- )
|
|||
"bool" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
float >>class
|
||||
[ alien-float ] >>getter
|
||||
[ [ >float ] 2dip set-alien-float ] >>setter
|
||||
4 >>size
|
||||
|
|
@ -425,6 +445,7 @@ M: long-long-type box-return ( type -- )
|
|||
"float" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
float >>class
|
||||
[ alien-double ] >>getter
|
||||
[ [ >float ] 2dip set-alien-double ] >>setter
|
||||
8 >>size
|
||||
|
|
|
|||
|
|
@ -40,6 +40,9 @@ PREDICATE: string-type < pair
|
|||
|
||||
M: string-type c-type ;
|
||||
|
||||
M: string-type c-type-class
|
||||
drop object ;
|
||||
|
||||
M: string-type heap-size
|
||||
drop "void*" heap-size ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,8 @@ TUPLE: struct-type size align fields ;
|
|||
|
||||
M: struct-type heap-size size>> ;
|
||||
|
||||
M: struct-type c-type-class drop object ;
|
||||
|
||||
M: struct-type c-type-align align>> ;
|
||||
|
||||
M: struct-type c-type-stack-align? drop f ;
|
||||
|
|
|
|||
|
|
@ -260,7 +260,7 @@ M: #terminate emit-node drop stop-iterating ;
|
|||
|
||||
: emit-alien-node ( node quot -- next )
|
||||
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
|
||||
begin-basic-block iterate-next ; inline
|
||||
##branch begin-basic-block iterate-next ; inline
|
||||
|
||||
M: #alien-invoke emit-node
|
||||
[ ##alien-invoke ] emit-alien-node ;
|
||||
|
|
|
|||
|
|
@ -262,5 +262,17 @@ TUPLE: id obj ;
|
|||
[ 3 ] [ 1 t fixnum-overflow-control-flow-test ] unit-test
|
||||
[ 2 ] [ 1 f fixnum-overflow-control-flow-test ] unit-test
|
||||
|
||||
! LOL
|
||||
: blah ( a -- b )
|
||||
{ float } declare dup 0 =
|
||||
[ drop 1 ] [
|
||||
dup 0 >=
|
||||
[ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
|
||||
[ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
|
||||
if
|
||||
] if ;
|
||||
|
||||
[ 4.0 ] [ 2.0 blah ] unit-test
|
||||
|
||||
[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
|
||||
[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -37,31 +37,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
|
||||
\ bitnot { integer } "input-classes" set-word-prop
|
||||
|
||||
{
|
||||
fcosh
|
||||
flog
|
||||
fsinh
|
||||
fexp
|
||||
fasin
|
||||
facosh
|
||||
fasinh
|
||||
ftanh
|
||||
fatanh
|
||||
facos
|
||||
fpow
|
||||
fatan
|
||||
fatan2
|
||||
fcos
|
||||
ftan
|
||||
fsin
|
||||
fsqrt
|
||||
} [
|
||||
dup stack-effect
|
||||
[ in>> length real <repetition> "input-classes" set-word-prop ]
|
||||
[ out>> length float <repetition> "default-output-classes" set-word-prop ]
|
||||
2bi
|
||||
] each
|
||||
|
||||
: ?change-interval ( info quot -- quot' )
|
||||
over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
|
||||
|
||||
|
|
@ -222,8 +197,15 @@ generic-comparison-ops [
|
|||
|
||||
{
|
||||
{ >fixnum fixnum }
|
||||
{ bignum>fixnum fixnum }
|
||||
|
||||
{ >bignum bignum }
|
||||
{ fixnum>bignum bignum }
|
||||
{ float>bignum bignum }
|
||||
|
||||
{ >float float }
|
||||
{ fixnum>float float }
|
||||
{ bignum>float float }
|
||||
} [
|
||||
'[
|
||||
_
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ math.functions math.private strings layouts
|
|||
compiler.tree.propagation.info compiler.tree.def-use
|
||||
compiler.tree.debugger compiler.tree.checker
|
||||
slots.private words hashtables classes assocs locals
|
||||
float-arrays system sorting ;
|
||||
float-arrays system sorting math.libm ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
\ propagate must-infer
|
||||
|
|
@ -594,6 +594,10 @@ MIXIN: empty-mixin
|
|||
|
||||
[ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
|
||||
|
||||
[ V{ float } ] [ [ fsqrt ] final-classes ] unit-test
|
||||
|
||||
[ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
|
||||
|
||||
! [ V{ string } ] [
|
||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
! ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors kernel sequences sequences.private assocs words
|
||||
namespaces classes.algebra combinators classes classes.tuple
|
||||
classes.tuple.private continuations arrays
|
||||
classes.tuple.private continuations arrays alien.c-types
|
||||
math math.private slots generic definitions
|
||||
stack-checker.state
|
||||
compiler.tree
|
||||
|
|
@ -137,11 +137,12 @@ M: #call propagate-after
|
|||
dup word>> "input-classes" word-prop dup
|
||||
[ propagate-input-classes ] [ 2drop ] if ;
|
||||
|
||||
M: #alien-invoke propagate-before
|
||||
out-d>> [ object-info swap set-value-info ] each ;
|
||||
: propagate-alien-invoke ( node -- )
|
||||
[ out-d>> ] [ params>> return>> ] bi
|
||||
[ drop ] [ c-type-class <class-info> swap first set-value-info ] if-void ;
|
||||
|
||||
M: #alien-indirect propagate-before
|
||||
out-d>> [ object-info swap set-value-info ] each ;
|
||||
M: #alien-invoke propagate-before propagate-alien-invoke ;
|
||||
|
||||
M: #return annotate-node
|
||||
dup in-d>> (annotate-node) ;
|
||||
M: #alien-indirect propagate-before propagate-alien-invoke ;
|
||||
|
||||
M: #return annotate-node dup in-d>> (annotate-node) ;
|
||||
|
|
|
|||
|
|
@ -100,7 +100,7 @@ PRIVATE>
|
|||
{ [ dup integer? ] [ integer^ ] }
|
||||
{ [ 2dup real^? ] [ fpow ] }
|
||||
[ ^complex ]
|
||||
} cond ;
|
||||
} cond ; inline
|
||||
|
||||
: (^mod) ( n x y -- z )
|
||||
1 swap [
|
||||
|
|
@ -174,47 +174,61 @@ M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ;
|
|||
|
||||
M: complex log >polar swap flog swap rect> ;
|
||||
|
||||
: cos ( x -- y )
|
||||
dup complex? [
|
||||
>float-rect 2dup
|
||||
fcosh swap fcos * -rot
|
||||
fsinh swap fsin neg * rect>
|
||||
] [ fcos ] if ; foldable
|
||||
GENERIC: cos ( x -- y ) foldable
|
||||
|
||||
M: complex cos
|
||||
>float-rect 2dup
|
||||
fcosh swap fcos * -rot
|
||||
fsinh swap fsin neg * rect> ;
|
||||
|
||||
M: real cos fcos ;
|
||||
|
||||
: sec ( x -- y ) cos recip ; inline
|
||||
|
||||
: cosh ( x -- y )
|
||||
dup complex? [
|
||||
>float-rect 2dup
|
||||
fcos swap fcosh * -rot
|
||||
fsin swap fsinh * rect>
|
||||
] [ fcosh ] if ; foldable
|
||||
GENERIC: cosh ( x -- y ) foldable
|
||||
|
||||
M: complex cosh
|
||||
>float-rect 2dup
|
||||
fcos swap fcosh * -rot
|
||||
fsin swap fsinh * rect> ;
|
||||
|
||||
M: real cosh fcosh ;
|
||||
|
||||
: sech ( x -- y ) cosh recip ; inline
|
||||
|
||||
: sin ( x -- y )
|
||||
dup complex? [
|
||||
>float-rect 2dup
|
||||
fcosh swap fsin * -rot
|
||||
fsinh swap fcos * rect>
|
||||
] [ fsin ] if ; foldable
|
||||
GENERIC: sin ( x -- y ) foldable
|
||||
|
||||
M: complex sin
|
||||
>float-rect 2dup
|
||||
fcosh swap fsin * -rot
|
||||
fsinh swap fcos * rect> ;
|
||||
|
||||
M: real sin fsin ;
|
||||
|
||||
: cosec ( x -- y ) sin recip ; inline
|
||||
|
||||
: sinh ( x -- y )
|
||||
dup complex? [
|
||||
>float-rect 2dup
|
||||
fcos swap fsinh * -rot
|
||||
fsin swap fcosh * rect>
|
||||
] [ fsinh ] if ; foldable
|
||||
GENERIC: sinh ( x -- y ) foldable
|
||||
|
||||
M: complex sinh
|
||||
>float-rect 2dup
|
||||
fcos swap fsinh * -rot
|
||||
fsin swap fcosh * rect> ;
|
||||
|
||||
M: real sinh fsinh ;
|
||||
|
||||
: cosech ( x -- y ) sinh recip ; inline
|
||||
|
||||
: tan ( x -- y )
|
||||
dup complex? [ dup sin swap cos / ] [ ftan ] if ; inline
|
||||
GENERIC: tan ( x -- y ) foldable
|
||||
|
||||
: tanh ( x -- y )
|
||||
dup complex? [ dup sinh swap cosh / ] [ ftanh ] if ; inline
|
||||
M: complex tan [ sin ] [ cos ] bi / ;
|
||||
|
||||
M: real tan ftan ;
|
||||
|
||||
GENERIC: tanh ( x -- y ) foldable
|
||||
|
||||
M: complex tanh [ sinh ] [ cosh ] bi / ;
|
||||
|
||||
M: real tanh ftanh ;
|
||||
|
||||
: cot ( x -- y ) tan recip ; inline
|
||||
|
||||
|
|
@ -231,7 +245,7 @@ M: complex log >polar swap flog swap rect> ;
|
|||
: acosech ( x -- y ) recip asinh ; inline
|
||||
|
||||
: atanh ( x -- y )
|
||||
dup 1+ swap 1- neg / log 2 / ; inline
|
||||
[ 1+ ] [ 1- neg ] bi / log 2 / ; inline
|
||||
|
||||
: acoth ( x -- y ) recip atanh ; inline
|
||||
|
||||
|
|
@ -246,8 +260,11 @@ M: complex log >polar swap flog swap rect> ;
|
|||
dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
|
||||
inline
|
||||
|
||||
: atan ( x -- y )
|
||||
dup complex? [ i* atanh i* ] [ fatan ] if ; inline
|
||||
GENERIC: atan ( x -- y ) foldable
|
||||
|
||||
M: complex atan i* atanh i* ;
|
||||
|
||||
M: real atan fatan ;
|
||||
|
||||
: asec ( x -- y ) recip acos ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -5,69 +5,69 @@ IN: math.libm
|
|||
|
||||
: facos ( x -- y )
|
||||
"double" "libm" "acos" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fasin ( x -- y )
|
||||
"double" "libm" "asin" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fatan ( x -- y )
|
||||
"double" "libm" "atan" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fatan2 ( x y -- z )
|
||||
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fcos ( x -- y )
|
||||
"double" "libm" "cos" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fsin ( x -- y )
|
||||
"double" "libm" "sin" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: ftan ( x -- y )
|
||||
"double" "libm" "tan" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fcosh ( x -- y )
|
||||
"double" "libm" "cosh" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fsinh ( x -- y )
|
||||
"double" "libm" "sinh" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: ftanh ( x -- y )
|
||||
"double" "libm" "tanh" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fexp ( x -- y )
|
||||
"double" "libm" "exp" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: flog ( x -- y )
|
||||
"double" "libm" "log" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fpow ( x y -- z )
|
||||
"double" "libm" "pow" { "double" "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fsqrt ( x -- y )
|
||||
"double" "libm" "sqrt" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
! Windows doesn't have these...
|
||||
: facosh ( x -- y )
|
||||
"double" "libm" "acosh" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fasinh ( x -- y )
|
||||
"double" "libm" "asinh" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
||||
: fatanh ( x -- y )
|
||||
"double" "libm" "atanh" { "double" } alien-invoke ;
|
||||
foldable
|
||||
inline
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts math math.order namespaces sequences
|
||||
sequences.private accessors ;
|
||||
IN: math.ranges
|
||||
|
|
@ -8,9 +10,7 @@ TUPLE: range
|
|||
{ step read-only } ;
|
||||
|
||||
: <range> ( a b step -- range )
|
||||
[ over - ] dip
|
||||
[ / 1+ 0 max >integer ] keep
|
||||
range boa ; inline
|
||||
[ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline
|
||||
|
||||
M: range length ( seq -- n )
|
||||
length>> ;
|
||||
|
|
|
|||
|
|
@ -1,63 +1,44 @@
|
|||
USING: math math.functions kernel sequences io io.styles
|
||||
prettyprint words hints ;
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.functions kernel io io.styles prettyprint
|
||||
combinators hints fry namespaces sequences ;
|
||||
IN: benchmark.partial-sums
|
||||
|
||||
: summing ( n quot -- y )
|
||||
[ >float ] swap [ + ] 3compose
|
||||
0.0 -rot 1 -rot (each-integer) ; inline
|
||||
|
||||
: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing ;
|
||||
|
||||
HINTS: 2/3^k fixnum ;
|
||||
|
||||
: k^-0.5 ( n -- y ) [ -0.5 ^ ] summing ;
|
||||
|
||||
HINTS: k^-0.5 fixnum ;
|
||||
|
||||
: 1/k(k+1) ( n -- y ) [ dup 1+ * recip ] summing ;
|
||||
|
||||
HINTS: 1/k(k+1) fixnum ;
|
||||
|
||||
! Helper words
|
||||
: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1+ @ + ] each ; inline
|
||||
: summing-floats ( n quot -- y ) '[ >float @ ] summing-integers ; inline
|
||||
: cube ( x -- y ) dup dup * * ; inline
|
||||
: -1^ ( n -- -1/1 ) 2 mod 2 * 1- ; inline
|
||||
|
||||
: flint-hills ( n -- y )
|
||||
[ dup cube swap sin sq * recip ] summing ;
|
||||
! The functions
|
||||
: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing-floats ; inline
|
||||
: k^-0.5 ( n -- y ) [ -0.5 ^ ] summing-floats ; inline
|
||||
: 1/k(k+1) ( n -- y ) [ dup 1+ * recip ] summing-floats ; inline
|
||||
: flint-hills ( n -- y ) [ [ cube ] [ sin sq ] bi * recip ] summing-floats ; inline
|
||||
: cookson-hills ( n -- y ) [ [ cube ] [ cos sq ] bi * recip ] summing-floats ; inline
|
||||
: harmonic ( n -- y ) [ recip ] summing-floats ; inline
|
||||
: riemann-zeta ( n -- y ) [ sq recip ] summing-floats ; inline
|
||||
: alternating-harmonic ( n -- y ) [ [ -1^ ] keep /f ] summing-integers ; inline
|
||||
: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1- ] bi / ] summing-integers ; inline
|
||||
|
||||
HINTS: flint-hills fixnum ;
|
||||
: partial-sums ( n -- results )
|
||||
[
|
||||
{
|
||||
[ 2/3^k \ 2/3^k set ]
|
||||
[ k^-0.5 \ k^-0.5 set ]
|
||||
[ 1/k(k+1) \ 1/k(k+1) set ]
|
||||
[ flint-hills \ flint-hills set ]
|
||||
[ cookson-hills \ cookson-hills set ]
|
||||
[ harmonic \ harmonic set ]
|
||||
[ riemann-zeta \ riemann-zeta set ]
|
||||
[ alternating-harmonic \ alternating-harmonic set ]
|
||||
[ gregory \ gregory set ]
|
||||
} cleave
|
||||
] { } make-assoc ;
|
||||
|
||||
: cookson-hills ( n -- y )
|
||||
[ dup cube swap cos sq * recip ] summing ;
|
||||
HINTS: partial-sums fixnum ;
|
||||
|
||||
HINTS: cookson-hills fixnum ;
|
||||
|
||||
: harmonic ( n -- y ) [ recip ] summing ;
|
||||
|
||||
HINTS: harmonic fixnum ;
|
||||
|
||||
: riemann-zeta ( n -- y ) [ sq recip ] summing ;
|
||||
|
||||
HINTS: riemann-zeta fixnum ;
|
||||
|
||||
: -1^ 2 mod zero? 1 -1 ? ; inline
|
||||
|
||||
: alternating-harmonic ( n -- y ) [ dup -1^ swap / ] summing ;
|
||||
|
||||
HINTS: alternating-harmonic fixnum ;
|
||||
|
||||
: gregory ( n -- y ) [ dup -1^ swap 2 * 1- / ] summing ;
|
||||
|
||||
HINTS: gregory fixnum ;
|
||||
|
||||
: functions
|
||||
{ 2/3^k k^-0.5 1/k(k+1) flint-hills cookson-hills harmonic riemann-zeta alternating-harmonic gregory } ;
|
||||
|
||||
: partial-sums ( n -- )
|
||||
standard-table-style [
|
||||
functions [
|
||||
[ tuck execute pprint-cell pprint-cell ] with-row
|
||||
] with each
|
||||
] tabular-output ;
|
||||
|
||||
: partial-sums-main ( -- ) 2500000 partial-sums ;
|
||||
: partial-sums-main ( -- )
|
||||
2500000 partial-sums simple-table. ;
|
||||
|
||||
MAIN: partial-sums-main
|
||||
|
|
|
|||
Loading…
Reference in New Issue