generic-random 0.2.0.0 → 0.3.0.0

raw patch · 9 files changed

+237/−106 lines, 9 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +2/−4
• generic-random.cabal +6/−3
• src/Generic/Random/Boltzmann.hs +6/−3
• src/Generic/Random/Generic.hs +11/−6
• src/Generic/Random/Internal/Generic.hs +56/−44
• test/Test/Stats.hs +77/−0
• test/Test/Tree.hs +19/−0
• test/tree.hs +55/−46

@@ -0,0 +1,5 @@+# 0.3.0.0++- Support GHC 7.10.3+- Replace TypeApplications with ad-hoc data types in+  genericArbitraryFrequency'/genericArbitrary'

@@ -1,4 +1,4 @@-Generic random generators [![Hackage](https://img.shields.io/hackage/v/generic-random.svg)](https://hackage.haskell.org/package/generic-random) [![Build Status](https://travis-ci.org/Lysxia/generic-random.svg)](https://travis-ci.org/Lysxia/generic-random)+Generic random generators [![Hackage](https://img.shields.io/hackage/v/generic-random.svg)](https://hackage.haskell.org/package/generic-random) [![Build Status](https://travis-ci.org/Lysxia/generic-random.svg)](https://travis-ci.org/Lysxia/generic-random.svg?branch=master) =========================  `Generic.Random.Data`@@ -40,9 +40,7 @@ Say goodbye to `Constructor <$> arbitrary <*> arbitrary <*> arbitrary`-boilerplate.  ```haskell-    {-# LANGUAGE DataKinds #-}     {-# LANGUAGE DeriveGeneric #-}-    {-# LANGUAGE TypeApplications #-}      import GHC.Generics ( Generic )     import Test.QuickCheck@@ -52,7 +50,7 @@       deriving (Show, Generic)      instance Arbitrary a => Arbitrary (Tree a) where-      arbitrary = genericArbitrary' @'Z+      arbitrary = genericArbitrary' Z      -- Equivalent to     -- > arbitrary =

@@ -1,5 +1,5 @@ name:                generic-random-version:             0.2.0.0+version:             0.3.0.0 synopsis:            Generic random generators description:         Please see the README. homepage:            http://github.com/lysxia/generic-random@@ -10,9 +10,9 @@ maintainer:          lysxia@gmail.com category:            Generics, Testing build-type:          Simple-extra-source-files:  README.md+extra-source-files:  README.md CHANGELOG.md cabal-version:       >=1.10-tested-with:         GHC == 8.0.1+tested-with:         GHC == 7.10.3, GHC == 8.0.1  library   hs-source-dirs:      src@@ -51,6 +51,9 @@     base,     QuickCheck,     generic-random+  other-modules:+    Test.Stats,+    Test.Tree  benchmark bench-binarytree   type:             exitcode-stdio-1.0

@@ -5,11 +5,11 @@ -- the library takes care of computing the oracles and setting the right -- distributions. -{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveFunctor, DeriveGeneric, ImplicitParams #-} {-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications #-} module Generic.Random.Boltzmann where  import Control.Applicative@@ -86,10 +86,13 @@   :: forall b c   . (forall a. Num a => System (ConstModule a) b c)   -> Double -> Maybe (Vector Double)-solve s x = fixedPoint defSolveArgs phi' (V.replicate (dim (s @Int)) 0)+solve s x = fixedPoint defSolveArgs phi' (V.replicate (dim s') 0)   where     phi' :: forall a. (AD.Mode a, AD.Scalar a ~ Double) => Endo (Vector a)     phi' = coerce (sys s (scalar (AD.auto x)) :: Endo (Vector (ConstModule a b)))+    -- Arbitrary instantiation to get its dimension.+    s' :: System (ConstModule Int) b c+    s' = s  sizedGenerator   :: forall b c m

@@ -3,10 +3,7 @@ -- Here is an example. Define your type. -- -- > data Tree a = Leaf a | Node (Tree a) (Tree a)------ Derive 'GHC.Generics.Generic'.------ >   deriving 'Generic'  -- Turn on the DeriveGeneric extension+-- >   deriving Generic -- -- Pick an arbitrary implementation. --@@ -18,11 +15,19 @@ -- @arbitrary@.  module Generic.Random.Generic-  ( genericArbitrary+  (+    -- * Arbitrary implementations+    genericArbitrary   , genericArbitraryFrequency   , genericArbitraryFrequency'   , genericArbitrary'-  , Nat (..)++    -- * Type-level natural numbers+    -- $nat+  , Z (..)+  , S (..)++    -- * Generic class for finite values   , BaseCases'   , BaseCases   ) where

@@ -1,8 +1,7 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications, TypeOperators #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-}-{-# LANGUAGE AllowAmbiguousTypes, ScopedTypeVariables #-}-{-# LANGUAGE DataKinds, KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} module Generic.Random.Internal.Generic where @@ -29,8 +28,9 @@ -- For instance for @Tree a@ values are finite but the average number of -- @Leaf@ and @Node@ constructors is infinite. -genericArbitrary :: (Generic a, GA Unsized (Rep a)) => Gen a-genericArbitrary = ($ repeat 1) . unFreq . fmap to $ ga @Unsized+genericArbitrary :: forall a. (Generic a, GA Unsized (Rep a)) => Gen a+genericArbitrary =+  (($ repeat 1) . unFreq . fmap to) (ga :: Freq Unsized (Rep a p))   -- | This allows to specify the probability distribution of constructors@@ -46,30 +46,28 @@ -- >     ]  genericArbitraryFrequency-  :: (Generic a, GA Unsized (Rep a))+  :: forall a. (Generic a, GA Unsized (Rep a))   => [Int]  -- ^ List of weights for every constructor   -> Gen a-genericArbitraryFrequency = unFreq . fmap to $ ga @Unsized+genericArbitraryFrequency = (unFreq . fmap to) (ga :: Freq Unsized (Rep a p))   -- | The size parameter of 'Gen' is divided among the fields of the chosen -- constructor.  When it reaches zero, the generator selects a finite term -- whenever it can find any of the given type. ----- The type of 'genericArbitraryFrequency'' has an ambiguous @n@ parameter; it--- is a type-level natural number of type 'Nat'. That number determines the--- maximum /depth/ of terms that can be used to end recursion.------ You'll need the @TypeApplications@ and @DataKinds@ extensions.+-- The natural number @n@ determines the maximum /depth/ of terms that can be+-- used to end recursion.+-- It is encoded using @'Z' :: 'Z'@ and @'S' :: n -> 'S' n@. ----- > genericArbitraryFrequency' @n weights+-- > genericArbitraryFrequency' n weights ----- With @n ~ ''Z'@, the generator looks for a simple nullary constructor.  If none+-- With @n = 'Z'@, the generator looks for a simple nullary constructor.  If none -- exist at the current type, as is the case for our @Tree@ type, it carries on -- as in 'genericArbitraryFrequency'. ----- > genericArbitraryFrequency' @'Z :: Arbitrary a => [Int] -> Gen (Tree a)--- > genericArbitraryFrequency' @'Z [x, y] =+-- > genericArbitraryFrequency' Z :: Arbitrary a => [Int] -> Gen (Tree a)+-- > genericArbitraryFrequency' Z [x, y] = -- >   frequency -- >     [ (x, Leaf <$> arbitrary) -- >     , (y, scale (`div` 2) $ Node <$> arbitrary <*> arbitrary)@@ -82,12 +80,12 @@ -- >   deriving Generic -- > -- > instance Arbitrary Tree' where--- >   arbitrary = genericArbitraryFrequency' @'Z [1, 2, 3]+-- >   arbitrary = genericArbitraryFrequency' Z [1, 2, 3] -- -- 'genericArbitraryFrequency'' is equivalent to: ----- > genericArbitraryFrequency' @'Z :: [Int] -> Gen Tree'--- > genericArbitraryFrequency' @'Z [x, y, z] =+-- > genericArbitraryFrequency' Z :: [Int] -> Gen Tree'+-- > genericArbitraryFrequency' Z [x, y, z] = -- >   sized $ \n -> -- >     if n == 0 then -- >       -- If the size parameter is zero, the non-nullary alternative is discarded.@@ -110,11 +108,11 @@ -- of this parameter depends on the concrete type the generator is used for. -- -- For instance, if we want to generate a value of type @Tree ()@, there is a--- value of depth 1 (represented by @''S' ''Z'@) that we can use to end+-- value of depth 1 (represented by @'S' 'Z'@) that we can use to end -- recursion: @Leaf ()@. ----- > genericArbitraryFrequency' @('S 'Z) :: [Int] -> Gen (Tree ())--- > genericArbitraryFrequency' @('S 'Z) [x, y] =+-- > genericArbitraryFrequency' (S Z) :: [Int] -> Gen (Tree ())+-- > genericArbitraryFrequency' (S Z) [x, y] = -- >   sized $ \n -> -- >     if n == 0 then -- >       return (Leaf ())@@ -130,29 +128,33 @@ -- -- @FlexibleContexts@ and @UndecidableInstances@ are also required. ----- > instance (Arbitrary a, Generic a, BaseCases 'Z (Rep a))+-- > instance (Arbitrary a, Generic a, BaseCases Z (Rep a)) -- >   => Arbitrary (Tree a) where--- >   arbitrary = genericArbitraryFrequency' @('S 'Z) [1, 2]+-- >   arbitrary = genericArbitraryFrequency' (S Z) [1, 2] -- -- A synonym is provided for brevity. ----- > instance (Arbitrary a, BaseCases' 'Z a) => Arbitrary (Tree a) where--- >   arbitrary = genericArbitraryFrequency' @('S 'Z) [1, 2]+-- > instance (Arbitrary a, BaseCases' Z a) => Arbitrary (Tree a) where+-- >   arbitrary = genericArbitraryFrequency' (S Z) [1, 2]  genericArbitraryFrequency'-  :: forall (n :: Nat) a+  :: forall n a   . (Generic a, GA (Sized n) (Rep a))-  => [Int]  -- ^ List of weights for every constructor+  => n+  -> [Int]  -- ^ List of weights for every constructor   -> Gen a-genericArbitraryFrequency' = unFreq . fmap to $ ga @(Sized n)+genericArbitraryFrequency' _ =+  (unFreq . fmap to) (ga :: Freq (Sized n) (Rep a p))   -- | Like 'genericArbitraryFrequency'', but with uniformly distributed -- constructors.  genericArbitrary'-  :: forall (n :: Nat) a. (Generic a, GA (Sized n) (Rep a)) => Gen a-genericArbitrary' = ($ repeat 1) . unFreq . fmap to $ ga @(Sized n)+  :: forall n a+  . (Generic a, GA (Sized n) (Rep a)) => n -> Gen a+genericArbitrary' _ =+  (($ repeat 1) . unFreq . fmap to) (ga :: Freq (Sized n) (Rep a p))   -- * Internal@@ -167,7 +169,7 @@ newtype Gen' sized a = Gen' { unGen' :: Gen a }   deriving (Functor, Applicative) -data Sized :: Nat -> *+data Sized n data Unsized  liftGen :: Gen a -> Freq sized a@@ -246,21 +248,29 @@       (n, b) = gaProduct  -newtype Tagged (a :: Nat) b = Tagged { unTagged :: b }+newtype Tagged a b = Tagged { unTagged :: b } --- | Peano-encoded natural numbers.-data Nat = Z | S Nat+-- $nat+-- Use the 'Z' and 'S' data types to define the depths of values used+-- by 'genericArbitraryFrequency'' and 'genericArbitrary'' to make+-- generators terminate. +-- | Zero+data Z = Z++-- | Successor+data S n = S n+ -- | A @BaseCases n ('Rep' a)@ constraint basically provides the list of values -- of type @a@ with depth at most @n@.-class BaseCases (n :: Nat) f where+class BaseCases n f where   baseCases :: Tagged n [[f p]]  -- | For convenience. type BaseCases' n a = (Generic a, BaseCases n (Rep a))  baseCases' :: forall n f p. BaseCases n f => Tagged n [f p]-baseCases' = (Tagged . concat . unTagged) (baseCases @n)+baseCases' = (Tagged . concat . unTagged) (baseCases :: Tagged n [[f p]])  instance BaseCases n U1 where   baseCases = Tagged [[U1]]@@ -268,19 +278,21 @@ instance BaseCases n f => BaseCases n (M1 i c f) where   baseCases = (coerce :: Tagged n [[f p]] -> Tagged n [[M1 i c f p]]) baseCases -instance BaseCases 'Z (K1 i c) where+instance BaseCases Z (K1 i c) where   baseCases = Tagged [[]] -instance (Generic c, BaseCases n (Rep c)) => BaseCases ('S n) (K1 i c) where-  baseCases = (Tagged . (fmap . fmap) (K1 . to) . unTagged) (baseCases @n)+instance (Generic c, BaseCases n (Rep c)) => BaseCases (S n) (K1 i c) where+  baseCases =+    (Tagged . (fmap . fmap) (K1 . to) . unTagged)+      (baseCases :: Tagged n [[Rep c p]])  instance (BaseCases n f, BaseCases n g) => BaseCases n (f :+: g) where   baseCases = Tagged $-    (fmap . fmap) L1 (unTagged (baseCases @n)) ++-    (fmap . fmap) R1 (unTagged (baseCases @n))+    ((fmap . fmap) L1 . unTagged) (baseCases :: Tagged n [[f p]]) +++    ((fmap . fmap) R1 . unTagged) (baseCases :: Tagged n [[g p]])  instance (BaseCases n f, BaseCases n g) => BaseCases n (f :*: g) where   baseCases = Tagged     [ liftA2 (:*:)-        (unTagged (baseCases' @n))-        (unTagged (baseCases' @n)) ]+        (unTagged (baseCases' :: Tagged n [f p]))+        (unTagged (baseCases' :: Tagged n [g p])) ]

@@ -0,0 +1,77 @@+module Test.Stats where++import Data.List+import Data.Maybe++import Test.Tree+import Control.Monad++mean :: Foldable v => v Int -> Double+mean xs = fromIntegral (sum xs) / fromIntegral (length xs)++-- | Number of samples to estimate a probability distribution on a finite set+-- of size @n@ to precision @epsilon@ (infinity-norm between distributions)+-- with probability at least @(1 - delta)@.+sampleSize+  :: Int  -- ^ Domain size+  -> Double  -- ^ Target distance (infinity-norm)+  -> Double  -- ^ Target error probability+  -> Int+sampleSize n epsilon delta =+  ceiling (log (2 * fromIntegral n / delta) / (2 * epsilon ^ 2))++-- | Number of trees with @n@ internal nodes.+catalan :: [Integer]+catalan = fmap catalan' [0 ..]+  where+    catalan' 0 = 1+    catalan' i =+      let prefix = take i catalan+      in sum $ zipWith (*) prefix (reverse prefix)++-- | Average size of a binary tree given the probability (@> 1/2@) of choosing+-- a leaf.+avgSize :: Fractional a => a -> a+avgSize p = 1 / (2 * p - 1)++-- | Inverse of 'avgSize'.+invAvgSize :: Fractional a => a -> a+invAvgSize s = (1 / s + 1) / 2++-- | Distribution of sizes (actually, @(size - 1) / 2@), given the probability+-- of choosing a leaf.+distribution :: Fractional a => a -> [a]+distribution p = zipWith f [0 ..] catalan+  where+    f i c = fromInteger c * p * (p * (1 - p)) ^ i++expected :: Fractional a => Maybe a -> (Int, Int) -> Double -> Double -> (Int, [(Int, a)])+expected avgSize' (minSize_, maxSize_) epsilon delta = (k, d)+  where+    p = maybe (1/2) invAvgSize avgSize'+    minSize = (minSize_ + 1) `div` 2+    maxSize = maxSize_ `div` 2+    n = maxSize - minSize + 1+    k = sampleSize n epsilon delta+    d_ = (take n . drop minSize . distribution) p+    d = zip [minSize ..] (fmap (/ sum d_) d_)++runExperiment+  :: (Fractional a, Ord a, Monad m)+  => (Int, [(Int, a)]) -> m Int -> m ([(Int, a)], [(Int, a)], a)+runExperiment (k, d) gen = cmp' . collect <$> replicateM k gen+  where+    collect :: Fractional a => [Int] -> [(Int, a)]+    collect = fmap c . group . sort+    c xs@(x : _) = (x, fromIntegral (length xs) / fromIntegral k)+    c _ = undefined+    cmp' z = (d, z, cmp d z)+    cmp :: (Ord a, Num a) => [(Int, a)] -> [(Int, a)] -> a+    cmp xs ys = maximum (zipWith_ (\x y -> abs (x - y)) xs ys)+    zipWith_ :: (a -> a -> a) -> [(Int, a)] -> [(Int, a)] -> [a]+    zipWith_ f xxs@((x, m) : xs) yys@((y, n) : ys)+      | x == y = f m n : zipWith_ f xs ys+      | x < y = m : zipWith_ f xs yys+      | otherwise = n : zipWith_ f xxs ys+    zipWith_ f [] ys = fmap snd ys+    zipWith_ f xs [] = fmap snd xs

@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+module Test.Tree where++import Data.Data ( Data )+import GHC.Generics ( Generic )+import Test.QuickCheck++import Generic.Random.Generic++data T = L | N T T+  deriving (Eq, Ord, Show, Data, Generic)++size :: T -> Int+size (N l r) = 1 + size l + size r+size L = 0++instance Arbitrary T where+  arbitrary = genericArbitraryFrequency [9, 8]

@@ -1,59 +1,68 @@-{-# LANGUAGE DeriveDataTypeable #-} import Control.Monad import Data.Data import Data.Foldable+import Data.IORef import Data.List-import Test.QuickCheck+import System.Exit+import System.IO+ import Generic.Random.Data+import Generic.Random.Internal.Data -data T = N T T | L-  deriving (Eq, Ord, Show, Data)+import Test.Tree+import Test.Stats --- size-s :: T -> Int-s (N l r) = 1 + s l + s r-s L = 0+eps, del :: Double+eps = 0.01+del = 0.001 -main =-  for_ [ 4 ^ e | e <- [2 .. 4] ] $ \n ->-    for_-      [ ("reject ", generatorSR)-      , ("rejectSimple ", generatorR')-      , ("point ", generatorP')-      , ("pointReject ", generatorPR')-      ] $ \(name, g) ->-      stats (name ++ show n) s (g n)+-- | Periodically print stuff so that Travis does not think we're stuck.+counting x gen = do+  modifyIORef x (+ 1)+  readIORef x >>= \x ->+    when (x `mod` 1000 == 0) $ putStr "." >> hFlush stdout+  gen -stats :: String -> (a -> Int) -> Gen a -> IO ()-stats s f g = do-  putStrLn s-  xs <- replicateM 1000 (fmap f (generate g))-  putStrLn $ "Mean: " ++ show (mean xs)-  pp (histogram xs)-  putStrLn ""+main = do+  success <- newIORef True -histogram xs' = (bounds, bins)-  where-    (xs, ys) = splitAt (95 * length xs' `div` 100) (sort xs')-    xMin = minimum xs-    xMax = maximum xs-    bounds-      | xMax - xMin < 20 = [xMin .. xMax]-      | otherwise = [xMin, xMin + (xMax - xMin) `div` 10 .. xMax]-    bins = f bounds xs-    f (_ : b1 : bs) xs =-      let (a, ys) = span (< b1) xs-      in length a : f (b1 : bs) ys-    f _ xs = [length xs + length ys]+  let n = 64+      range = tolerance epsilon n -pp :: ([Int], [Int]) -> IO ()-pp (vs, bs) = do-  putStrLn $ vs >>= \v -> three v ++ " - "-  putStrLn $ bs >>= \b -> " | " ++ three b+  for_+    [ ( "reject "+      , generatorSR+      , expected Nothing range eps del+      )+    , ( "rejectSimple "+      , generatorR'+      , expected (Just (fromIntegral n)) range eps del+      )+    ] $ \(name, g, kdist) -> do+    putStrLn $ name ++ show n+    let gen = (fmap size . asMonadRandom . g) n+    x <- newIORef 0+    (expectedDist, estimatedDist, diff) <- runExperiment kdist (counting x gen)+    putStrLn ""+    when (diff > eps) $ do+      writeIORef success False+      putStrLn $ "FAIL > " ++ show diff+      print expectedDist+      print estimatedDist -three x = replicate (3 - length s) ' ' ++ s-  where-    s = show x+{-+  let k = 80000+      eps = 0.1+      gen = (fmap size . asMonadRandom . generatorP') n+  putStrLn $ "pointed " ++ show n+  x <- newIORef 0+  sizes <- replicateM k (counting x gen)+  putStrLn ""+  let diff = abs (mean sizes - fromIntegral (n `div` 2))+  when (diff > eps) $ do+    writeIORef success False+    putStrLn $ "FAIL > " ++ show diff+-} -mean :: Foldable v => v Int -> Double-mean xs = fromIntegral (sum xs) / fromIntegral (length xs)+  success <- readIORef success+  unless success exitFailure