Commit 8f5db157 authored by Steffen Michels's avatar Steffen Michels

add bent data generation mode

parent 5fb78ab6
Pipeline #13023 passed with stage
in 55 seconds
......@@ -26,13 +26,18 @@ generic ggen a :: !GenState -> [a]
{ depth :: !Int //* depth
, maxDepth :: !Int
, path :: ![ConsPos] //* path to nonrecursive constructor
, skewl :: !Int
, skewr :: !Int
, mode :: !Mode
, recInfo :: !Map TypeName (Set TypeName)
, pairTree :: !PairTree
, recFieldValueNrLimits :: !Map (TypeName, RecFieldName) Int //* Restricts the number of values generated for record fields
}
:: Mode = SkewGeneration !SkewParameters | BentGeneration
:: SkewParameters = { skewl :: !Int
, skewr :: !Int
}
:: TypeName :== String
:: RecFieldName :== String
:: PairTree = PTLeaf | PTNode PairTree Bool Bool PairTree
......
......@@ -11,7 +11,7 @@ implementation module Gast.Gen
pieter@cs.ru.nl
*/
import StdEnv, StdGeneric, Math.Random, Data.Maybe, Data.Functor
import StdEnv, StdGeneric, Math.Random, Data.Maybe, Data.Functor, Data.List
from Data.Set import :: Set
import qualified Data.Set as Set
from Data.Map import :: Map, instance Functor (Map k)
......@@ -55,8 +55,9 @@ genState =
{ depth = 0
, maxDepth = maxint
, path = []
, skewl = 1
, skewr = 3
, mode = SkewGeneration { skewl = 1
, skewr = 3
}
, recInfo = 'Map'.newMap
, pairTree = PTLeaf
, recFieldValueNrLimits = 'Map'.newMap
......@@ -119,7 +120,7 @@ ggen{|Real|} s
where
l = [0.0
:interleave
[r \\ x <- diag s.skewl s.skewr [1:prims] [1:prims] (\n d.toReal n/toReal d), r <- [x,~ x]]
[r \\ x <- diag [1:prims] [1:prims] (\n d.toReal n/toReal d), r <- [x,~ x]]
(interleave
[r \\ x <- map sqrt [2.0..], r <- [x, ~x]]
(if (s.maxDepth == maxint)
......@@ -135,11 +136,18 @@ where
= [r, 0.0 - r: largeReals (r/2.0)]
prims = sieve [2..]
sieve [p:xs] = [p: sieve [x \\ x <- xs | x rem p <> 0]]
diag ls rs f = case s.mode of
SkewGeneration p = diagSkew p.skewl p.skewr ls rs f
BentGeneration = uncurry f <$> diagBent ls rs
ggen{|UNIT|} s = [UNIT]
ggen{|PAIR|} f g s
= case s.pairTree of
PTNode ptl sl sr ptr = diag (if sl s.skewr s.skewl) (if sr s.skewr s.skewl) (f {s & pairTree = ptl}) (g {s & pairTree = ptr}) PAIR
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
......@@ -206,8 +214,8 @@ interleave :: [a] [a] -> [a]
interleave [x:xs] ys = [x: interleave ys xs]
interleave [] ys = ys
diag :: !Int !Int [a] [b] (a b-> c) -> [c]
diag skewl skewr as bs f = skew skewl [] [] [[f a b \\ a <- as] \\ b <- bs]
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)]
......@@ -219,4 +227,25 @@ where
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`]
derive bimap []
......@@ -77,6 +77,7 @@ generateAll :: !GenState -> [a] | ggen{|*|} a //& genType{|*|} a
| RandomSeed Int
| RandomList [Int]
| Skew Int
| Bent
| MaxDepth Int
| ArgTypes [GenType]
......
......@@ -293,9 +293,10 @@ where
handleOption c (RandomList r) = {c & randoms = r}
handleOption c (MaxDepth i) = {c & genState = {c.genState & maxDepth = i}}
handleOption c (Skew s)
| s > 0 = {c & genState = {c.genState & skewl = 1, skewr = s}}
| s < 0 = {c & genState = {c.genState & skewl = ~s, skewr = 1}}
| otherwise = {c & genState = {c.genState & skewl = 1, skewr = 1}}
| s > 0 = {c & genState = {c.genState & mode = SkewGeneration {skewl = 1, skewr = s}}}
| s < 0 = {c & genState = {c.genState & mode = SkewGeneration {skewl = ~s, skewr = 1}}}
| otherwise = {c & genState = {c.genState & mode = SkewGeneration {skewl = 1, skewr = 1}}}
handleOption c Bent = {c & genState = {c.genState & mode = BentGeneration}}
handleOption _ o = abort ("Test: unknown option \"" +++ show1 o +++ "\"\n")
TestList :: ![Testoption] ![p] -> [GastEvent] | Testable p
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment