X-Git-Url: https://gerrit.simantics.org/r/gitweb?a=blobdiff_plain;f=bundles%2Forg.simantics.scl.runtime%2Fscl%2FArbitrary.scl;fp=bundles%2Forg.simantics.scl.runtime%2Fscl%2FArbitrary.scl;h=17a6ec65fcd7237c2db9a7542ef65afd753bf2ac;hb=969bd23cab98a79ca9101af33334000879fb60c5;hp=0000000000000000000000000000000000000000;hpb=866dba5cd5a3929bbeae85991796acb212338a08;p=simantics%2Fplatform.git

diff --git a/bundles/org.simantics.scl.runtime/scl/Arbitrary.scl b/bundles/org.simantics.scl.runtime/scl/Arbitrary.scl
new file mode 100644
index 000000000..17a6ec65f
--- /dev/null
+++ b/bundles/org.simantics.scl.runtime/scl/Arbitrary.scl
@@ -0,0 +1,194 @@
+import "Prelude"
+import "Random"
+import "IterN"
+import "Vector" as Vector
+
+data Gen a = Gen (Integer -> <Random> a)
+
+@inline
+genRandom :: (<Random> a) -> Gen a
+genRandom r = Gen (\_ -> r)
+
+@inline
+runGen :: Gen a -> Integer -> <Random> a
+runGen (Gen f) n = f n
+
+class Arbitrary a where
+    arbitrary :: Gen a
+
+class CoArbitrary a where
+    variateSeed :: Integer -> Long -> a -> Long
+
+instance Arbitrary Boolean where
+    arbitrary = genRandom randomBoolean
+instance CoArbitrary Boolean where
+    variateSeed _ seed v = if v then seed + 1 else seed
+
+@private
+@inline
+negateRandomly :: Integer -> <Random> Integer
+negateRandomly v = if randomBoolean then v else -v
+
+instance Arbitrary Integer where
+    arbitrary = Gen $ \n -> negateRandomly $ randomN $ n+1
+instance CoArbitrary Integer where
+    variateSeed _ seed v = seed + fromInteger v
+    
+instance Arbitrary Long where
+    arbitrary = genRandom randomLong
+instance CoArbitrary Long where
+    variateSeed _ seed v = seed + v
+    
+instance Arbitrary Float where
+    arbitrary = Gen $ \n -> fromInteger n 
+                          * (fromInteger $ negateRandomly $ randomN $ pres)
+                          / (fromInteger $ 1+randomN pres)
+        where pres = 999999999
+instance CoArbitrary Float where
+    variateSeed _ seed v = seed + fromInteger (floatToIntBits v)
+
+instance Arbitrary Double where
+    arbitrary = Gen $ \n -> fromInteger n 
+                          * (fromInteger $ negateRandomly $ randomN $ pres)
+                          / (fromInteger $ 1+randomN pres)
+        where pres = 999999999
+instance CoArbitrary Double where
+    variateSeed _ seed v = seed + doubleToLongBits v
+
+randomCharacter :: <Random> Character
+randomCharacter = let p = randomN 100 
+                  in if p < 80
+                     then addChar ' ' (randomN 95)
+                     else if p < 90
+                     then addChar '\0' (randomN 256)
+                     else addChar '\0' (randomN 65536)
+randomIdentifierFirstCharacter :: <Random> Character
+randomIdentifierFirstCharacter = if randomBoolean
+                                 then addChar 'a' (randomN 26)
+                                 else addChar 'A' (randomN 26)
+randomIdentifierCharacter :: <Random> Character
+randomIdentifierCharacter = let p = randomN 100 
+                            in if p < 70
+                               then addChar 'a' (randomN 26)
+                               else if p < 90
+                               then addChar 'A' (randomN 26)
+                               else addChar '0' (randomN 10)
+                        
+instance Arbitrary Character where
+    arbitrary = genRandom randomCharacter
+instance CoArbitrary Character where
+    variateSeed _ seed v = seed + fromInteger (hash (showCharacter v))
+
+"""Generates a random string that is a valid SCL or Java identifier""" 
+arbitraryIdentifier = Gen $ \n -> string (Vector.vectorF (1+randomN (max n 1))
+    (\i -> if i==0 then randomIdentifierFirstCharacter else randomIdentifierCharacter))
+
+instance Arbitrary String where
+    arbitrary = Gen $ \n -> string (Vector.vectorF (randomN (1+n)) (\_ -> randomCharacter))
+instance CoArbitrary String where
+    variateSeed _ seed v = seed + fromInteger (hash v)
+
+instance Arbitrary () where
+    arbitrary = genRandom ()
+instance CoArbitrary () where
+    variateSeed _ seed _ = seed
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where
+    arbitrary = arbitraryTuple2 arbitrary arbitrary
+instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (a, b) where
+    variateSeed n seed (a, b) = variateSeed n (13*variateSeed n seed a) b
+
+instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c) where
+    arbitrary = arbitraryTuple3 arbitrary arbitrary arbitrary
+instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) => CoArbitrary (a, b, c) where
+    variateSeed n seed (a, b, c) = variateSeed n (13*variateSeed n (13*variateSeed n seed a) b) c
+
+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (a, b, c, d) where
+    arbitrary = arbitraryTuple4 arbitrary arbitrary arbitrary arbitrary
+instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d) => CoArbitrary (a, b, c, d) where
+    variateSeed n seed (a, b, c, d) = variateSeed n (13*variateSeed n (13*variateSeed n (13*variateSeed n seed a) b) c) d
+
+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) => Arbitrary (a, b, c, d, e) where
+    arbitrary = arbitraryTuple5 arbitrary arbitrary arbitrary arbitrary arbitrary
+instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e) 
+      => CoArbitrary (a, b, c, d, e) where
+    variateSeed n seed (a, b, c, d, e) = 
+        variateSeed n (13*variateSeed n (13*variateSeed n (13*variateSeed n (13*variateSeed n seed a) b) c) d) e
+
+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f) 
+      => Arbitrary (a, b, c, d, e, f) where
+    arbitrary = arbitraryTuple6 arbitrary arbitrary arbitrary arbitrary arbitrary arbitrary
+instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e, CoArbitrary f) 
+      => CoArbitrary (a, b, c, d, e, f) where
+    variateSeed n seed (a, b, c, d, e, f) = 
+        variateSeed n (13*variateSeed n (13*variateSeed n (13*variateSeed n (13*variateSeed n (13*variateSeed n seed a) b) c) d) e) f
+
+instance (Arbitrary a) => Arbitrary (Maybe a) where
+    arbitrary = arbitraryMaybe arbitrary
+instance (CoArbitrary a) => CoArbitrary (Maybe a) where
+    variateSeed n seed v = match v with
+        Nothing -> 13*seed+1
+        Just a -> 13*variateSeed n seed a
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
+    arbitrary = arbitraryEither arbitrary arbitrary
+instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where
+    variateSeed n seed v = match v with
+        Left a  -> 13*variateSeed n seed a
+        Right a -> 13*variateSeed n seed a+1
+
+instance (Arbitrary a) => Arbitrary [a] where
+    arbitrary = arbitraryList arbitrary
+instance (CoArbitrary a) => CoArbitrary [a] where
+    variateSeed n = foldl (variateSeed n)
+        
+instance (Arbitrary a, VecComp a) => Arbitrary (Vector a) where
+    arbitrary = arbitraryVector arbitrary
+instance (CoArbitrary a) => CoArbitrary (Vector a) where
+    variateSeed n = Vector.foldlVector (variateSeed n)
+    
+instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where
+    arbitrary = Gen $ \n -> let seed = randomLong
+                            in  \v -> withSeed (variateSeed n seed v) (runGen arbitrary n)
+instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where
+    variateSeed n seed f = variateSeed n seed (withSeed seed (mapList f (runGen arbitrary n)))
+
+arbitraryTuple2 (Gen a) (Gen b) = Gen $ \n -> (a n, b n)
+
+arbitraryTuple3 (Gen a) (Gen b) (Gen c) = Gen $ \n -> (a n, b n, c n)
+
+arbitraryTuple4 (Gen a) (Gen b) (Gen c) (Gen d) = Gen $ \n -> (a n, b n, c n, d n)
+
+arbitraryTuple5 (Gen a) (Gen b) (Gen c) (Gen d) (Gen e) = Gen $ \n -> (a n, b n, c n, d n, e n)
+
+arbitraryTuple6 (Gen a) (Gen b) (Gen c) (Gen d) (Gen e) (Gen f) = Gen $ \n -> (a n, b n, c n, d n, e n, f n)
+
+arbitraryMaybe (Gen f) =
+    Gen $ \n -> if randomN 4 < 1
+                then Nothing
+                else Just (f n)
+
+arbitraryEither (Gen left) (Gen right) =
+    Gen $ \n -> if randomBoolean
+                then Left (left n)
+                else Right (right n)
+
+arbitraryFixedSizeList :: Integer -> Gen a -> Gen [a]
+arbitraryFixedSizeList s (Gen f) = Gen $ \n -> mapN (\_ -> f n) s
+
+arbitraryList :: Gen a -> Gen [a]
+arbitraryList (Gen f) = Gen $ \n -> mapN (\_ -> f n) (randomN n)
+
+@inline
+arbitraryFixedSizeVector :: VecComp a => Integer -> Gen a -> Gen (Vector a)
+arbitraryFixedSizeVector s (Gen f) = Gen $ \n -> Vector.vectorF s (\_ -> f n)
+
+@inline
+arbitraryVector :: VecComp a => Gen a -> Gen (Vector a)
+arbitraryVector (Gen f) = Gen $ \n -> Vector.vectorF (randomN n) (\_ -> f n)
+
+arbitraryElement :: [a] -> Gen a
+arbitraryElement elements = genRandom (elements ! randomN (length elements))
+
+arbitraryResized :: (Integer -> Integer) -> Gen a -> Gen a
+arbitraryResized f (Gen gen) = Gen (gen . f)