rodrigosetti/master-plan
1
1
Fork 0
mirror of https://github.com/rodrigosetti/master-plan.git synced 2024-11-21 17:13:41 +03:00
Code Issues Projects Releases Wiki Activity

Refactor: using newtypes

Browse Source
This commit is contained in:
Rodrigo Setti 2017-08-15 22:26:01 -07:00
parent dd4f8bf6f9
commit 73baeba40b
No known key found for this signature in database
GPG Key ID: 3E2EB67B3A72ABD3
9 changed files with 133 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
.stylish-haskell.yaml
View File

@ -7,13 +7,13 @@
steps:
# Convert some ASCII sequences to their Unicode equivalents. This is disabled
# by default.
- unicode_syntax:
# In order to make this work, we also need to insert the UnicodeSyntax
# language pragma. If this flag is set to true, we insert it when it's
# not already present. You may want to disable it if you configure
# language extensions using some other method than pragmas. Default:
# true.
add_language_pragma: true
#- unicode_syntax:
# # In order to make this work, we also need to insert the UnicodeSyntax
# # language pragma. If this flag is set to true, we insert it when it's
# # not already present. You may want to disable it if you configure
# # language extensions using some other method than pragmas. Default:
# # true.
# add_language_pragma: true
# Align the right hand side of some elements. This is quite conservative
# and only applies to statements where each element occupies a single

6
app/Main.hs
View File

@ -64,12 +64,12 @@ cmdParser = Opts <$> optional (strArgument ( help "plan file to read from (defau
<> help "height of the output image"
<> value (-1)
<> metavar "NUMBER")
<*> strOption ( long "root"
<*> (ProjectKey <$> strOption ( long "root"
<> short 'r'
<> help "name of the root project definition"
<> value "root"
<> showDefault
<> metavar "NAME")
<> metavar "NAME"))
<*> (invertProps <$> many (option property ( long "hide"
<> help "hide a particular property"
<> metavar (intercalate "|" $ map fst propertyNames))))
@ -80,7 +80,7 @@ cmdParser = Opts <$> optional (strArgument ( help "plan file to read from (defau
invertProps l = filter (`notElem` l) $ map snd propertyNames
filterParser ∷ Parser ProjFilter
filterParser = (ProjFilter . mkProgressFilter) <$> option auto ( long "progress-below"
filterParser = (ProjFilter . mkProgressFilter . Progress) <$> option auto ( long "progress-below"
<> help "only display projects which progress is < N%"
<> metavar "N" )
where

33
src/MasterPlan/Backend/Graph.hs
View File

@ -7,25 +7,26 @@ Maintainer : rodrigosetti@gmail.com
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnicodeSyntax #-}
module MasterPlan.Backend.Graph (render, RenderOptions(..)) where
import MasterPlan.Data
import Diagrams.Prelude hiding (render, Product, Sum)
import Diagrams.Backend.Rasterific
import Data.List (intersperse)
import Control.Applicative ((<|>))
import Control.Monad.State
import qualified Data.Map as M
import Data.Tree
import Data.Maybe (fromMaybe, catMaybes)
import Data.List (intersperse)
import qualified Data.List.NonEmpty as NE
import Text.Printf (printf)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Tree
import Diagrams.Backend.Rasterific
import Diagrams.Prelude hiding (Product, Sum, render)
import Diagrams.TwoD.Text (Text)
import MasterPlan.Data
import Text.Printf (printf)
-- text :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any
-- text = texterific
@ -83,10 +84,10 @@ toRenderModel sys rootK = case M.lookup rootK (bindings sys) of
projToRM p@(Product ps) = mkNode (\x -> Node (ProductNode, x)) p ps
projToRM (Reference n) =
\k p -> case M.lookup n $ bindings sys of
Nothing -> pure $ Node (AtomicNode, PNode k (p <|> pure defaultProjectProps {title=n}) defaultCost defaultTrust defaultProgress) []
Nothing -> pure $ Node (AtomicNode, PNode k (p <|> pure defaultProjectProps {title=getProjectKey n}) defaultCost defaultTrust defaultProgress) []
Just b -> do alreadyProcessed <- gets (n `elem`)
if alreadyProcessed
then pure $ Node (AtomicNode, NodeRef $ bindingTitle b) []
then pure $ Node (AtomicNode, NodeRef $ ProjectKey $ bindingTitle b) []
else modify (n:) >> bindingToRM n b
-- |how many children
@ -105,7 +106,7 @@ data RenderOptions = RenderOptions { colorByProgress :: Bool -- ^Whether to colo
-- | The main rendering function
render ∷ FilePath -> RenderOptions-> ProjectSystem → IO ()
render fp (RenderOptions colorByP w h rootK props) sys =
let noRootEroor = text $ "no project named \"" ++ rootK ++ "\" found."
let noRootEroor = text $ "no project named \"" ++ getProjectKey rootK ++ "\" found."
dia = fromMaybe noRootEroor $ renderTree colorByP props <$> evalState (toRenderModel sys rootK) []
in renderRasterific fp (dims2D (fromInteger w) (fromInteger h)) $ bgFrame 1 white $ centerXY dia
@ -136,7 +137,7 @@ renderTree colorByP props x@(Node (ty, n) ts@(t:_)) =
in txt # fontSizeL 2 # bold <> circle 2 # fc white # lwO 1
renderNode :: Bool -> [ProjAttribute] -> PNode -> QDiagram B V2 Double Any
renderNode _ _ (NodeRef n) =
renderNode _ _ (NodeRef (ProjectKey n)) =
text n <> roundedRect 30 12 0.5 # lwO 2 # fc white # dashingN [0.005, 0.005] 0
renderNode colorByP props (PNode _ prop c t p) =
centerY nodeDia # withEnvelope (rect 30 12 :: D V2 Double)
@ -179,7 +180,7 @@ renderNode colorByP props (PNode _ prop c t p) =
displayCost c'
| c' == 0 = mempty
| otherwise = rightText $ "(" ++ printf "%.1f" c' ++ ")"
| otherwise = rightText $ "(" ++ printf "%.1f" (getCost c') ++ ")"
displayProgress p'
| p' == 0 = mempty
| p' == 1 = leftText "done"

23
src/MasterPlan/Backend/Identity.hs
View File

@ -7,19 +7,19 @@ Maintainer : rodrigosetti@gmail.com
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnicodeSyntax #-}
module MasterPlan.Backend.Identity (render) where
import Control.Monad (when)
import Control.Monad.RWS (RWS, evalRWS, gets, tell, modify)
import Control.Monad.RWS (RWS, evalRWS, gets, modify, tell)
import Data.Generics
import Data.List (nub)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Maybe (isJust)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Maybe (isJust)
import MasterPlan.Data
-- |Plain text renderer
@ -29,14 +29,14 @@ render (ProjectSystem bs) whitelist =
where
renderRest = gets M.keys >>= mapM_ renderName
type RenderMonad = RWS [ProjAttribute] T.Text (M.Map String Binding)
type RenderMonad = RWS [ProjAttribute] T.Text (M.Map ProjectKey Binding)
renderName ∷ ProjectKey → RenderMonad ()
renderName projName =
do mb <- gets $ M.lookup projName
case mb of
Nothing -> pure ()
Just b -> do tell $ T.pack projName
Just b -> do tell $ T.pack $ getProjectKey projName
when (hasAttribute b) $ do
tell " {\n"
renderAttr b
@ -52,7 +52,7 @@ renderName projName =
|| c /= defaultCost
|| t /= defaultTrust
|| p /= defaultProgress
hasProperty props = title props /= projName
hasProperty props = title props /= getProjectKey projName
|| isJust (description props)
|| isJust (owner props)
|| isJust (url props)
@ -62,14 +62,15 @@ renderName projName =
renderAttr (BindingExpr props _) = renderProps props
renderAttr (BindingAtomic props c t p) =
do renderProps props
when (c /= defaultCost) $ tell $ "cost " <> T.pack (show c) <> "\n"
when (t /= defaultTrust) $ tell $ "trust " <> percentage t <> "\n"
when (p /= defaultProgress) $ tell $ "progress " <> percentage p <> "\n"
when (c /= defaultCost) $ tell $ "cost " <> T.pack (show $ getCost c) <> "\n"
when (t /= defaultTrust) $ tell $ "trust " <> percentage (getTrust t) <> "\n"
when (p /= defaultProgress) $ tell $ "progress " <> percentage (getProgress p) <> "\n"
renderProps :: ProjectProperties -> RenderMonad ()
renderProps p = do let maybeRender :: T.Text -> Maybe String -> RenderMonad ()
maybeRender n = maybe (pure ()) (\x -> tell $ n <> " " <> T.pack (show x) <> "\n")
when (title p /= projName) $ tell $ "title " <> T.pack (show $ title p) <> "\n"
when (title p /= getProjectKey projName) $
tell $ "title " <> T.pack (show $ title p) <> "\n"
maybeRender "description" (description p)
maybeRender "url" (url p)
maybeRender "owner" (owner p)
@ -79,7 +80,7 @@ renderName projName =
in if parens && length ps > 1 then "(" <> s <> ")" else s
expressionToStr :: Bool -> ProjectExpr -> T.Text
expressionToStr _ (Reference n) = T.pack n
expressionToStr _ (Reference (ProjectKey n)) = T.pack n
expressionToStr parens (Product ps) = combinedEToStr parens "*" ps
expressionToStr parens (Sequence ps) = combinedEToStr parens "->" ps
expressionToStr parens (Sum ps) = combinedEToStr parens "+" ps

48
src/MasterPlan/Data.hs
View File

@ -9,16 +9,18 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module MasterPlan.Data ( ProjectExpr(..)
, ProjectProperties(..)
, ProjectSystem(..)
, Binding(..)
, ProjectKey
, ProjectKey(..)
, ProjAttribute(..)
, Trust
, Cost
, Progress
, Trust(..)
, Cost(..)
, Progress(..)
, defaultProjectProps
, defaultCost
, defaultTrust
@ -37,13 +39,19 @@ import Data.Generics
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.String (IsString)
-- * Types
type Trust = Float
type Cost = Float
type Progress = Float
type ProjectKey = String
newtype Trust = Trust { getTrust :: Float }
deriving (Show, Eq, Data, Ord, Num, Real, RealFrac, Fractional)
newtype Cost = Cost { getCost :: Float }
deriving (Show, Eq, Data, Ord, Num, Real, RealFrac, Fractional)
newtype Progress = Progress { getProgress :: Float }
deriving (Show, Eq, Data, Ord, Num, Real, RealFrac, Fractional)
newtype ProjectKey = ProjectKey { getProjectKey :: String }
deriving (Show, Eq, Data, Ord, IsString)
-- |Structure of a project expression
data ProjectExpr = Sum (NE.NonEmpty ProjectExpr)
@ -109,38 +117,38 @@ bindingTitle (BindingExpr ProjectProperties { title=t} _) = t
cost ∷ ProjectSystem → ProjectExpr → Cost
cost sys (Reference n) =
case M.lookup n (bindings sys) of
Just (BindingAtomic _ c _ p) -> c * (1-p) -- cost is weighted by remaining progress
Just (BindingAtomic _ (Cost c) _ (Progress p)) -> Cost $ c * (1 - p) -- cost is weighted by remaining progress
Just (BindingExpr _ p) -> cost sys p -- TODO:0 avoid cyclic
Nothing -> defaultCost -- mentioned but no props neither task defined
cost sys (Sequence ps) = costConjunction sys ps
cost sys (Product ps) = costConjunction sys ps
cost sys (Sum ps) =
sum $ map (\x -> (1 - snd x) * fst x) $ zip costs accTrusts
Cost $ sum $ map (\x -> (1 - snd x) * fst x) $ zip costs accTrusts
where
accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ trust sys <$> ps
costs = NE.toList $ cost sys <$> ps
costs = NE.toList $ (getCost . cost sys) <$> ps
accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ (getTrust . trust sys) <$> ps
costConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Cost
costConjunction sys ps =
sum $ zipWith (*) costs accTrusts
Cost $ sum $ zipWith (*) costs accTrusts
where
costs = NE.toList $ cost sys <$> ps
accTrusts = NE.toList $ product <$> NE.inits (trust sys <$> ps)
costs = NE.toList $ (getCost . cost sys) <$> ps
accTrusts = NE.toList $ product <$> NE.inits ((getTrust . trust sys) <$> ps)
-- | Expected probability of succeeding
trust ∷ ProjectSystem → ProjectExpr → Trust
trust sys (Reference n) =
case M.lookup n (bindings sys) of
Just (BindingAtomic _ _ t p) -> p + t * (1-p)
Just (BindingAtomic _ _ (Trust t) (Progress p)) -> Trust $ p + t * (1-p)
Just (BindingExpr _ p) -> trust sys p -- TODO:10 avoid cyclic
Nothing -> defaultTrust -- mentioned but no props neither task defined
trust sys (Sequence ps) = trustConjunction sys ps
trust sys (Product ps) = trustConjunction sys ps
trust sys (Sum ps) =
foldl (\a b -> a + b*(1-a)) 0 $ trust sys <$> ps
Trust $ foldl (\a b -> a + b*(1-a)) 0 $ (getTrust . trust sys) <$> ps
trustConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Trust
trustConjunction sys ps = product $ trust sys <$> ps
trustConjunction sys ps = Trust $ product $ (getTrust . trust sys) <$> ps
progress ∷ ProjectSystem → ProjectExpr → Progress
progress sys (Reference n) =
@ -190,10 +198,10 @@ prioritizeSys sys = everywhere (mkT $ prioritizeProj sys) sys
-- |Sort project in order that minimizes cost
prioritizeProj ∷ ProjectSystem → ProjectExpr → ProjectExpr
prioritizeProj sys (Sum ps) =
let f p = cost sys p / trust sys p
let f p = getCost (cost sys p) / getTrust (trust sys p)
in Sum $ NE.sortWith (nanToInf . f) $ prioritizeProj sys <$> ps
prioritizeProj sys (Product ps) =
let f p = cost sys p / (1 - trust sys p)
let f p = getCost (cost sys p) / (1 - getTrust (trust sys p))
in Product $ NE.sortWith (nanToInf . f) $ prioritizeProj sys <$> ps
prioritizeProj _ p = p

12
src/MasterPlan/Internal/Debug.hs
View File

@ -22,10 +22,11 @@ debugSys ∷ ProjectSystem → IO ()
debugSys sys@(ProjectSystem bs) = void $ M.traverseWithKey printBinding bs
where
printBinding key b = do putStrLn "-------------------"
putStr $ key ++ " = "
putStr $ getProjectKey key ++ " = "
case b of
BindingExpr _ e -> putStr "\n" >> debugProj sys e
BindingAtomic _ c t p -> putStrLn $ printf "(c:%.2f,t:%.2f,p:%2.f)" c t p
BindingAtomic _ (Cost c) (Trust t) (Progress p) ->
putStrLn $ printf "(c:%.2f,t:%.2f,p:%2.f)" c t p
-- |Print a Project Expression in a Project System to standard output.
-- The expression is printed in a tree like fashion.
@ -36,9 +37,12 @@ debugProj sys = print' 0
ident il = replicateM_ il $ putStr " |"
print' ∷ Int → ProjectExpr → IO ()
print' il p@(Reference n) = ident il >> putStr ("-" ++ n ++ " ") >> ctp p
print' il p@(Reference (ProjectKey n)) = ident il >> putStr ("-" ++ n ++ " ") >> ctp p
print' il p@(Sum ps) = ident il >> putStr "-+ " >> ctp p >> forM_ ps (print' $ il+1)
print' il p@(Sequence ps) = ident il >> putStr "-> " >> ctp p >> forM_ ps (print' $ il+1)
print' il p@(Product ps) = ident il >> putStr "-* " >> ctp p >> forM_ ps (print' $ il+1)
ctp p = putStrLn $ printf " c=%.2f t=%.2f p=%.2f" (cost sys p) (trust sys p) (progress sys p)
ctp p = putStrLn $ printf " c=%.2f t=%.2f p=%.2f"
(getCost $ cost sys p)
(getTrust $ trust sys p)
(getProgress $ progress sys p)

26
src/MasterPlan/Parser.hs
View File

@ -7,13 +7,13 @@ Maintainer : rodrigosetti@gmail.com
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnicodeSyntax #-}
module MasterPlan.Parser (runParser) where
import Control.Monad.State
import Control.Applicative (empty)
import Control.Monad.State
import Data.Generics hiding (empty)
import Data.List (nub)
import qualified Data.List.NonEmpty as NE
@ -50,8 +50,8 @@ rws = map show [minBound :: ProjAttribute ..]
identifier ∷ Parser String
identifier = (lexeme . try) $ (:) <$> letterChar <*> many alphaNumChar
nonKeywordIdentifier :: Parser String
nonKeywordIdentifier = identifier >>= check
projectKey :: Parser ProjectKey
projectKey = ProjectKey <$> (identifier >>= check) <?> "project key"
where
check x
| x `elem` rws = fail $ "keyword " ++ show x ++ " cannot be an identifier"
@ -73,7 +73,7 @@ expression ∷ Parser ProjectExpr
expression =
simplifyProj <$> makeExprParser term table <?> "expression"
where
term = parens expression <|> (Reference <$> nonKeywordIdentifier)
term = parens expression <|> (Reference <$> projectKey)
table = [[binary "*" (combineWith Product)]
,[binary "->" (combineWith Sequence)]
,[binary "+" (combineWith Sum)]]
@ -105,9 +105,9 @@ binding key = do (props, mc, mt, mp) <- try simpleTitle <|> try bracketAttribute
simpleTitle = do s <- stringLiteral <?> "title"
pure (defaultProjectProps {title=s}, Nothing, Nothing, Nothing)
bracketAttributes = symbol "{" *> attributes (defaultProjectProps {title=key}) Nothing Nothing Nothing
bracketAttributes = symbol "{" *> attributes (defaultProjectProps {title=getProjectKey key}) Nothing Nothing Nothing
noAttributes = pure (defaultProjectProps {title=key}, Nothing, Nothing, Nothing)
noAttributes = pure (defaultProjectProps {title=getProjectKey key}, Nothing, Nothing, Nothing)
attributes :: ProjectProperties -> Maybe Cost -> Maybe Trust -> Maybe Progress
-> Parser (ProjectProperties, Maybe Cost, Maybe Trust, Maybe Progress)
@ -127,13 +127,13 @@ binding key = do (props, mc, mt, mp) <- try simpleTitle <|> try bracketAttribute
s <- stringLiteral <?> "owner"
attributes (props {owner=Just s}) mc mt mp
PCost -> do when (isJust mc) $ fail "redefinition of cost"
c <- nonNegativeNumber <?> "cost"
c <- Cost <$> nonNegativeNumber <?> "cost"
attributes props (Just c) mt mp
PTrust -> do when (isJust mt) $ fail "redefinition of cost"
t <- percentage <?> "trust"
t <- Trust <$> percentage <?> "trust"
attributes props mc (Just t) mp
PProgress -> do when (isJust mp) $ fail "redefinition of progress"
p <- percentage <?> "progress"
p <- Progress <$> percentage <?> "progress"
attributes props mc mt (Just p)
@ -150,13 +150,13 @@ projectSystem =
where
mkProjSystem = ProjectSystem . M.fromList
definitions ds = do key <- sc *> nonKeywordIdentifier <?> "project key"
when (key `elem` map fst ds) $ fail $ "redefinition of \"" ++ key ++ "\""
definitions ds = do key <- sc *> projectKey
when (key `elem` map fst ds) $ fail $ "redefinition of \"" ++ getProjectKey key ++ "\""
b <- binding key <* symbol ";"
-- check if it's recursive
let deps = dependencies (mkProjSystem ds) b
when (key `elem` deps) $ fail $ "definition of \"" ++ key ++ "\" is recursive"
when (key `elem` deps) $ fail $ "definition of \"" ++ getProjectKey key ++ "\" is recursive"
let ds' = (key,b):ds
(try eof *> pure ds') <|> definitions ds'

11
test/MasterPlan/Arbitrary.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnicodeSyntax #-}
module MasterPlan.Arbitrary () where
@ -20,7 +21,7 @@ instance Arbitrary ProjectProperties where
(if isNothing (url p) then [] else [p { url = Nothing }]) ++
(if isNothing (owner p) then [] else [p { owner = Nothing }])
testingKeys ∷ [String]
testingKeys ∷ [ProjectKey]
testingKeys = ["a", "b", "c", "d"]
instance Arbitrary ProjectSystem where
@ -32,7 +33,7 @@ instance Arbitrary ProjectSystem where
shrink (ProjectSystem bs) =
map ProjectSystem $ concatMap shrinkOne testingKeys
where
shrinkOne ∷ String → [M.Map String Binding]
shrinkOne ∷ ProjectKey → [M.Map ProjectKey Binding]
shrinkOne k = case M.lookup k bs of
Nothing -> []
Just b -> map (\s -> M.adjust (const s) k bs) $ shrink b
@ -44,9 +45,9 @@ instance Arbitrary Binding where
arbitrary =
let unitGen = elements [0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0]
in BindingAtomic <$> arbitrary
<*> elements [0, 1 .. 100]
<*> unitGen
<*> unitGen
<*> (Cost <$> elements [0, 1 .. 100])
<*> (Trust <$> unitGen)
<*> (Progress <$> unitGen)
shrink (BindingExpr pr e) = map (BindingExpr pr) $ shrink e
shrink _ = []

15
test/MasterPlan/DataSpec.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnicodeSyntax #-}
module MasterPlan.DataSpec (spec) where
@ -11,8 +12,8 @@ import MasterPlan.Data
import System.Random
import System.Random.Shuffle (shuffle')
import Test.Hspec
import Test.QuickCheck hiding (sample)
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck hiding (sample)
-- |Sample the simulation model of the execution of a project.
-- It's a stateful computation with the random generator, which computes
@ -21,12 +22,12 @@ import Test.Hspec.QuickCheck (prop)
simulate ∷ RandomGen g ⇒ ProjectSystem → ProjectExpr → State g (Bool, Cost)
simulate sys (Reference n) =
case M.lookup n (bindings sys) of
Just (BindingAtomic _ c t p) ->
Just (BindingAtomic _ (Cost c) (Trust t) (Progress p)) ->
do r <- state $ randomR (0, 1)
let remainingProgress = 1 - p
effectiveTrust = p + t * remainingProgress
effectiveCost = c * remainingProgress
pure (effectiveTrust > r, effectiveCost)
pure (effectiveTrust > r, Cost effectiveCost)
Just (BindingExpr _ p) -> simulate sys p -- TODO:30 avoid cyclic
Nothing -> pure (True, defaultCost)
@ -65,7 +66,7 @@ monteCarloTrustAndCost n sys p = do results <- replicateM n $ simulate sys p
pure (sum trusts / fromIntegral n,
sum costs / fromIntegral n)
aproximatelyEqual ∷ Float -> Float -> Float → Float -> Property
aproximatelyEqual ∷ (Show a, Real a, Fractional a) => a -> a -> a → a -> Property
aproximatelyEqual alpha beta x y =
counterexample (show x ++ " /= " ++ show y) $ diff <= max relError beta
where
@ -78,7 +79,8 @@ spec = do
let g = mkStdGen 837183
let eq = aproximatelyEqual 0.05 0.05
let eq :: (Show a, Real a, Fractional a) => a -> a -> Property
eq = aproximatelyEqual 0.05 0.05
prop "monte-carlo and analytical implementations should agree" $ do
let p = Reference "root"
@ -92,7 +94,8 @@ spec = do
describe "simplification" $ do
let eq = aproximatelyEqual 0.005 0.005
let eq :: (Show a, Real a, Fractional a) => a -> a -> Property
eq = aproximatelyEqual 0.005 0.005
prop "is irreductible" $ do
let simplificationIsIrreductible :: ProjectExpr -> Property