Oberon.vyRanBase.Mod 26 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694
  1. MODULE vyRanBase IN Oberon;
  2. (* Copyright notice:
  3. This file is part of Voyager
  4. Copyright (C) 1993-2002 Project Voyager, StatLab Heidelberg ; (C) 1993-2002 G. Sawitzki et al.
  5. This library is free software; you can redistribute it and/or
  6. modify it under the terms of the GNU Lesser General Public
  7. License as published by the Free Software Foundation; either
  8. version 2.1 of the License, or (at your option) any later version.
  9. This library is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. Lesser General Public License for more details.
  13. You should have received a copy of the GNU Lesser General Public
  14. License along with this library; if not, write to the Free Software
  15. Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16. Copy of the GNU Lesser General Public License can be found in the file COPYING.TXT
  17. Report any problems as soon as possible to voyager@statlab.uni-heidelberg.de
  18. *)
  19. (***** Abstract random number generators, and common implementations *****)
  20. (*= This module gives the abstract definition for all random number generators used in Voyager.
  21. It should not depend on other Voyager modules.
  22. It should not assume any specific structure of the generator, nor any specific seed length.
  23. To implement a new basic random number generator, use the module template at the end of
  24. this file.
  25. For more information on random number generators, see
  26. B.D.Ripley: A Short Tutorial on Random Numbers. ISI Reviews (??yyyy??).
  27. See also B.D.Ripley's home page at http://stats.ox.ac.uk
  28. G. Marsaglia: A Current View of Random Number Generators. in: Proceedings of the
  29. 16th Symposium on the Interface, Atlanta 1984. Elsevier Press.
  30. G. Marsaglia: Monky Tests for Random Number Generators. Computers & Mathematics
  31. with Applications 9 (1993) 1-10
  32. Both papers are included in the DIEHARD software distribution.
  33. See also G. Marsaglia's home page on http://stat.fso.edu/~geo/
  34. *)
  35. (*! Add explicit range checks *)
  36. (*? Persistence model may need discussion. Should basic generators be document bound, or should we have system wide random number generators? *)
  37. (* jb 5.5.01 version check when storing random generators *)
  38. (* jb 6.3.01 SumPSqr added, GetRandomLExact added, reset mechanism changed, some constants added *)
  39. (* jb 10.1.01 support for loading/storing seeds added *)
  40. (* jb 27.3.00 return value of GetRandom, MAX and GetRandomBitV is Bits = LONGINT now *)
  41. (* jb 21.2.00 major changes *)
  42. (* gs 23.1.98 replace naive Parks&Miller by left-adjusted version. Naive version is kept as example. *)
  43. (* gs 1.6.96 moved from 32 bit LONGINT to generic seed *)
  44. IMPORT SYSTEM, Oberon, Objects, Gadgets, Files;
  45. CONST
  46. cModuleName = "vyRanBase"; idversion* = 'vyRanBase 0.0a7';
  47. cBaseVersion* = 1; cLongintSeedVersion* = 0;
  48. cMagic = "nmfsrg"; (* "New Mechansism For Storing Random Generators" *)
  49. ccbase = 100;
  50. CONST
  51. (* system dependent constants, change when necessary *)
  52. sysBitsTypeSize* = 4;
  53. sysHalfBitsType* = 10000H; (* = 2 ^ (SIZEOF(LONGINT) * 8 / 2) *)
  54. sysMaskFirstHalf* = LONGINT(0FFFF0000H); sysMaskSecondHalf* = 0FFFFH; (* mask first/second half of a LONGINT value *)
  55. sysMaxUnsigned* = LONGINT(0FFFFFFFFH); (* = 2 ^ (SIZEOF(LONGINT) * 8) - 1 *)
  56. sysSHL* = 1; sysSHR* = -1; (* sign for left/right shift of a LONGINT value when using LSH *)
  57. TYPE
  58. Bits* = LONGINT;
  59. (*** The general type used as seed, and for task communcation ***)
  60. tMsg* = OBJECT
  61. PROCEDURE (* VAR seed: tSeedDesc*)Store*( VAR r: Files.Rider );
  62. BEGIN
  63. HALT( 100 )
  64. END Store;
  65. PROCEDURE (* VAR seed: tSeedDesc*)Load*( VAR r: Files.Rider; seedVersion: INTEGER );
  66. (* if you do not store seeds without storing the whole generator, i. e. if you do not call seed.Store and
  67. seed.Load yourself, you do not have to worry about seed versions; otherwise the seed version code must be
  68. stored somewhere in the file and passed to this procedure as parameter seedVersion *)
  69. BEGIN
  70. HALT( 100 )
  71. END Load;
  72. PROCEDURE (* VAR seed: tSeedDesc*)Copy*( ): tSeed; (* fof 020625 *)
  73. BEGIN
  74. HALT( 100 )
  75. END Copy;
  76. END tMsg; (* POINTER TO tMsgDesc; *)
  77. (* tMsgDesc* = RECORD END; *)
  78. tSeed* = tMsg;
  79. (* tSeedDesc* = tMsgDesc; *) (*= an abstract type is used to allow for various seed types *)
  80. (*? could this be replaced by a variant of Attribute? *)
  81. tShortIdStr* = ARRAY 8 OF CHAR;
  82. tIdStr* = ARRAY 64 OF CHAR;
  83. (*** The general type for random number generators ***)
  84. (*= a new random number generator should shield its internal structure,
  85. but allow as efficient access as possible. The minimum is to supply a LONGINT variant
  86. Random with values in 0..MAX, and a LONGREAL variant normed to [0,1] *)
  87. tRandom* = POINTER TO tRandomNumberDesc;
  88. (* tRandomFct*=PROCEDURE (gen:tRandom):;*)
  89. tRandomNumberDesc* = RECORD (Gadgets.ObjDesc)
  90. seedVersion*: INTEGER;
  91. seed-: tSeed;
  92. (** This information should be supplied to allow identification **)
  93. shortid*: tShortIdStr; (*= a short string to identify the generator in synthetic names *)
  94. id*: tIdStr; (*= generator id *)
  95. (** These routines must be supplied for each basic generator **)
  96. (* Init replaced by Reset - jb 21.2.00 *)
  97. Reset*: PROCEDURE ( gen: tRandom ); (*= set default seed; reset other things when necessary *)
  98. (*= Read out functions. Supply best attempts for each generator *)
  99. GetRandom*: PROCEDURE ( gen: tRandom ): Bits; (*= A bit pattern within [0, unsigned (MAX)] *)
  100. GetRandomU*: PROCEDURE ( gen: tRandom ): LONGREAL; (*= U[0,1] *)
  101. NextRandom*: PROCEDURE ( gen: tRandom ); (*= advance random number generator. Status is kept in seed *)
  102. Max*: PROCEDURE ( gen: tRandom ): Bits; (*= maximum value returned by GetRandom *)
  103. (*= Read out functions which can be savely kept to defaults. Replace, if this gives a speed advantage *)
  104. GetRandomBitV*: PROCEDURE ( gen: tRandom; count: LONGINT; VAR nrs: ARRAY OF Bits; start: LONGINT ); (*= A bit pattern *)
  105. (* jb28.3.00 - replaced by GetRandomBitV
  106. GetRandomV*: PROCEDURE (gen: tRandom; count: LONGINT; VAR nrs: ARRAY OF LONGINT; start: LONGINT); (*= A bit pattern, stored as LONGINT *)
  107. *)
  108. GetRandomUV*: PROCEDURE ( gen: tRandom; count: LONGINT; VAR nrs: ARRAY OF REAL; start: LONGINT ); (*= U[0,1] *)
  109. GetRandomUVX*: PROCEDURE ( gen: tRandom; count: LONGINT; VAR nrs: ARRAY OF LONGREAL; start: LONGINT ); (*= U[0,1] *)
  110. (* the following procedures generate a random LONGINT within [0; top) *)
  111. (* if top <= 0 or top > min ( MAX (LONGINT), unsigned (MAX ()) ), a non-negative random LONGINT
  112. within [ 0; min ( MAX (LONGINT), unsigned (MAX ()) ) ] is returned *)
  113. (* the results are calculated from a full range random value as "MOD top", so they normally will not be
  114. uniformly distributed, but the error seems to be very small [to avoid this problem see procedure GetRandomLExact below]
  115. - value of Herfindahl index as measure of concentration is returned by SumPSqr
  116. theoretical value of chi square test statistic is then given by unsigned (MAX ()) * (SumPSqr () * top - 1),
  117. unsigned (MAX ()) - 1 degrees of freedom *)
  118. (* jb 6.3.01 *)
  119. SumPSqr*: PROCEDURE ( gen: tRandom; top: LONGINT ): LONGREAL;
  120. GetRandomL*: PROCEDURE ( gen: tRandom; top: LONGINT ): LONGINT;
  121. GetRandomLV*: PROCEDURE ( gen: tRandom; top: LONGINT; count: LONGINT; VAR nrs: ARRAY OF LONGINT; start: LONGINT );
  122. (* deprecated *)
  123. GetRandomSet*: PROCEDURE ( gen: tRandom ): SET;
  124. MAXSet*: PROCEDURE ( gen: tRandom ): SET;
  125. (*= general purpose hook for extensions *)
  126. RandomHandler*: PROCEDURE ( r: tRandom; VAR msg: tMsg );
  127. AllocSeed*: PROCEDURE ( ): tSeed; (* jb10.1.01 *)
  128. (** These routines usually take some default **)
  129. GetSeed*: PROCEDURE ( gen: tRandom; VAR s: tSeed );
  130. SetSeed*: PROCEDURE ( gen: tRandom; s: tSeed );
  131. Name*: PROCEDURE ( r: tRandom; pre: ARRAY OF CHAR; VAR name: ARRAY OF CHAR ); (* return encoded seed and generator *)
  132. END;
  133. (*** Example ***)
  134. tLongintSeed* = OBJECT (* POINTER TO tLongintSeedDesc;
  135. tLongintSeedDesc* = RECORD*) (tSeed)
  136. VAR
  137. val*: LONGINT;
  138. PROCEDURE (*VAR seed: tLongintSeedDesc*) Store*( VAR r: Files.Rider );
  139. BEGIN
  140. Files.WriteLInt( r, (*seed.*)val )
  141. END Store;
  142. PROCEDURE (*VAR seed: tLongintSeedDesc*) Load*( VAR r: Files.Rider; seedVersion: INTEGER );
  143. BEGIN
  144. IF seedVersion # cLongintSeedVersion THEN HALT( 100 ) END;
  145. Files.ReadLInt( r, (*seed.*)val )
  146. END Load;
  147. PROCEDURE (*VAR seed: tLongintSeedDesc*) Copy*( ): tSeed; (* fof 020625 *)
  148. VAR cp: tSeed; copy: tLongintSeed;
  149. BEGIN
  150. cp := AllocLongintSeed(); copy := cp( tLongintSeed );
  151. copy^ := SELF^ (*seed*); (* copy of content *)
  152. RETURN copy
  153. END Copy;
  154. END tLongintSeed;
  155. (*fof val not write-protected for access from outside this module *)
  156. (*tNameArray*= ARRAY 32 OF CHAR; (*= should be same as vyName.tNameArray *)*)
  157. (*** The global random number generator ***)
  158. VAR
  159. RandomGenerator-: tRandom; initSeed1, initSeed2, initSeed3: LONGINT;
  160. (*** procedures to load/store seeds - jb 29.11.00 *** *)
  161. (* must be implemented in derived types *)
  162. PROCEDURE WriteSeedVersion*( VAR r: Files.Rider; seedVersion: INTEGER ); (* jb 5.5.01 *)
  163. BEGIN
  164. Files.WriteInt( r, seedVersion )
  165. END WriteSeedVersion;
  166. (*
  167. PROCEDURE ( VAR seed: tSeedDesc)Store*( VAR r: Files.Rider );
  168. BEGIN
  169. HALT( 100 )
  170. END Store;
  171. *)
  172. PROCEDURE ReadSeedVersion*( VAR r: Files.Rider; VAR seedVersion: INTEGER ); (* jb 5.5.01 *)
  173. BEGIN
  174. Files.ReadInt( r, seedVersion )
  175. END ReadSeedVersion;
  176. (*
  177. PROCEDURE ( VAR seed: tSeedDesc)Load*( VAR r: Files.Rider; seedVersion: INTEGER );
  178. (* if you do not store seeds without storing the whole generator, i. e. if you do not call seed.Store and
  179. seed.Load yourself, you do not have to worry about seed versions; otherwise the seed version code must be
  180. stored somewhere in the file and passed to this procedure as parameter seedVersion *)
  181. BEGIN
  182. HALT( 100 )
  183. END Load;
  184. PROCEDURE ( VAR seed: tSeedDesc)Copy*( ): tSeed; (* fof 020625 *)
  185. BEGIN
  186. HALT( 100 )
  187. END Copy;
  188. *)
  189. (*** Access routines ***)
  190. PROCEDURE RandomBits*( ): Bits;
  191. (*= return a random number from RandomGenerator *)
  192. BEGIN
  193. RETURN RandomGenerator.GetRandom( RandomGenerator )
  194. END RandomBits;
  195. (* jb 28.3.00 - replaced by RandomBits
  196. PROCEDURE Random* (): LONGINT;
  197. (*= return a random number from RandomGenerator *)
  198. BEGIN RETURN RandomGenerator.GetRandomL(RandomGenerator, MAX(LONGINT)) END Random;
  199. *)
  200. PROCEDURE RandomU*( ): LONGREAL;
  201. (*= return a random number from RandomGenerator, transformed to U[0,1] *)
  202. BEGIN
  203. RETURN RandomGenerator.GetRandomU( RandomGenerator )
  204. END RandomU;
  205. PROCEDURE RandomName*( pre: ARRAY OF CHAR; VAR name: ARRAY OF CHAR );
  206. (*= prefix and name of currently installed generator *)
  207. BEGIN
  208. RandomGenerator.Name( RandomGenerator, pre, name )
  209. END RandomName;
  210. (** Vector access to current generator **)
  211. PROCEDURE RandomBitV*( count: LONGINT; VAR nrs: ARRAY OF Bits; start: LONGINT );
  212. BEGIN
  213. RandomGenerator.GetRandomBitV( RandomGenerator, count, nrs, start )
  214. END RandomBitV;
  215. (* jb 28.3.00 - replaced by RandomBitV
  216. PROCEDURE RandomV* (count: LONGINT; VAR nrs: ARRAY OF LONGINT; start: LONGINT);
  217. (* VAR i: LONGINT; *)
  218. BEGIN
  219. (* jb 12.3.00
  220. FOR i := start TO start + count - 1 DO nrs[i] := RandomGenerator.GetRandomL(RandomGenerator, MAX(LONGINT)) END
  221. *)
  222. RandomGenerator.GetRandomV (RandomGenerator, count, nrs, start)
  223. END RandomV;
  224. *)
  225. PROCEDURE RandomLV*( top: LONGINT; exact: BOOLEAN; count: LONGINT; VAR nrs: ARRAY OF LONGINT; start: LONGINT );
  226. (* VAR i: LONGINT; *)
  227. BEGIN
  228. (* jb 12.3.00
  229. FOR i := start TO start + count - 1 DO nrs[i] := RandomGenerator.GetRandomL(RandomGenerator, top) END
  230. *)
  231. RandomGenerator.GetRandomLV( RandomGenerator, top, count, nrs, start )
  232. END RandomLV;
  233. PROCEDURE RandomUV*( count: LONGINT; VAR nrs: ARRAY OF REAL; start: LONGINT );
  234. (* VAR i: LONGINT; *)
  235. BEGIN
  236. (* jb 12.3.00
  237. FOR i := start TO start + count - 1 DO nrs[i] := SHORT(RandomGenerator.GetRandomU(RandomGenerator)) END
  238. *)
  239. RandomGenerator.GetRandomUV( RandomGenerator, count, nrs, start )
  240. END RandomUV;
  241. PROCEDURE RandomUVX*( count: LONGINT; VAR nrs: ARRAY OF LONGREAL; start: LONGINT );
  242. (* VAR i: LONGINT; *)
  243. BEGIN
  244. (* jb 12.3.00
  245. FOR i := start TO start + count - 1 DO nrs[i] := RandomGenerator.GetRandomU(RandomGenerator) END
  246. *)
  247. RandomGenerator.GetRandomUVX( RandomGenerator, count, nrs, start )
  248. END RandomUVX;
  249. (* auxiliary procedures *)
  250. PROCEDURE GetRandomLExact*( gen: tRandom; max, top, maxtries: LONGINT ): LONGINT;
  251. (*= get a random value which is (theoretically) uniformly distributed within [0, top)
  252. pass the result of gen.MAX (gen) as parameter max
  253. full range of possible random values 0..max is divided into a maxium number of intervals
  254. of length top, then a random value is drawn; if it falls into one of these intervals
  255. a random value within [0, top) returned, according to the position of the random number in the
  256. interval, if not, another random number is drawn; if we were not successful within maxtries times, -1
  257. is returned
  258. *)
  259. VAR m1, m2, m3, max1, max2, max3, c, nTry, z: LONGINT;
  260. BEGIN
  261. IF max < 0 THEN max2 := max1 - MIN( LONGINT ); max1 := MAX( LONGINT ) ELSE max2 := -1; max1 := max END;
  262. c := max1 MOD top + 1;
  263. IF c = top THEN m1 := max1 ELSE m1 := max1 - c END;
  264. ASSERT ( -1 MOD 3 = -1, 100 ); (* if not, the cases max2 = -1 and max3 = -1
  265. must be handled separately when setting m2 and m3 *)
  266. c := max2 MOD top + 1;
  267. IF c = top THEN m2 := max2 ELSE m2 := max2 - c END;
  268. max3 := max1 - m1 + max2 - m2 - 1; c := max3 MOD top + 1;
  269. IF c = top THEN m3 := max3 ELSE m3 := max3 - c END;
  270. nTry := 1;
  271. LOOP
  272. z := gen.GetRandom( gen );
  273. IF z >= 0 THEN
  274. IF z <= m1 THEN RETURN z MOD top END;
  275. z := z - m1 - 1
  276. ELSE
  277. DEC( z, MIN( LONGINT ) );
  278. IF z <= m2 THEN RETURN z MOD top END;
  279. z := z - m2 - 1 + max1 - m1
  280. END;
  281. IF z <= m3 THEN RETURN z MOD top
  282. END;
  283. IF nTry = maxtries THEN RETURN -1
  284. END;
  285. INC( nTry )
  286. END
  287. END GetRandomLExact;
  288. (* default routines which are set by SetDefaultProcs *)
  289. (** These are the default routines for vector oriented usage **)
  290. PROCEDURE DefaultRandomBitV*( gen: tRandom; count: LONGINT; VAR nrs: ARRAY OF Bits; start: LONGINT );
  291. VAR i: LONGINT;
  292. BEGIN
  293. FOR i := start TO start + count - 1 DO nrs[i] := gen.GetRandom( gen ) END
  294. END DefaultRandomBitV;
  295. (* jb 28.3.00 *)
  296. (*
  297. PROCEDURE DefaultRandomV* (gen: tRandom; count: LONGINT; VAR nrs: ARRAY OF LONGINT; start: LONGINT);
  298. VAR i: LONGINT;
  299. BEGIN
  300. FOR i := start TO start + count - 1 DO nrs[i] := gen.GetRandomL(gen, MAX(LONGINT)) END
  301. END DefaultRandomV;
  302. *)
  303. PROCEDURE DefaultRandomLV*( gen: tRandom; top: LONGINT; count: LONGINT; VAR nrs: ARRAY OF LONGINT; start: LONGINT );
  304. VAR i: LONGINT;
  305. BEGIN
  306. FOR i := start TO start + count - 1 DO nrs[i] := gen.GetRandomL( gen, top ) END
  307. END DefaultRandomLV;
  308. PROCEDURE DefaultRandomUV*( gen: tRandom; count: LONGINT; VAR nrs: ARRAY OF REAL; start: LONGINT );
  309. VAR i: LONGINT;
  310. BEGIN
  311. FOR i := start TO start + count - 1 DO nrs[i] := SHORT( gen.GetRandomU( gen ) ) END
  312. END DefaultRandomUV;
  313. PROCEDURE DefaultRandomUVX*( gen: tRandom; count: LONGINT; VAR nrs: ARRAY OF LONGREAL; start: LONGINT );
  314. VAR i: LONGINT;
  315. BEGIN
  316. FOR i := start TO start + count - 1 DO nrs[i] := gen.GetRandomU( gen ) END
  317. END DefaultRandomUVX;
  318. (* default routines which return SET, jb 28.3.00*)
  319. PROCEDURE DefaultGetSet*( gen: tRandom ): SET;
  320. BEGIN
  321. RETURN SYSTEM.VAL( SET, gen.GetRandom( gen ) )
  322. END DefaultGetSet;
  323. PROCEDURE DefaultMAXSet*( gen: tRandom ): SET;
  324. BEGIN
  325. RETURN SYSTEM.VAL( SET, gen.Max( gen ) )
  326. END DefaultMAXSet;
  327. PROCEDURE GetSeed( r: tRandom; VAR s: tSeed );
  328. BEGIN
  329. s := r.seed
  330. END GetSeed;
  331. PROCEDURE SetSeed( r: tRandom; s: tSeed );
  332. BEGIN
  333. r.seed := s
  334. END SetSeed;
  335. PROCEDURE DefaultName( r: tRandom; pre: ARRAY OF CHAR; VAR name: ARRAY OF CHAR );
  336. VAR i, j: LONGINT; x, y: LONGINT;
  337. BEGIN
  338. j := 0;
  339. (* vyHostTexts.MsgSS('shortid:',r.shortid);vyHostTexts.MsgSS(' pre:',pre);vyHostTexts.MsgSS(' name:',name); *)
  340. i := 0;
  341. WHILE pre[i] # 0X DO name[j] := pre[i]; INC( i ); INC( j ) END;
  342. i := 0;
  343. WHILE r.shortid[i] # 0X DO name[j] := r.shortid[i]; INC( i ); INC( j ) END;
  344. name[j] := 0X;
  345. (*>* vyHostStrings.AppendHex(r.seed,name); -- expanded to avoid dependeny on Strings *)
  346. x := r.seed( tLongintSeed ).val; i := j; j := j + 8; name[j] := 0X;
  347. REPEAT
  348. DEC( j ); y := x MOD 10H;
  349. IF y < 10 THEN name[j] := CHR( y + 30H ) ELSE name[j] := CHR( y + 37H ) END;
  350. x := x DIV 10H
  351. UNTIL j = i;
  352. (*<* vyHostStrings.AppendHex(r.seed,name); -- expanded to avoid dependeny on Strings *)
  353. (* vyHostTexts.MsgSS('shortid:',r.shortid);vyHostTexts.MsgSS(' pre:',pre);vyHostTexts.MsgSS(' name:',name); *)
  354. END DefaultName;
  355. PROCEDURE HandleAttributes( obj: tRandom; VAR M: Objects.AttrMsg );
  356. BEGIN
  357. IF M.id = Objects.get THEN
  358. IF M.name = "ShortClass" THEN COPY( obj.shortid, M.s ); M.class := Objects.String; M.res := 0
  359. ELSIF M.name = "Class" THEN COPY( obj.id, M.s ); M.class := Objects.String; M.res := 0
  360. ELSE Gadgets.objecthandle( obj, M )
  361. END
  362. (* ELSIF M.id = Objects.set THEN
  363. IF (M.name = "Value") OR (M.name="Seed") THEN
  364. IF M.class = Objects.Int THEN obj.seed(tSeed).val:= M.i; M.res := 0 END
  365. ELSE Gadgets.objecthandle(obj,M)
  366. END
  367. *)
  368. ELSIF M.id = Objects.enum THEN M.Enum( "ShortClass" ); M.Enum( "Class" ); Gadgets.objecthandle( obj, M )
  369. ELSE Gadgets.objecthandle( obj, M )
  370. END
  371. END HandleAttributes;
  372. PROCEDURE StoreVersionInformation( VAR r: Files.Rider; shortid: tShortIdStr; seedVersion: INTEGER );
  373. BEGIN
  374. Files.WriteString( r, cMagic ); Files.WriteString( r, shortid ); Files.WriteInt( r, cBaseVersion );
  375. Files.WriteInt( r, seedVersion )
  376. END StoreVersionInformation;
  377. PROCEDURE LoadVersionInformation( VAR r: Files.Rider; VAR shortid: tShortIdStr; VAR baseVersion, seedVersion: INTEGER );
  378. VAR dummy: tIdStr;
  379. BEGIN
  380. Files.ReadString( r, shortid );
  381. IF shortid = cMagic THEN Files.ReadString( r, shortid ); Files.ReadInt( r, baseVersion ); Files.ReadInt( r, seedVersion )
  382. ELSE (* for compatibility with older versions of vyRanBase *)
  383. baseVersion := 0; seedVersion := 0;
  384. Files.ReadString( r, dummy ) (* obj.id - no longer stored *)
  385. END
  386. END LoadVersionInformation;
  387. (*
  388. PROCEDURE Store (obj: tRandom; VAR M: Objects.FileMsg);
  389. BEGIN
  390. Files.WriteString(M.R,obj.shortid);
  391. Files.WriteString(M.R,obj.id);
  392. obj.seed.Store (M.R);
  393. Gadgets.objecthandle(obj, M)
  394. END Store;
  395. *)
  396. PROCEDURE Store( obj: tRandom; VAR M: Objects.FileMsg );
  397. BEGIN
  398. StoreVersionInformation( M.R, obj.shortid, obj.seedVersion ); obj.seed.Store( M.R ); Gadgets.objecthandle( obj, M )
  399. END Store;
  400. PROCEDURE Load( obj: tRandom; VAR M: Objects.FileMsg );
  401. VAR shortid: tShortIdStr; baseVersion, seedVersion: INTEGER; seed: tSeed;
  402. BEGIN
  403. LoadVersionInformation( M.R, shortid, baseVersion, seedVersion );
  404. IF shortid # obj.shortid THEN HALT( 100 ) END;
  405. IF (baseVersion < 0) OR (baseVersion > 1) THEN HALT( 101 ) END;
  406. seed := obj.AllocSeed(); seed.Load( M.R, seedVersion ); obj.seed := seed; Gadgets.objecthandle( obj, M )
  407. END Load;
  408. PROCEDURE Handler*( obj: Objects.Object; VAR M: Objects.ObjMsg );
  409. BEGIN
  410. WITH obj: tRandom DO
  411. IF M IS Objects.AttrMsg THEN
  412. WITH M: Objects.AttrMsg DO HandleAttributes( obj, M )
  413. END
  414. ELSIF M IS Objects.FileMsg THEN
  415. WITH M: Objects.FileMsg DO
  416. IF M.id = Objects.store THEN Store( obj, M )
  417. ELSIF M.id = Objects.load THEN Load( obj, M )
  418. END
  419. END
  420. ELSE Gadgets.objecthandle( obj, M )
  421. END
  422. END; (*WITH obj:tRandom DO*)
  423. END Handler;
  424. PROCEDURE SetDefaultProcs*( gen: tRandom ); (* changed, jb 21.2.00 *)
  425. (*= install default access routines in random number generator
  426. call this first before installing your own procedures *)
  427. BEGIN
  428. gen.GetRandomBitV := DefaultRandomBitV;
  429. (* gen.GetRandomV := DefaultRandomV; *) (* jb 28.3.00 *)
  430. gen.GetRandomLV := DefaultRandomLV; gen.GetRandomUV := DefaultRandomUV;
  431. gen.GetRandomUVX := DefaultRandomUVX;
  432. gen.GetRandomSet := DefaultGetSet; gen.MAXSet := DefaultMAXSet;
  433. gen.RandomHandler := NIL;
  434. gen.GetSeed := GetSeed; gen.SetSeed := SetSeed; gen.Name := DefaultName;
  435. gen.handle := Handler
  436. END SetDefaultProcs;
  437. (** Default implementations not set by SetDefaultProcs **)
  438. (* jb 2.3.01 - Reset mechanism changed *)
  439. PROCEDURE Combo( VAR x, y, z: LONGINT ): LONGINT;
  440. (*= One step of Combo random number generator. *)
  441. (*! only for DefaultLongSeed, Combo implemented in own Module vyRanCombo.Mod *)
  442. CONST mwcParam = 30903;
  443. VAR v: LONGINT;
  444. BEGIN
  445. v := x * y; x := y; y := v;
  446. z :=
  447. mwcParam * SYSTEM.VAL( Bits, SYSTEM.VAL( SET, z ) * SYSTEM.VAL( SET, sysMaskSecondHalf ) ) +
  448. LSH( z, sysBitsTypeSize DIV 2 * sysSHR );
  449. RETURN y + z
  450. END Combo;
  451. PROCEDURE SetInitSeeds;
  452. VAR res: WORD; i: INTEGER;
  453. BEGIN
  454. initSeed1 := Oberon.Time(); Oberon.GetClock( initSeed2, initSeed3 );
  455. FOR i := 1 TO 10 DO res := Combo( initSeed1, initSeed2, initSeed3 ) END
  456. END SetInitSeeds;
  457. PROCEDURE DefaultLongSeed*( ): LONGINT;
  458. (*= return a seed, to be used with the Init procedure of the random number generator
  459. !!! use with care - this procedure gives a full LONGINT, which may be negative or zero !!! *)
  460. BEGIN
  461. RETURN Combo( initSeed1, initSeed2, initSeed3 )
  462. END DefaultLongSeed;
  463. PROCEDURE DefaultLongintReset*( gen: tRandom ); (* jb 21.2.00 *)
  464. (* !!! use with care - this procedure gives a full LONGINT, which may be negative or zero !!!
  465. if something different is needed, you have to create your one Reset procedure *)
  466. VAR seed: tSeed;
  467. BEGIN
  468. seed := gen.seed;
  469. WITH seed: tLongintSeed DO seed.val := DefaultLongSeed()
  470. END
  471. END DefaultLongintReset;
  472. PROCEDURE DefaultSumPSqr*( gen: tRandom; top: LONGINT ): LONGREAL;
  473. (* default procedure if MAX () = sysMaxUnsigned *)
  474. CONST N = MAX( LONGINT );
  475. VAR k, t: LONGREAL;
  476. BEGIN
  477. IF top <= 0 THEN RETURN 1 / top END;
  478. t := N DIV top; k := N - t * top; RETURN (k * (t + 1) / N + t) / N
  479. END DefaultSumPSqr;
  480. (* added - jb 29.11.00, changed - jb 10.1.01 *)
  481. PROCEDURE AllocLongintSeed*( ): tSeed;
  482. VAR seed: tLongintSeed;
  483. BEGIN
  484. NEW( seed ); RETURN seed
  485. END AllocLongintSeed;
  486. (*
  487. PROCEDURE ( VAR seed: tLongintSeedDesc)Store*( VAR r: Files.Rider );
  488. BEGIN
  489. Files.WriteLInt( r, seed.val )
  490. END Store;
  491. PROCEDURE ( VAR seed: tLongintSeedDesc)Load*( VAR r: Files.Rider; seedVersion: INTEGER );
  492. BEGIN
  493. IF seedVersion # cLongintSeedVersion THEN HALT( 100 ) END;
  494. Files.ReadLInt( r, seed.val )
  495. END Load;
  496. PROCEDURE ( VAR seed: tLongintSeedDesc)Copy*( ): tSeed; (* fof 020625 *)
  497. VAR cp: tSeed; copy: tLongintSeed;
  498. BEGIN
  499. cp := AllocLongintSeed(); copy := cp( tLongintSeed );
  500. copy^ := seed; (* copy of content *)
  501. RETURN copy
  502. END Copy;
  503. *)
  504. (* probably not necessary - jb 21.2.00 *)
  505. (*
  506. PROCEDURE FixDefaults* (generator: tRandom);
  507. BEGIN
  508. IF generator.GetRandomBitV = NIL THEN generator.GetRandomBitV := DefaultRandomBitV END;
  509. IF generator.GetRandomV = NIL THEN generator.GetRandomV := DefaultRandomV END;
  510. IF generator.GetRandomLV = NIL THEN generator.GetRandomLV := DefaultRandomLV END;
  511. IF generator.GetRandomUV = NIL THEN generator.GetRandomUV := DefaultRandomUV END;
  512. IF generator.GetRandomUVX = NIL THEN generator.GetRandomUVX := DefaultRandomUVX END;
  513. IF generator.Name = NIL THEN generator.Name := DefaultName END;
  514. IF generator.SetSeed = NIL THEN generator.SetSeed := SetSeed END;
  515. IF generator.GetSeed = NIL THEN generator.GetSeed := GetSeed END
  516. END FixDefaults;
  517. *)
  518. PROCEDURE Install*( generator: tRandom );
  519. BEGIN
  520. ASSERT ( generator # NIL , 100 );
  521. (*! find a mechanism to check if generator has been inited *)
  522. (* ASSERT(generator.Init # NIL, 101); *)
  523. (* not needed - jb 21.2.00
  524. IF generator.GetRandomBitV = NIL THEN generator.GetRandomBitV := DefaultRandomBitV END;
  525. IF generator.GetRandomV = NIL THEN generator.GetRandomV := DefaultRandomV END;
  526. IF generator.GetRandomUV = NIL THEN generator.GetRandomUV := DefaultRandomUV END;
  527. IF generator.GetRandomUVX = NIL THEN generator.GetRandomUVX := DefaultRandomUVX END;
  528. IF generator.Name = NIL THEN generator.Name := DefaultName END;
  529. generator.SetSeed := SetSeed;
  530. generator.GetSeed := GetSeed;
  531. *)
  532. RandomGenerator := generator; (* RandomGenerator.Init(RandomGenerator) *)
  533. (* RandomGenerator.Reset (RandomGenerator) *)
  534. END Install;
  535. (* No Gen procedure for abstract generator *)
  536. PROCEDURE NewAbstractGenerator;
  537. BEGIN
  538. HALT( ccbase )
  539. END NewAbstractGenerator;
  540. PROCEDURE Deposit*;
  541. (*= Copy RandomGenerator to Objects.New, to allow access from Gadgets system *)
  542. BEGIN
  543. Objects.NewObj := RandomGenerator
  544. END Deposit;
  545. PROCEDURE NextRandom*;
  546. BEGIN
  547. IF RandomGenerator # NIL THEN
  548. RandomGenerator.NextRandom( RandomGenerator ); Gadgets.Update( RandomGenerator )
  549. END
  550. END NextRandom;
  551. PROCEDURE DoAsserts;
  552. VAR tmp: Bits;
  553. BEGIN
  554. ASSERT ( SIZEOF( LONGINT ) = sysBitsTypeSize, 100 ); (* jb 28.3.00 *)
  555. ASSERT ( sysMaxUnsigned = -1, 101 ); (* jb 10.1.01 *)
  556. ASSERT ( sysHalfBitsType = LSH( 80000000H, -(sysBitsTypeSize * 8) DIV 2 + 1 ), 102 ); (* jb 10.1.01 *)
  557. tmp := 1;
  558. ASSERT ( LSH( tmp, sysSHL ) = 2, 103 ); (* jb 2.3.01 *)
  559. tmp := -1;
  560. ASSERT ( LSH( tmp, sysSHR ) > 0, 104 ); (* jb 2.3.01 - assert shift is unsigned *)
  561. ASSERT ( SIZEOF( SET ) = SIZEOF( LONGINT ), 105 )
  562. END DoAsserts;
  563. BEGIN
  564. DoAsserts; RandomGenerator := NIL;
  565. SetInitSeeds (* jb 2.3.01 *)
  566. END vyRanBase.
  567. call these only after a random number generator has been installed, for example
  568. vyRanSkeleton.Install ~
  569. Gadgets.Insert SetFrame vyRanBase.Deposit ~
  570. vyRanBase.NextRandom ~