June 2018 Update
This commit is contained in:
Ingy döt Net
parent
ba8067c3b7
commit
22f33d4004
5278 changed files with 84726 additions and 14379 deletions
|
|
@ -0,0 +1,14 @@
|
|||
: epsilon 1.0e-12 ;
|
||||
|
||||
with: n
|
||||
|
||||
: iter \ n1 n2 -- n1 n2
|
||||
2dup * sqrt >r + 2 / r> ;
|
||||
|
||||
: agn \ n1 n2 -- n
|
||||
repeat iter 2dup epsilon ~= not while! drop ;
|
||||
|
||||
"agn(1, 1/sqrt(2)) = " . 1 1 2 sqrt / agn "%.10f" s:strfmt . cr
|
||||
|
||||
;with
|
||||
bye
|
||||
|
|
@ -1,46 +1,46 @@
|
|||
-- ARITHMETIC GEOMETRIC MEAN -------------------------------------------------
|
||||
|
||||
property tolerance : 1.0E-5
|
||||
|
||||
-- agm :: Num a => a -> a -> a
|
||||
on agm(a, g)
|
||||
script withinTolerance
|
||||
on lambda(m)
|
||||
on |λ|(m)
|
||||
tell m to ((its an) - (its gn)) < tolerance
|
||||
end lambda
|
||||
end |λ|
|
||||
end script
|
||||
|
||||
script nextRefinement
|
||||
on lambda(m)
|
||||
on |λ|(m)
|
||||
tell m
|
||||
set {an, gn} to {its an, its gn}
|
||||
{an:(an + gn) / 2, gn:(an * gn) ^ 0.5}
|
||||
end tell
|
||||
end lambda
|
||||
end |λ|
|
||||
end script
|
||||
|
||||
an of |until|(withinTolerance, ¬
|
||||
nextRefinement, {an:(a + g) / 2, gn:(a * g) ^ 0.5})
|
||||
end agm
|
||||
|
||||
|
||||
-- TEST
|
||||
-- TEST ----------------------------------------------------------------------
|
||||
on run
|
||||
|
||||
agm(1, 1 / (2 ^ 0.5))
|
||||
|
||||
--> 0.847213084835
|
||||
|
||||
end run
|
||||
|
||||
|
||||
|
||||
-- GENERIC FUNCTIONS
|
||||
-- GENERIC FUNCTIONS ---------------------------------------------------------
|
||||
|
||||
-- until :: (a -> Bool) -> (a -> a) -> a -> a
|
||||
on |until|(p, f, x)
|
||||
set mp to mReturn(p)
|
||||
set v to x
|
||||
|
||||
tell mReturn(f)
|
||||
repeat until mp's lambda(v)
|
||||
set v to lambda(v)
|
||||
repeat until mp's |λ|(v)
|
||||
set v to |λ|(v)
|
||||
end repeat
|
||||
end tell
|
||||
return v
|
||||
|
|
@ -53,7 +53,7 @@ on mReturn(f)
|
|||
f
|
||||
else
|
||||
script
|
||||
property lambda : f
|
||||
property |λ| : f
|
||||
end script
|
||||
end if
|
||||
end mReturn
|
||||
|
|
|
|||
|
|
@ -0,0 +1,10 @@
|
|||
10 A = 1
|
||||
20 G = 1/SQR(2)
|
||||
30 GOSUB 100
|
||||
40 PRINT A
|
||||
50 END
|
||||
100 TA = A
|
||||
110 A = (A+G)/2
|
||||
120 G = SQR(TA*G)
|
||||
130 IF A<TA THEN 100
|
||||
140 RETURN
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
#include<math.h>
|
||||
#include<stdio.h>
|
||||
#include<stdlib.h>
|
||||
|
||||
double agm( double a, double g ) {
|
||||
/* arithmetic-geometric mean */
|
||||
double iota = 1.0E-16;
|
||||
double a1, g1;
|
||||
|
||||
if( a*g < 0.0 ) {
|
||||
printf( "arithmetic-geometric mean undefined when x*y<0\n" );
|
||||
exit(1);
|
||||
}
|
||||
|
||||
while( fabs(a-g)>iota ) {
|
||||
a1 = (a + g) / 2.0;
|
||||
g1 = sqrt(a * g);
|
||||
|
||||
a = a1;
|
||||
g = g1;
|
||||
}
|
||||
|
||||
return a;
|
||||
}
|
||||
|
||||
int main( void ) {
|
||||
double x, y;
|
||||
printf( "Enter two numbers: " );
|
||||
scanf( "%lf%lf", &x, &y );
|
||||
printf( "The arithmetic-geometric mean is %lf\n", agm(x, y) );
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
USING: kernel math math.functions prettyprint ;
|
||||
IN: rosetta-code.arithmetic-geometric-mean
|
||||
|
||||
: agm ( a g -- a' g' ) 2dup [ + 0.5 * ] 2dip * sqrt ;
|
||||
|
||||
1 1 2 sqrt / [ 2dup - 1e-15 > ] [ agm ] while drop .
|
||||
|
|
@ -1,29 +1,21 @@
|
|||
function agm{T<:FloatingPoint,U<:Integer}(x::T, y::T, e::U=5)
|
||||
0 < y && 0 < y && 0 < e || throw(DomainError())
|
||||
err = e*eps(x)
|
||||
(g, a) = extrema([x, y])
|
||||
function agm(x::T, y::T, e::Real = 5) where T<:AbstractFloat
|
||||
if x ≤ 0 || y ≤ 0 || e ≤ 0 throw(DomainError("x, y must be strictly positive")) end
|
||||
err = e * eps(x)
|
||||
g, a = minmax(x, y)
|
||||
while err < (a - g)
|
||||
ap = a
|
||||
a = 0.5*(a + g)
|
||||
g = sqrt(ap*g)
|
||||
a, g = (a + g) / 2, sqrt(a * g)
|
||||
end
|
||||
return a
|
||||
end
|
||||
|
||||
x = 1.0
|
||||
y = 1.0/sqrt(2.0)
|
||||
y = 1 / √2
|
||||
|
||||
println("Using literal-precision float numbers:")
|
||||
println(" agm(", x, ",", y, ") = ", agm(x, y))
|
||||
|
||||
println()
|
||||
println("Using half-precision float numbers:")
|
||||
x = float16(x)
|
||||
y = float16(y)
|
||||
println(" agm(", x, ",", y, ") = ", agm(x, y))
|
||||
|
||||
println()
|
||||
println("Using ", get_bigfloat_precision(), "-bit float numbers:")
|
||||
x = BigFloat(1.0)
|
||||
y = x/sqrt(BigFloat(2.0))
|
||||
println(" agm(", x, ",", y, ") = \n ", agm(x, y))
|
||||
println("# Using literal-precision float numbers:")
|
||||
@show agm(x, y)
|
||||
println("# Using half-precision float numbers:")
|
||||
x, y = Float32(x), Float32(y)
|
||||
@show agm(x, y)
|
||||
println("# Using ", precision(BigFloat), "-bit float numbers:")
|
||||
x, y = big(1.0), 1 / √big(2.0)
|
||||
@show agm(x, y)
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
: agm while(2dup <>) [ 2dup + 2 / tor * sqrt ] drop ;
|
||||
: agm \ a b -- m
|
||||
while( 2dup <> ) [ 2dup + 2 / -rot * sqrt ] drop ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
agm(A,G,A) :- abs(A-G) < 1.0e-15, !.
|
||||
agm(A,G,Res) :- A1 is (A+G)/2.0, G1 is sqrt(A*G),!, agm(A1,G1,Res).
|
||||
|
||||
?- agm(1,1/sqrt(2),Res).
|
||||
Res = 0.8472130847939792.
|
||||
|
|
@ -3,26 +3,25 @@ parse arg a b digs . /*obtain optional numbers from
|
|||
if digs=='' | digs=="," then digs=110 /*No DIGS specified? Then use default.*/
|
||||
numeric digits digs /*REXX will use lots of decimal digits.*/
|
||||
if a=='' | a=="," then a=1 /*No A specified? Then use the default*/
|
||||
if b=='' | b=="," then b=1/sqrt(2) /* " B " " " " " */
|
||||
if b=='' | b=="," then b=1 / sqrt(2) /* " B " " " " " */
|
||||
call AGM a,b /*invoke the AGM function. */
|
||||
say '1st # =' a /*display the A value. */
|
||||
say '2nd # =' b /* " " B " */
|
||||
say ' AGM =' agm(a, b) /* " " AGM " */
|
||||
exit /*stick a fork in it, we're all done. */
|
||||
/*──────────────────────────────────────────────────────────────────────────────────────*/
|
||||
agm: procedure: parse arg x,y; if x=y then return x /*is this an equality case?*/
|
||||
if y=0 then return 0 /*is Y equal to zero ? */
|
||||
if x=0 then return y/2 /* " X " " " */
|
||||
d=digits(); numeric digits d+5 /*add 5 more digs to ensure convergence*/
|
||||
tiny='1e-' || ( digits() -1 ) /*construct a pretty tiny REXX number. */
|
||||
ox=x+1
|
||||
agm: procedure: parse arg x,y; if x=y then return x /*is this an equality case?*/
|
||||
if y=0 then return 0 /*is Y equal to zero ? */
|
||||
if x=0 then return y / 2 /* " X " " " */
|
||||
d=digits(); numeric digits d+5 /*add 5 more digs to ensure convergence*/
|
||||
tiny='1e-' || (digits() - 1) /*construct a pretty tiny REXX number. */
|
||||
ox=x + 1
|
||||
do #=1 while ox\=x & abs(ox)>tiny; ox=x; oy=y
|
||||
x=(ox+oy)/2; y=sqrt(ox*oy)
|
||||
end /*#*/
|
||||
numeric digits d; return x/1 /*restore digs, normalize X to new digs*/
|
||||
numeric digits d; return x / 1 /*restore digs, normalize X to new digs*/
|
||||
/*──────────────────────────────────────────────────────────────────────────────────────*/
|
||||
sqrt: procedure; parse arg x; if x=0 then return 0; d=digits(); m.=9; numeric form; h=d+6
|
||||
numeric digits; parse value format(x,2,1,,0) 'E0' with g 'E' _ .; g=g *.5'e'_ % 2
|
||||
do j=0 while h>9; m.j=h; h=h%2+1; end /*j*/
|
||||
do k=j+5 to 0 by -1; numeric digits m.k; g=(g+x/g)*.5; end /*k*/
|
||||
return g
|
||||
do j=0 while h>9; m.j=h; h=h % 2 + 1; end /*j*/
|
||||
do k=j+5 to 0 by -1; numeric digits m.k; g=(g+x/g)*.5; end /*k*/; return g
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue