[m-dev.] for review : quickcheck
Mark Anthony BROWN
dougl at cs.mu.OZ.AU
Thu Mar 8 22:38:35 AEDT 2001
Hi,
Here's the next round of review comments. After you have addressed these,
please post a relative diff here.
Cheers,
Mark.
Xiao Chun Simon MEI writes:
> For Mark to review.
>
> Estimated hours taken : 180
>
> qcheck is an autotesting tool similar to Haskell's Quickcheck.
>
> RELEASE_NOTES:
> compiler/notes/authors.html:
> extras/README:
> Modified to mention quickcheck.
>
> extras/quickcheck/qcheck.m:
> New file that contains the souce code for qcheck.
>
> extras/quickcheck/rnd.m:
> New file written by conway. Its functions are similar
> to those in library random.m.
>
> Index: mercury/RELEASE_NOTES
> ===================================================================
> RCS file: /home/mercury1/repository/mercury/RELEASE_NOTES,v
> retrieving revision 1.27
> diff -u -r1.27 RELEASE_NOTES
> --- mercury/RELEASE_NOTES 2001/02/05 10:08:42 1.27
> +++ mercury/RELEASE_NOTES 2001/02/15 02:43:55
> @@ -183,6 +183,7 @@
> - arithmetic on complex and imaginary numbers
> - a CLP(R) interface, i.e. constraint solving over real numbers
> o a set of generic stream type classes
> + o an autotesting tool similar to Haskell's QuickCheck
> o UIs:
> - graphics using Tk and OpenGL
> - text interfaces using curses
> Index: mercury/compiler/notes/authors.html
> ===================================================================
> RCS file: /home/mercury1/repository/mercury/compiler/notes/authors.html,v
> retrieving revision 1.5
> diff -u -r1.5 authors.html
> --- mercury/compiler/notes/authors.html 2000/04/22 07:12:17 1.5
> +++ mercury/compiler/notes/authors.html 2001/02/15 02:18:32
> @@ -54,6 +54,8 @@
> <tr>
> <td>stayl <td>Simon Taylor <td>stayl at students.cs.mu.oz.au </tr>
> <tr>
> +<td>xcsm <td>Simon Mei <td>xcsm at students.cs.mu.oz.au </tr>
> +<tr>
> <td>trd <td>Tyson Dowd <td>trd at students.cs.mu.oz.au </tr>
> <tr>
> <td>zs <td>Zoltan Somogyi <td>zs at cs.mu.oz.au </tr>
> Index: mercury/extras/README
> ===================================================================
> RCS file: /home/mercury1/repository/mercury/extras/README,v
> retrieving revision 1.9
> diff -u -r1.9 README
> --- mercury/extras/README 2000/11/28 16:30:30 1.9
> +++ mercury/extras/README 2001/02/15 02:40:17
> @@ -43,6 +43,8 @@
> odbc A Mercury interface to ODBC (Open Database Connectivity),
> for interfacing to standard relational database packages.
>
> +quickcheck An autotesting tool similar to Haskell's QuickCheck.
> +
> references A library package containing modules for manipulating
> ML-style references (mutable state).
>
> Index: mercury/extras/quickcheck/qcheck.m
> ===================================================================
> RCS file: qcheck.m
> diff -N qcheck.m
> --- /dev/null Wed Nov 15 09:24:47 2000
> +++ qcheck.m Sat Feb 24 03:21:12 2001
> @@ -0,0 +1,1376 @@
> +%-----------------------------------------------------------------------------%
> +% Copyright (C) 2001 The University of Melbourne.
> +% This file may only be copied under the terms of the GNU Library General
> +% Public License - see the file COPYING.LIB in the Mercury distribution.
> +%-----------------------------------------------------------------------------%
> +%
> +% file qcheck.m
> +% author: xcsm
> +%
> +% The source code for autotest generator similar to Haskell's quickcheck.
> +% A user guide should be available at ./tutes/ in html format.
> +%
> +%---------------------------------------------------------------------------%
> +%---------------------------------------------------------------------------%
> +
> +:- module qcheck.
> +
> +:- interface.
> +:- import_module io, std_util, list, bool, char, float, string.
> +:- import_module rnd.
> +
> +%---------------------------------------------------------------------------%
> +
> + % The invariant function must return a property to
> + % indicate the result of invariant function.
> + % yes : success
> + % no : failure
> + % trivial : mark the property being returned by a trivial test
> + % info(univ) : store some arbitrary information in type univ,
> + % condition : mark the property being returned by a test which failed
> + % the pre-conditional
> +:- type property == list(flag).
> +:- type flag
> + ---> yes
> + ; no
> + ; trivial
> + ; info(univ)
> + ; condition.
> +
> + % Each distribution store the value in univ and it's number of
s/store/stores/
s/it's/its/
> + % occurences in the second element.
> +:- type distribution == {univ, int}.
> +
> + % Each result composes of a property, which is the property
> + % returned by the invariant test funcion. The second argument
> + % stores the generated inputs in a univ.
> +:- type result
> + ---> result(property, univ).
> +
> + % The required format for specific frequency :
> + % int : relative frequency of this type being generated
> + % list(list(frequency)) : a constructor may have arity 0 to
> + % infinity. The outer list is a list
> + % for constructor arguments.
> + % Inner list states the relative
> + % frequency of all alternatives for
> + % 1 argument
> + % eg: green(coin, color)
> + % where coin ---> head ; tail.
> + % color ---> black ; white.
> + % Then frequency should be : {99 , [ [{30,[]},{70,[]}],
> + % [{40,[]},{60,[]}]
> + % ]
> + % }
> + % For type coin, there is 30% chance of being head
> + % and 70% chance of being tail.
> + % For type color, there is 40% chance of being black
> + % and 60% chance of bing white.
> +:- type frequency
> + ---> {int, list(list(frequency))}.
> +
> + % user_gen_type is the type format for each of user-defined
> + % generator.
> + % The first element, type_desc, is the type_of the variable
> + % which this generator is suppose to handle. The second element
> + % should be a user defined generator. The user defined generator
> + % should take a type_desc, which shows what type is required. It's
> + % followed by a Specific Frequency, a list of Generanl frequency,
s/Generanl/General/
> + % a list of custom generators, and finally the input and output
> + % of random number supply.
> +:- type user_gen_type
> + ---> { type_desc,
> + func(type_desc, list(frequency),
> + list({type_desc, list(frequency)}),
> + list(user_gen_type), rnd, rnd) = univ
> + }.
> +
> + % user_gen_inst is the instance for each user-defined generator
> +:- inst user_gen_inst
> + = bound({ ground,
> + func(in, in, in,
> + list_skel_in(user_gen_inst), in, out) = out is det
> + }).
> +
> +%---------------------------------------------------------------------------%
> +
> + % The implemented instances are designed for invariant
> + % functions with 0 to 10 arity, and returning a property.
> +:- typeclass testable(T) where [
> + pred test(T, list(list(frequency)), list({type_desc, list(frequency)}),
> + list(user_gen_type), qcheck__result, rnd, rnd),
> + mode test(in, in, in, list_skel_in(user_gen_inst), out, in, out) is det
> +].
> +
> +% Mercury doesn't allow instance declarations for function types.
> +% Hence we have to wrap up the function types in user-defined
> +% types f1(T), f2(T1, T2), f3(T1, T2, T3), ...
> +:- type f0
> + ---> f((func) = property).
> +:- type f1(T1)
> + ---> f(func(T1) = property).
> +:- type f2(T1, T2)
> + ---> f(func(T1, T2) = property).
> +:- type f3(T1, T2, T3)
> + ---> f(func(T1, T2, T3) = property).
> +:- type f4(T1, T2, T3, T4)
> + ---> f(func(T1, T2, T3, T4) = property).
> +:- type f5(T1, T2, T3, T4, T5)
> + ---> f(func(T1, T2, T3, T4, T5) = property).
> +:- type f6(T1, T2, T3, T4, T5, T6)
> + ---> f(func(T1, T2, T3, T4, T5, T6) = property).
> +:- type f7(T1, T2, T3, T4, T5, T6, T7)
> + ---> f(func(T1, T2, T3, T4, T5, T6, T7) = property).
> +:- type f8(T1, T2, T3, T4, T5, T6, T7, T8)
> + ---> f(func(T1, T2, T3, T4, T5, T6, T7, T8) = property).
> +:- type f9(T1, T2, T3, T4, T5, T6, T7, T8, T9)
> + ---> f(func(T1, T2, T3, T4, T5, T6, T7, T8, T9) = property).
> +:- type f10(T1, T2, T3, T4, T5, T6, T7, T8, T9, T10)
> + ---> f(func(T1, T2, T3, T4, T5, T6, T7, T8, T9, T10) = property).
> +
> +:- instance testable(f0).
> +:- instance testable(f1(T1)).
> +:- instance testable(f2(T1, T2)).
> +:- instance testable(f3(T1, T2, T3)).
> +:- instance testable(f4(T1, T2, T3, T4)).
> +:- instance testable(f5(T1, T2, T3, T4, T5)).
> +:- instance testable(f6(T1, T2, T3, T4, T5, T6)).
> +:- instance testable(f7(T1, T2, T3, T4, T5, T6, T7)).
> +:- instance testable(f8(T1, T2, T3, T4, T5, T6, T7, T8)).
> +:- instance testable(f9(T1, T2, T3, T4, T5, T6, T7, T8, T9)).
> +:- instance testable(f10(T1, T2, T3, T4, T5, T6, T7, T8, T9, T10)).
> +
> +
> +
> +%---------------------------------------------------------------------------%
> +
> + % qcheck/4(A, B, G, H) = qcheck/8(A,B,100,[],[],[],G,H)
> + % qcheck/7(A, B, C, D, E G, H) = qcheck/8(A,B, C, D, E,[],G,H)
> + % qcheck/8(A, B, C, D, E, F, G, H)
> + % A : invariant test function, satisfing testable(T)
> + % B : some test description
> + % C : number of tests to run
> + % D : specific frequency
> + % E : general frequency
> + % F : list of user-defined generator
> + % G : io__state in
> + % H : io__state out
> +:- pred qcheck(T, string, io__state, io__state) <= testable(T).
> +:- mode qcheck(in, in, di, uo) is det.
> +:- pred qcheck(T,string, int,list(list(frequency)),
> + list({type_desc, list(frequency)}),
> + io__state, io__state) <= testable(T).
> +:- mode qcheck(in, in, in, in, in, di, uo) is det.
> +:- pred qcheck(T, string, int,list(list(frequency)),
> + list({type_desc, list(frequency)}),
> + list(user_gen_type), io__state, io__state) <= testable(T).
> +:- mode qcheck(in, in, in, in, in, list_skel_in(user_gen_inst), di, uo) is det.
> +
> +%---------------------------------------------------------------------------%
> + % The following are the default generators for int, char, float,
> + % and string. Please refer to tutorials for details.
> +:- func rand_int(rnd, rnd) = int.
> +:- mode rand_int(in, out) = out is det.
> +
> +:- func rand_char(rnd, rnd) = char.
> +:- mode rand_char(in, out) = out is det.
> +
> +:- func rand_float(rnd, rnd) = float.
> +:- mode rand_float(in, out) = out is det.
> +
> +:- func rand_string(rnd, rnd) = string.
> +:- mode rand_string(in, out) = out is det.
> +
> +%---------------------------------------------------------------------------%
> +
> + % rand_union/6 generates a discriminated union via following steps:
> + % 1 It determines what frequency to use at this level
> + % 2 Then chooses which constructor of discriminated union to generate,
> + % and generate the argument list for the particular constructor
> + % 3 And finally call construct/3 to build the term.
> +:- func rand_union(type_desc, list(frequency), list({type_desc,
> + list(frequency)}), list(user_gen_type), rnd, rnd) = univ.
> +:- mode rand_union(in, in, in, list_skel_in(user_gen_inst), in, out) = out is det.
> +
> + % rand_function generates a random forward mode function with types
> + % described in type_desc. However rand_function/3 can only generate
> + % functions with arity 0 to 10, it will throw an error is unable to
s/is/if/
> + % generate the required type.
> +:- func rand_function(type_desc, rnd, rnd) = univ.
> +:- mode rand_function(in, in, out) = out is det.
> +
> + % rand_allint/2 generates an int with equal distribution over all
> + % possible int.
> +:- func rand_allint(rnd, rnd) = int.
> +:- mode rand_allint(in, out) = out is det.
> +
> + % oneof/3 randomly selects an element from the list.
> + % An error will be thrown if the list is empty.
> +:- func oneof(list(T), rnd, rnd) = T.
> +:- mode oneof(in, in, out) = out is det.
> +
> + % The 1st argument is used as random seed, on average there is 5% chance
> + % this function will return 0 regardless of 2nd argument, otherwise
> + % this function produce an int that is dependent on its argument's
> + % type and value where the argument can be of any type.
> +:- func any_to_int(int, T) = int.
> +:- mode any_to_int(in, in) = out is det.
> +
> + % value_to_int/1 produce an int that is dependent on its argument's
> + % type and value where the argument can be of any type.
> +:- func value_to_int(T) = int.
> +:- mode value_to_int(in) = out is det.
> +
> + % The new property will store the value in T
> + % as type univ, later calling function will count
> + % the number of occurrence of that value
> +:- func T `>>>` property = property.
> +:- mode in `>>>` in = out is det.
> +
> + % If the 1st argument is equal to the 2nd argument
> + % then the new property will be marked as trivial
> +:- func to_trivial(T, T, property) = property.
> +:- mode to_trivial(in, in, in) = out is det.
> +
> + % If the left argument equals the right, then reture property:[yes],
> + % otherwise reture property:[no]
> +:- func T `===` T = property.
> +:- mode in `===` in = out is det.
> +
> + % list_length/1 is the same as the function version of list__length.
> + % list__length/1 always returns an int. The problem is that the
> + % compiler doesn't know whether to call the list__length function, or
> + % pass a curried version of the predicate version of list__length/2.
> +:- func list_length(list(T)) = int.
> +:- mode list_length(in) = out is det.
> +
> + % If the right argument is a property, then 'flag:condition' will
> + % be added into the original property provided the left argument is
> + % 'bool:yes' or '(pred):succeed'
> + % If the right argument is (func) = property, then `===>` will return
> + % 'property:[condition]' without evaluating the (func) if the left
> + % argument is 'bool:yes' or '(pred):succeed'.
> +:- typeclass conditional(T1, T2) where [
> + ( func T1 `===>` T2 = property ),
> + ( mode in `===>` in = out is det )
> +].
> +
> +:- instance conditional(bool, property).
> +:- instance conditional(bool, f0).
> +:- instance conditional((pred), property).
> +:- instance conditional((pred), f0).
> +
> +%---------------------------------------------------------------------------%
> +%---------------------------------------------------------------------------%
> +
> +:- implementation.
> +:- import_module io, int, integer.
> +:- import_module builtin, pprint, require, time.
> +
> +qcheck(TestFunction, Name) -->
> + qcheck(TestFunction, Name, 100, [], [], []).
> +
> +qcheck(TestFunction, Name, Counter, SpecificFrequency, GeneralFrequency) -->
> + qcheck(TestFunction, Name, Counter,
> + SpecificFrequency, GeneralFrequency, []).
> +
> + % qcheck//6 first seed the random number on local time, then it
That should be a single '/', and similarly below.
> + % generates the reqiured inputs for the invariant function and runs
> + % it. A table of test results are shown at the end.
> +qcheck(TestFunction, Name, TestCount, SpecificFrequency,
> + GeneralFrequency, Generators) -->
> + time__time(Sometime),
> + { tm(Seconds, Minutes, Hours, _Weekday, Yearday, _Month, Year, _DST)
> + = time__localtime(Sometime) },
> + { TotalSecs = ((( Year * 365 + Yearday ) * 24 + Hours ) * 60 + Minutes ) * 60
> + + Seconds },
Unfortunately, this will currently overflow on 32-bit architectures, with
undefined results. Probably the easiest way around this is to use the same
formula, but with arbitrary precision arithmetic (integer.m), then reduce
the number to an appropriate range (e.g. S = (S0 mod integer(max_int)) + 1)
before converting it back to a normal int.
I would put this into a separate predicate, called something like
"generate_seed_from_time".
> + { init_setup(TotalSecs, RS0) },
> + testing(TestFunction, Name, SpecificFrequency, GeneralFrequency,
> + Generators, RS0, _, TestCount, YesCount, NoFlag,
> + TrivialCount, Distributions, FailedConditionCount),
> + (if { NoFlag = yes }
> + then
> + { true }
> + else
> + io__write_string("\nTest Description : "),
> + io__write_string(Name),
> + io__write_string("\nNumber of test cases that succeeded : "),
> + io__write_int(YesCount),
> + io__write_string("\nNumber of trivial tests : "),
> + io__write_int(TrivialCount),
> + io__write_string("\nNumber of tests cases "),
> + io__write_string("which failed the pre-condition : "),
> + io__write_int(FailedConditionCount),
> + io__write_string("\nDistributions of selected arguments : \n"),
> + { list__sort(rev_field(Distributions), Distributions_Sorted) },
> + show_dist(rev_field(Distributions_Sorted)),
There is a version of list__sort which takes a comparison predicate as an
argument, so you could call that with a predicate that compares the second
tuple argument (followed by the first argument if necessary). That would
be more efficient than what you do here.
> + io__nl
> + ).
> +
> +
> +%---------------------------------------------------------------------------%
> +
> + % testing/15 recursively runs the test until TestCount drops to 0.
> + % After each test it updates the statistics.
> +:- pred testing(T, string, list(list(frequency)),
> + list({type_desc, list(frequency)}),
> + list(user_gen_type), rnd, rnd, int, int, bool, int,
> + list(distribution), int, io__state, io__state) <= testable(T).
> +:- mode testing(in, in, in, in, list_skel_in(user_gen_inst),
> + in, out, in, out, out, out, out, out, di, uo) is det.
> +testing(TestFunction, Name, SpecificFrequency, GeneralFrequency, Generators,
> + RS0, RS, TestCount, YesCount, NoFlag, TrivialCount, Distribution, FailedConditionCount, S0, S) :-
> + (if TestCount =< 0
> + then
> + YesCount = 0,
> + NoFlag = no,
> + TrivialCount = 0,
> + Distribution = [],
> + FailedConditionCount = 0,
> + RS = RS0,
> + S = S0
> + else
> + test(TestFunction, SpecificFrequency, GeneralFrequency,
> + Generators, Result, RS0, RS1),
> + result(P, Univ) = Result,
> + (if member(no, P),
> + not member(condition, P)
> + then
> + io__write_string("\nTest description : ", S0, S1),
> + io__write_string(Name, S1, S2),
> + io__write_string("\nFalsifiable : \n", S2, S3),
> + display_univ(Univ, S3, S),
> + RS = RS1,
> + YesCount = 0,
> + NoFlag = yes,
> + TrivialCount = 0,
> + Distribution = [],
> + FailedConditionCount = 0
> + else
> + testing(TestFunction, Name, SpecificFrequency,
> + GeneralFrequency,
> + Generators, RS1, RS, TestCount - 1, YesCount0,
> + NoFlag0, TrivialCount0,
> + Distribution0, FailedConditionCount0, S0, S),
> + NoFlag = NoFlag0,
> + update(P, YesCount0, TrivialCount0,
> + Distribution0, FailedConditionCount0,
> + YesCount, TrivialCount, Distribution,
> + FailedConditionCount)
> + )
> + ).
> +
> + % update/8 analyses the current invariant test result and updates
> + % the statistic accordingly
> +:- pred update(property, int, int, list(distribution), int,
> + int, int, list(distribution), int).
> +:- mode update(in, in, in, in, in, out, out, out, out) is det.
> +update(P, YesCount0, TrivialCount0, Distribution0, FailedConditionCount0,
> + YesCount, TrivialCount, Distribution, FailedConditionCount) :-
> + (if member(condition, P)
> + then
> + YesCount = YesCount0,
> + TrivialCount = TrivialCount0,
> + Distribution = Distribution0,
> + FailedConditionCount = FailedConditionCount0 + 1
> + else
> + YesCount = YesCount0 + 1,
> + FailedConditionCount = FailedConditionCount0,
> + update_dist(P, Distribution0, Distribution),
> + (if member(trivial, P)
> + then
> + TrivialCount = TrivialCount0 + 1
> + else
> + TrivialCount = TrivialCount0
> + )
> + ).
> +
> + % update_dist/3 recursively exacts the 'flag:info(univ)' from property i
> + % iand adds it to the master list of distribution.
> +:- pred update_dist(property, list(distribution), list(distribution)).
> +:- mode update_dist(in, in, out) is det.
> +update_dist([], Distribution, Distribution).
> +update_dist([Property | Propertys], Distribution0, Distribution) :-
> + (if Property = info(Univ)
> + then
> + update_dist_2(Univ, Distribution0, Distribution1)
> + else
> + Distribution1 = Distribution0
> + ),
> + update_dist(Propertys, Distribution1, Distribution).
> +
> + % If the first argument is alreay stored in the master list, then
> + % update_dist_2/3 just increments the counter, otherwise adds it to
> + % the list with a new counter being 1.
> +:- pred update_dist_2(univ, list(distribution), list(distribution)).
> +:- mode update_dist_2(in, in, out) is det.
> +update_dist_2(Univ, [], [{Univ, 1}]).
> +update_dist_2(Univ, [Distribution | Distributions], Output) :-
> + Distribution = {Patten, Counter},
> + (if Univ = Patten
> + then
> + Output = [{Univ, Counter + 1} | Distributions]
> + else
> + update_dist_2(Univ, Distributions, Output1),
> + Output = [Distribution | Output1]
> + ).
> +
> +%---------------------------------------------------------------------------%
> +
> + % The following are the 11 instances of testable
> + % Each instance began by inst cast the invariant test function from
> + % ground to func(in, in, ...) = out.
> + % Then the specific frequency is extracted; if the SF list is shorter
> + % than the list of arguments, then the last few argument will have
> + % [] as their SF; if the SF list is longer than the list of arguments,
> + % then the list few SF is not used.
> + % test//5 then calls gen//4 to generate the arguments, the invariant
> + % function is then run with those arguments.
> + % the invariant test funtion with the
That comment is incomplete.
> +
> +
> +:- instance testable(f0) where [
> + (test(F, _, _, _, R) -->
> + { inst_cast_f0(F, NF) },
> + { univ({"no argument"}) = Args },
> + { R = result(apply(NF), Args) })
> +].
> +
> +:- instance testable(f1(T1)) where [
> + (test(F, SF0, GF, Generators, R) -->
> + { inst_cast_f1(F, NF) },
> + gen(X, det_headlist(SF0, _), GF, Generators),
> + { univ({X}) = Args },
> + { R = result(NF(X), Args) })
> +].
> +
> +:- instance testable(f2(T1, T2)) where [
> + (test(F, SF0, GF, Generators, R) -->
> + { inst_cast_f2(F, NF) },
> + gen(X, det_headlist(SF0, SF1), GF, Generators),
> + gen(Y, det_headlist(SF1, _), GF, Generators),
> + { univ({X, Y}) = Args },
> + { R = result(NF(X, Y), Args) })
> +].
> +
> +:- instance testable(f3(T1, T2, T3)) where [
> + (test(F, SF0, GF, Generators, R) -->
> + { inst_cast_f3(F, NF) },
> + gen(X, det_headlist(SF0, SF1), GF, Generators),
> + gen(Y, det_headlist(SF1, SF2), GF, Generators),
> + gen(Z, det_headlist(SF2, _), GF, Generators),
> + { univ({X, Y, Z}) = Args },
> + { R = result(apply(NF, X, Y, Z), Args) })
> +].
> +
> +:- instance testable(f4(T1, T2, T3, T4)) where [
> + (test(F, SF0, GF, Generators, R) -->
> + { inst_cast_f4(F, NF) },
> + gen(X1, det_headlist(SF0, SF1), GF, Generators),
> + gen(X2, det_headlist(SF1, SF2), GF, Generators),
> + gen(X3, det_headlist(SF2, SF3), GF, Generators),
> + gen(X4, det_headlist(SF3, _), GF, Generators),
> + { univ({X1, X2, X3, X4}) = Args },
> + { R = result(NF(X1, X2, X3, X4), Args) })
> +].
> +
> +:- instance testable(f5(T1, T2, T3, T4, T5)) where [
> + (test(F, SF0, GF, Generators, R) -->
> + { inst_cast_f5(F, NF) },
> + gen(X1, det_headlist(SF0, SF1), GF, Generators),
> + gen(X2, det_headlist(SF1, SF2), GF, Generators),
> + gen(X3, det_headlist(SF2, SF3), GF, Generators),
> + gen(X4, det_headlist(SF3, SF4), GF, Generators),
> + gen(X5, det_headlist(SF4, _), GF, Generators),
> + { univ({X1, X2, X3, X4, X5}) = Args },
> + { R = result(NF(X1, X2, X3, X4, X5), Args) })
> +].
> +
> +:- instance testable(f6(T1, T2, T3, T4, T5, T6)) where [
> + (test(F, SF0, GF, Generators, R) -->
> + { inst_cast_f6(F, NF) },
> + gen(X1, det_headlist(SF0, SF1), GF, Generators),
> + gen(X2, det_headlist(SF1, SF2), GF, Generators),
> + gen(X3, det_headlist(SF2, SF3), GF, Generators),
> + gen(X4, det_headlist(SF3, SF4), GF, Generators),
> + gen(X5, det_headlist(SF4, SF5), GF, Generators),
> + gen(X6, det_headlist(SF5, _), GF, Generators),
> + { univ({X1, X2, X3, X4, X5, X6}) = Args },
> + { R = result(NF(X1, X2, X3, X4, X5, X6), Args) })
> +].
> +
> +:- instance testable(f7(T1, T2, T3, T4, T5, T6, T7)) where [
> + (test(F, SF0, GF, Generators, R) -->
> + { inst_cast_f7(F, NF) },
> + gen(X1, det_headlist(SF0, SF1), GF, Generators),
> + gen(X2, det_headlist(SF1, SF2), GF, Generators),
> + gen(X3, det_headlist(SF2, SF3), GF, Generators),
> + gen(X4, det_headlist(SF3, SF4), GF, Generators),
> + gen(X5, det_headlist(SF4, SF5), GF, Generators),
> + gen(X6, det_headlist(SF5, SF6), GF, Generators),
> + gen(X7, det_headlist(SF6, _), GF, Generators),
> + { univ({X1, X2, X3, X4, X5, X6, X7}) = Args },
> + { R = result(NF(X1, X2, X3, X4, X5, X6, X7), Args) })
> +].
> +
> +:- instance testable(f8(T1, T2, T3, T4, T5, T6, T7, T8)) where [
> + (test(F, SF0, GF, Generators, R) -->
> + { inst_cast_f8(F, NF) },
> + gen(X1, det_headlist(SF0, SF1), GF, Generators),
> + gen(X2, det_headlist(SF1, SF2), GF, Generators),
> + gen(X3, det_headlist(SF2, SF3), GF, Generators),
> + gen(X4, det_headlist(SF3, SF4), GF, Generators),
> + gen(X5, det_headlist(SF4, SF5), GF, Generators),
> + gen(X6, det_headlist(SF5, SF6), GF, Generators),
> + gen(X7, det_headlist(SF6, SF7), GF, Generators),
> + gen(X8, det_headlist(SF7, _), GF, Generators),
> + { univ({X1, X2, X3, X4, X5, X6, X7, X8}) = Args },
> + { R = result(NF(X1, X2, X3, X4, X5, X6, X7, X8), Args) })
> +].
> +
> +:- instance testable(f9(T1, T2, T3, T4, T5, T6, T7, T8, T9)) where [
> + (test(F, SF0, GF, Generators, R) -->
> + { inst_cast_f9(F, NF) },
> + gen(X1, det_headlist(SF0, SF1), GF, Generators),
> + gen(X2, det_headlist(SF1, SF2), GF, Generators),
> + gen(X3, det_headlist(SF2, SF3), GF, Generators),
> + gen(X4, det_headlist(SF3, SF4), GF, Generators),
> + gen(X5, det_headlist(SF4, SF5), GF, Generators),
> + gen(X6, det_headlist(SF5, SF6), GF, Generators),
> + gen(X7, det_headlist(SF6, SF7), GF, Generators),
> + gen(X8, det_headlist(SF7, SF8), GF, Generators),
> + gen(X9, det_headlist(SF8, _), GF, Generators),
> + { univ({X1, X2, X3, X4, X5, X6, X7, X8, X9}) = Args },
> + { R = result(NF(X1, X2, X3, X4, X5, X6, X7, X8, X9), Args) })
> +].
> +
> +:- instance testable(f10(T1, T2, T3, T4, T5, T6, T7, T8, T9, T10)) where [
> + (test(F, SF0, GF, Generators, R) -->
> + { inst_cast_f10(F, NF) },
> + gen(X1, det_headlist(SF0, SF1), GF, Generators),
> + gen(X2, det_headlist(SF1, SF2), GF, Generators),
> + gen(X3, det_headlist(SF2, SF3), GF, Generators),
> + gen(X4, det_headlist(SF3, SF4), GF, Generators),
> + gen(X5, det_headlist(SF4, SF5), GF, Generators),
> + gen(X6, det_headlist(SF5, SF6), GF, Generators),
> + gen(X7, det_headlist(SF6, SF7), GF, Generators),
> + gen(X8, det_headlist(SF7, SF8), GF, Generators),
> + gen(X9, det_headlist(SF8, SF9), GF, Generators),
> + gen(X10, det_headlist(SF9, _), GF, Generators),
> + { univ({X1, X2, X3, X4, X5, X6, X7, X8, X9, X10}) = Args },
> + { R = result(NF(X1, X2, X3, X4, X5, X6, X7, X8, X9, X10),Args)})
> +].
> +
> +
> +%---------------------------------------------------------------------------%
> +
> + % The following are the 11 inst casts, each corresponding to the 11
> + % insances of testable.
> +:- pred inst_cast_f0(f0, (func) = property).
> +:- mode inst_cast_f0(in, out((func) = out is det)) is det.
> +:- pragma c_code(inst_cast_f0(F0::in, F1::out((func) = out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +:- pred inst_cast_f1(f1(T1), func(T1) = property).
> +:- mode inst_cast_f1(in, out(func(in) = out is det)) is det.
> +:- pragma c_code(inst_cast_f1(F0::in, F1::out(func(in) = out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +:- pred inst_cast_f2(f2(T1, T2), func(T1, T2) = property).
> +:- mode inst_cast_f2(in, out(func(in, in) = out is det)) is det.
> +:- pragma c_code(inst_cast_f2(F0::in, F1::out(func(in, in) = out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +:- pred inst_cast_f3(f3(T1, T2, T3), func(T1, T2, T3) = property).
> +:- mode inst_cast_f3(in, out(func(in, in, in) = out is det)) is det.
> +:- pragma c_code(inst_cast_f3(F0::in, F1::out(func(in, in, in) = out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +:- pred inst_cast_f4(f4(T1, T2, T3, T4), func(T1, T2, T3, T4) = property).
> +:- mode inst_cast_f4(in, out(func(in, in, in, in) = out is det)) is det.
> +:- pragma c_code(inst_cast_f4(F0::in,
> + F1::out(func(in, in, in, in) = out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +:- pred inst_cast_f5(f5(T1, T2, T3, T4, T5),
> + func(T1, T2, T3, T4, T5) = property).
> +:- mode inst_cast_f5(in, out(func(in, in, in, in, in) = out is det)) is det.
> +:- pragma c_code(inst_cast_f5(F0::in,
> + F1::out(func(in, in, in, in, in)=out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +:- pred inst_cast_f6(f6(T1, T2, T3, T4, T5, T6),
> + func(T1, T2, T3, T4, T5, T6) = property).
> +:- mode inst_cast_f6(in, out(func(in, in, in, in, in, in) = out is det)) is det.
> +:- pragma c_code(inst_cast_f6(F0::in,
> + F1::out(func(in, in, in, in, in, in)
> + = out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +:- pred inst_cast_f7(f7(T1, T2, T3, T4, T5, T6, T7),
> + func(T1, T2, T3, T4, T5, T6, T7) = property).
> +:- mode inst_cast_f7(in, out(func(in, in, in, in, in, in, in)
> + = out is det)) is det.
> +:- pragma c_code(inst_cast_f7(F0::in,
> + F1::out(func(in, in, in, in, in, in, in)
> + = out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +:- pred inst_cast_f8(f8(T1, T2, T3, T4, T5, T6, T7, T8),
> + func(T1, T2, T3, T4, T5, T6, T7, T8) = property).
> +:- mode inst_cast_f8(in, out(func(in, in, in, in, in, in, in, in)
> + = out is det)) is det.
> +:- pragma c_code(inst_cast_f8(F0::in,
> + F1::out(func(in, in, in, in, in, in, in, in)
> + = out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +:- pred inst_cast_f9(f9(T1, T2, T3, T4, T5, T6, T7, T8, T9),
> + func(T1, T2, T3, T4, T5, T6, T7, T8, T9) = property).
> +:- mode inst_cast_f9(in,
> + out(func(in, in, in, in, in, in, in, in, in)
> + = out is det)) is det.
> +:- pragma c_code(inst_cast_f9(F0::in,
> + F1::out(func(in, in, in, in, in, in,
> + in, in, in) = out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +:- pred inst_cast_f10(f10(T1, T2, T3, T4, T5, T6, T7, T8, T9, T10),
> + func(T1, T2, T3, T4, T5, T6, T7, T8, T9, T10) = property).
> +:- mode inst_cast_f10(in,
> + out(func(in, in, in, in, in, in, in, in, in, in)
> + = out is det)) is det.
> +:- pragma c_code(inst_cast_f10(F0::in,
> + F1::out(func(in, in, in, in, in, in,
> + in, in, in, in) = out is det)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +%---------------------------------------------------------------------------%
> +
> + % The following are the 4 instances of conditional, and an inst cast
> + % from ground to (pred)
> +
> +:- instance conditional(bool, property) where [
> + ( Left `===>` Right = Property :-
> + (if Left = yes
> + then
> + Property = Right
> + else
> + Property = [condition|Right]
> + )
> + )
> +].
> +
> +:- instance conditional(bool, f0) where [
> + ( Left `===>` Right = Property :-
> + inst_cast_f0(Right, Right_Cast),
> + (if Left = yes
> + then
> + Property = apply(Right_Cast)
> + else
> + Property = [condition]
> + )
> + )
> +].
> +
> +:- instance conditional((pred), property) where [
> + ( Left `===>` Right = Property :-
> + inst_cast_p0(Left, Left_Cast),
> + (if call(Left_Cast)
> + then
> + Property = Right
> + else
> + Property = [condition|Right]
> + )
> + )
> +].
> +
> +:- instance conditional((pred), f0) where [
> + ( Left `===>` Right = Property :-
> + inst_cast_p0(Left, Left_Cast),
> + inst_cast_f0(Right, Right_Cast),
> + (if call(Left_Cast)
> + then
> + Property = apply(Right_Cast)
> + else
> + Property = [condition]
> + )
> + )
> +].
> +
> +:- pred inst_cast_p0((pred), (pred)).
> +:- mode inst_cast_p0(in, out((pred) is semidet)) is det.
> +:- pragma c_code(inst_cast_p0(F0::in, F1::out((pred) is semidet)),
> + [thread_safe, will_not_call_mercury],
> + "F1 = F0;").
> +
> +%---------------------------------------------------------------------------%
> +
> + % gen/6 calls gen_arg/7 to generate the first argument of gen/6,
> +:- pred gen(T, list(frequency), list({type_desc, list(frequency)}),
> + list(user_gen_type), rnd, rnd).
> +:- mode gen(out, in, in, list_skel_in(user_gen_inst), in, out) is det.
> +gen(Term, Frequencys, GF, Generators, RS0, RS) :-
> + Type = type_of(Term),
> + gen_arg(Type, Frequencys, GF, Generators, Univ, RS0, RS),
> + det_univ_to_type(Univ, Term).
> +
> + % gen_arg/7 searches for a user-defined generator first, if it is found,
> + % then runs the generator. Otherwise, gen_arg/7 will try to determine
> + % which type it is suppose to generate, and calls the appropriate
> + % default generator. rand_function/3 will be called only if the required
> + % type is not int, char, float, string, or discriminated union.
There is an implicit assumption here that needs to be documented in the
interface to this module. I mentioned this in the first review, but you
don't appear to have addressed it.
> +:- pred gen_arg(type_desc, list(frequency), list({type_desc, list(frequency)}),
> + list(user_gen_type), univ, rnd, rnd).
> +:- mode gen_arg(in, in, in, list_skel_in(user_gen_inst), out, in, out) is det.
> +gen_arg(Datatype, Frequencys, GF, UserGenerators, Univ, RS0, RS) :-
> + (if find_user_gen(Datatype, UserGenerators, User_generator)
To be consistent, the variable name should be UserGenerator.
> + then
> + Univ = User_generator(Datatype, Frequencys, GF, UserGenerators,
> + RS0,RS)
> + else
> + ( Datatype = type_of(0) ->
> + Temp = rand_int(RS0, RS),
> + Univ = univ(Temp)
> + ; Datatype = type_of('0') ->
> + Temp = rand_char(RS0, RS),
> + Univ = univ(Temp)
> + ; Datatype = type_of(0.0) ->
> + Temp = rand_float(RS0, RS),
> + Univ = univ(Temp)
> + ; Datatype = std_util__type_of("String") ->
> + Temp = rand_string(RS0, RS),
> + Univ = univ(Temp)
> + ; num_functors(Datatype) = -1 ->
> + Univ = rand_function(Datatype, RS0, RS)
> + ;
> + Univ = rand_union(Datatype, Frequencys,
> + GF, UserGenerators, RS0, RS)
> + )
> + ).
> +
> + % gen_arg_list/7 is similar to gen_arg/7, except it generates a list of
> + % univ, instead of just 1 univ as in gen_arg/7.
> + % gen_arg_list/7 recursively calls gen_arg/7 until the list is empty.
> +:- pred gen_arg_list(list(type_desc), list(list(frequency)),
> + list({type_desc, list(frequency)}), list(user_gen_type),
> + list(univ), rnd, rnd).
> +:- mode gen_arg_list(in,in,in,list_skel_in(user_gen_inst),out,in,out) is det.
> +gen_arg_list([], _, _, _, [], RS, RS).
> +gen_arg_list([Type|Types], FrequencyList, GF, UserGenerators, [Univ|Univs],
> + RS0, RS) :-
> + ( FrequencyList = [],
> + F = [],
> + Fs = []
> + ;
> + FrequencyList = [F | Fs]
> + ),
> + gen_arg(Type, F, GF, UserGenerators, Univ, RS0, RS1),
> + gen_arg_list(Types, Fs, GF, UserGenerators, Univs, RS1, RS).
> +
> +%---------------------------------------------------------------------------%
> +
> + % generate an int of N Bits
> +:- pred next(int, int, rnd, rnd).
> +:- mode next(in, out, in, out) is det.
> +next(N, Bits, Rnd0, Rnd) :-
> + rnd(F, Rnd0, Rnd),
> + Range = pow(2.0, N) - 1.0,
> + Bits = round_to_int(F * Range).
> +
> + % generate int
> +rand_int(BS0, BS) = Int :-
> + Temp = rand_allint(BS0, BS1) rem 2,
> + (if Temp = 0
> + then
> + irange(-100, 100, Int, BS1, BS)
> + else
> + Int = rand_allint(BS1, BS)
> + ).
> +
> + % generate int
> +rand_allint(BS0, BS) = Int :-
> + next(1, Sign, BS0, BS1),
> + next(31, TempInt, BS1, BS),
> + ( Sign > 0 ->
> + Int = TempInt
> + ;
> + Int = -TempInt
> + ).
> +
> + % generate char
> +rand_char(RS0, RS) = Char :-
> + Int = rand_allint(RS0, RS1) rem 1000,
> + (if char__to_int(Char0, Int)
> + then
> + Char = Char0,
> + RS = RS1
> + else
> + Char = rand_char(RS1, RS)
> + ).
> +
> + % generate float
> +rand_float(BS0, BS) = Flt :-
> + next(31, Mant0, BS0, BS1),
> + next(1, Sign, BS1, BS2),
> + ( Sign > 0 ->
> + Mant = Mant0
> + ;
> + Mant = -Mant0
> + ),
> + next(7, Exp, BS2, BS3),
> + next(1, ExpSign, BS3, BS),
> + Flt0 = float(Mant) * pow(2.0, Exp),
> + ( ExpSign > 0, Flt0 \= 0.0 ->
> + Flt = 1.0/Flt0
> + ;
> + Flt = Flt0
> + ).
> +
> + % generate string
> +rand_string(RS0, RS) = X :-
> + gen(Charlist, [], [ {type_of(['A']), [{10, []}, {90, []}]} ],
> + [], RS0, RS),
> + string__from_char_list(Charlist,X).
> +
> + % generate disciminated union
> +rand_union(Datatype, Frequencys, GF, UserGenerators, RS0, RS) = Univ :-
> + NumFunctors = std_util__num_functors(Datatype),
> + TempFreq = get_freq(Datatype, NumFunctors, 0, Frequencys, GF),
> + rnd__irange(0, freq_base(TempFreq) - 1, Selector, RS0, RS1),
> + { Branch, SubBranch } = select_branch(Selector, 0, 0, TempFreq),
> + (if get_functor(Datatype, Branch, _, _, ArgTypesTemp)
> + then
> + ArgTypes = ArgTypesTemp,
> + gen_arg_list(ArgTypes, SubBranch, GF,
> + UserGenerators, ArgList, RS1, RS),
> + (if Temp = construct(Datatype, Branch, ArgList)
> + then
> + Univ = Temp
> + else
> + error("rand_union/6 : construct/3 failed")
> + )
> + else
> + error("rand_union/6 : get_functor/5 failed")
> + ).
> +
> +
> + % generate random function
> +rand_function(Type, RS0, RS) = Univ :-
> + rnd__irange(1, const_million, X0, RS0, RS1),
> + rnd__irange(1, const_million, X1, RS1, RS2),
> + rnd__irange(1, const_million, X2, RS2, RS3),
> + rnd__irange(1, const_million, X3, RS3, RS4),
> + rnd__irange(1, const_million, X4, RS4, RS5),
> + rnd__irange(1, const_million, X5, RS5, RS6),
> + rnd__irange(1, const_million, X6, RS6, RS7),
> + rnd__irange(1, const_million, X7, RS7, RS8),
> + rnd__irange(1, const_million, X8, RS8, RS9),
> + rnd__irange(1, const_million, X9, RS9, RS10),
> + rnd__irange(1, const_million, X10, RS10, RS),
By a "more meaningful name" I was asking for something like max_int_argument,
rather than spelling the number out in words.
> + type_ctor_and_args(Type, _, Args),
> + ( Args = [RetType] ->
> + has_type(RetVal, RetType),
> + Func = dummy(X0,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10),
> + nailFuncType(RetVal, Func),
> + Univ = univ(Func)
> + ; Args = [ArgType1, RetType] ->
> + has_type(Arg1, ArgType1),
> + has_type(RetVal, RetType),
> + Func = dummy(X0,X1,X2,X3,X4,X5,X6,X7,X8,X9),
> + nailFuncType(Arg1, RetVal, Func),
> + Univ = univ(Func)
> + ; Args = [ArgType1, ArgType2, RetType] ->
> + has_type(Arg1, ArgType1),
> + has_type(Arg2, ArgType2),
> + has_type(RetVal, RetType),
> + Func = dummy(X0,X1,X2,X3,X4,X5,X6,X7,X8),
> + nailFuncType(Arg1, Arg2, RetVal, Func),
> + Univ = univ(Func)
> + ; Args = [ArgType1, ArgType2, ArgType3, RetType] ->
> + has_type(Arg1, ArgType1),
> + has_type(Arg2, ArgType2),
> + has_type(Arg3, ArgType3),
> + has_type(RetVal, RetType),
> + Func = dummy(X0,X1,X2,X3,X4,X5,X6,X7),
> + nailFuncType(Arg1, Arg2, Arg3, RetVal, Func),
> + Univ = univ(Func)
> + ; Args = [ArgType1, ArgType2, ArgType3, ArgType4, RetType] ->
> + has_type(Arg1, ArgType1),
> + has_type(Arg2, ArgType2),
> + has_type(Arg3, ArgType3),
> + has_type(Arg4, ArgType4),
> + has_type(RetVal, RetType),
> + Func = dummy(X0,X1,X2,X3,X4,X5,X6),
> + nailFuncType(Arg1, Arg2, Arg3, Arg4, RetVal, Func),
> + Univ = univ(Func)
> + ; Args = [ArgType1, ArgType2, ArgType3, ArgType4,
> + ArgType5, RetType] ->
> + has_type(Arg1, ArgType1),
> + has_type(Arg2, ArgType2),
> + has_type(Arg3, ArgType3),
> + has_type(Arg4, ArgType4),
> + has_type(Arg5, ArgType5),
> + has_type(RetVal, RetType),
> + Func = dummy(X0,X1,X2,X3,X4,X5),
> + nailFuncType(Arg1, Arg2, Arg3, Arg4, Arg5,
> + RetVal, Func),
> + Univ = univ(Func)
> + ; Args = [ArgType1, ArgType2, ArgType3, ArgType4,
> + ArgType5, ArgType6, RetType] ->
> + has_type(Arg1, ArgType1),
> + has_type(Arg2, ArgType2),
> + has_type(Arg3, ArgType3),
> + has_type(Arg4, ArgType4),
> + has_type(Arg5, ArgType5),
> + has_type(Arg6, ArgType6),
> + has_type(RetVal, RetType),
> + Func = dummy(X0,X1,X2,X3,X4),
> + nailFuncType(Arg1, Arg2, Arg3, Arg4, Arg5,
> + Arg6, RetVal, Func),
> + Univ = univ(Func)
> + ; Args = [ArgType1, ArgType2, ArgType3, ArgType4,
> + ArgType5, ArgType6, ArgType7, RetType] ->
> + has_type(Arg1, ArgType1),
> + has_type(Arg2, ArgType2),
> + has_type(Arg3, ArgType3),
> + has_type(Arg4, ArgType4),
> + has_type(Arg5, ArgType5),
> + has_type(Arg6, ArgType6),
> + has_type(Arg7, ArgType7),
> + has_type(RetVal, RetType),
> + Func = dummy(X0,X1,X2,X3),
> + nailFuncType(Arg1, Arg2, Arg3, Arg4, Arg5,
> + Arg6, Arg7, RetVal, Func),
> + Univ = univ(Func)
> + ; Args = [ArgType1, ArgType2, ArgType3, ArgType4,
> + ArgType5, ArgType6, ArgType7, ArgType8,
> + RetType] ->
> + has_type(Arg1, ArgType1),
> + has_type(Arg2, ArgType2),
> + has_type(Arg3, ArgType3),
> + has_type(Arg4, ArgType4),
> + has_type(Arg5, ArgType5),
> + has_type(Arg6, ArgType6),
> + has_type(Arg7, ArgType7),
> + has_type(Arg8, ArgType8),
> + has_type(RetVal, RetType),
> + Func = dummy(X0,X1,X2),
> + nailFuncType(Arg1, Arg2, Arg3, Arg4, Arg5,
> + Arg6, Arg7, Arg8, RetVal, Func),
> + Univ = univ(Func)
> + ; Args = [ArgType1, ArgType2, ArgType3, ArgType4,
> + ArgType5, ArgType6, ArgType7, ArgType8,
> + ArgType9, RetType] ->
> + has_type(Arg1, ArgType1),
> + has_type(Arg2, ArgType2),
> + has_type(Arg3, ArgType3),
> + has_type(Arg4, ArgType4),
> + has_type(Arg5, ArgType5),
> + has_type(Arg6, ArgType6),
> + has_type(Arg7, ArgType7),
> + has_type(Arg8, ArgType8),
> + has_type(Arg9, ArgType9),
> + has_type(RetVal, RetType),
> + Func = dummy(X0,X1),
> + nailFuncType(Arg1, Arg2, Arg3, Arg4, Arg5,
> + Arg6, Arg7, Arg8, Arg9, RetVal, Func),
> + Univ = univ(Func)
> + ; Args = [ArgType1, ArgType2, ArgType3, ArgType4,
> + ArgType5, ArgType6, ArgType7, ArgType8,
> + ArgType9, ArgType10, RetType] ->
> + has_type(Arg1, ArgType1),
> + has_type(Arg2, ArgType2),
> + has_type(Arg3, ArgType3),
> + has_type(Arg4, ArgType4),
> + has_type(Arg5, ArgType5),
> + has_type(Arg6, ArgType6),
> + has_type(Arg7, ArgType7),
> + has_type(Arg8, ArgType8),
> + has_type(Arg9, ArgType9),
> + has_type(Arg10, ArgType10),
> + has_type(RetVal, RetType),
> + Func = dummy(X0),
> + nailFuncType(Arg1, Arg2, Arg3, Arg4, Arg5,
> + Arg6, Arg7, Arg8, Arg9, Arg10,
> + RetVal, Func),
> + Univ = univ(Func)
> + ;
> + error("no default generator for this type")
> + ).
> +
> +%---------------------------------------------------------------------------%
> +
> + % There are 11 version of nailFuncType correspond to each arity of random funcion
> +:- pred nailFuncType(T, (func) = T).
> +:- mode nailFuncType(unused, unused) is det.
> +
> +:- pred nailFuncType(T1, T, func(T1) = T).
> +:- mode nailFuncType(unused, unused, unused) is det.
> +
> +:- pred nailFuncType(T1, T2, T, func(T1, T2) = T).
> +:- mode nailFuncType(unused, unused, unused, unused) is det.
> +
> +:- pred nailFuncType(T1, T2, T3, T, func(T1, T2, T3) = T).
> +:- mode nailFuncType(unused, unused, unused, unused, unused) is det.
> +
> +:- pred nailFuncType(T1, T2, T3, T4, T, func(T1, T2, T3, T4) = T).
> +:- mode nailFuncType(unused, unused, unused, unused, unused, unused) is det.
> +
> +:- pred nailFuncType(T1, T2, T3, T4, T5, T, func(T1, T2, T3, T4, T5) = T).
> +:- mode nailFuncType(unused, unused, unused, unused, unused,
> + unused, unused) is det.
> +
> +:- pred nailFuncType(T1, T2, T3, T4, T5, T6, T,
> + func(T1, T2, T3, T4, T5, T6) = T).
> +:- mode nailFuncType(unused, unused, unused, unused, unused,
> + unused, unused, unused) is det.
> +
> +:- pred nailFuncType(T1, T2, T3, T4, T5, T6, T7, T,
> + func(T1, T2, T3, T4, T5, T6, T7) = T).
> +:- mode nailFuncType(unused, unused, unused, unused, unused,
> + unused, unused, unused, unused) is det.
> +
> +:- pred nailFuncType(T1, T2, T3, T4, T5, T6, T7, T8, T,
> + func(T1, T2, T3, T4, T5, T6, T7, T8) = T).
> +:- mode nailFuncType(unused, unused, unused, unused, unused,
> + unused, unused, unused, unused, unused) is det.
> +
> +:- pred nailFuncType(T1, T2, T3, T4, T5, T6, T7, T8, T9, T,
> + func(T1, T2, T3, T4, T5, T6, T7, T8, T9) = T).
> +:- mode nailFuncType(unused, unused, unused, unused, unused, unused,
> + unused, unused, unused, unused, unused) is det.
> +
> +:- pred nailFuncType(T1, T2, T3, T4, T5, T6, T7, T8, T9, T10, T,
> + func(T1, T2, T3, T4, T5, T6, T7, T8, T9, T10) = T).
> +:- mode nailFuncType(unused, unused, unused, unused, unused, unused,
> + unused, unused, unused, unused, unused, unused) is det.
> +
> +nailFuncType(_, _).
> +nailFuncType(_, _, _).
> +nailFuncType(_, _, _, _).
> +nailFuncType(_, _, _, _, _).
> +nailFuncType(_, _, _, _, _, _).
> +nailFuncType(_, _, _, _, _, _, _).
> +nailFuncType(_, _, _, _, _, _, _, _).
> +nailFuncType(_, _, _, _, _, _, _, _, _).
> +nailFuncType(_, _, _, _, _, _, _, _, _, _).
> +nailFuncType(_, _, _, _, _, _, _, _, _, _, _).
> +nailFuncType(_, _, _, _, _, _, _, _, _, _, _, _).
> +
> +%---------------------------------------------------------------------------%
> +
> + % dummy/11 is the base function for curry.
> +:- func dummy(int, T1, T2, T3, T4, T5, T6, T7, T8, T9, T10) = T11.
> +:- mode dummy(in, in, in, in, in, in, in, in, in, in, in) = out is det.
> +dummy(X, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10) = Y :-
> + init_setup(X, RS0),
> + rnd__irange(1, const_million, Seed_initial, RS0, RS1),
> + rnd__irange(1, const_million, Seed_any_to_int1, RS1, RS2),
> + rnd__irange(1, const_million, Seed_any_to_int2, RS2, RS3),
> + rnd__irange(1, const_million, Seed_any_to_int3, RS3, RS4),
> + rnd__irange(1, const_million, Seed_any_to_int4, RS4, RS5),
> + rnd__irange(1, const_million, Seed_any_to_int5, RS5, RS6),
> + rnd__irange(1, const_million, Seed_any_to_int6, RS6, RS7),
> + rnd__irange(1, const_million, Seed_any_to_int7, RS7, RS8),
> + rnd__irange(1, const_million, Seed_any_to_int8, RS8, RS9),
> + rnd__irange(1, const_million, Seed_any_to_int9, RS9, RS10),
> + rnd__irange(1, const_million, Seed_any_to_int10, RS10, _),
> + Final_Seed = Seed_initial + any_to_int(Seed_any_to_int1, X1)
> + + any_to_int(Seed_any_to_int2, X2)
> + + any_to_int(Seed_any_to_int3, X3)
> + + any_to_int(Seed_any_to_int4, X4)
> + + any_to_int(Seed_any_to_int5, X5)
> + + any_to_int(Seed_any_to_int6, X6)
> + + any_to_int(Seed_any_to_int7, X7)
> + + any_to_int(Seed_any_to_int8, X8)
> + + any_to_int(Seed_any_to_int9, X9)
> + + any_to_int(Seed_any_to_int10, X10),
> + init_setup(Final_Seed, New_RS),
> + gen(Y, [], [], [], New_RS, _).
> +
> +%---------------------------------------------------------------------------%
> +any_to_int(Seed, X) = Int :-
> + Temp = value_to_int(X),
> + init_setup(Seed, RS0),
> + (if irange(1, 20, Output, RS0, _),
> + Output = 1
> + then
> + Int = 0
> + else
> + Int = Temp
> + ).
> +
> +value_to_int(X) = Temp :-
> + univ(X) = X1,
> + Temp = univ_to_int(X1).
> +
> +:- func univ_to_int(univ) = int.
> +:- mode univ_to_int(in) = out is det.
> +univ_to_int(X) = Y :-
> + univ_value(X) = Value,
> + std_util__deconstruct(Value, Functor, _Arity, ArgList),
> + string__to_char_list(Functor, Charlist),
> + Temp = charlist_to_int(Charlist),
> + Y = Temp + univlist_to_int(ArgList).
> +
> +
> +:- func charlist_to_int(list(char)) = int.
> +:- mode charlist_to_int(in) = out is det.
> +charlist_to_int([]) = 0.
> +charlist_to_int([X|Xs]) = Y :-
> + char__to_int(X, X1),
> + Y = X1 * 10 + charlist_to_int(Xs).
> +
> +:- func univlist_to_int(list(univ)) = int.
> +:- mode univlist_to_int(in) = out is det.
> +univlist_to_int([]) = 0.
> +univlist_to_int([X|Xs]) = univ_to_int(X) + univlist_to_int(Xs).
> +
> +%---------------------------------------------------------------------------%
> +
> +to_trivial(Input, Pattern, Property0) = Property :-
> + (if Input = Pattern
> + then
> + Property = [trivial|Property0]
> + else
> + Property = Property0
> + ).
> +
> +Left `>>>` Right = Property :-
> + Property = [ info(univ(Left)) | Right].
> +
> +Left `===` Right = Property :-
> + (if Left = Right
> + then
> + Property = [yes]
> + else
> + Property = [no]
> + ).
> +
> +list_length(List) = list__length(List).
> +
> +oneof(Xs, RS0, RS) = Y :-
> + (if list__length(Xs) = 0
> + then
> + error("The input list should not be empty")
> + else
> + rnd__irange(1, list__length(Xs), Nth, RS0, RS),
> + index1_det(Xs, Nth, Y)
> + ).
> +
> +%---------------------------------------------------------------------------%
> +
> + % det_headlist/2 returns the first element of a list of lists, and the
> + % list of lists without the first element.
> + % If the input list is [], then return [] for both.
> +:- func det_headlist(list(list(T)), list(list(T))) = list(T).
> +:- mode det_headlist(in, out) = out is det.
> +det_headlist([], []) = [].
> +det_headlist([X|Xs], Xs) = X.
> +
> + % inin_setup/2 converts negative or zero seed to a positive, not-zero seed,
> + % because rnd__init/2 should not be called with negative or zero seed.
> +:- pred init_setup(int, rnd).
> +:- mode init_setup(in, out) is det.
> +init_setup(Seed, RS0) :-
> + (if Seed =< 0
> + then
> + rnd__init(Seed * -1 + 1, RS0)
> + else
> + rnd__init(Seed, RS0)
> + ).
> +
> + % display_univ/3 should will called with a univ of a tuple, it will then
> + % prints out the elements in that tuple.
s/prints/print/
> +:- pred display_univ(univ, io__state, io__state).
> +:- mode display_univ(in, di, uo) is det.
> +display_univ(Univ) -->
> + { Args = univ_value(Univ) },
> + { deconstruct(Args, _, _, Univs) },
> + display_univs(Univs).
> +
> + % display_univs prints the values which are stored in a list of univ.
> +:- pred display_univs(list(univ), io__state, io__state).
> +:- mode display_univs(in, di, uo) is det.
> +display_univs([], S, S).
> +display_univs([Univ|Univs]) -->
> + io__write(univ_value(Univ)),
> + io__nl,
> + display_univs(Univs).
> +
> +
> + % show_dist/3 prints out the distribution.
> +:- pred show_dist(list(distribution), io__state, io__state).
> +:- mode show_dist(in, di, uo) is det.
> +show_dist([], S, S).
> +show_dist([Dist|Dists]) -->
> + { Dist = {Univ, Freq} },
> + io__write_int(Freq),
> + io__write_string("\t"),
> + io__write(univ_value(Univ)),
> + io__nl,
> + show_dist(Dists).
> +
> +%---------------------------------------------------------------------------%
> +
> + % get_freq/5 works out what distribution to use at current level by looking
> + % at the SF and GF.
> +:- func get_freq(type_desc, int, int, list(frequency),
> + list({type_desc, list(frequency)})) = list({int, list(list(frequency))}).
> +:- mode get_freq(in, in, in, in, in) = out is det.
> +get_freq(Datatype, NumFunctors, Counter, Frequencys, GF) = List :-
> + (if NumFunctors = Counter
> + then
> + List = []
> + else
> + (if get_functor_ordinal(Datatype, Counter, Temp_Nth)
> + then
> + Real_Nth = Temp_Nth
> + else
> + error("sum_freq/6 : get_functor_ordinal/3 failed")
s/sum_freq/get_freq/
> + ),
> + test_freq(Datatype, NumFunctors, Real_Nth, LevelRequired0,
> + Frequencys, GF, SubBranch),
> + List0 = get_freq(Datatype, NumFunctors, Counter + 1, Frequencys, GF),
> + (if LevelRequired0 < 0
> + then
> + LevelRequired = 0
> + else
> + LevelRequired = LevelRequired0
> + ),
> + List = [{LevelRequired, SubBranch} | List0 ]
> + ).
> +
> +
> + % test_freq/7 extract the required_level and the frequency of
> + % sub-constructors by the following steps :
> + % 1 If Frequencys is non-empty, then there is specific frequency,
> + % so call freq_info/5 to get the infomation
> + % 2 If Frequencys is empty, then search for general frequency
> + % 3a If a match is found in general frequency, then restart test_freq
> + % with the general frequency for that type as the specific frequency
> + % 3b If no match is found, then apply default frequency
> +:- pred test_freq(type_desc, int, int, int, list(frequency), list({type_desc,
> + list(frequency)}), list(list(frequency))).
> +:- mode test_freq(in, in, in, out, in, in, out) is det.
> +test_freq(Datatype, NumFunctors, Nth, LevelRequired, Frequencys, GF, NewF) :-
> + (if list__length(Frequencys) = NumFunctors
> + then
> + freq_info(0, Nth, Frequencys, LevelRequired, NewF)
> + else if Frequencys = []
> + then
> + TempFreq = locate_general(Datatype, GF),
> + (if TempFreq = []
> + then
> + LevelRequired = 1,
> + NewF = []
> + else
> + test_freq(Datatype, NumFunctors, Nth,
> + LevelRequired, TempFreq, [], NewF)
> + )
> + else
> + error("test_freq/5 error: freqencys not match args \n")
> + ).
> +
> + % freq_info/5 extracts specifict frequency and its sub-constructor's
> + % frequency contained in the Nth element.
> + % The base case may be redundant, to cover [[]] case.
> + % freq_info/5 recursively increases the counter until it equals Nth,
> + % then get the info stored in Frequency.
> +:- pred freq_info(int, int, list(frequency), int, list(list(frequency))).
> +:- mode freq_info(in, in, in, out, out) is det.
> +freq_info(_, _, [], 100, []).
> +freq_info(Counter, Nth, [Frequency | Frequencys], LevelRequired, NewF) :-
> + (if Counter = Nth
> + then
> + Frequency = {LevelRequired, NewF}
> + else
> + freq_info(Counter + 1, Nth, Frequencys, LevelRequired, NewF)
> + ).
> +
> + % locate_general/2 passes through general frequency list, looking for
> + % matching type_desc, and return [] to indicate not found.
> +:- func locate_general(type_desc,
> + list({type_desc, list(frequency)})) = list(frequency).
> +:- mode locate_general(in, in) = out is det.
> +locate_general(_, []) = [].
> +locate_general(Datatype, [Info|Infos]) = Freq :-
> + Info = {Type, List_freq},
> + (if Datatype = Type
> + then
> + Freq = List_freq
> + else
> + Freq = locate_general(Datatype, Infos)
> + ).
> +
> + % freq_base/1 sums up all the relative frequency.
> +:- func freq_base( list({int, list(list(frequency))}) ) = int.
> +:- mode freq_base(in) = out is det.
> +freq_base([]) = 0.
> +freq_base([X | Xs]) = Int + freq_base(Xs) :-
> + X = {Int, _}.
> +
> + % select_branch/4 selects a branch when the Selector is within
> + % that branch's range.
> +:- func select_branch(int, int, int, list({int, list(list(frequency))}) )
> + = { int, list(list(frequency)) }.
> +:- mode select_branch(in, in, in, in) = out is det.
> +select_branch(_, _, _, []) = _ :-
> + error("select_branch/4 : no branch to select").
> +select_branch(Selector, Counter, Branch0, [TempFreq | TempFreqs]) = { Branch, SubFreq } :-
> + TempFreq = { Relative, SubBranch },
> + (if Counter + Relative > Selector
> + then
> + Branch = Branch0,
> + SubFreq = SubBranch
> + else
> + { Branch, SubFreq } = select_branch(Selector, Counter + Relative,
> + Branch0 + 1, TempFreqs)
> + ).
> +
> + % find_user_gen/3 pass through the generator list, looking for matching
> + % type_desc. If it's found, then return the generating function, else this
> + % predicate will fail.
> +:- pred find_user_gen(type_desc, list(user_gen_type),
> + func(type_desc, list(frequency),
> + list({type_desc, list(frequency)}),
> + list(user_gen_type), rnd, rnd)=univ).
> +:- mode find_user_gen(in, list_skel_in(user_gen_inst),
> + out(func(in, in, in, list_skel_in(user_gen_inst),
> + in, out) = out is det) ) is semidet.
> +find_user_gen(Datatype, [UserGenerator | UserGenerators], Generator) :-
> + UserGenerator = {Type, TempGenerator},
> + (if Datatype = Type
> + then
> + Generator = TempGenerator
> + else
> + find_user_gen(Datatype, UserGenerators, Generator)
> + ).
> +
> +:- func rev_field(list({T1, T2})) = list({T2, T1}).
> +:- mode rev_field(in) = out is det.
> +rev_field([]) = [].
> +rev_field([{A, B} | Xs]) = [{B, A} | rev_field(Xs) ].
> +
> +:- func (const_million) = int.
> +:- mode (const_million) = out is det.
> +(const_million) = 1000000.
> +
> +
> +%---------------------------------------------------------------------------%
> +%---------------------------------------------------------------------------%
> +
> +:- end_module qcheck.
> +
I haven't reviewed the rnd module.
> Index: mercury/extras/quickcheck/rnd.m
> ===================================================================
> RCS file: rnd.m
> diff -N rnd.m
> --- /dev/null Wed Nov 15 09:24:47 2000
> +++ rnd.m Thu Feb 15 13:14:26 2001
> @@ -0,0 +1,607 @@
> +%---------------------------------------------------------------------------%
> +% file: rnd.m
> +% main author: conway.
> +%
> +% This pseudo-random number generator is derived from C source due to
> +% George Marsaglia geo at stat.fsu.edu.
> +%
> +% The original source is included at the end of the module as a reference.
> +%
> +%---------------------------------------------------------------------------%
> +
> +:- module rnd.
> +
> +:- interface.
> +
> +:- import_module float, int, list, std_util.
> +
> +:- type rnd.
> +
> + % initialize a random number supply
> +:- pred rnd__init(int, rnd).
> +:- mode rnd__init(in, out) is det.
> +
> + % get a random float on the range [0, 1)
> +:- pred rnd(float, rnd, rnd).
> +:- mode rnd(out, in, out) is det.
> +
> + % get a random int on the range [Lower, Upper]
> +:- pred irange(int, int, int, rnd, rnd).
> +:- mode irange(in, in, out, in, out) is det.
> +
> + % get a random float on the range [Lower, Upper)
> +:- pred frange(float, float, float, rnd, rnd).
> +:- mode frange(in, in, out, in, out) is det.
> +
> + % generate a random permutation of a list
> +:- pred shuffle(list(T), list(T), rnd, rnd).
> +:- mode shuffle(in, out, in, out) is det.
> +
> + % get a random element of a list.
> +:- pred oneof(list(T), T, rnd, rnd).
> +:- mode oneof(in, out, in, out) is det.
> +
> + % get a random element of a weighted list.
> +:- pred wghtd_oneof(list(pair(int, T)), T, rnd, rnd).
> +:- mode wghtd_oneof(in, out, in, out) is det.
> +
> + % gaussian(X, Y, Rnd0, Rnd)
> + % generate a pair of gaussian deviates `X' and `Y'.
> +:- pred gaussian(float, float, rnd, rnd).
> +:- mode gaussian(out, out, in, out) is det.
> +
> +%---------------------------------------------------------------------------%
> +
> +:- implementation.
> +
> +:- import_module math, require.
> +
> +irange(Min, Max, Val, R0, R) :-
> + frange(rfloat(Min), rfloat(Max+1), FVal, R0, R),
> + Val = rint(FVal).
> +
> +frange(Min, Max, Val, R0, R) :-
> + rnd(J, R0, R),
> + Val = J*(Max - Min)+Min.
> +
> +shuffle(Ins, Outs, R0, R) :-
> + list__length(Ins, N),
> + shuffle2(N, Ins, [], T0, R0, R1),
> + shuffle2(N, T0, [], T1, R1, R2),
> + shuffle2(N, T1, [], T2, R2, R3),
> + shuffle2(N, T2, [], T3, R3, R4),
> + shuffle2(N, T3, [], U, R4, R5),
> + shuffle2(N, U, [], Outs, R5, R).
> +
> +:- pred shuffle2(int, list(T), list(T), list(T), rnd, rnd).
> +:- mode shuffle2(in, in, in, out, in, out) is det.
> +
> +shuffle2(N, Ins, Acc0, Acc, R0, R) :-
> + ( N > 0 ->
> + irange(0, N-1, J, R0, R1),
> + delnth(Ins, J, Rest, T),
> + shuffle2(N-1, Rest, [T|Acc0], Acc, R1, R)
> + ;
> + Acc = Acc0,
> + R = R0
> + ).
> +
> +:- pred delnth(list(T), int, list(T), T).
> +:- mode delnth(in, in, out, out) is det.
> +
> +delnth([], _, _, _) :-
> + error("delnth: no enough elems!").
> +delnth([X|Xs], N, Zs, Z) :-
> + ( N =< 0 ->
> + Z = X,
> + Zs = Xs
> + ;
> + Zs = [X|Ys],
> + delnth(Xs, N-1, Ys, Z)
> + ).
> +
> +oneof(Things, Thing, R0, R) :-
> + list__length(Things, Num),
> + irange(0, Num-1, X, R0, R),
> + list__index0_det(Things, X, Thing).
> +
> +wghtd_oneof(WghtdThings, Thing, R0, R) :-
> + cumu(WghtdThings, 0, Sum),
> + irange(0, Sum, X, R0, R),
> + pick(WghtdThings, X, Thing).
> +
> +:- pred cumu(list(pair(int, T)), int, int).
> +:- mode cumu(in, in, out) is det.
> +
> +cumu([], Sum, Sum).
> +cumu([X - _T|Rest0], Sum, Sum1) :-
> + cumu(Rest0, X+Sum, Sum1).
> +
> +:- pred pick(list(pair(int, T)), int, T).
> +:- mode pick(in, in, out) is det.
> +
> +pick([], _, _) :-
> + error("pick: no things to pick from!").
> +pick([N - T|Rest], P, Thing) :-
> + ( N >= P ->
> + Thing = T
> + ;
> + pick(Rest, P - N, Thing)
> + ).
> +
> +gaussian(X, Y, Rnd0, Rnd) :-
> + frange(-1.0, 1.0, V1, Rnd0, Rnd1),
> + frange(-1.0, 1.0, V2, Rnd1, Rnd2),
> + R = V1*V1 + V2*V2,
> + ( R >= 1.0, R \= 0.0 ->
> + gaussian(X, Y, Rnd2, Rnd)
> + ;
> + Fac = sqrt(-2.0 * ln(R) / R),
> + X = V1 * Fac,
> + Y = V2 * Fac,
> + Rnd = Rnd2
> + ).
> +
> +%---------------------------------------------------------------------------%
> +
> +:- type vec
> + ---> vec(int, int, int, int, int, int, int, int, int, int).
> +
> +:- type rnd
> + ---> rnd(
> + vec,
> + vec,
> + int
> + ).
> +
> +rnd__init(Seed, rnd(M1, M2, Seed)) :-
> + SN = Seed /\ ((1 << 15) - 1),
> + N = Seed /\ ((1 << 30) - 1),
> + M1a = vec(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
> + M2a = vec(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
> + seed1(17, SN, N, M1a, M2a, M1b, M2b),
> + set(M1b, 0, (M1b ** 0) /\ ((1 << 15) - 1), M1),
> + set(M2b, 0, (M2b ** 0) /\ ((1 << 15) - 1), M2).
> +
> +:- pred seed1(int, int, int, vec, vec, vec, vec).
> +:- mode seed1(in, in, in, in, in, out, out) is det.
> +
> +seed1(N, SNum0, Num0, M1a, M2a, M1, M2) :-
> + (N > 0 ->
> + Num1 = 30903 * SNum0 + (Num0 >> 15),
> + SNum1 = Num1 /\ ((1 << 15) - 1),
> + ( N >= 9 ->
> + M2b = M2a,
> + set(M1a, 17 - N, SNum1, M1b)
> + ;
> + M1b = M1a,
> + set(M2a, 8 - N, SNum1, M2b)
> + ),
> + seed1(N-1, SNum1, Num1, M1b, M2b, M1, M2)
> + ;
> + M1 = M1a,
> + M2 = M2a
> + ).
> +
> +rnd(Res, rnd(M1a, M2a, _Seed0), rnd(M1d, M2d, Seed1)) :-
> + shift(M1a, M1b),
> + shift(M2a, M2b),
> + N1a = (M1b ** 0),
> + N2a = (M2b ** 0),
> +
> + N1b = N1a + 1941 * (M1b ** 2) + 1860 * (M1b ** 3) + 1812 * (M1b ** 4)
> + + 1776 * (M1b ** 5) + 1492 * (M1b ** 6) + 1215 * (M1b ** 7)
> + + 1066 * (M1b ** 8) + 12013 * (M1b ** 9),
> +
> + N2b = N2a + 1111 * (M2b ** 2) + 2222 * (M2b ** 3) + 3333 * (M2b ** 4)
> + + 4444 * (M2b ** 5) + 5555 * (M2b ** 6) + 6666 * (M2b ** 7)
> + + 7777 * (M2b ** 8) + 9272 * (M2b ** 9),
> +
> + set(M1b, 0, (N1b >> 15) /\ ((1 << 15) - 1), M1c),
> + set(M2b, 0, (N2b >> 15) /\ ((1 << 15) - 1), M2c),
> +
> + set(M1c, 1, N1b /\ ((1 << 15) - 1), M1d),
> + set(M2c, 1, N2b /\ ((1 << 15) - 1), M2d),
> +
> + Seed1 = ((M1d ** 1) << 15) + (M2d ** 1),
> +
> + Res = rfloat(Seed1)/rfloat((1 << 30) - 1).
> +
> +:- pred shift(vec, vec).
> +:- mode shift(in, out) is det.
> +
> +shift(Vec0, Vec1) :-
> + Vec0 = vec(A, B, C, D, E, F, G, H, I, _),
> + Vec1 = vec(A, B, B, C, D, E, F, G, H, I).
> +
> +%---------------------------------------------------------------------------%
> +
> +:- func (vec ** int) = int.
> +:- mode ((in ** in) = out) is det.
> +:- mode ((in ** in(bound(0))) = out) is det.
> +:- mode ((in ** in(bound(1))) = out) is det.
> +:- mode ((in ** in(bound(2))) = out) is det.
> +:- mode ((in ** in(bound(3))) = out) is det.
> +:- mode ((in ** in(bound(4))) = out) is det.
> +:- mode ((in ** in(bound(5))) = out) is det.
> +:- mode ((in ** in(bound(6))) = out) is det.
> +:- mode ((in ** in(bound(7))) = out) is det.
> +:- mode ((in ** in(bound(8))) = out) is det.
> +:- mode ((in ** in(bound(9))) = out) is det.
> +
> +( Vec ** Ind ) = Res :-
> + Vec = vec(A, B, C, D, E, F, G, H, I, J),
> + (
> + ( Ind = 0, Res0 = A
> + ; Ind = 1, Res0 = B
> + ; Ind = 2, Res0 = C
> + ; Ind = 3, Res0 = D
> + ; Ind = 4, Res0 = E
> + ; Ind = 5, Res0 = F
> + ; Ind = 6, Res0 = G
> + ; Ind = 7, Res0 = H
> + ; Ind = 8, Res0 = I
> + ; Ind = 9, Res0 = J
> + )
> + ->
> + Res = Res0
> + ;
> + error("**: out of range")
> + ).
> +
> +:- pred set(vec, int, int, vec).
> +:- mode set(in, in, in, out) is det.
> +:- mode set(in, in(bound(0)), in, out) is det.
> +:- mode set(in, in(bound(1)), in, out) is det.
> +:- mode set(in, in(bound(2)), in, out) is det.
> +:- mode set(in, in(bound(3)), in, out) is det.
> +:- mode set(in, in(bound(4)), in, out) is det.
> +:- mode set(in, in(bound(5)), in, out) is det.
> +:- mode set(in, in(bound(6)), in, out) is det.
> +:- mode set(in, in(bound(7)), in, out) is det.
> +:- mode set(in, in(bound(8)), in, out) is det.
> +:- mode set(in, in(bound(9)), in, out) is det.
> +
> +set(Vec0, Ind, V, Vec) :-
> + Vec0 = vec(A, B, C, D, E, F, G, H, I, J),
> + (
> + ( Ind = 0, Vec1 = vec(V, B, C, D, E, F, G, H, I, J)
> + ; Ind = 1, Vec1 = vec(A, V, C, D, E, F, G, H, I, J)
> + ; Ind = 2, Vec1 = vec(A, B, V, D, E, F, G, H, I, J)
> + ; Ind = 3, Vec1 = vec(A, B, C, V, E, F, G, H, I, J)
> + ; Ind = 4, Vec1 = vec(A, B, C, D, V, F, G, H, I, J)
> + ; Ind = 5, Vec1 = vec(A, B, C, D, E, V, G, H, I, J)
> + ; Ind = 6, Vec1 = vec(A, B, C, D, E, F, V, H, I, J)
> + ; Ind = 7, Vec1 = vec(A, B, C, D, E, F, G, V, I, J)
> + ; Ind = 8, Vec1 = vec(A, B, C, D, E, F, G, H, V, J)
> + ; Ind = 9, Vec1 = vec(A, B, C, D, E, F, G, H, I, V)
> + )
> + ->
> + Vec = Vec1
> + ;
> + error("set: out of range")
> + ).
> +
> +%---------------------------------------------------------------------------%
> +
> +:- func rfloat(int) = float.
> +:- pragma c_code(rfloat(I::in) = (F::out), "F = I;").
> +
> +:- func rint(float) = int.
> +:- pragma c_code(rint(F::in) = (I::out), "I = F;").
> +
> +%---------------------------------------------------------------------------%
> +%
> +%/*
> +%
> +%Article: 16024 of sci.math.num-analysis
> +%Xref: taurus.cs.nps.navy.mil sci.stat.consult:7790 sci.math.num-analysis:16024
> +%Path: taurus.cs.nps.navy.mil!lll-winken.llnl.gov!uwm.edu!news.alpha.net!news.mathworks.com!udel!ssnet.com!usenet
> +%From: Bob Wheeler <bwheeler at ssnet.com>
> +%Newsgroups: sci.stat.consult,sci.math.num-analysis
> +%Subject: Marsaglia's Mother of all RNG's (Long?)
> +%Date: Fri, 28 Oct 94 19:32:08 EDT
> +%Organization: SSNet -- Public Internet Access in Delaware!
> +%Lines: 285
> +%Distribution: inet
> +%Message-ID: <38s2p1$qaf at marlin.ssnet.com>
> +%NNTP-Posting-Host: echip.com
> +%Mime-Version: 1.0
> +%Content-Type: TEXT/PLAIN; charset=US-ASCII
> +%X-Newsreader: NEWTNews & Chameleon -- TCP/IP for MS Windows from NetManage
> +%
> +%
> +%Several people have asked me to post this:
> +%First the C program, then George Marsaliga's post with details
> +%about the RNG. He claims a period of about 2^250 for this and
> +%that it passes all of the usual tests. I've tried it enough
> +%to be sure his claim is reasonable.
> +%
> +%The program:
> +%
> +%*/
> +%
> +%
> +%#include <string.h>
> +%
> +%static short mother1[10];
> +%static short mother2[10];
> +%static short mStart=1;
> +%
> +%#define m16Long 65536L /* 2^16 */
> +%#define m16Mask 0xFFFF /* mask for lower 16 bits */
> +%#define m15Mask 0x7FFF /* mask for lower 15 bits */
> +%#define m31Mask 0x7FFFFFFF /* mask for 31 bits */
> +%#define m32Double 4294967295.0 /* 2^32-1 */
> +%
> +%/* Mother **************************************************************
> +%| George Marsaglia's The mother of all random number generators
> +%| producing uniformly distributed pseudo random 32 bit values
> +%with
> +%| period about 2^250.
> +%| The text of Marsaglia's posting is appended at the end of the function.
> +%|
> +%| The arrays mother1 and mother2 store carry values in their
> +%| first element, and random 16 bit numbers in elements 1 to 8.
> +%| These random numbers are moved to elements 2 to 9 and a new
> +%| carry and number are generated and placed in elements 0 and 1.
> +%| The arrays mother1 and mother2 are filled with random 16 bit values
> +%| on first call of Mother by another generator. mStart is the
> +%switch.
> +%|
> +%| Returns:
> +%| A 32 bit random number is obtained by combining the output of the
> +%| two generators and returned in *pSeed. It is also scaled by
> +%| 2^32-1 and returned as a double between 0 and 1
> +%|
> +%| SEED:
> +%| The inital value of *pSeed may be any long value
> +%|
> +%| Bob Wheeler 8/8/94
> +%*/
> +%
> +%
> +%double Mother(unsigned long *pSeed)
> +%{
> +% unsigned long number,
> +% number1,
> +% number2;
> +% short n,
> +% *p;
> +% unsigned short sNumber;
> +%
> +% /* Initialize motheri with 9 random values the first time */
> +% if (mStart) {
> +% sNumber= *pSeed&m16Mask; /* The low 16 bits */
> +% number= *pSeed&m31Mask; /* Only want 31 bits */
> +%
> +% p=mother1;
> +% for (n=18;n--;) {
> +% number=30903*sNumber+(number>>16); /* One line
> +%multiply-with-cary */
> +% *p++=sNumber=number&m16Mask;
> +% if (n==9)
> +% p=mother2;
> +% }
> +% /* make cary 15 bits */
> +% mother1[0]&=m15Mask;
> +% mother2[0]&=m15Mask;
> +% mStart=0;
> +% }
> +%
> +% /* Move elements 1 to 8 to 2 to 9 */
> +% memmove(mother1+2,mother1+1,8*sizeof(short));
> +% memmove(mother2+2,mother2+1,8*sizeof(short));
> +%
> +% /* Put the carry values in numberi */
> +% number1=mother1[0];
> +% number2=mother2[0];
> +%
> +% /* Form the linear combinations */
> +%
> +%number1+=1941*mother1[2]+1860*mother1[3]+1812*mother1[4]+1776*mother1[5]+
> +%
> +%1492*mother1[6]+1215*mother1[7]+1066*mother1[8]+12013*mother1[9];
> +%
> +%number2+=1111*mother2[2]+2222*mother2[3]+3333*mother2[4]+4444*mother2[5]+
> +%
> +%5555*mother2[6]+6666*mother2[7]+7777*mother2[8]+9272*mother2[9];
> +%
> +% /* Save the high bits of numberi as the new carry */
> +% mother1[0]=number1/m16Long;
> +% mother2[0]=number2/m16Long;
> +% /* Put the low bits of numberi into motheri[1] */
> +% mother1[1]=m16Mask&number1;
> +% mother2[1]=m16Mask&number2;
> +%
> +% /* Combine the two 16 bit random numbers into one 32 bit */
> +% *pSeed=(((long)mother1[1])<<16)+(long)mother2[1];
> +%
> +% /* Return a double value between 0 and 1 */
> +% return ((double)*pSeed)/m32Double;
> +%}
> +%
> +%
> +%
> +%/*
> +%
> +%*********************
> +%Marsaglia's comments
> +%
> +% Yet another RNG
> +%Random number generators are frequently posted on
> +%the network; my colleagues and I posted ULTRA in
> +%1992 and, from the number of requests for releases
> +%to use it in software packages, it seems to be
> +%widely used.
> +%
> +%I have long been interested in RNG's and several
> +%of my early ones are used as system generators or
> +%in statistical packages.
> +%
> +%So why another one? And why here?
> +%
> +%Because I want to describe a generator, or
> +%rather, a class of generators, so promising
> +%I am inclined to call it
> +%
> +% The Mother of All Random Number Generators
> +%
> +%and because the generator seems promising enough
> +%to justify shortcutting the many months, even
> +%years, before new developments are widely
> +%known through publication in a journal.
> +%
> +%This new class leads to simple, fast programs that
> +%produce sequences with very long periods. They
> +%use multiplication, which experience has shown
> +%does a better job of mixing bits than do +,- or
> +%exclusive-or, and they do it with easily-
> +%implemented arithmetic modulo a power of 2, unlike
> +%arithmetic modulo a prime. The latter, while
> +%satisfactory, is difficult to implement. But the
> +%arithmetic here modulo 2^16 or 2^32 does not suffer
> +%the flaws of ordinary congruential generators for
> +%those moduli: trailing bits too regular. On the
> +%contrary, all bits of the integers produced by
> +%this new method, whether leading or trailing, have
> +%passed extensive tests of randomness.
> +%
> +%Here is an idea of how it works, using, say, integers
> +%of six decimal digits from which we return random 3-
> +%digit integers. Start with n=123456, the seed.
> +%
> +%Then form a new n=672*456+123=306555 and return 555.
> +%Then form a new n=672*555+306=373266 and return 266.
> +%Then form a new n=672*266+373=179125 and return 125,
> +%
> +%and so on. Got it? This is a multiply-with-carry
> +%sequence x(n)=672*x(n-1)+ carry mod b=1000, where
> +%the carry is the number of b's dropped in the
> +%modular reduction. The resulting sequence of 3-
> +%digit x's has period 335,999. Try it.
> +%
> +%No big deal, but that's just an example to give
> +%the idea. Now consider the sequence of 16-bit
> +%integers produced by the two C statements:
> +%
> +%k=30903*(k&65535)+(k>>16); return(k&65535);
> +%
> +%Notice that it is doing just what we did in the
> +%example: multiply the bottom half (by 30903,
> +%carefully chosen), add the top half and return the
> +%new bottom.
> +%
> +%That will produce a sequence of 16-bit integers
> +%with period > 2^29, and if we concatenate two
> +%such:
> +% k=30903*(k&65535)+(k>>16);
> +% j=18000*(j&65535)+(j>>16);
> +% return((k<<16)+j);
> +%we get a sequence of more than 2^59 32-bit integers
> +%before cycling.
> +%
> +%The following segment in a (properly initialized)
> +%C procedure will generate more than 2^118
> +%32-bit random integers from six random seed values
> +%i,j,k,l,m,n:
> +% k=30903*(k&65535)+(k>>16);
> +% j=18000*(j&65535)+(j>>16);
> +% i=29013*(i&65535)+(i>>16);
> +% l=30345*(l&65535)+(l>>16);
> +% m=30903*(m&65535)+(m>>16);
> +% n=31083*(n&65535)+(n>>16);
> +% return((k+i+m)>>16)+j+l+n);
> +%
> +%And it will do it much faster than any of several
> +%widely used generators designed to use 16-bit
> +%integer arithmetic, such as that of Wichman-Hill
> +%that combines congruential sequences for three
> +%15-bit primes (Applied Statistics, v31, p188-190,
> +%1982), period about 2^42.
> +%
> +%I call these multiply-with-carry generators. Here
> +%is an extravagant 16-bit example that is easily
> +%implemented in C or Fortran. It does such a
> +%thorough job of mixing the bits of the previous
> +%eight values that it is difficult to imagine a
> +%test of randomness it could not pass:
> +%
> +%x[n]=12013x[n-8]+1066x[n-7]+1215x[n-6]+1492x[n-5]+1776x[n-4]
> +% +1812x[n-3]+1860x[n-2]+1941x[n-1]+carry mod 2^16.
> +%
> +%The linear combination occupies at most 31 bits of
> +%a 32-bit integer. The bottom 16 is the output, the
> +%top 15 the next carry. It is probably best to
> +%implement with 8 case segments. It takes 8
> +%microseconds on my PC. Of course it just provides
> +%16-bit random integers, but awfully good ones. For
> +%32 bits you would have to combine it with another,
> +%such as
> +%
> +%x[n]=9272x[n-8]+7777x[n-7]+6666x[n-6]+5555x[n-5]+4444x[n-4]
> +% +3333x[n-3]+2222x[n-2]+1111x[n-1]+carry mod 2^16.
> +%
> +%Concatenating those two gives a sequence of 32-bit
> +%random integers (from 16 random 16-bit seeds),
> +%period about 2^250. It is so awesome it may merit
> +%the Mother of All RNG's title.
> +%
> +%The coefficients in those two linear combinations
> +%suggest that it is easy to get long-period
> +%sequences, and that is true. The result is due to
> +%Cemal Kac, who extended the theory we gave for
> +%add-with-carry sequences: Choose a base b and give
> +%r seed values x[1],...,x[r] and an initial 'carry'
> +%c. Then the multiply-with-carry sequence
> +%
> +% x[n]=a1*x[n-1]+a2*x[n-2]+...+ar*x[n-r]+carry mod b,
> +%
> +%where the new carry is the number of b's dropped
> +%in the modular reduction, will have period the
> +%order of b in the group of residues relatively
> +%prime to m=ar*b^r+...+a1b^1-1. Furthermore, the
> +%x's are, in reverse order, the digits in the
> +%expansion of k/m to the base b, for some 0<k<m.
> +%
> +%In practice b=2^16 or b=2^32 allows the new
> +%integer and the new carry to be the bottom and top
> +%half of a 32- or 64-bit linear combination of 16-
> +%or 32-bit integers. And it is easy to find
> +%suitable m's if you have a primality test: just
> +%search through candidate coefficients until you
> +%get an m that is a safeprime---both m and (m-1)/2
> +%are prime. Then the period of the multiply-with-
> +%carry sequence will be the prime (m-1)/2. (It
> +%can't be m-1 because b=2^16 or 2^32 is a square.)
> +%
> +%Here is an interesting simple MWC generator with
> +%period> 2^92, for 32-bit arithmetic:
> +%
> +%x[n]=1111111464*(x[n-1]+x[n-2]) + carry mod 2^32.
> +%
> +%Suppose you have functions, say top() and bot(),
> +%that give the top and bottom halves of a 64-bit
> +%result. Then, with initial 32-bit x, y and carry
> +%c, simple statements such as
> +% y=bot(1111111464*(x+y)+c)
> +% x=y
> +% c=top(y)
> +%will, repeated, give over 2^92 random 32-bit y's.
> +%
> +%Not many machines have 64 bit integers yet. But
> +%most assemblers for modern CPU's permit access to
> +%the top and bottom halves of a 64-bit product.
> +%
> +%I don't know how to readily access the top half of
> +%a 64-bit product in C. Can anyone suggest how it
> +%might be done? (in integer arithmetic)
> +%
> +%George Marsaglia geo at stat.fsu.edu
> +%
> +%*/
> +%
> +%
> +%
> +%
> +%
>
>
> --------------------------------------------------------------------------
> mercury-developers mailing list
> Post messages to: mercury-developers at cs.mu.oz.au
> Administrative Queries: owner-mercury-developers at cs.mu.oz.au
> Subscriptions: mercury-developers-request at cs.mu.oz.au
> --------------------------------------------------------------------------
>
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list