[m-dev.] for review : quickcheck
Xiao Chun Simon MEI
xcsm at students.cs.mu.oz.au
Sat Feb 24 04:28:38 AEDT 2001
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
+ % 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,
+ % 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
+ % 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
+ % 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 },
+ { 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)),
+ 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
+
+
+:- 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.
+:- 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)
+ 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),
+ 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.
+:- 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")
+ ),
+ 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.
+
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
--------------------------------------------------------------------------
More information about the developers
mailing list