random_shaped.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
------------------------> GNU Sather - sourcefile <-------------------------
-- Copyright (C) 2000 by K Hopper, University of Waikato, New Zealand --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute and/or modify it under the terms of the GNU Library General --
-- Public License (LGPL) as published by the Free Software Foundation; --
-- either version 2 of the license, or (at your option) any later version. --
-- This library is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details. --
-- The license text is also available from: Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --
--------------> Please email comments to <bug-sather@gnu.org> <--------------
class DISTRIBUTIONS{GEN < $RANDOM_GEN}
class DISTRIBUTIONS{GEN < $RANDOM_GEN} is
-- This class represents a random number source, which uses a "raw"
-- random number generator stream of type "GEN" and provides random numbers
-- which are generated according to a particular distribution (see also the
-- Required Library Numeric sub-section for 'white noise' distribution).
--
-- This extends the White noise random facilities of the Required Library
-- which do not provide for particular statistical distributions. Note that
-- when this is used the funct/functd classes will need to be incorporated
-- into their respective Float classes since this uses the floating number
-- log_gamma routine which is defined there.
-- Version 1.1 Dec 2000. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 12 Aug 97 kh Original from 1.1 distrib as RANDOM
-- 22 Dec 00 kh separated from Required Library, renamed
-- 22 Mar 01 djw new gamma functions (bugfixes)
include WHITE{GEN}
make_generator -> private make_generator ;
-- Standard normal generator
private attr norm_cache : FLTD ; -- Cache of normal deviate
private shared snorm_cache : FLTD ; -- Shared version of above.
private attr norm_cache_valid : BOOL ; -- `True' if a value is cached.
private shared snorm_cache_valid : BOOL ; -- Shared version of above.
standard_normal : FLTD is
-- This routine returns a normally distributed approximate number value
-- with a mean of zero.
--
-- It uses Box-Muller method which generates two normal deviates and
-- requires two calls to uniform. One of these is cached for the next call.
-- Based on Knuth, Vol. 2, p. 117.
res : FLTD ;
if void(self) then -- use shareds
if snorm_cache_valid then -- use stored value
snorm_cache_valid := false ;
res := snorm_cache
else -- must recompute
sample : FLTD := 10.0d ;
val1,
val2 :FLTD ;
loop -- get two samples in unit circle!
until!(sample < 1.0d
and sample /= 0.0d) ;
val1 := uniform_range(-1.0d,1.0d) ;
val2 := uniform_range(-1.0d,1.0d) ;
sample := val1 * val1 + val2 * val2
end ; -- executes 1.27 times on average
rt : FLTD := (-2.0d *(sample).log/sample).sqrt ;
snorm_cache := val1 * rt ;
snorm_cache_valid := true ;
res := val2 * rt
end
else -- use locals
if norm_cache_valid then -- use stored value
res := norm_cache ;
norm_cache_valid := false
else -- must recompute
sample : FLTD := 10.0d ;
val1,
val2 : FLTD ;
loop -- get two samples in unit circle
until!(sample <1.0d
and sample /= 0.0d) ;
val1 := uniform_range(-1.0d,1.0d) ;
val2 := uniform_range(-1.0d,1.0d) ;
sample := val1 * val1 + val2 * val2 ;
end ; -- executes 1.27 times on average
rt : FLTD := (-2.0d * (sample).log/sample).sqrt ;
norm_cache := val1 * rt ;
norm_cache_valid := true ;
res := val2 * rt
end
end ;
return res
end ;
exponential(
mean : FLTD
) : FLTD
pre mean >= 0.0d is
-- This routine returns samples from an exponential distribution whose
-- mean is given.
-- Based on Knuth, Vol. 2, p. 128.
loc_uniform : FLTD ;
loop
until!(loc_uniform /= 0.0d) ;
loc_uniform := uniform
end ;
return -mean * loc_uniform.log
end ;
gamma(
a:FLTD
):FLTD
pre a > 0.0d
is
-- Samples from the Gamma distribution: 'p(x)=(x^(a-1)e^(-x))/G(a)'.
-- Mean and variance are `a>0'.
-- Author: Darren Wilkinson <d.j.wilkinson@freeuk.com>
-- <URL:http://home.freeuk.com/d.j.wilkinso/>
-- Based on the C function "gammarand" in "dists.c"
-- in Luke Tierney's XLISPSTAT source code distribution. See:
-- http://www.stat.umn.edu/~luke/xls/xlsinfo/xlsinfo.html
e::=1.0d.exp;
x,u0,u1,u2:FLTD;
if (a < 1.0d) then
-- Ahrens and Dieter algorithm
c::=(a+e)/e;
loop
u0:=uniform;
u1:=uniform;
v::=c*u0;
if (v <= 1.0d) then
x:=(v.log/a).exp;
if (u1 <= (-x).exp) then return x; end;
else
x:= -(((c-v)/a).log);
if (x>0.0d) and (u1<((a-1.0d)*(x.log)).exp) then return x; end;
end;
end; -- loop
elsif (a = 1.0d) then
x:= -(uniform).log;
return x;
else
-- Cheng and Feast algorithm
c1::=a-1.0d;
c2::=(a - 1.0d/(6.0d*a))/c1;
c3::=2.0d/c1;
c4::=2.0d/(a-1.0d) + 2.0d;
c5::=1.0d/(a.sqrt);
w:FLTD;
loop
loop
u1:=uniform;
u2:=uniform;
if (a>2.5d) then u1:=u2+c5*(1.0d-1.86d*u1); end;
while!((u1<=0.0d) or (u1>=1.0d));
end;
w:=c2*u2/u1;
while!((c3*u1+w+1.0d/w)>c4 and (c3*(u1.log)-(w.log)+w)>1.0d);
end;
x:=c1*w;
return x;
end; -- if
end; -- gamma
gamma(
a,b : FLTD
) : FLTD
pre a>0.0d and b>0.0d
is
-- Samples from the Gamma distribution:
-- `p(x)=(b^(a)x^(a-1)e^(-bx))/G(a)'.
-- Mean is `a/b>0' and variance is 'a/(b^2)>0'.
return gamma(a)/b;
end; -- gamma
beta(
factor_a,
factor_b :CARD
) : FLTD is
-- This routine yields samples form the Bete distribution whose mean is
-- given by factor_a / (factor_a + factor_b).
-- Knuth, Vol. 2, p. 129.
x1 : FLTD := gamma(factor_a.fltd) ;
if x1 =0.0d then
return 0.0d
else
return x1/(x1 + gamma(factor_b.fltd))
end
end ;
chi_square(
mean : CARD
) : FLTD is
-- This routine yields samples from the Chi-squared distribution with
-- the given mean.
-- Based on Knuth, Vol. 2, p. 130.
return 2.0d * gamma(mean.fltd/2.0d)
end ;
f_dist(
freedom1,
freedom2 : CARD
) : FLTD is
-- This routine yields samples from the F distribution (Snedecor's F)
-- with the given degrees of freedom.
-- Based on Knuth, Vol. 2, p. 130.
return chi_square(freedom1) * freedom2.fltd/
(chi_square(freedom2) * freedom1.fltd)
end ;
t_dist(
freedom : CARD
) : FLTD is
-- This routine yields samples form the Student's T distribution with
-- the given number of degrees of freedom.
-- Based on Knuth, Vol. 2, p. 130.
return standard_normal/((chi_square(freedom)/freedom.fltd).sqrt)
end ;
geometric(
probability : FLTD
) : CARD
pre probability >= 0.0d
and probability <= 1.0d is
-- This routine yields samples from the standard geometric distribution
-- with the given probability -- ie having the mean 1/probability.
-- Based on Knuth, Vol. 2, p. 131.
if probability = 1.0d then
return 1
else
return (uniform.log/(1.0d - probability).log).ceiling.card
end
end ;
cauchy : FLTD is
-- This routine yields samples from the Cauchy (Lorentz) distribution.
-- Based on Numeric Results in C. p. 220.
return ANGLED::radians(FLTD::pi * uniform).tan
end ;
private const Poisson_Limit : FLTD := 12.0d ;
poisson(
mean : FLTD
) : CARD is
-- This routine yields samples from the Poisson distribution with
-- the given mean. This gives the number of events in the mean time
-- interval.
-- Based on Numerical Recipes in C, p. 221.
res : CARD := 0 ;
if (mean <Poisson_Limit) then -- use direct method
temp : FLTD := 1.0d ;
guess : FLTD := (-mean).exp ;
loop
res := res + 1 ;
temp := temp * uniform ;
if temp <= guess then
return res - 1
end
end
else -- use rejection method
approx_res : FLTD ; -- FLTD version of res
loop
temp : FLTD ;
guess : FLTD := (mean * (mean.log)) - (mean + 1.0d).log_gamma ;
sq : FLTD := (2.0d * mean).sqrt ;
loop -- use Lorentzian comparison
temp := cauchy ;
approx_res := sq * temp + mean ;
if approx_res >= 0.0d then
break!
end
end ;
approx_res := approx_res.floor ;
if uniform <= 0.9d * (1.0d + temp * temp) *
(approx_res * mean.log -
(approx_res + 1.0d).log_gamma - guess).exp then
break!
end
end ;
res := approx_res.floor.card
end ;
return res
end ;
private const Trial_Limit : CARD := 25 ;
binomial(
trials : CARD,
probability : FLTD
) : CARD
pre probability >= 0.0d
and probability <= 1.0d is
-- Tgis routine yields samples from the binomial distribution which has
-- a mean of probability * trials. It is therefore the number of
-- occurrences of an event of the given probability occurring in the given
-- number of trials.
-- Based on Knuth, Vol. 2, p. 131. and Numerical Recipes in C, p. 223.
res : CARD ;
approx_res : FLTD ; -- FLTD version of res.
-- It is possible to increase convergence by inverting the
-- probability -- and the result too!
loc_probability : FLTD ;
if probability < 0.5d then
loc_probability := probability
else
loc_probability := 1.0d - probability
end ;
arith_mean : FLTD := trials.fltd *loc_probability ; -- mean of res
if trials < Trial_Limit then -- direct method if n small enough
cnt : CARD ;
loop
until!(cnt = trials) ;
if uniform <loc_probability then
approx_res := approx_res + 1.0d
end ;
cnt := cnt + 1
end
elsif arith_mean < 1.0d then -- approximate by Poisson
approx_res := poisson(arith_mean).fltd ;-- Poisson dist with same mean
if approx_res > trials.fltd then -- chop Poisson tail
approx_res := trials.fltd
end
else -- use rejection method
loc_val : FLTD ;
temp : FLTD ;
sq : FLTD :=(2.0d * arith_mean *(1.0d - loc_probability)) ;
loop
loop -- reject with Lorenzian comparison
loc_val := cauchy ;
approx_res := sq * loc_val + arith_mean ;
if approx_res >= 0.0d
and approx_res < trials.fltd + 1.0d then
break!
end
end ;
approx_res := approx_res.floor ;
if uniform <= 1.2d * sq * (1.0d + loc_val * loc_val) *
((trials.fltd + 1.0d).log_gamma -
(approx_res + 1.0d).log_gamma -
(trials.fltd - approx_res + 1.0d).log_gamma +
approx_res * (loc_probability).log +
(trials.fltd - approx_res) *
(1.0d - loc_probability).log).exp then
break!
end
end
end ;
if loc_probability /= probability then -- invert again
res := trials - approx_res.floor.card
else
res := approx_res.floor.card
end ;
return res
end ;
private const Cantor_Limit : CARD := 33 ;
cantor(
scaling : FLTD
) : FLTD is
-- This routine yields a uniform random sample from a Cantor set with
-- the given scaling.
res : FLTD ;
loc_res : FLTD := uniform ;
multiplier : FLTD := 1.0d - scaling ;
cnt : CARD := 0 ;
loop
until!(cnt > Cantor_Limit) ;
if loc_res >= 0.5d then
loc_res := loc_res - 0.5d ;
res := res + multiplier
end ;
loc_res := loc_res * 2.0d ;
multiplier := multiplier * scaling ;
cnt := cnt + 1
end ;
return res
end ;
standard_cantor : FLTD is
-- This routine yields a uniform random sample fro the canonical Cantor
-- set in the range zeeo to one.
return cantor(0.3333333333d)
end ;
end ; -- DISTRIBUTIONS
class SHAPED_RANDOM
class SHAPED_RANDOM is
-- This class implements the standard random number abstraction using
-- a minimal standard random number generator.
-- Version 1.1 Dec 2000. Copyright K Hopper,U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 14 Aug 97 kh Original from 1.1 distrib
-- 22 Dec 00 kh Separated from Required Library
include DISTRIBUTIONS{WHITE_GEN} ;
end ; -- SHAPED_RANDOM