mirror of
https://github.com/rodrigosetti/master-plan.git
synced 2024-11-22 04:13:26 +03:00
rename and refactor places in code
This commit is contained in:
Rodrigo Setti
parent
cefad4ecbb
commit
99540dff2d
44
app/Main.hs
44
app/Main.hs
@ -10,26 +10,26 @@ Portability : POSIX
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
module Main (main) where
|
||||
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Semigroup ((<>))
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Semigroup ((<>))
|
||||
import qualified Data.Text.IO as TIO
|
||||
import MasterPlan.Backend.Graph
|
||||
import MasterPlan.Data
|
||||
import qualified MasterPlan.Parser as P
|
||||
import qualified MasterPlan.Parser as P
|
||||
import Options.Applicative
|
||||
import System.IO (hPutStr, stderr, stdin)
|
||||
import System.IO (hPutStr, stderr, stdin)
|
||||
|
||||
-- |Type output from the command line parser
|
||||
data Opts = Opts { inputPath :: Maybe FilePath
|
||||
, outputPath :: Maybe FilePath
|
||||
, projFilter :: ProjFilter -- ^ filter to consider
|
||||
, renderOptions :: RenderOptions }
|
||||
data Opts = Opts { inputPath :: Maybe FilePath
|
||||
, outputPath :: Maybe FilePath
|
||||
, projFilter :: ProjFilter -- ^ filter to consider
|
||||
, renderOptions :: RenderOptions }
|
||||
deriving (Show)
|
||||
|
||||
newtype ProjFilter = ProjFilter (ProjectSystem -> Project → Bool)
|
||||
newtype ProjFilter = ProjFilter (ProjectSystem → ProjectExpr → Bool)
|
||||
|
||||
noFilter ∷ ProjFilter
|
||||
noFilter = ProjFilter $ const $ const True
|
||||
@ -51,7 +51,7 @@ cmdParser = Opts <$> optional (strArgument ( help "plan file to read from (defau
|
||||
<*> (filterParser <|> pure noFilter)
|
||||
<*> renderOptionsParser
|
||||
where
|
||||
renderOptionsParser :: Parser RenderOptions
|
||||
renderOptionsParser ∷ Parser RenderOptions
|
||||
renderOptionsParser = RenderOptions <$> switch ( long "color"
|
||||
<> short 'c'
|
||||
<> help "color each project by progress")
|
||||
@ -94,16 +94,16 @@ main = masterPlan =<< execParser opts
|
||||
<> progDesc "See documentation on how to write project plan files"
|
||||
<> header "master-plan - project management tool for hackers" )
|
||||
|
||||
filterBinding ∷ ProjectSystem → ProjFilter → ProjectBinding → Maybe ProjectBinding
|
||||
filterBinding sys (ProjFilter f) (ExpressionProj r e) = ExpressionProj r <$> filterProj e
|
||||
filterBinding ∷ ProjectSystem → ProjFilter → Binding → Maybe Binding
|
||||
filterBinding sys (ProjFilter f) (BindingExpr r e) = BindingExpr r <$> filterProj e
|
||||
where
|
||||
filterProj p@(SumProj ps) = filterHelper p ps SumProj
|
||||
filterProj p@(ProductProj ps) = filterHelper p ps ProductProj
|
||||
filterProj p@(SequenceProj ps) = filterHelper p ps SequenceProj
|
||||
filterProj p = if f sys p then Just p else Nothing
|
||||
filterProj p@(Sum ps) = filterHelper p ps Sum
|
||||
filterProj p@(Product ps) = filterHelper p ps Product
|
||||
filterProj p@(Sequence ps) = filterHelper p ps Sequence
|
||||
filterProj p = if f sys p then Just p else Nothing
|
||||
|
||||
filterHelper p ps c = if f sys p then c <$> filterProjs ps else Nothing
|
||||
filterProjs ps = NE.nonEmpty (catMaybes $ NE.toList $ NE.map filterProj ps)
|
||||
filterProjs ps = NE.nonEmpty (catMaybes $ NE.toList $ filterProj <$> ps)
|
||||
|
||||
filterBinding _ _ b = Just b
|
||||
|
||||
@ -113,7 +113,7 @@ masterPlan opts =
|
||||
case P.runParser (fromMaybe "stdin" $ inputPath opts) contents of
|
||||
Left e -> hPutStr stderr e
|
||||
Right sys@(ProjectSystem b) ->
|
||||
do let sys' = optimizeSys $ ProjectSystem $ M.mapMaybe
|
||||
do let sys' = prioritizeSys $ ProjectSystem $ M.mapMaybe
|
||||
(filterBinding sys $ projFilter opts) b
|
||||
let outfile = fromMaybe (fromMaybe "output" (outputPath opts) ++ ".pdf") $ outputPath opts
|
||||
render outfile (renderOptions opts) sys'
|
||||
|
||||
@ -58,6 +58,7 @@ library
|
||||
, MasterPlan.Parser
|
||||
, MasterPlan.Backend.Graph
|
||||
, MasterPlan.Backend.Identity
|
||||
, MasterPlan.Internal.Debug
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
|
||||
@ -15,7 +15,7 @@ Portability : POSIX
|
||||
module MasterPlan.Backend.Graph (render, RenderOptions(..)) where
|
||||
|
||||
import MasterPlan.Data
|
||||
import Diagrams.Prelude hiding (render)
|
||||
import Diagrams.Prelude hiding (render, Product, Sum)
|
||||
import Diagrams.Backend.Rasterific
|
||||
import Data.List (intersperse)
|
||||
import Control.Applicative ((<|>))
|
||||
@ -52,20 +52,20 @@ toRenderModel sys rootK = case M.lookup rootK (bindings sys) of
|
||||
Nothing -> pure Nothing
|
||||
Just b -> Just <$> bindingToRM rootK b
|
||||
where
|
||||
bindingToRM :: ProjectKey -> ProjectBinding -> State [ProjectKey] RenderModel
|
||||
bindingToRM key (ExpressionProj prop p) = projToRM p (Just key) (Just prop)
|
||||
bindingToRM key (TaskProj prop c t p) = pure $ Leaf $ Node (Just key)
|
||||
bindingToRM :: ProjectKey -> Binding -> State [ProjectKey] RenderModel
|
||||
bindingToRM key (BindingExpr prop p) = projToRM p (Just key) (Just prop)
|
||||
bindingToRM key (BindingAtomic prop c t p) = pure $ Leaf $ Node (Just key)
|
||||
(Just prop)
|
||||
c t p
|
||||
bindingToRM key (UnconsolidatedProj prop) = pure $ Leaf $ Node (Just key)
|
||||
bindingToRM key (BindingPlaceholder prop) = pure $ Leaf $ Node (Just key)
|
||||
(Just prop)
|
||||
defaultCost
|
||||
defaultTrust
|
||||
defaultProgress
|
||||
|
||||
mkNode :: (Node -> NE.NonEmpty RenderModel -> RenderModel)
|
||||
-> Project
|
||||
-> NE.NonEmpty Project
|
||||
-> ProjectExpr
|
||||
-> NE.NonEmpty ProjectExpr
|
||||
-> Maybe ProjectKey
|
||||
-> Maybe ProjectProperties
|
||||
-> State [ProjectKey] RenderModel
|
||||
@ -75,11 +75,11 @@ toRenderModel sys rootK = case M.lookup rootK (bindings sys) of
|
||||
(progress sys p))
|
||||
<$> mapM (\p' -> projToRM p' Nothing Nothing) ps
|
||||
|
||||
projToRM :: Project -> Maybe ProjectKey -> Maybe ProjectProperties -> State [ProjectKey] RenderModel
|
||||
projToRM p@(SumProj ps) = mkNode (Tree SumNode) p ps
|
||||
projToRM p@(SequenceProj ps) = mkNode (Tree SequenceNode) p ps
|
||||
projToRM p@(ProductProj ps) = mkNode (Tree ProductNode) p ps
|
||||
projToRM (RefProj n) =
|
||||
projToRM :: ProjectExpr -> Maybe ProjectKey -> Maybe ProjectProperties -> State [ProjectKey] RenderModel
|
||||
projToRM p@(Sum ps) = mkNode (Tree SumNode) p ps
|
||||
projToRM p@(Sequence ps) = mkNode (Tree SequenceNode) p ps
|
||||
projToRM p@(Product ps) = mkNode (Tree ProductNode) p ps
|
||||
projToRM (Reference n) =
|
||||
\k p -> case M.lookup n $ bindings sys of
|
||||
Nothing -> pure $ Leaf $ Node k (p <|> pure defaultProjectProps {title=n}) defaultCost defaultTrust defaultProgress
|
||||
Just b -> do alreadyProcessed <- gets (n `elem`)
|
||||
@ -89,7 +89,7 @@ toRenderModel sys rootK = case M.lookup rootK (bindings sys) of
|
||||
|
||||
-- |how many children
|
||||
treeSize :: Num a => Tree t n -> a
|
||||
treeSize (Tree _ _ ts) = sum $ NE.map treeSize ts
|
||||
treeSize (Tree _ _ ts) = sum $ treeSize <$> ts
|
||||
treeSize _ = 1
|
||||
|
||||
data RenderOptions = RenderOptions { colorByProgress :: Bool
|
||||
@ -103,9 +103,8 @@ data RenderOptions = RenderOptions { colorByProgress :: Bool
|
||||
render ∷ FilePath -> RenderOptions-> ProjectSystem → IO ()
|
||||
render fp (RenderOptions colorByP w h rootK props) sys =
|
||||
let noRootEroor = text $ "no project named \"" ++ rootK ++ "\" found."
|
||||
dia :: QDiagram B V2 Double Any
|
||||
dia = fromMaybe noRootEroor $ renderTree colorByP props <$> evalState (toRenderModel sys rootK) []
|
||||
in renderRasterific fp (dims $ V2 (fromInteger w) (fromInteger h)) $ pad 1.05 $ centerXY dia
|
||||
in renderRasterific fp (dims $ V2 (fromInteger w) (fromInteger h)) $ pad 1.01 $ centerXY dia
|
||||
|
||||
renderTree :: Bool -> [ProjProperty] -> RenderModel -> QDiagram B V2 Double Any
|
||||
renderTree colorByP props (Leaf n) = alignL $ renderNode colorByP props n
|
||||
@ -133,7 +132,7 @@ renderTree colorByP props t@(Tree ty n ts) =
|
||||
|
||||
renderNode :: Bool -> [ProjProperty] -> Node -> QDiagram B V2 Double Any
|
||||
renderNode _ _ (NodeRef n) =
|
||||
text n <> roundedRect 30 12 0.5 # lwO 2 # fc white # dashingN [0.005, 0.005] 0
|
||||
text n <> roundedRect 30 12 0.5 # lwO 2 # fc white # dashingN [0.005, 0.005] 0
|
||||
renderNode colorByP props (Node _ prop c t p) =
|
||||
centerY nodeDia # withEnvelope (rect 30 12 :: D V2 Double)
|
||||
where
|
||||
|
||||
@ -11,11 +11,13 @@ Portability : POSIX
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module MasterPlan.Backend.Identity (render) where
|
||||
|
||||
import Control.Monad.RWS
|
||||
import Control.Monad (when, void)
|
||||
import Control.Monad.RWS (RWS, evalRWS, gets, tell, modify, asks)
|
||||
import Data.Generics
|
||||
import Data.List (nub)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
import Data.Monoid ((<>))
|
||||
import qualified Data.Text as T
|
||||
import Data.Maybe (fromMaybe)
|
||||
import MasterPlan.Data
|
||||
@ -27,7 +29,7 @@ render (ProjectSystem bs) whitelist =
|
||||
where
|
||||
renderRest = gets M.keys >>= mapM_ renderName
|
||||
|
||||
type RenderMonad = RWS [ProjProperty] T.Text (M.Map String ProjectBinding)
|
||||
type RenderMonad = RWS [ProjProperty] T.Text (M.Map String Binding)
|
||||
|
||||
renderLine ∷ T.Text → RenderMonad ()
|
||||
renderLine s = tell $ s <> ";\n"
|
||||
@ -42,10 +44,10 @@ renderName projName =
|
||||
modify $ M.delete projName
|
||||
mapM_ renderName $ dependencies b
|
||||
|
||||
dependencies ∷ ProjectBinding → [ProjectKey]
|
||||
dependencies ∷ Binding → [ProjectKey]
|
||||
dependencies = nub . everything (++) ([] `mkQ` collectDep)
|
||||
where
|
||||
collectDep (RefProj n) = [n]
|
||||
collectDep (Reference n) = [n]
|
||||
collectDep _ = []
|
||||
|
||||
renderProps ∷ String → ProjectProperties → RenderMonad Bool
|
||||
@ -63,9 +65,9 @@ renderProperty projName prop val def toText
|
||||
renderLine $ T.pack (show prop) <> "(" <> T.pack projName <> ") = " <> toText val
|
||||
pure whitelisted
|
||||
|
||||
renderBinding ∷ ProjectKey → ProjectBinding → RenderMonad Bool
|
||||
renderBinding projName (UnconsolidatedProj p) = renderProps projName p
|
||||
renderBinding projName (TaskProj props c t p) =
|
||||
renderBinding ∷ ProjectKey → Binding → RenderMonad Bool
|
||||
renderBinding projName (BindingPlaceholder p) = renderProps projName p
|
||||
renderBinding projName (BindingAtomic props c t p) =
|
||||
or <$> sequence [ renderProps projName props
|
||||
, renderProperty projName PCost c 0 (T.pack . show)
|
||||
, renderProperty projName PTrust t 1 percentage
|
||||
@ -74,7 +76,7 @@ renderBinding projName (TaskProj props c t p) =
|
||||
percentage n = T.pack $ show (n * 100) <> "%"
|
||||
|
||||
|
||||
renderBinding projName (ExpressionProj pr e) =
|
||||
renderBinding projName (BindingExpr pr e) =
|
||||
do void $ renderProps projName pr
|
||||
renderLine $ T.pack projName <> " = " <> expressionToStr False e
|
||||
pure True
|
||||
@ -83,8 +85,8 @@ renderBinding projName (ExpressionProj pr e) =
|
||||
s = T.intercalate (" " <> op <> " ") sube
|
||||
in if parens && length ps > 1 then "(" <> s <> ")" else s
|
||||
|
||||
expressionToStr :: Bool -> Project -> T.Text
|
||||
expressionToStr _ (RefProj n) = T.pack n
|
||||
expressionToStr parens (ProductProj ps) = combinedEToStr parens "*" ps
|
||||
expressionToStr parens (SequenceProj ps) = combinedEToStr parens "->" ps
|
||||
expressionToStr parens (SumProj ps) = combinedEToStr parens "+" ps
|
||||
expressionToStr :: Bool -> ProjectExpr -> T.Text
|
||||
expressionToStr _ (Reference 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
|
||||
|
||||
@ -10,10 +10,10 @@ Portability : POSIX
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
module MasterPlan.Data ( Project(..)
|
||||
module MasterPlan.Data ( ProjectExpr(..)
|
||||
, ProjectProperties(..)
|
||||
, ProjectSystem(..)
|
||||
, ProjectBinding(..)
|
||||
, Binding(..)
|
||||
, ProjectKey
|
||||
, ProjProperty(..)
|
||||
, Trust
|
||||
@ -30,16 +30,13 @@ module MasterPlan.Data ( Project(..)
|
||||
, trust
|
||||
, simplify
|
||||
, simplifyProj
|
||||
, optimizeSys
|
||||
, optimizeProj
|
||||
, printStructure) where
|
||||
, prioritizeSys
|
||||
, prioritizeProj ) where
|
||||
|
||||
import Control.Monad.Writer
|
||||
import Data.Generics
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M (Map, lookup)
|
||||
import Data.Semigroup (sconcat)
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
|
||||
-- * Types
|
||||
|
||||
@ -49,18 +46,18 @@ type Progress = Float
|
||||
type ProjectKey = String
|
||||
|
||||
-- |Structure of a project expression
|
||||
data Project = SumProj (NE.NonEmpty Project)
|
||||
| ProductProj (NE.NonEmpty Project)
|
||||
| SequenceProj (NE.NonEmpty Project)
|
||||
| RefProj ProjectKey
|
||||
data ProjectExpr = Sum (NE.NonEmpty ProjectExpr)
|
||||
| Product (NE.NonEmpty ProjectExpr)
|
||||
| Sequence (NE.NonEmpty ProjectExpr)
|
||||
| Reference ProjectKey
|
||||
deriving (Eq, Show, Data, Typeable)
|
||||
|
||||
-- |A binding of a name can refer to an expression. If there are no
|
||||
-- associated expressions (i.e. equation) then it can have task-level
|
||||
-- properties
|
||||
data ProjectBinding = TaskProj ProjectProperties Cost Trust Progress
|
||||
| ExpressionProj ProjectProperties Project
|
||||
| UnconsolidatedProj ProjectProperties
|
||||
data Binding = BindingAtomic ProjectProperties Cost Trust Progress
|
||||
| BindingExpr ProjectProperties ProjectExpr
|
||||
| BindingPlaceholder ProjectProperties
|
||||
deriving (Eq, Show, Data, Typeable)
|
||||
|
||||
-- |Any binding (with a name) may have associated properties
|
||||
@ -84,7 +81,7 @@ instance Show ProjProperty where
|
||||
|
||||
-- |A project system defines the bindins (mapping from names to expressions or tasks)
|
||||
-- and properties, which can be associated to any binding
|
||||
newtype ProjectSystem = ProjectSystem { bindings :: M.Map ProjectKey ProjectBinding }
|
||||
newtype ProjectSystem = ProjectSystem { bindings :: M.Map ProjectKey Binding }
|
||||
deriving (Eq, Show, Data, Typeable)
|
||||
|
||||
defaultProjectProps ∷ ProjectProperties
|
||||
@ -93,130 +90,113 @@ defaultProjectProps = ProjectProperties { title = "?"
|
||||
, url = Nothing
|
||||
, owner = Nothing }
|
||||
|
||||
defaultCost :: Cost
|
||||
defaultCost ∷ Cost
|
||||
defaultCost = 0
|
||||
|
||||
defaultTrust :: Trust
|
||||
defaultTrust ∷ Trust
|
||||
defaultTrust = 1
|
||||
|
||||
defaultProgress :: Progress
|
||||
defaultProgress ∷ Progress
|
||||
defaultProgress = 0
|
||||
|
||||
defaultTaskProj ∷ ProjectProperties → ProjectBinding
|
||||
defaultTaskProj pr = TaskProj pr defaultCost defaultTrust defaultProgress
|
||||
defaultTaskProj ∷ ProjectProperties → Binding
|
||||
defaultTaskProj pr = BindingAtomic pr defaultCost defaultTrust defaultProgress
|
||||
|
||||
bindingTitle :: ProjectBinding -> String
|
||||
bindingTitle (TaskProj ProjectProperties { title=t} _ _ _) = t
|
||||
bindingTitle (ExpressionProj ProjectProperties { title=t} _) = t
|
||||
bindingTitle (UnconsolidatedProj ProjectProperties { title=t}) = t
|
||||
bindingTitle ∷ Binding → String
|
||||
bindingTitle (BindingAtomic ProjectProperties { title=t} _ _ _) = t
|
||||
bindingTitle (BindingExpr ProjectProperties { title=t} _) = t
|
||||
bindingTitle (BindingPlaceholder ProjectProperties { title=t}) = t
|
||||
|
||||
-- | Expected cost
|
||||
cost ∷ ProjectSystem → Project → Cost
|
||||
cost sys (RefProj n) =
|
||||
cost ∷ ProjectSystem → ProjectExpr → Cost
|
||||
cost sys (Reference n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just (TaskProj _ c _ p) -> c * (1-p) -- cost is weighted by remaining progress
|
||||
Just (ExpressionProj _ p) -> cost sys p -- TODO: avoid cyclic
|
||||
Just (UnconsolidatedProj _) -> defaultCost -- mentioned but no props neither task defined
|
||||
Nothing -> defaultCost -- mentioned but no props neither task defined
|
||||
cost sys (SequenceProj ps) = costConjunction sys ps
|
||||
cost sys (ProductProj ps) = costConjunction sys ps
|
||||
cost sys (SumProj ps) =
|
||||
Just (BindingAtomic _ c _ p) -> c * (1-p) -- cost is weighted by remaining progress
|
||||
Just (BindingExpr _ p) -> cost sys p -- TODO: avoid cyclic
|
||||
Just (BindingPlaceholder _) -> defaultCost -- mentioned but no props neither task defined
|
||||
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
|
||||
where
|
||||
accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ NE.map (trust sys) ps
|
||||
costs = NE.toList $ NE.map (cost sys) ps
|
||||
accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ trust sys <$> ps
|
||||
costs = NE.toList $ cost sys <$> ps
|
||||
|
||||
costConjunction ∷ ProjectSystem → NE.NonEmpty Project → Cost
|
||||
costConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Cost
|
||||
costConjunction sys ps =
|
||||
sum $ zipWith (*) costs accTrusts
|
||||
where
|
||||
costs = NE.toList $ NE.map (cost sys) ps
|
||||
accTrusts = NE.toList $ NE.map product $ NE.inits $ NE.map (trust sys) ps
|
||||
costs = NE.toList $ cost sys <$> ps
|
||||
accTrusts = NE.toList $ product <$> NE.inits (trust sys <$> ps)
|
||||
|
||||
-- | Expected probability of succeeding
|
||||
trust ∷ ProjectSystem → Project → Trust
|
||||
trust sys (RefProj n) =
|
||||
trust ∷ ProjectSystem → ProjectExpr → Trust
|
||||
trust sys (Reference n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just (TaskProj _ _ t p) -> p + t * (1-p)
|
||||
Just (ExpressionProj _ p) -> trust sys p -- TODO: avoid cyclic
|
||||
Just (UnconsolidatedProj _) -> defaultTrust -- mentioned but no props neither task defined
|
||||
Nothing -> defaultTrust -- mentioned but no props neither task defined
|
||||
trust sys (SequenceProj ps) = trustConjunction sys ps
|
||||
trust sys (ProductProj ps) = trustConjunction sys ps
|
||||
trust sys (SumProj ps) =
|
||||
foldl (\a b -> a + b*(1-a)) 0 $ NE.map (trust sys) ps
|
||||
Just (BindingAtomic _ _ t p) -> p + t * (1-p)
|
||||
Just (BindingExpr _ p) -> trust sys p -- TODO: avoid cyclic
|
||||
Just (BindingPlaceholder _) -> defaultTrust -- mentioned but no props neither task defined
|
||||
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
|
||||
|
||||
trustConjunction ∷ ProjectSystem → NE.NonEmpty Project → Trust
|
||||
trustConjunction sys ps = product $ NE.map (trust sys) ps
|
||||
trustConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Trust
|
||||
trustConjunction sys ps = product $ trust sys <$> ps
|
||||
|
||||
progress ∷ ProjectSystem → Project → Progress
|
||||
progress sys (RefProj n) =
|
||||
progress ∷ ProjectSystem → ProjectExpr → Progress
|
||||
progress sys (Reference n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just (TaskProj _ _ _ p) -> p
|
||||
Just (ExpressionProj _ p) -> progress sys p -- TODO: avoid cyclic
|
||||
Just (UnconsolidatedProj _) -> defaultProgress -- props without task or expression
|
||||
Nothing -> defaultProgress -- mentioned but no props neither task defined
|
||||
progress sys (SequenceProj ps) = progressConjunction sys ps
|
||||
progress sys (ProductProj ps) = progressConjunction sys ps
|
||||
progress sys (SumProj ps) = maximum $ NE.map (progress sys) ps
|
||||
Just (BindingAtomic _ _ _ p) -> p
|
||||
Just (BindingExpr _ p) -> progress sys p -- TODO: avoid cyclic
|
||||
Just (BindingPlaceholder _) -> defaultProgress -- props without task or expression
|
||||
Nothing -> defaultProgress -- mentioned but no props neither task defined
|
||||
progress sys (Sequence ps) = progressConjunction sys ps
|
||||
progress sys (Product ps) = progressConjunction sys ps
|
||||
progress sys (Sum ps) = maximum $ progress sys <$> ps
|
||||
|
||||
progressConjunction ∷ ProjectSystem → NE.NonEmpty Project → Progress
|
||||
progressConjunction sys ps = sum (NE.map (progress sys) ps) / fromIntegral (length ps)
|
||||
progressConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Progress
|
||||
progressConjunction sys ps = sum (progress sys <$> ps) / fromIntegral (length ps)
|
||||
|
||||
-- |Simplify a project binding structure
|
||||
simplify ∷ ProjectSystem → ProjectSystem
|
||||
simplify = everywhere (mkT simplifyProj)
|
||||
|
||||
-- |Helper function: concatMap for NonEmpty
|
||||
neConcatMap ∷ (a → NE.NonEmpty b) → NE.NonEmpty a → NE.NonEmpty b
|
||||
neConcatMap f = sconcat . NE.map f
|
||||
|
||||
-- |Simplify a project expression structure
|
||||
-- 1) transform singleton collections into it's only child
|
||||
-- 2) flatten same constructor of the collection
|
||||
simplifyProj ∷ Project → Project
|
||||
simplifyProj (SumProj (p :| [])) = simplifyProj p
|
||||
simplifyProj (ProductProj (p :| [])) = simplifyProj p
|
||||
simplifyProj (SequenceProj (p :| [])) = simplifyProj p
|
||||
simplifyProj (SumProj ps) =
|
||||
SumProj $ neConcatMap (reduce . simplifyProj) ps
|
||||
simplifyProj ∷ ProjectExpr → ProjectExpr
|
||||
simplifyProj (Sum (p :| [])) = simplifyProj p
|
||||
simplifyProj (Product (p :| [])) = simplifyProj p
|
||||
simplifyProj (Sequence (p :| [])) = simplifyProj p
|
||||
simplifyProj (Sum ps) =
|
||||
Sum $ (reduce . simplifyProj) =<< ps
|
||||
where
|
||||
reduce (SumProj ps') = neConcatMap reduce ps'
|
||||
reduce (Sum ps') = reduce =<< ps'
|
||||
reduce p = [simplifyProj p]
|
||||
simplifyProj (Product ps) =
|
||||
Product $ (reduce . simplifyProj) =<< ps
|
||||
where
|
||||
reduce (Product ps') = reduce =<< ps'
|
||||
reduce p = [simplifyProj p]
|
||||
simplifyProj (ProductProj ps) =
|
||||
ProductProj $ neConcatMap (reduce . simplifyProj) ps
|
||||
simplifyProj (Sequence ps) =
|
||||
Sequence $ (reduce . simplifyProj) =<< ps
|
||||
where
|
||||
reduce (ProductProj ps') = neConcatMap reduce ps'
|
||||
reduce p = [simplifyProj p]
|
||||
simplifyProj (SequenceProj ps) =
|
||||
SequenceProj $ neConcatMap (reduce . simplifyProj) ps
|
||||
where
|
||||
reduce (SequenceProj ps') = neConcatMap reduce ps'
|
||||
reduce p = [simplifyProj p]
|
||||
simplifyProj p@RefProj {} = p
|
||||
reduce (Sequence ps') = reduce =<< ps'
|
||||
reduce p = [simplifyProj p]
|
||||
simplifyProj p@Reference {} = p
|
||||
|
||||
optimizeSys ∷ ProjectSystem → ProjectSystem
|
||||
optimizeSys sys = everywhere (mkT $ optimizeProj sys) sys
|
||||
prioritizeSys ∷ ProjectSystem → ProjectSystem
|
||||
prioritizeSys sys = everywhere (mkT $ prioritizeProj sys) sys
|
||||
|
||||
-- Sort project in order that minimizes cost
|
||||
optimizeProj ∷ ProjectSystem → Project → Project
|
||||
optimizeProj sys (SumProj ps) =
|
||||
prioritizeProj ∷ ProjectSystem → ProjectExpr → ProjectExpr
|
||||
prioritizeProj sys (Sum ps) =
|
||||
let f p = cost sys p / trust sys p
|
||||
in SumProj $ NE.sortWith f $ NE.map (optimizeProj sys) ps
|
||||
optimizeProj sys (ProductProj ps) =
|
||||
in Sum $ NE.sortWith f $ prioritizeProj sys <$> ps
|
||||
prioritizeProj sys (Product ps) =
|
||||
let f p = cost sys p / (1 - trust sys p)
|
||||
in ProductProj $ NE.sortWith f $ NE.map (optimizeProj sys) ps
|
||||
optimizeProj _ p = p
|
||||
|
||||
-- |Debugging
|
||||
printStructure ∷ Project → String
|
||||
printStructure = execWriter . print' 0
|
||||
where
|
||||
ident ∷ Int → Writer String ()
|
||||
ident il = replicateM_ il $ tell " |"
|
||||
|
||||
print' ∷ Int → Project → Writer String ()
|
||||
print' il (RefProj n) = ident il >> tell ("-" ++ n ++ "\n")
|
||||
print' il (SumProj ps) = ident il >> tell "-+\n" >> forM_ ps (print' $ il+1)
|
||||
print' il (SequenceProj ps) = ident il >> tell "->\n" >> forM_ ps (print' $ il+1)
|
||||
print' il (ProductProj ps) = ident il >> tell "-*\n" >> forM_ ps (print' $ il+1)
|
||||
in Product $ NE.sortWith f $ prioritizeProj sys <$> ps
|
||||
prioritizeProj _ p = p
|
||||
|
||||
42
src/MasterPlan/Internal/Debug.hs
Normal file
42
src/MasterPlan/Internal/Debug.hs
Normal file
@ -0,0 +1,42 @@
|
||||
{-|
|
||||
Module : MasterPlan.Internal.Debug
|
||||
Description : Debugging functions
|
||||
Copyright : (c) Rodrigo Setti, 2017
|
||||
License : MIT
|
||||
Maintainer : rodrigosetti@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
module MasterPlan.Internal.Debug ( debugSys , debugProj) where
|
||||
|
||||
import Control.Monad (forM_, replicateM_, void)
|
||||
import qualified Data.Map as M
|
||||
import MasterPlan.Data
|
||||
import Text.Printf (printf)
|
||||
|
||||
-- * Debugging
|
||||
|
||||
debugSys ∷ ProjectSystem → IO ()
|
||||
debugSys sys@(ProjectSystem bs) = void $ M.traverseWithKey printBinding bs
|
||||
where
|
||||
printBinding key b = do putStrLn "-------------------"
|
||||
putStr $ 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
|
||||
BindingPlaceholder _ -> putStrLn "?"
|
||||
|
||||
debugProj ∷ ProjectSystem → ProjectExpr → IO ()
|
||||
debugProj sys = print' 0
|
||||
where
|
||||
ident ∷ Int → IO ()
|
||||
ident il = replicateM_ il $ putStr " |"
|
||||
|
||||
print' ∷ Int → ProjectExpr → IO ()
|
||||
print' il p@(Reference 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:%2.f)" (cost sys p) (trust sys p) (progress sys p)
|
||||
@ -74,9 +74,9 @@ definition =
|
||||
, propsProp PDescription stringLiteral (\v p -> p { description = Just v})
|
||||
, propsProp PUrl stringLiteral (\v p -> p { url = Just v})
|
||||
, propsProp POwner stringLiteral (\v p -> p { owner = Just v})
|
||||
, taskProp PCost nonNegativeNumber (\v b -> case b of TaskProj r _ t p -> TaskProj r v t p; _ -> b)
|
||||
, taskProp PTrust percentage (\v b -> case b of TaskProj r c _ p -> TaskProj r c v p; _ -> b)
|
||||
, taskProp PProgress percentage (\v b -> case b of TaskProj r c t _ -> TaskProj r c t v; _ -> b)
|
||||
, taskProp PCost nonNegativeNumber (\v b -> case b of BindingAtomic r _ t p -> BindingAtomic r v t p; _ -> b)
|
||||
, taskProp PTrust percentage (\v b -> case b of BindingAtomic r c _ p -> BindingAtomic r c v p; _ -> b)
|
||||
, taskProp PProgress percentage (\v b -> case b of BindingAtomic r c t _ -> BindingAtomic r c t v; _ -> b)
|
||||
, structure ] :: [Parser ()])
|
||||
where
|
||||
structure :: Parser ()
|
||||
@ -90,10 +90,10 @@ definition =
|
||||
|
||||
let binding = M.lookup projName $ bindings sys
|
||||
newBinding <- case binding of
|
||||
Nothing -> pure $ ExpressionProj (defaultProjectProps { title=projName }) projectExpr
|
||||
Just ExpressionProj {} -> fail $ "Redefinition of \"" ++ projName ++ "\"."
|
||||
Just (UnconsolidatedProj p) -> pure $ ExpressionProj p projectExpr
|
||||
Just TaskProj {} -> fail $ "Project \"" ++ projName ++ "\" is atomic"
|
||||
Nothing -> pure $ BindingExpr (defaultProjectProps { title=projName }) projectExpr
|
||||
Just BindingExpr {} -> fail $ "Redefinition of \"" ++ projName ++ "\"."
|
||||
Just (BindingPlaceholder p) -> pure $ BindingExpr p projectExpr
|
||||
Just BindingAtomic {} -> fail $ "ProjectExpr \"" ++ projName ++ "\" is atomic"
|
||||
|
||||
lift $ put $ sys { bindings = M.insert projName newBinding $ bindings sys }
|
||||
|
||||
@ -101,19 +101,19 @@ definition =
|
||||
propsProp prop valueParser modifier =
|
||||
property prop valueParser setter
|
||||
where
|
||||
setter projName val Nothing = pure $ UnconsolidatedProj $ modifier val $ defaultProjectProps { title=projName }
|
||||
setter projName val Nothing = pure $ BindingPlaceholder $ modifier val $ defaultProjectProps { title=projName }
|
||||
setter _ val (Just p) = pure $ everywhere (mkT $ modifier val) p
|
||||
|
||||
taskProp :: ProjProperty -> Parser a -> (a -> ProjectBinding -> ProjectBinding) -> Parser ()
|
||||
taskProp :: ProjProperty -> Parser a -> (a -> Binding -> Binding) -> Parser ()
|
||||
taskProp prop valueParser modifier =
|
||||
property prop valueParser setter
|
||||
where
|
||||
setter projName val Nothing = pure $ modifier val $ defaultTaskProj defaultProjectProps { title=projName }
|
||||
setter projName _ (Just ExpressionProj {}) = fail $ "Project \"" ++ projName ++ "\" is not atomic."
|
||||
setter _ val (Just (UnconsolidatedProj p)) = pure $ modifier val $ defaultTaskProj p
|
||||
setter _ val (Just p@TaskProj {}) = pure $ modifier val p
|
||||
setter projName _ (Just BindingExpr {}) = fail $ "ProjectExpr \"" ++ projName ++ "\" is not atomic."
|
||||
setter _ val (Just (BindingPlaceholder p)) = pure $ modifier val $ defaultTaskProj p
|
||||
setter _ val (Just p@BindingAtomic {}) = pure $ modifier val p
|
||||
|
||||
property ∷ ProjProperty → Parser a → (String -> a -> Maybe ProjectBinding -> Parser ProjectBinding) -> Parser ()
|
||||
property ∷ ProjProperty → Parser a → (String -> a -> Maybe Binding -> Parser Binding) -> Parser ()
|
||||
property prop valueParser setter =
|
||||
do void $ symbol $ T.pack $ show prop
|
||||
projName <- parens identifier
|
||||
@ -124,23 +124,23 @@ definition =
|
||||
modifySys sys = sys { bindings = M.insert projName newBinding $ bindings sys }
|
||||
lift $ modify modifySys
|
||||
|
||||
expressionParser ∷ Parser Project
|
||||
expressionParser ∷ Parser ProjectExpr
|
||||
expressionParser =
|
||||
simplifyProj <$> makeExprParser term table <?> "expression"
|
||||
where
|
||||
term = parens expressionParser <|> (RefProj <$> identifier)
|
||||
table = [[binary "*" (combineWith ProductProj)]
|
||||
,[binary "->" (combineWith SequenceProj)]
|
||||
,[binary "+" (combineWith SumProj)]]
|
||||
term = parens expressionParser <|> (Reference <$> identifier)
|
||||
table = [[binary "*" (combineWith Product)]
|
||||
,[binary "->" (combineWith Sequence)]
|
||||
,[binary "+" (combineWith Sum)]]
|
||||
binary op f = InfixL (f <$ symbol op)
|
||||
|
||||
combineWith :: (NE.NonEmpty Project -> Project) -> Project -> Project -> Project
|
||||
combineWith :: (NE.NonEmpty ProjectExpr -> ProjectExpr) -> ProjectExpr -> ProjectExpr -> ProjectExpr
|
||||
combineWith c p1 p2 = c $ p1 NE.<| [p2]
|
||||
|
||||
dependencies ∷ ProjectSystem -> Project → [ProjectKey]
|
||||
dependencies ∷ ProjectSystem -> ProjectExpr → [ProjectKey]
|
||||
dependencies sys = everything (++) ([] `mkQ` collectDep)
|
||||
where
|
||||
collectDep (RefProj n) = nub $ n : everything (++) ([] `mkQ` collectDep) (M.lookup n $ bindings sys)
|
||||
collectDep (Reference n) = nub $ n : everything (++) ([] `mkQ` collectDep) (M.lookup n $ bindings sys)
|
||||
collectDep _ = []
|
||||
|
||||
projectSystem :: Parser ProjectSystem
|
||||
|
||||
@ -26,42 +26,42 @@ testingKeys = ["a", "b", "c", "d"]
|
||||
instance Arbitrary ProjectSystem where
|
||||
|
||||
arbitrary = do bs <- replicateM (length testingKeys) arbitrary
|
||||
rootB <- ExpressionProj <$> arbitrary <*> arbitrary
|
||||
rootB <- BindingExpr <$> arbitrary <*> arbitrary
|
||||
pure $ ProjectSystem $ M.insert "root" rootB $ M.fromList $ zip testingKeys bs
|
||||
|
||||
shrink (ProjectSystem bs) =
|
||||
map ProjectSystem $ concatMap shrinkOne testingKeys
|
||||
where
|
||||
shrinkOne ∷ String → [M.Map String ProjectBinding]
|
||||
shrinkOne ∷ String → [M.Map String Binding]
|
||||
shrinkOne k = case M.lookup k bs of
|
||||
Nothing -> []
|
||||
Just b -> map (\s -> M.adjust (const s) k bs) $ shrink b
|
||||
|
||||
instance Arbitrary ProjectBinding where
|
||||
instance Arbitrary Binding where
|
||||
|
||||
-- NOTE: ProjectBinding arbitrary are always tasks (no expression)
|
||||
-- NOTE: Binding arbitrary are always tasks (no expression)
|
||||
-- to avoid generating cycles
|
||||
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 frequency [ (50, TaskProj <$> arbitrary
|
||||
in frequency [ (50, BindingAtomic <$> arbitrary
|
||||
<*> elements [0, 1 .. 100]
|
||||
<*> unitGen
|
||||
<*> unitGen)
|
||||
, (1, pure $ UnconsolidatedProj defaultProjectProps) ]
|
||||
, (1, pure $ BindingPlaceholder defaultProjectProps) ]
|
||||
|
||||
shrink (ExpressionProj pr e) = map (ExpressionProj pr) $ shrink e
|
||||
shrink (BindingExpr pr e) = map (BindingExpr pr) $ shrink e
|
||||
shrink _ = []
|
||||
|
||||
instance Arbitrary Project where
|
||||
instance Arbitrary ProjectExpr where
|
||||
|
||||
arbitrary =
|
||||
let shrinkFactor n = 3 * n `quot` 5
|
||||
in frequency [ (1, SumProj <$> scale shrinkFactor arbitrary)
|
||||
, (1, ProductProj <$> scale shrinkFactor arbitrary)
|
||||
, (1, SequenceProj <$> scale shrinkFactor arbitrary)
|
||||
, (2, RefProj <$> elements testingKeys) ]
|
||||
in frequency [ (1, Sum <$> scale shrinkFactor arbitrary)
|
||||
, (1, Product <$> scale shrinkFactor arbitrary)
|
||||
, (1, Sequence <$> scale shrinkFactor arbitrary)
|
||||
, (2, Reference <$> elements testingKeys) ]
|
||||
|
||||
shrink (SumProj ps) = NE.toList ps
|
||||
shrink (ProductProj ps) = NE.toList ps
|
||||
shrink (SequenceProj ps) = NE.toList ps
|
||||
shrink (RefProj _) = []
|
||||
shrink (Sum ps) = NE.toList ps
|
||||
shrink (Product ps) = NE.toList ps
|
||||
shrink (Sequence ps) = NE.toList ps
|
||||
shrink (Reference _) = []
|
||||
|
||||
@ -17,25 +17,25 @@ average ∷ RandomGen g ⇒ State g Float → Int → State g Float
|
||||
average sample n = do tot <- replicateM n sample
|
||||
pure $ sum tot / fromIntegral n
|
||||
|
||||
simulate ∷ RandomGen g ⇒ ProjectSystem → Project → State g (Bool, Cost)
|
||||
simulate sys (RefProj n) =
|
||||
simulate ∷ RandomGen g ⇒ ProjectSystem → ProjectExpr → State g (Bool, Cost)
|
||||
simulate sys (Reference n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just (TaskProj _ c t p) ->
|
||||
Just (BindingAtomic _ c t p) ->
|
||||
do r <- state $ randomR (0, 1)
|
||||
let remainingProgress = 1 - p
|
||||
effectiveTrust = p + t * remainingProgress
|
||||
effectiveCost = c * remainingProgress
|
||||
pure (effectiveTrust > r, effectiveCost)
|
||||
Just (ExpressionProj _ p) -> simulate sys p -- TODO: avoid cyclic
|
||||
Just (UnconsolidatedProj _) -> pure (True, 0)
|
||||
Just (BindingExpr _ p) -> simulate sys p -- TODO: avoid cyclic
|
||||
Just (BindingPlaceholder _) -> pure (True, 0)
|
||||
Nothing -> pure (False, 0) -- should not happen
|
||||
|
||||
simulate sys (SequenceProj ps) = simulateConjunction sys $ NE.toList ps
|
||||
simulate sys (ProductProj ps) = simulateConjunction sys $ NE.toList ps
|
||||
simulate sys (SumProj ps) =
|
||||
simulate sys (Sequence ps) = simulateConjunction sys $ NE.toList ps
|
||||
simulate sys (Product ps) = simulateConjunction sys $ NE.toList ps
|
||||
simulate sys (Sum ps) =
|
||||
simulate' $ NE.toList ps
|
||||
where
|
||||
simulate' ∷ RandomGen g ⇒ [Project] → State g (Bool, Cost)
|
||||
simulate' ∷ RandomGen g ⇒ [ProjectExpr] → State g (Bool, Cost)
|
||||
simulate' [] = pure (False, 0)
|
||||
simulate' (p:rest) = do (success, c) <- simulate sys p
|
||||
if success then
|
||||
@ -44,7 +44,7 @@ simulate sys (SumProj ps) =
|
||||
do (success', c') <- simulate' rest
|
||||
pure (success', c + c')
|
||||
|
||||
simulateConjunction ∷ RandomGen g ⇒ ProjectSystem → [Project] → State g (Bool, Cost)
|
||||
simulateConjunction ∷ RandomGen g ⇒ ProjectSystem → [ProjectExpr] → State g (Bool, Cost)
|
||||
simulateConjunction _ [] = pure (True, 0)
|
||||
simulateConjunction sys (p:rest) = do (success, c) <- simulate sys p
|
||||
if success then do
|
||||
@ -53,7 +53,7 @@ simulateConjunction sys (p:rest) = do (success, c) <- simulate sys p
|
||||
else
|
||||
pure (False, c)
|
||||
|
||||
monteCarloTrustAndCost ∷ RandomGen g ⇒ Int → ProjectSystem → Project → State g (Trust, Cost)
|
||||
monteCarloTrustAndCost ∷ RandomGen g ⇒ Int → ProjectSystem → ProjectExpr → State g (Trust, Cost)
|
||||
monteCarloTrustAndCost n sys p = do results <- replicateM n $ simulate sys p
|
||||
let trusts = map (bool 0 1 . fst) results
|
||||
let costs = map snd results
|
||||
@ -81,7 +81,7 @@ spec = do
|
||||
(counterexample "disagree on cost" $ cost' `eq` cost sys p) .&&.
|
||||
(counterexample "disagree on trust" $ trust' `eq` trust sys p)
|
||||
where
|
||||
p = RefProj "root"
|
||||
p = Reference "root"
|
||||
(trust', cost') = evalState (monteCarloTrustAndCost 50000 sys p) g
|
||||
|
||||
property monteCarloAndAnalyticalAgree
|
||||
@ -91,7 +91,7 @@ spec = do
|
||||
let eq = aproximatelyEqual 0.005 0.005
|
||||
|
||||
it "is irreductible" $ do
|
||||
let simplificationIsIrreductible :: Project -> Property
|
||||
let simplificationIsIrreductible :: ProjectExpr -> Property
|
||||
simplificationIsIrreductible p =
|
||||
let p' = simplifyProj p
|
||||
p'' = simplifyProj p'
|
||||
@ -103,33 +103,33 @@ spec = do
|
||||
let propSimplifyIsStable :: ProjectSystem -> Property
|
||||
propSimplifyIsStable sys =
|
||||
let sys' = simplify sys
|
||||
p = RefProj "root"
|
||||
p = Reference "root"
|
||||
in cost sys p `eq` cost sys' p .&&. trust sys p `eq` trust sys' p
|
||||
|
||||
property propSimplifyIsStable
|
||||
|
||||
describe "optimization" $ do
|
||||
|
||||
let shuffleProjs :: NE.NonEmpty Project -> IO (NE.NonEmpty Project)
|
||||
let shuffleProjs :: NE.NonEmpty ProjectExpr -> IO (NE.NonEmpty ProjectExpr)
|
||||
shuffleProjs ps = do ps' <- NE.toList <$> mapM shuffleProj ps
|
||||
g <- newStdGen
|
||||
pure $ NE.fromList $ shuffle' ps' (length ps') g
|
||||
|
||||
shuffleProj :: Project -> IO Project
|
||||
shuffleProj (SumProj ps) = SumProj <$> shuffleProjs ps
|
||||
shuffleProj (ProductProj ps) = ProductProj <$> shuffleProjs ps
|
||||
shuffleProj :: ProjectExpr -> IO ProjectExpr
|
||||
shuffleProj (Sum ps) = Sum <$> shuffleProjs ps
|
||||
shuffleProj (Product ps) = Product <$> shuffleProjs ps
|
||||
shuffleProj p = pure p
|
||||
|
||||
it "minimize cost and keep trust stable" $ do
|
||||
-- This test verifies that for any arbitrary project tree, the
|
||||
-- optimized version of it will have the minimum cost.
|
||||
-- prioritized version of it will have the minimum cost.
|
||||
|
||||
let eq = aproximatelyEqual 0.005 0.005
|
||||
|
||||
let optimizeMinimizesCost :: ProjectSystem -> Property
|
||||
optimizeMinimizesCost sys =
|
||||
let (ExpressionProj _ p) = fromJust $ M.lookup "root" $ bindings sys
|
||||
op = optimizeProj sys p
|
||||
let prioritizeMinimizesCost :: ProjectSystem -> Property
|
||||
prioritizeMinimizesCost sys =
|
||||
let (BindingExpr _ p) = fromJust $ M.lookup "root" $ bindings sys
|
||||
op = prioritizeProj sys p
|
||||
ocost = cost sys op
|
||||
otrust = trust sys op
|
||||
costIsLessOrEqual p' =
|
||||
@ -138,4 +138,4 @@ spec = do
|
||||
in ioProperty $ do variations <- replicateM 10 (shuffleProj p)
|
||||
return $ conjoin (map costIsLessOrEqual variations) .&.
|
||||
conjoin (map trustIsSame variations)
|
||||
property optimizeMinimizesCost
|
||||
property prioritizeMinimizesCost
|
||||
|
||||
Loading…
Reference in New Issue
Block a user