add bent data generation mode

Libraries/Gast/Gen.dcl

@@ -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

Libraries/Gast/Gen.icl

@@ -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 []

Libraries/Gast/Testable.dcl

@@ -77,6 +77,7 @@ generateAll :: !GenState -> [a] | ggen{|*|} a //& genType{|*|} a
 	| RandomSeed Int
 	| RandomList [Int]
 	| Skew       Int
+	| Bent
 	| MaxDepth   Int
 	| ArgTypes   [GenType]
 

Libraries/Gast/Testable.icl

@@ -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