Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Boltzmann atempt

  • Loading branch information...
commit 57ed296677773705400a0b3eaf1e8a0b836bfb3c 1 parent 0c4b43b
@kmels authored
View
1  dart-haskell.cabal
@@ -85,6 +85,7 @@ library
-- control
, transformers >= 0.3
, mtl >= 2.1.1
+ , MonadRandom >= 0.1.9
-- text
, utf8-string >= 0.3.7
View
4 examples/testing/OnTrees.hs
@@ -40,7 +40,9 @@ sumTreeI (Branch t r) = sumTreeI t + sumTreeI r
-- | Function that fails if a tree sum is even, otherwise returns the sum
failOnEvenSumI :: IntTree -> Int
-failOnEvenSumI tree = let sum = sumTreeI tree in if (sum `mod` 2 /= 0) then sum else error $ "Sum is even: " ++ show sum
+failOnEvenSumI tree = let
+ sum = sumTreeI tree
+ in if (sum `mod` 2 /= 0) then sum else error $ "Sum is even: " ++ show sum
-- | Function that fails if a tree sum is odd, otherwise returns the sum
failOnOddSumI :: IntTree -> Int
View
9 src/DART/CmdLine.hs
@@ -220,6 +220,9 @@ mergeConfigSettings st cp = do
-- primitives
, min_int_bound = mergeInt "primitive types" "min_int_bound" (min_int_bound st)
, max_int_bound = mergeInt "primitive types" "max_int_bound" (max_int_bound st)
+ , data_min_size = mergeInt "data structures" "data_min_size" (data_min_size st)
+ , data_max_size = mergeInt "data structures" "data_max_size" (data_max_size st)
+ , data_target_size = mergeInt "data structures" "data_target_size" (data_target_size st)
}
where
-- merge a string setting
@@ -230,11 +233,11 @@ mergeConfigSettings st cp = do
mergeStr _ _ cmd_val = cmd_val
-- merge an int setting
- mergeInt :: Conf.SectionSpec -> Conf.OptionSpec -> Int -> Int
- mergeInt sec opt 0 = case Conf.get cp sec opt of
+ mergeInt :: Conf.SectionSpec -> Conf.OptionSpec -> Int -> Int
+ mergeInt sec opt 0 = case Conf.get cp sec opt of -- we have no cmdline val
Left _ -> error $ "Missing settings field '" ++ opt ++ "' in section '" ++ sec ++ "'"
Right val -> val
- mergeInt _ _ cmd_val = cmd_val
+ mergeInt _ _ cmd_val = cmd_val -- we have a cmdline val
-- | Reads the configuration file, if it doesn't exist, it is created
-- on Unix-like systems: ~/.dart-haskell
View
9 src/DART/DARTSettings.hs
@@ -27,6 +27,10 @@ data DARTSettings = InterpreterMode {
-- primitive types
, max_int_bound :: Int
, min_int_bound :: Int
+ -- data types
+ , data_min_size :: Int
+ , data_max_size :: Int
+ , data_target_size :: Int
} deriving (Show, Data, Typeable)
-- | We'll use the package cmdargs to identify flags, parameters, etc., from the command line
@@ -59,6 +63,11 @@ interpret = InterpreterMode {
-- primitives
, min_int_bound = def &= help "Minimum random integer to be generated"
, max_int_bound = def &= help "Maximum random integer to be generated"
+
+ -- data types
+ , data_min_size = def &= help "The minimum size to consider when generating a value for a data type"
+ , data_max_size = def &= help "The maximum size to consider when generating a value for a data type"
+ , data_target_size = def &= help "The target size to consider when generating a value for a data type (Takes precedente over min_data_size and max_data_size)"
} &= summary "Reads a .hcr file and evaluates its declarations. "
View
188 src/DART/MkRandom.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
----------------------------------------------------------------------------
-- |
-- Module : DART.MkRandom
@@ -13,11 +14,33 @@
module DART.MkRandom where
+--------------------------------------------------------------------------------
+-- Control
+import Control.Applicative
+import Control.Monad.Trans.Maybe
+import Control.Monad.Random
+import Control.Monad.Reader
+--------------------------------------------------------------------------------
+-- Random
+import System.Random
+
import Language.Core.Interpreter.Structures
import Language.Core.Interpreter
-import System.Random
import Data.List((!!))
+infixl 1 ??
+
+-- | Copied from the lens package. This is convenient to 'flip' argument order of composite functions.
+--
+-- >>> over _2 ?? ("hello","world") $ length
+-- ("hello",5)
+--
+-- >>> over ?? length ?? ("hello","world") $ _2
+-- ("hello",5)
+(??) :: Functor f => f (a -> b) -> a -> f b
+fab ?? a = fmap ($ a) fab
+{-# INLINE (??) #-}
+
-- newtype GenM a = GenM
-- { unGenM :: ReaderT (Int,Int) (StateT Int (MaybeT (Rand StdGen))) a }
-- deriving (Functor, Applicative, Monad, MonadPlus, MonadRandom,
@@ -41,17 +64,18 @@ import Data.List((!!))
-- curSize <- get
-- when (curSize >= maxSize) mzero
-- put (curSize + 1)
-
-
+
-- | Randomize on external core types. An environment might be needed in case there is a reference to the heap as an identifier in e.g. a data type
mkRandomVal :: Env -> Ty -> IM Value
-mkRandomVal env (Tcon qual_tcon) = case zDecodeQualified qual_tcon of
- -- Make a random integer
- "ghc-prim:GHC.Types.Int" -> rndInt >>= return . Num . toInteger
- -- Make a random "id" type
- id -> do
- type_constructors <- fetchDataCons id env
- sumTypeMkRandom type_constructors env
+mkRandomVal env (Tcon qual_tcon) =
+ --io (putStrLn ("#mkRandomVal for " ++ zDecodeQualified qual_tcon)) >>
+ case zDecodeQualified qual_tcon of
+ -- Make a random integer
+ "ghc-prim:GHC.Types.Int" -> rndInt >>= return . Num . toInteger
+ -- Make a random "id" type
+ id -> do
+ type_constructors <- fetchDataCons id env
+ sumTypeMkRandom type_constructors env
-- application of a type constructor qtycon1 to qtycon2
mkRandomVal env (Tapp (Tcon zqtycon1) (Tcon zqtycon2)) = do
@@ -88,10 +112,10 @@ mkRandomVal env ty = return . Wrong $ " mkRandomVal: I don't know how to make a
-- | Given a list of type constructors, and an environment of type bindings, fabricate a value.
-newtype FreeTypeBind = FreeTypeBind { typeInstantiation :: (Ty,Id) }
+--newtype FreeTypeBind = FreeTypeBind { typeInstantiation :: (Ty,Id) }
-fabricateValue :: [DataCon] -> [FreeTypeBind] -> IM Value
-fabricateValue xs ys = return $ Wrong $ "TODO fabricateVal"
+--fabricateValue :: [DataCon] -> [FreeTypeBind] -> IM Value
+--fabricateValue xs ys = return $ Wrong $ "TODO fabricateVal"
-- | Given a qualified type constructor name – e.g, (:) – seek the data constructor and also the qualified type it builds – e.g., [] for cons
fetchTyCon :: Id -> Env -> IM Value
@@ -118,11 +142,145 @@ sumTypeMkRandom :: [DataCon] -> Env -> IM Value
sumTypeMkRandom [] _ = return . Wrong $ "@dconsMkRandom: No data constructor"
sumTypeMkRandom tcs@(dc:dcs) env = do
-- randomly pick one data constructor
+ io . putStrLn $ "Making a sum type .. "
+
+ stdgen <- io newStdGen
+ io $ setStdGen stdgen
typecons_idx <- io . getStdRandom $ randomR (0,length dcs)
let typecons@(MkDataCon typecons_id _) = tcs !! typecons_idx
- --io . putStrLn $ "Picked type cons: " ++ typecons_id
- tyConMkRandom typecons env
+
+
+ val <- (genBoltzmann tcs env)
+ return val
+ --tyConMkRandom typecons env
+{-newtype GenM a = GenM
+ { unGenM :: ReaderT (Int,Int) (StateT Int (MaybeT (Rand StdGen))) a }
+ deriving (Functor, Applicative, Monad, MonadPlus, MonadRandom,
+ MonadState Int, MonadReader (Int,Int))
+
+runGenM :: Int -> Double -> GenM Value -> IM (Maybe Value)
+runGenM targetSize eps m = do
+ let wiggle = floor $ fromIntegral targetSize * eps
+ minSize = targetSize - wiggle
+ maxSize = targetSize + wiggle
+ g <- io $ newStdGen
+ return . (evalRand ?? g) . runMaybeT . (evalStateT ?? 0)
+ . (runReaderT ?? (minSize, maxSize)) . unGenM
+ $ m
+
+atom :: GenM ()
+atom = do
+ (_, maxSize) <- ask
+ curSize <- get
+ when (curSize >= maxSize) mzero
+ put (curSize + 1) -}
+
+-- | An atomic operation on the boltzmann sampler
+-- it increases the size and checks whether we have surpased the max size
+updateBoltzmann :: IM ()
+updateBoltzmann = do
+ maxSize <- getSetting data_max_size
+ currentSize <- gets gen_val_size
+ --io $ putStrLn $ "Updating boltzmann, size= " ++ show (currentSize)
+
+ -- if the size is greater, don't generate further
+ when (currentSize >= maxSize) $ do
+ io $ putStrLn "We should stop NOW!"
+ resetSize
+ modify (\st -> st { gen_val = Nothing})
+ --mzero
+ return ()
+
+ -- update size
+-- io $ putStrLn "Updating size!"
+ modify $ \st -> st {gen_val_size = currentSize + 1}
+ where
+ resetSize :: IM ()
+ resetSize = do
+ io $ putStrLn "Resetting size to 0"
+ --modify (\st -> st { gen_val = Just (Wrong "")})
+ modify (\st -> st { gen_val_size = 0 })
+
+pickTypeConstructor :: [DataCon] -> IM DataCon
+pickTypeConstructor tcs = do
+ typecons_idx <- io . getStdRandom $ randomR (0,length tcs - 1)
+ let typecons = tcs !! typecons_idx -- tcs[typecons_idx]
+ return typecons
+
+genBoltzmannUB :: [DataCon] -> Env -> IM Value
+genBoltzmannUB tcs env = do
+ --io $ putStrLn "Doing Upperbound"
+ updateBoltzmann
+
+ maybeVal <- gets gen_val
+ case maybeVal of
+ Nothing -> do
+ io $ putStrLn "Got nothing"
+ return $ Wrong "Too big"
+-- return () --mzero
+ Just _ -> gen
+ where
+ gen :: IM Value
+ gen = do
+ tycon@(MkDataCon tycon_id _) <- pickTypeConstructor tcs
+
+ --gets gen_val_size >>= \cs -> io $ putStr $ "Current size is " ++ (show cs) ++ ", will pick constructor .. "
+ --io . putStrLn $ "picked type cons: " ++ tycon_id
+
+ val <- tyConMkRandom tycon env
+ return val
+
+genBoltzmannLB :: [DataCon] -> Env -> IM Value
+genBoltzmannLB tcs env = do
+ --io $ putStrLn "Doing Lower bound"
+ val <- genBoltzmannUB tcs env
+ valSize <- gets gen_val_size
+ minSize <- getSetting data_min_size
+
+ guard $ valSize >= minSize -- if size is good enough, return (don't to anything else).
+
+ modify (\st -> st { gen_val = Just val })
+ return val
+
+-- | Given a list of type constructors for a data type, generate a
+-- new value using a boltzmann sampler around a size
+-- See: http://byorgey.wordpress.com/2013/04/25/random-binary-trees-with-a-size-limited-critical-boltzmann-sampler-2/
+genBoltzmann :: [DataCon] -> Env -> IM Value
+genBoltzmann tcs env = do
+ siz <- gets gen_val_size
+ --io $ putStrLn $ "Doing Boltzmann, size=" ++ (show siz)
+ val <- (genBoltzmannLB tcs env) --gets gen_val
+ maybeGenVal <- gets gen_val
+ case maybeGenVal of
+ Nothing -> do
+ io $ putStrLn "Got nothing"
+ --resetSize
+ genBoltzmann tcs env
+ (Just (Wrong "Too big")) -> do
+ io $ putStrLn $ "We're settling again."
+ resetSize
+ genBoltzmann tcs env
+ (Just v) -> do
+ size' <- gets gen_val_size
+ io $ putStrLn $ "Got something of size " ++ (show size')
+ return v
+ --genBoltzmann tcs env
+--- (genBoltzmannLB tcs env) `mplus` (genBoltzmann tcs env)
+ where
+ resetSize :: IM ()
+ resetSize = do
+ io $ putStrLn "Resetting size to 0"
+ modify (\st -> st { gen_val = Just (Wrong "")})
+ modify (\st -> st { gen_val_size = 0 })
+
+mkNewRandomVal :: Env -> Ty -> IM Value
+mkNewRandomVal env ty = resetSize >> mkRandomVal env ty where
+ resetSize = do
+ io $ putStrLn "Resetting size to 0"
+ modify (\st -> st { gen_val = Just (Wrong "")})
+ modify (\st -> st { gen_val_size = 0 })
+
-- | Creates a value using a type constructor, exhausting every type argument
-- an environment might be needed in case the types in the type constructors
-- contain references to some data type in the heap as an identifier
View
2  src/DART/ModuleTester.hs
@@ -129,7 +129,7 @@ testFun def@(Vdef (qvar,ty,vdef_exp)) env =
ntests <- getSetting number_of_tests
test_results <- replicateM ntests $ do
- arg_vals <- mapM (mkRandomVal env) fun_type_args
+ arg_vals <- mapM (mkNewRandomVal env) fun_type_args
debugM $ "Did " ++ (show . length) arg_vals ++ " random values"
testFunOnce fun arg_vals
View
1  src/DART/Run.hs
@@ -66,6 +66,7 @@ initDART settings = do
, settings = settings { include = (absolute_includes) }
, start_time = now
, test_name = Nothing
+ , gen_val = Nothing
}
-- | Returns a list of *relative* paths pointing to default included libraries e.g. base
View
4 src/Language/Core/Interpreter/Structures.hs
@@ -83,7 +83,9 @@ data DARTState = DState {
-- state of testing
, test_name :: Maybe (Qual Var)
-
+-- , generator :: GenM Value
+ , gen_val :: Maybe Value
+ , gen_val_size :: Int
}
type Heap = H.CuckooHashTable HeapAddress (Either Thunk Value)
Please sign in to comment.
Something went wrong with that request. Please try again.