implementation module Gast.Gen

/*
	GAST: A Generic Automatic Software Test-system

	gen: generic generation of values of a type

	Pieter Koopman, 2004 - 2017
	Radboud Universty, Nijmegen
	The Netherlands
	pieter@cs.ru.nl
*/

import StdEnv, StdOverloadedList, Math.Random, Data.Maybe, Data.Functor, Data.List, Data.Int, Data.Real
from Data.Set import :: Set
import qualified Data.Set
from Data.Map import :: Map, instance Functor (Map k)
import qualified Data.Map
from Data.Func import $
import Control.GenBimap

// -------
aStream :: RandomStream
aStream = genRandInt 42

splitRandomStream :: !RandomStream -> (RandomStream,RandomStream)
splitRandomStream [r,s:rnd]
	# seed = r*s
	| seed == 0
		= splitRandomStream rnd
		= (genRandInt seed, rnd)
splitRandomStream _ = abort "Gast.Gen.icl: the increadable has been done, you have used all random values!"

// -------

randomize :: ![a] [Int] Int ([Int] -> [a]) -> [a]
randomize list rnd n c = rand list rnd n []
where
	rand [] rnd m [] = c rnd
	rand [] rnd m [x] = [x:c rnd]
	rand [] rnd m l = rand l rnd n []
	rand [a:x] [i:rnd] m l
		| m==0 || (i rem m) == 0
			= [a:rand x rnd (m-1) l]
			= rand x rnd m [a:l]
// -------

genState :: GenState
genState =
	{ depth                 = 0
	, maxDepth              = LargestInt
	, maxStringLength       = defaultMaxStrLen
	, path                  = []
	, mode                  = SkewGeneration { skewl = 1
	                                         , skewr = 3
	                                         }
	, recInfo               = 'Data.Map'.newMap
	, pairTree              = PTLeaf
	, recFieldValueNrLimits = 'Data.Map'.newMap
	}

// ================= skew generation ================= //
directNames :: GenericTypeDefDescriptor -> Set TypeName
directNames gtd = 'Data.Set'.fromList (foldr scan [] gtd.gtd_conses)
where
	scan gcd = allTypes (init (types gcd.gcd_type)) // init removes the type itself, as required.

	types :: GenType -> [GenType]
	types (GenTypeArrow s t) = types s ++ types t
	types t = [t]

	allTypes :: [GenType] [TypeName] -> [TypeName]
	allTypes [GenTypeArrow s t:r] c	= allTypes [s] (allTypes [t] (allTypes r c))
	allTypes [GenTypeApp   s t:r] c	= allTypes [s] (allTypes [t] (allTypes r c))
	allTypes [GenTypeCons name:r] c = [name:allTypes r c]
	allTypes [GenTypeVar     v:r] c = allTypes r c
	allTypes []                   c = c

addRecInfo :: TypeName (Set TypeName) (Map TypeName (Set TypeName)) -> Map TypeName (Set TypeName)
addRecInfo name names ri
	# ri =  (\types -> if ('Data.Set'.member name types) ('Data.Set'.union types names) types) <$> ri
    = 'Data.Map'.alter (?Just o maybe names ('Data.Set'.union names)) name ri

recArgs :: TypeName (Map TypeName (Set TypeName)) GenType -> [Bool]
recArgs typeName ri genType = scanArgs genType
where
	scanArgs :: GenType -> [Bool]
	scanArgs (GenTypeArrow t1 t2) = [recCount t1:scanArgs t2]
	scanArgs genType = []

	recCount :: GenType -> Bool
	recCount (GenTypeApp t1 t2)   = recCount t1 || recCount t2
	recCount (GenTypeArrow t1 t2) = recCount t1 || recCount t2
	recCount (GenTypeCons name)   = maybe False ('Data.Set'.member typeName) ('Data.Map'.get name ri)
	recCount genType              = False

genPairTree :: [Bool] Int -> PairTree
genPairTree l   n
	| n<2
		= PTLeaf
		= PTNode (genPairTree l1 m) (or l1) (or l2) (genPairTree l2 n2)
where
	m = n/2
	n2 = n-m
	(l1,l2) = splitAt m l

// ================= generic generation ================= //

ggen{|Int|}  s = [!0: interleave [!i \\ n <|- [!1..(s.maxDepth - s.depth)], i <|- [!n,~n]] (if (s.maxDepth == LargestInt) [!LargestInt,SmallestInt,LargestInt - 1, SmallestInt + 1] [!])]
ggen{|Bool|} s = [!False,True]
ggen{|Char|} s = Take (s.maxDepth - s.depth) (interleave [!'a'..'~'] (interleave [!'A'..'`'] (interleave (Map toChar [!32..64]) [!'\t\n\r'])))
ggen{|Real|} s
	| s.maxDepth < LargestInt
		= TakeWhile (\r -> abs r <= toReal (s.maxDepth - s.depth)) l
		= l
where
	/* The idea here is to generate reals in various methods and to avoid
	 * overlap between the different methods as much as possible. We only add
	 * some common values (0.0 through ~Infinity) which are not generated by
	 * any of these methods. */
	l =
		[! 0.0, 1.0, -1.0, NaN, ~NaN, Infinity, ~Infinity
		: interleave quotients (interleave squareRoots largeReals)
		]

	/* This generates quotients n/d (and -n/d) for which n and d are unequal primes.
	 * We use primes to make sure quotients are not generated twice (e.g. 1/2 and 2/4).
	 * The 1 is used to simultaneously generate 1/p and -1/p for primes p.
	 * We do not add 1 to the second list, because primes themselves are generated by the square roots below. */
	quotients =
		[!r \\ x <|- diag [!1:primes] primes (\n d -> toReal n / toReal d), r <- [x,~ x] | x <> 1.0]
	where
		primes = sieve [!2..]
		sieve [!p:xs] = [!p: sieve [!x \\ x <|- xs | x rem p <> 0]]

		diag :: ![!a] ![!b] !(a b -> c) -> [!c]
		diag ls rs f = case s.mode of
			SkewGeneration p = diagSkew p.skewl p.skewr ls rs f
			BentGeneration   = uncurry f <$> diagBent ls rs

	/* For square roots of integers r there exist no unequal primes p,q with p/q=r. */
	squareRoots = [!r \\ x <- map sqrt [2.0..], r <- [x, ~x]]

	/* This generates powers of two, starting from the largest real down to 16.
	 * This causes some duplicates with squareRoots above, but they are very few. */
	largeReals
		| s.maxDepth <> LargestInt
			= [!]
			= [!5.0E-324, 2.2250738585072009E-308, LowestReal: largeReals` LargestReal] // double precision
	where
		largeReals` r
			| r < 10.0
				= [!]
				= [!r, 0.0 - r: largeReals` (r/2.0)]

ggen{|UNIT|} s = [!UNIT]
ggen{|PAIR|} f g s
	= case s.pairTree of
		PTNode ptl sl sr ptr = case s.mode of
			SkewGeneration p = diagSkew (if sl p.skewr p.skewl)  (if sr p.skewr p.skewl)
                                        (f {s & pairTree = ptl}) (g {s & pairTree = ptr})
                                        PAIR
			BentGeneration   = uncurry PAIR <$> diagBent (f {s & pairTree = ptl}) (g {s & pairTree = ptr})
		_ = abort "ggen{|PAIR|}: invalid pairTree: PTNode"

ggen{|EITHER|} f g s
		# path	= s.path
		| isEmpty path
			= interleave (Map LEFT (f s)) (Map RIGHT (g s))
			# s	= { s & path = drop 1 path }
			  gs = Map RIGHT (g s)
			  fs = Map LEFT (f s)
			= case path of
				[ConsRight:_]	= interleave gs fs
				_				= interleave fs gs

ggen{|CONS of gcd|} f s
	= Map CONS (f {s & pairTree = pairTree})
where
	typeName	= gcd.gcd_type_def.gtd_name
	type		= gcd.gcd_type
	recCount	= recArgs typeName s.recInfo type
	pairTree	= genPairTree recCount gcd.gcd_arity
ggen{|OBJECT of gtd|} f s
	| s.depth >= s.maxDepth
		= [!]
		= [!OBJECT o \\ o <|- (f {s & depth = s.depth + 1, path = path, recInfo = ri2})]
where
	path = hd (	[	getConsPath gcd
				\\	gcd <- sortBy argCount
					(filter (\gcd -> not (or (recArgs gtd.gtd_name s.recInfo gcd.gcd_type))) gtd.gtd_conses)
				] ++ [[]])
	argCount gcd1 gcd2 = gcd1.gcd_arity < gcd2.gcd_arity
	ri2 = addRecInfo gtd.gtd_name (directNames gtd) s.recInfo

ggen{|RECORD of grd|} f s
	= Map RECORD (f {s & pairTree = pairTree})
where
	typeName	= grd.grd_name
	type		= grd.grd_type
	recCount	= recArgs typeName s.recInfo type
	pairTree	= genPairTree recCount grd.grd_arity

ggen{|FIELD of d|}  f s = [!FIELD fi \\ fi <|- vals]
where
	vals = case 'Data.Map'.get (d.gfd_cons.grd_name, d.gfd_name) s.recFieldValueNrLimits of
		?None       -> f s
		?Just limit -> Take limit $ f s

ggenString :: !Int !Real !Int !Int !RandomStream -> [!String]
ggenString maxlen factor minchar maxchar stream = rndStrings stream
where
	rndStrings [len:rnd]
		# len = toInt ((randIntToReal len) ^ factor * (fromInt maxlen - 0.5))
		# (chars,rnd)	= genElems [] len rnd
		  string		= {c \\ c<-chars}
		= [!string:rndStrings rnd]
	where
		genElems :: ![Char] !Int !RandomStream -> (![Char], !RandomStream)
		genElems cs 0 rnd     = (cs,rnd)
		genElems cs n [r:rnd] = genElems [toChar (minchar+((abs r) rem (maxchar+1-minchar))):cs] (n-1) rnd

		randIntToReal :: Int -> Real
		randIntToReal x = (toReal x + if (x >= 0) 0.0 4294967296.0) / 4294967295.0

ggen{|String|} s = init ++| [!"":ggenString s.maxStringLength 4.0 32 126 aStream]
where
	init = Filter ((>=) s.maxStringLength o size) [!"hello world!", "Gast"]

derive ggen (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
derive ggen [], [!], [ !], [!!]
ggen{|{}|}  fx r = [!{x \\ x <- xs} \\ xs <|- ggen{|*->*|} fx r]
ggen{|{!}|} fx r = [!{x \\ x <- xs} \\ xs <|- ggen{|*->*|} fx r]

interleave :: ![!a] [!a] -> [!a]
interleave [!x:xs] ys = [!x: interleave ys xs]
interleave [!]     ys = ys

diagSkew :: !Int !Int [!a] [!b] (a b-> c) -> [!c]
diagSkew skewl skewr as bs f = skew skewl [!] [!] [![!f a b \\ a <|- as] \\ b <|- bs]
where
	skew :: Int [![!a]] [![!a]] [![!a]] -> [!a]
	skew n [![!a:as]:ass] bs  cs  = [!a: if (n>1) (skew (n-1) [!as:ass] bs cs) (skew skewl ass [!as:bs] cs)]
	skew n [![!]    :ass] bs  cs  = skew skewl ass bs cs
	skew n [!]            [!] [!] = [!]
	skew n [!]            bs  cs  = skew skewl (rev bs cs1) [!] cs2 where (cs1,cs2) = SplitAt (max skewr 1) cs

	rev :: ![!a] [!a] -> [!a]
	rev [!a:as] bs = rev as [!a:bs]
	rev [!]     bs = bs

diagBent :: ![!a] ![!b] -> [!(a, b)]
diagBent [!] _  = [!]
diagBent _  [!] = [!]
diagBent lss=:[!l: ls] rss=:[!r: rs] =
	diagBent` [!(lss, rss)] [!] (interleave [!(ls`, rss) \\ ls` <|- sublists ls] [!(lss, rs`) \\ rs` <|- sublists rs])
where
	diagBent` :: ![!([!a], [!b])] ![!([!a], [!b])] [!([!a], [!b])] -> [!(a, b)]
	diagBent` [!] [!]  [!]       = [!]
	diagBent` [!] done nextDiags = diagBent` todo [!] nextDiags`
	where
		(todo, nextDiags`) = case nextDiags of
			[!]                    = (done,              [!]      )
			[!nextDiag: nextDiags] = ([!nextDiag: done], nextDiags)
	diagBent` [!([!], _): todo]             done nextDiags = diagBent` todo [!] nextDiags
	diagBent` [!(_, [!]): todo]             done nextDiags = diagBent` todo [!] nextDiags
	diagBent` [!([!l: ls], [!r: rs]): todo] done nextDiags = [!(l, r): diagBent` todo [!(ls, rs): done] nextDiags]

	sublists :: ![!a] -> [![!a]]
	sublists [!] = [!]
	sublists l=:[!_: l`] = [!l: sublists l`]
