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