[m-dev.] for review : quickcheck
Xiao Chun Simon MEI
xcsm at students.cs.mu.oz.au
Fri Feb 9 15:09:45 AEDT 2001
Estimated hours taken : 150
an autotesting tool similar to Haskell's QuickCheck
quickcheck/qcheck.m
source code qcheck
Index: quickcheck/qcheck.m
===================================================================
RCS file: qcheck.m
diff -N qcheck.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ qcheck.m Fri Feb 9 15:02:04 2001
@@ -0,0 +1,1352 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1994-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
+%
+% source code for autotest generator similar to Haskell's quickcheck
+%
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- module qcheck.
+
+:- interface.
+:- import_module io, std_util, list, bool, char, float, string.
+:- import_module rnd.
+
+%---------------------------------------------------------------------------%
+
+ % invariant test function must return a property
+ % to indicate the result of invariant funtion
+ % yes : success
+ % no : fail
+ % trivial : mark the property being returned by a trivial test
+ % info(univ) : store some arbitrary information in type univ,
+ % condition : mark the property being retured by a test which failed
+ % the pre-conditional
+:- type property == list(flag).
+
+:- type flag
+ ---> yes
+ ; no
+ ; trivial
+ ; info(univ)
+ ; condition.
+
+ % univ : value of data
+ % int : counter
+:- type distribution
+ ---> {univ, int}.
+
+ % result compose of
+ % property : returned by invariant test function
+ % univ : store the arguments generated for invariant test function
+:- type result
+ ---> result(property, univ).
+
+ % 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
+ % 70% chance of being tail
+ % for type color : there is 40% chance of being black
+ % 60% chance of bing white
+:- type frequency
+ ---> {int, list(list(frequency))}.
+
+ % format for each of user-defined generator
+ % test_desc : type_of the variable which this generator is
+ % suppose to handle
+ % func/6 : required function interface
+ % must take 6 argument and return a univ
+:- type user_gen_type
+ ---> { type_desc,
+ func(type_desc, list(frequency),
+ list({type_desc, list(frequency)}),
+ list(user_gen_type), rnd, rnd) = univ
+ }.
+
+ % inst declaration 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
+ }).
+
+%---------------------------------------------------------------------------%
+
+ % typeclass testable
+ % currenly only implemented instances for function
+ % with 0 to 4 arguments and return type 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)).
+
+%---------------------------------------------------------------------------%
+
+ % by conway
+ % use bit supply to generate some types
+ % provides better distribution/randomness
+ % currently only 1 instance is defined
+ % may remove this typeclass to just a function
+:- typeclass bitSupply(B) where [
+ (pred next(int, int, B, B)),
+ (mode next(in, out, in, out) is det)
+].
+
+:- instance bitSupply(rnd).
+
+%---------------------------------------------------------------------------%
+
+ % qcheck is overloaded (sort of)
+ % qcheck/4(A, N, F, G) = qcheck/8(A,N,100,[],[],[],F,G)
+ % qcheck/7(A, N, B, C, D, F, G) = qcheck/8(A,N,B, C, D, [],F,G)
+ % qcheck/8(A, N, B, C, D, E, F, G)
+ % A : invariant test function, satisfing testable(T)
+ % B : number of tests to run
+ % C : specific frequency
+ % D : general frequency
+ % E : list of user-defined generator
+ % F : io__state in
+ % G : io__state out
+ % N : some test description
+:- 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.
+
+%---------------------------------------------------------------------------%
+
+ % refer to tutorials for detail about the following generator
+:- func rand_int(rnd, rnd) = int.
+:- mode rand_int(in, out) = out is det.
+
+:- func rand_allint(rnd, rnd) = int.
+:- mode rand_allint(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.
+
+ % generate a discriminated union
+ % 1 determine which contructor of discriminated union to generate
+ % 2 extract the its frequency, (ie: level_required)
+ % 3 compare the frequency to an random int,
+ % 4 if fail, restart rand_union()
+ % 5 if pass, generate the ArgList for the particular
+ % constructor
+ % 6 call construct()
+:- 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.
+
+ % generate a random function with types described in type_desc
+ % forward mode only
+:- func rand_function(type_desc, rnd, rnd) = univ.
+:- mode rand_function(in, in, out) = out is det.
+
+ % 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 it's argument's
+ % type and value where the argument can be of anytype.
+:- func any_to_int(int, T) = int.
+:- mode any_to_int(in, in) = out is det.
+
+ % value_int/1 produce an int that is dependent on it's argument's
+ % type and value where the argument can be of anytype.
+:- func value_int(T) = int.
+:- mode value_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.
+
+ % X `===` Y
+ % if X equals Y , retures property:[yes]
+ % else property:[no]
+:- func T `===` T = property.
+:- mode in `===` in = out is det.
+
+ % same as function version of list__length
+ % list__length has two version; func & pred
+ % the output of this function could be passed
+ % to `>>>`/2 . list__length() is
+ % overloaded, there are two possible return types
+ % But `>>>`/2 takes type T as its 1st argument, thus
+ % the complier doesn't know which version of list__length
+ % to use.
+:- func list_length(list(T)) = int.
+:- mode list_length(in) = out is det.
+
+ % if left argument is bool:yes or (pred):succeed
+ % insert the condiont flag into right argument(a list of flags)
+ % other wise, return the original list
+:- typeclass conditional(T) where [
+ ( func T `===>` property = property ),
+ ( mode in `===>` in = out is det )
+].
+
+:- instance conditional(bool).
+:- instance conditional((pred)).
+
+%---------------------------------------------------------------------------%
+
+:- 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, []).
+
+ % 1 seed the random number on localtime
+ % 2 generate + run the test
+ % 3 print the result
+qcheck(TestFunction,Name, Counter,SpecificFrequency,
+ GeneralFrequency,Generators) -->
+ time__time(Sometime),
+ { tm(Seconds, Minutes, Hours, _Weekday, _Yearday, _Month, _Year, _DST)
+ = time__localtime(Sometime) },
+ { init_setup(Seconds + Minutes * Hours, RS0) },
+ testing(TestFunction, Name, SpecificFrequency, GeneralFrequency,
+ Generators,
+ RS0, _, Counter, Yes, No, Trivial, Distributions, Condition),
+ (if { No = 1 }
+ then
+ { true }
+ else
+ io__write_string("\nTest Description : "),
+ io__write_string(Name),
+ io__write_string("\nNumber of test cases that succeeded : "),
+ io__write_int(Yes),
+ io__write_string("\nNumber of trivial tests : "),
+ io__write_int(Trivial),
+ io__write_string("\nNumber of tests cases "),
+ io__write_string("which failed the pre-condition : "),
+ io__write_int(Condition),
+ io__write_string("\nDistributions of selected argument(s) : \n"),
+ { distribution_sort(Distributions, Distributions_Sorted) },
+ show_dist(Distributions_Sorted),
+ io__nl
+ ).
+
+
+%---------------------------------------------------------------------------%
+
+ % recursively run the test until counter drops to 0
+ % after each test update the
+ % statistics (ie: yes, no, trivial distribution)
+:- pred testing(T, string, list(list(frequency)), list({type_desc,
+ list(frequency)}),
+ list(user_gen_type), rnd, rnd, int, int, int, 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, Counter, Yes, No, Trivial, Distribution, Condition, S0, S) :-
+ (if Counter =< 0
+ then Yes = 0,
+ No = 0,
+ Trivial = 0,
+ Distribution = [],
+ Condition = 0,
+ RS = RS0,
+ S = S0
+ else testing2(TestFunction, SpecificFrequency, GeneralFrequency,
+ Generators, RS0, RS1, Result),
+ 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,
+ Yes = 0,
+ No = 1,
+ Trivial = 0,
+ Distribution = [],
+ Condition = 0
+ else
+ testing(TestFunction, Name, SpecificFrequency,
+ GeneralFrequency,
+ Generators, RS1, RS, Counter - 1, Yes0, No0,
+ Trivial0,
+ Distribution0, Condition0, S0, S),
+ update(P, Yes0, No0, Trivial0,
+ Distribution0, Condition0,
+ Yes, No, Trivial, Distribution, Condition)
+ )
+ ),
+ (if No >= 2
+ then
+ error("testing error No must be 0 or 1")
+ else
+ true
+ ).
+
+ % analyse the current invariant test result, update
+ % the statistic accordingly
+:- pred update(property, int, int, int, list(distribution), int,
+ int, int, int, list(distribution), int).
+:- mode update(in, in, in, in, in, in, out, out, out, out, out) is det.
+update(P, Yes0, No0, Trivial0, Distribution0, Condition0,
+ Yes, No, Trivial, Distribution, Condition) :-
+ (if member(condition, P)
+ then
+ Yes = Yes0,
+ No = No0,
+ Trivial = Trivial0,
+ Distribution = Distribution0,
+ Condition = Condition0 + 1
+ else
+ update_trivial(P, Trivial0, Trivial),
+ update_dist(P, Distribution0, Distribution),
+ update_yes_no(P, Yes0, Yes, No0, No),
+ Condition = Condition0
+ ).
+
+:- pred update_trivial(property, int, int).
+:- mode update_trivial(in, in, out) is det.
+update_trivial(P, Trivial0, Trivial) :-
+ (if member(trivial, P)
+ then
+ Trivial = Trivial0 + 1
+ else
+ Trivial = Trivial0
+ ).
+
+:- 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_dist2(Univ, Distribution0, Distribution1)
+ else
+ Distribution1 = Distribution0
+ ),
+ update_dist(Propertys, Distribution1, Distribution).
+
+ % updates the distribution counter
+ % search through the list, if alreay exist, increment counter
+ % else add to the list with a new counter being 1
+:- pred update_dist2(univ, list(distribution), list(distribution)).
+:- mode update_dist2(in, in, out) is det.
+update_dist2(Univ, [], [{Univ, 1}]).
+update_dist2(Univ, [Distribution|Distributions], Output) :-
+ Distribution = {Patten, Counter},
+ (if Univ = Patten
+ then
+ Output = [{Univ, Counter+1} | Distributions]
+ else
+ update_dist2(Univ, Distributions, Output1),
+ Output = [Distribution | Output1]
+ ).
+
+:- pred update_yes_no(property, int, int, int, int).
+:- mode update_yes_no(in, in, out, in, out) is det.
+update_yes_no(P, Yes0, Yes, No0, No) :-
+ (if member(no, P)
+ then
+ Yes = Yes0,
+ No = No0 + 1
+ else
+ Yes = Yes0 + 1,
+ No = No0
+ ).
+
+ % runs the invariant test once, return the result in
+ % format property
+:- pred testing2(T, list(list(frequency)), list({type_desc, list(frequency)}),
+ list(user_gen_type), rnd, rnd, qcheck__result) <= testable(T).
+:- mode testing2(in, in, in, list_skel_in(user_gen_inst),
+ in, out, out) is det.
+testing2(TestFunction, SpecificFrequency, GeneralFrequency, Generators,
+ RS0, RS, Result) :-
+ test(TestFunction, SpecificFrequency, GeneralFrequency, Generators,
+ Result, RS0, RS).
+
+%---------------------------------------------------------------------------%
+ % instance of testable
+ % 1 instance cast the invariant test function,
+ % from ground, to func(in, in ...) = out
+ % 2 extract the specific frequency,
+ % if specific frequency is mis-specified
+ % report an error
+ % 3 call gen() to generate the arguments
+ % 4 run the invariant test funtion with the
+ % arguments generated before
+ % 5 return the result + argument
+%---------------------------------------------------------------------------%
+
+:- 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)})
+].
+
+
+%---------------------------------------------------------------------------%
+
+:- 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;").
+
+%---------------------------------------------------------------------------%
+
+ % by conway
+ % generate an int with its size
+ % specified by N
+:- instance bitSupply(rnd) where [
+ ( next(N, Bits, Rnd0, Rnd) :-
+ rnd(F, Rnd0, Rnd),
+ Range = pow(2.0, N) - 1.0,
+ Bits = round_to_int(F * Range) )
+].
+
+%---------------------------------------------------------------------------%
+
+:- instance conditional(bool) where [
+ ( Left `===>` Right = Property :-
+ (if Left = yes
+ then
+ Property = Right
+ else
+ Property = [condition|Right]
+ )
+ )
+].
+
+:- instance conditional((pred)) where [
+ ( Left `===>` Right = Property :-
+ inst_cast_p0(Left, Left_Cast),
+ (if call(Left_Cast)
+ then
+ Property = Right
+ else
+ Property = [condition|Right]
+ )
+ )
+].
+
+:- 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;").
+
+%---------------------------------------------------------------------------%
+
+ % calls gen_arg() to generate,
+ % converts the univ to the required type
+ % run-time error if unable to convert univ to required T
+:- 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).
+
+ % 1 search for a user-defined generator,
+ % if found, runs that generator
+ % 2 if not found, determine if it's
+ % of type int, char, float or string.
+ % then call the appropriated default generator of that type
+ % 3 if not of type int, char, float, string
+ % but num_functors() returns -1, assume it's of function type
+ % thus call rand_function()
+ % 4 if still not match any above type, assume it's a
+ % discriminated union, thus call rand_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, Generators, Univ, RS0, RS) :-
+ (if find_user_gen(Datatype, Generators, User_generator)
+ then
+ Univ = User_generator(Datatype,Frequencys,GF,Generators,RS0,RS)
+ else
+ (if Datatype = type_of(0)
+ then
+ Temp = rand_int(RS0, RS),
+ Univ = univ(Temp)
+ else if Datatype = type_of('0')
+ then
+ Temp = rand_char(RS0, RS),
+ Univ = univ(Temp)
+ else if Datatype = type_of(0.0)
+ then
+ Temp = rand_float(RS0, RS),
+ Univ = univ(Temp)
+ else if Datatype = std_util__type_of("String")
+ then
+ Temp = rand_string(RS0, RS),
+ Univ = univ(Temp)
+ else if num_functors(Datatype) = -1
+ then
+ Univ = rand_function(Datatype, RS0, RS)
+ else
+ Univ = rand_union(Datatype, Frequencys,
+ GF, Generators, RS0, RS)
+ )
+ ).
+
+ % similar to gen_arg, but generate a list of univ, instead
+ % of just 1 univ as in get_arg
+ % gen_arg_list recursively calls gen_arg 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], Frequency_List, GF, Generators, [Univ|Univs],
+ RS0, RS) :-
+ ( Frequency_List = [],
+ F = [],
+ Fs = []
+ ;
+ Frequency_List = [F|Fs]
+ ),
+ gen_arg(Type, F, GF, Generators, Univ, RS0, RS1),
+ gen_arg_list(Types, Fs, GF, Generators, Univs, RS1, RS).
+
+%---------------------------------------------------------------------------%
+
+
+ % 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
+ % currently default char is
+ % any char that can be converted to
+ % from int of value between +999 to -999
+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, Generators, RS0, RS) = Univ :-
+ Num_functors = std_util__num_functors(Datatype),
+ rnd__irange(0, Num_functors - 1, Nth, RS0, RS1),
+ rnd__irange(0, 99, Level, RS1, RS2),
+ (if get_functor_ordinal(Datatype, Nth, Temp_Nth)
+ then
+ Real_Nth = Temp_Nth
+ else
+ error("get_functor_ordinal/3 failed \n")
+ ),
+ test_freq(Datatype, Num_functors, Real_Nth, Level_required,
+ Frequencys, GF, FrequencysN),
+ (if Level_required > Level
+ then
+ (if get_functor(Datatype, Nth, _, _, ArgTypesTemp)
+ then
+ ArgTypes = ArgTypesTemp,
+ gen_arg_list(ArgTypes, FrequencysN, GF,
+ Generators, ArgList, RS2, RS),
+ (if Temp = construct(Datatype, Nth, ArgList)
+ then
+ Univ = Temp
+ else
+ error("gen_arg/4 error in construct \n")
+ )
+ else
+ error("error in get_functor \n")
+ )
+ else
+ gen_arg(Datatype, Frequencys, GF, Generators, Univ,
+ RS2, RS)
+ ).
+
+
+ % function is generated using curry
+ % currently only generate functions that takes
+ % 1-3 arguments
+rand_function(Type, RS0, RS) = Univ :-
+ rnd__irange(1, 1000000, X0, RS0, RS1),
+ rnd__irange(1, 1000000, X1, RS1, RS2),
+ rnd__irange(1, 1000000, X2, RS2, RS3),
+ rnd__irange(1, 1000000, X3, RS3, RS4),
+ rnd__irange(1, 1000000, X4, RS4, RS5),
+ rnd__irange(1, 1000000, X5, RS5, RS6),
+ rnd__irange(1, 1000000, X6, RS6, RS7),
+ rnd__irange(1, 1000000, X7, RS7, RS8),
+ rnd__irange(1, 1000000, X8, RS8, RS9),
+ rnd__irange(1, 1000000, X9, RS9, RS10),
+ rnd__irange(1, 1000000, X10, RS10, RS),
+ type_ctor_and_args(Type, _, Args),
+ (if Args = [RetType]
+ then
+ has_type(RetVal, RetType),
+ Func = dummy(X0,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10),
+ nailFuncType(RetVal, Func),
+ Univ = univ(Func)
+ else if Args = [ArgType1, RetType]
+ then
+ 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)
+ else if Args = [ArgType1, ArgType2, RetType]
+ then
+ 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)
+ else if Args = [ArgType1, ArgType2, ArgType3, RetType]
+ then
+ 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)
+ else if Args = [ArgType1, ArgType2, ArgType3, ArgType4, RetType]
+ then
+ 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)
+ else if Args = [ArgType1, ArgType2, ArgType3, ArgType4,
+ ArgType5, RetType]
+ then
+ 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)
+ else if Args = [ArgType1, ArgType2, ArgType3, ArgType4,
+ ArgType5, ArgType6, RetType]
+ then
+ 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)
+ else if Args = [ArgType1, ArgType2, ArgType3, ArgType4,
+ ArgType5, ArgType6, ArgType7, RetType]
+ then
+ 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)
+ else if Args = [ArgType1, ArgType2, ArgType3, ArgType4,
+ ArgType5, ArgType6, ArgType7, ArgType8,
+ RetType]
+ then
+ 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)
+ else if Args = [ArgType1, ArgType2, ArgType3, ArgType4,
+ ArgType5, ArgType6, ArgType7, ArgType8,
+ ArgType9, RetType]
+ then
+ 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)
+ else if Args = [ArgType1, ArgType2, ArgType3, ArgType4,
+ ArgType5, ArgType6, ArgType7, ArgType8,
+ ArgType9, ArgType10, RetType]
+ then
+ 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)
+ else
+ error("no default generator for this type \n")
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % determine the types of the generated functions
+:- 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 function, used by rand_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, 1000000, Seed_initial, RS0, RS1),
+ rnd__irange(1, 1000000, Seed_any_to_int1, RS1, RS2),
+ rnd__irange(1, 1000000, Seed_any_to_int2, RS2, RS3),
+ rnd__irange(1, 1000000, Seed_any_to_int3, RS3, RS4),
+ rnd__irange(1, 1000000, Seed_any_to_int4, RS4, RS5),
+ rnd__irange(1, 1000000, Seed_any_to_int5, RS5, RS6),
+ rnd__irange(1, 1000000, Seed_any_to_int6, RS6, RS7),
+ rnd__irange(1, 1000000, Seed_any_to_int7, RS7, RS8),
+ rnd__irange(1, 1000000, Seed_any_to_int8, RS8, RS9),
+ rnd__irange(1, 1000000, Seed_any_to_int9, RS9, RS10),
+ rnd__irange(1, 1000000, 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 :-
+ univ(X) = X1,
+ Temp = univ_to_int(X1),
+ init_setup(Seed, RS0),
+ (if irange(1, 20, Output, RS0, _),
+ Output = 1
+ then
+ Int = 0
+ else
+ Int = Temp
+ ).
+
+value_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).
+
+%---------------------------------------------------------------------------%
+:- 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.
+
+:- 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)
+ ).
+
+ % prints the value which is store in univ
+:- 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).
+
+ % prints the value which is store 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).
+
+
+ % 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(" "),
+ io__write(univ_value(Univ)),
+ io__nl,
+ show_dist(Dists).
+
+%---------------------------------------------------------------------------%
+
+ % extract the required_level and the frequency of sub-constructors
+ % 1 if Frequencys non-empty, then there is specific frequency
+ % call freq_info to get the infomation
+ % 2 if Frequencys is empty, then search for general frequency
+ % 3a if found in general frequency, then restart test_freq with
+ % the general frequency for that type as the specific frequency
+ % 3b if no match found in general frequecy, 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, Num_functors, Nth, Level_required, Frequencys, GF, NewF) :-
+ (if list__length(Frequencys) = Num_functors
+ then
+ freq_info(0, Nth, Frequencys, Level_required, NewF)
+ else if Frequencys = []
+ then
+ Temp_freq = locate_general(Datatype, GF),
+ (if Temp_freq = []
+ then
+ Level_required = 100,
+ NewF = []
+ else
+ test_freq(Datatype, Num_functors, Nth,
+ Level_required, Temp_freq, GF, NewF)
+ )
+ else
+ error("test_freq/5 error: freqencys not match Args \n")
+ ).
+
+ % extract the specifict frequency and its sub-constructor's frequency
+ % the base case may be redundant, to cover [[]] case...
+ % recursively increase 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], Level_required, NewF) :-
+ (if Counter = Nth
+ then
+ Frequency = {Level_required, NewF}
+ else
+ freq_info(Counter + 1, Nth, Frequencys, Level_required, NewF)
+ ).
+
+ % pass through general frequency list, looking for matching type_desc
+ % 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)
+ ).
+
+ % pass through the generator list, looking for matching type_desc
+ % if found, return the generating function
+ % else 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, [Generator|Generators], User_generator) :-
+ Generator = {Type, Temp_generator},
+ (if Datatype = Type
+ then
+ User_generator = Temp_generator
+ else
+ find_user_gen(Datatype, Generators, User_generator)
+ ).
+
+ % for debug, like printf() in c
+ % but doesn't require io__state
+:- pred myerror(T).
+:- mode myerror(in) is erroneous.
+myerror(Data) :-
+ to_doc(999999, Data) = Doc,
+ to_string(99999, Doc) = String,
+ error(String).
+
+ % sort a list of distribution
+:- pred distribution_sort(list(distribution), list(distribution)).
+:- mode distribution_sort(in, out) is det.
+distribution_sort([], []).
+distribution_sort([Dist|Dists], Output) :-
+ distribution_sort(Dists, Sorted),
+ inserting(Dist, Sorted, Output).
+
+ % insert into a sorted distribution list
+:- pred inserting(distribution, list(distribution), list(distribution)).
+:- mode inserting(in, in, out) is det.
+inserting(Elem, [], [Elem]).
+inserting(Elem, [Dist|Dists], Output) :-
+ Elem = {_, Freq1},
+ Dist = {_, Freq2},
+ (if Freq2 < Freq1
+ then
+ Output = [Dist | Temp],
+ distribution_sort([Elem|Dists], Temp)
+ else
+ Output = [Elem | [Dist|Dists] ]
+ ).
+%-----------------------------------------------------------------------------%
+% END
--------------------------------------------------------------------------
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