mirror of
https://github.com/rodrigosetti/master-plan.git
synced 2024-11-22 04:13:26 +03:00
refactor data structures
Refactor data structures that represent projects to have a simple expression and an associated bindings in a project system type
This commit is contained in:
Rodrigo Setti
parent
74f102b4a1
commit
69215a35aa
@ -42,6 +42,7 @@ test-suite spec
|
||||
, master-plan
|
||||
, random
|
||||
, mtl
|
||||
, containers
|
||||
, hspec
|
||||
, QuickCheck
|
||||
other-modules: MasterPlan.DataSpec
|
||||
|
||||
@ -3,122 +3,144 @@ module MasterPlan.Data where
|
||||
import Data.Foldable (asum)
|
||||
import Data.List (find, inits)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
type Percentage = Float
|
||||
type Trust = Float
|
||||
type Cost = Float
|
||||
|
||||
-- | properties that common to composed and atomic projects
|
||||
data ProjectProperties = ProjectProperties {
|
||||
name :: String,
|
||||
description :: Maybe[String],
|
||||
url :: Maybe[String],
|
||||
owner :: Maybe[String]
|
||||
} deriving (Eq, Show)
|
||||
type Progress = Float
|
||||
|
||||
data Status = Ready | Blocked | InProgress | Done | Cancelled
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- |Structure of a project expression
|
||||
data Project = SumProj {
|
||||
props :: ProjectProperties,
|
||||
subprojects :: NE.NonEmpty Project
|
||||
} |
|
||||
ProductProj {
|
||||
props :: ProjectProperties,
|
||||
subprojects :: NE.NonEmpty Project
|
||||
} |
|
||||
SequenceProj {
|
||||
props :: ProjectProperties,
|
||||
subprojects :: NE.NonEmpty Project
|
||||
} |
|
||||
TaskProj {
|
||||
props :: ProjectProperties,
|
||||
reportedCost :: Cost,
|
||||
reportedConfidence :: Percentage,
|
||||
reportedStatus :: Status,
|
||||
reportedProgress :: Percentage
|
||||
RefProj {
|
||||
name :: String
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- |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 { props :: ProjectProperties
|
||||
, reportedCost :: Cost
|
||||
, reportedTrust :: Trust
|
||||
, reportedStatus :: Status
|
||||
, reportedProgress :: Progress
|
||||
} |
|
||||
ExpressionProj { props :: ProjectProperties
|
||||
, expression :: Project
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- |Any binding (with a name) may have associated properties
|
||||
data ProjectProperties = ProjectProperties { title :: String
|
||||
, description :: Maybe[String]
|
||||
, url :: Maybe[String]
|
||||
, owner :: Maybe[String]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- |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 String ProjectBinding }
|
||||
deriving (Eq, Show)
|
||||
|
||||
defaultProjectProps :: ProjectProperties
|
||||
defaultProjectProps = ProjectProperties { name = "root"
|
||||
defaultProjectProps = ProjectProperties { title = "root"
|
||||
, description = Nothing
|
||||
, url = Nothing
|
||||
, owner = Nothing }
|
||||
|
||||
defaultTaskProj :: Project
|
||||
defaultTaskProj = TaskProj { props = defaultProjectProps
|
||||
, reportedCost = 0
|
||||
, reportedConfidence = 1
|
||||
, reportedStatus = Ready
|
||||
, reportedProgress = 0 }
|
||||
isOpen :: ProjectSystem -> Project -> Bool
|
||||
isOpen sys p = status sys p `elem` [InProgress, Ready, Blocked]
|
||||
|
||||
isOpen :: Project -> Bool
|
||||
isOpen p = status p `elem` [InProgress, Ready, Blocked]
|
||||
|
||||
isClosed :: Project -> Bool
|
||||
isClosed = not . isOpen
|
||||
isClosed :: ProjectSystem -> Project -> Bool
|
||||
isClosed sys p = not $ isOpen sys p
|
||||
|
||||
-- | Expected cost
|
||||
cost :: Project -> Cost
|
||||
cost TaskProj { reportedCost=c } = c
|
||||
cost SequenceProj { subprojects=ps } = costConjunction $ NE.dropWhile isClosed ps
|
||||
cost ProductProj { subprojects=ps } = costConjunction $ NE.filter isOpen ps
|
||||
cost SumProj { subprojects=s } =
|
||||
final_cost
|
||||
cost :: ProjectSystem -> Project -> Cost
|
||||
cost sys (RefProj n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just TaskProj { reportedCost=c } -> c
|
||||
Just ExpressionProj { expression=p} -> cost sys p -- TODO: avoid cyclic
|
||||
Nothing -> 0 -- should not happen
|
||||
cost sys SequenceProj { subprojects=ps } = costConjunction sys $ NE.dropWhile (isClosed sys) ps
|
||||
cost sys ProductProj { subprojects=ps } = costConjunction sys $ NE.filter (isOpen sys) ps
|
||||
cost sys SumProj { subprojects=s } =
|
||||
sum $ map (\x -> (1 - snd x) * fst x) $ zip costs accTrusts
|
||||
where
|
||||
final_prob = scanl (\a b -> a + b*(1-a)) 0 $ map confidence opens
|
||||
final_cost = sum $ map (\x -> (1 - snd x) * fst x) $ zip costs final_prob
|
||||
costs = map cost opens
|
||||
opens = NE.filter isOpen s
|
||||
accTrusts = scanl (\a b -> a + b*(1-a)) 0 $ map (trust sys) opens
|
||||
costs = map (cost sys) opens
|
||||
opens = NE.filter (isOpen sys) s
|
||||
|
||||
costConjunction :: [Project] -> Cost
|
||||
costConjunction ps =
|
||||
sum $ zipWith (*) costs accConfidences
|
||||
costConjunction :: ProjectSystem -> [Project] -> Cost
|
||||
costConjunction sys ps =
|
||||
sum $ zipWith (*) costs accTrusts
|
||||
where
|
||||
costs = map cost ps
|
||||
accConfidences = map product $ inits $ map confidence ps
|
||||
costs = map (cost sys) ps
|
||||
accTrusts = map product $ inits $ map (trust sys) ps
|
||||
|
||||
-- | Expected confidence probability
|
||||
confidence :: Project -> Percentage
|
||||
confidence TaskProj { reportedConfidence=c } = c
|
||||
confidence SequenceProj { subprojects=ps } = confidenceConjunction $ NE.dropWhile isClosed ps
|
||||
confidence ProductProj { subprojects=ps } = confidenceConjunction $ NE.filter isOpen ps
|
||||
confidence SumProj { subprojects=s } =
|
||||
if null opens then 1 else final_prob
|
||||
-- | Expected trust probability
|
||||
trust :: ProjectSystem -> Project -> Trust
|
||||
trust sys (RefProj n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just TaskProj { reportedTrust=t } -> t
|
||||
Just ExpressionProj { expression=p} -> trust sys p -- TODO: avoid cyclic
|
||||
Nothing -> 0 -- should not happen
|
||||
trust sys SequenceProj { subprojects=ps } = trustConjunction sys $ NE.dropWhile (isClosed sys) ps
|
||||
trust sys ProductProj { subprojects=ps } = trustConjunction sys $ NE.filter (isOpen sys) ps
|
||||
trust sys SumProj { subprojects=s } =
|
||||
if null opens then 1 else accTrusts
|
||||
where
|
||||
final_prob = foldl (\a b -> a + b*(1-a)) 0 $ map confidence opens
|
||||
opens = NE.filter isOpen s
|
||||
accTrusts = foldl (\a b -> a + b*(1-a)) 0 $ map (trust sys) opens
|
||||
opens = NE.filter (isOpen sys) s
|
||||
|
||||
confidenceConjunction :: [Project] -> Percentage
|
||||
confidenceConjunction ps = product $ map confidence ps
|
||||
trustConjunction :: ProjectSystem -> [Project] -> Trust
|
||||
trustConjunction sys ps = product $ map (trust sys) ps
|
||||
|
||||
progress :: Project -> Percentage
|
||||
progress TaskProj { reportedProgress=p, reportedStatus=s } = if s == Done then 1 else p
|
||||
progress SequenceProj { subprojects=s } = progressConjunction s
|
||||
progress ProductProj { subprojects=s } = progressConjunction s
|
||||
progress SumProj { subprojects=s } = maximum $ NE.map progress s
|
||||
progress ::ProjectSystem -> Project -> Progress
|
||||
progress sys (RefProj n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just TaskProj { reportedStatus=Done } -> 1
|
||||
Just TaskProj { reportedProgress=p } -> p
|
||||
Just ExpressionProj { expression=p} -> progress sys p -- TODO: avoid cyclic
|
||||
Nothing -> 0 -- should not happen
|
||||
progress sys SequenceProj { subprojects=s } = progressConjunction sys s
|
||||
progress sys ProductProj { subprojects=s } = progressConjunction sys s
|
||||
progress sys SumProj { subprojects=s } = maximum $ NE.map (progress sys) s
|
||||
|
||||
progressConjunction :: NE.NonEmpty Project -> Percentage
|
||||
progressConjunction ps =
|
||||
let opens = NE.filter isOpen ps
|
||||
progressConjunction :: ProjectSystem -> NE.NonEmpty Project -> Progress
|
||||
progressConjunction sys ps =
|
||||
let opens = NE.filter (isOpen sys) ps
|
||||
in if null opens
|
||||
then 1
|
||||
else sum (map progress opens) / fromIntegral (length opens)
|
||||
else sum (map (progress sys) opens) / fromIntegral (length opens)
|
||||
|
||||
status :: Project -> Status
|
||||
status TaskProj { reportedProgress=p, reportedStatus=s } = if p >= 1 then Done else s
|
||||
status SequenceProj { subprojects=s } =
|
||||
let rest = NE.dropWhile isClosed s
|
||||
in case rest of (p : _) -> status p
|
||||
status :: ProjectSystem -> Project -> Status
|
||||
status sys (RefProj n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just TaskProj { reportedProgress=p, reportedStatus=s } -> if p>=1 then Done else s
|
||||
Just ExpressionProj { expression=p} -> status sys p -- TODO: avoid cyclic
|
||||
Nothing -> Cancelled -- should not happen
|
||||
status sys SequenceProj { subprojects=s } =
|
||||
let rest = NE.dropWhile (isClosed sys) s
|
||||
in case rest of (p : _) -> status sys p
|
||||
[] -> Done
|
||||
status ProductProj { subprojects=ps } =
|
||||
statusPriority [InProgress, Ready, Blocked, Cancelled, Done] ps
|
||||
status SumProj { subprojects=ps } =
|
||||
statusPriority [Done, InProgress, Ready, Blocked, Cancelled] ps
|
||||
status sys ProductProj { subprojects=ps } =
|
||||
statusPriority [InProgress, Ready, Blocked, Cancelled, Done] sys ps
|
||||
status sys SumProj { subprojects=ps } =
|
||||
statusPriority [Done, InProgress, Ready, Blocked, Cancelled] sys ps
|
||||
|
||||
statusPriority :: [Status] -> NE.NonEmpty Project -> Status
|
||||
statusPriority priority ps =
|
||||
let ss = NE.map status ps
|
||||
statusPriority :: [Status] -> ProjectSystem -> NE.NonEmpty Project -> Status
|
||||
statusPriority priority sys ps =
|
||||
let ss = NE.map (status sys) ps
|
||||
in fromMaybe Done $ asum $ map (\x -> find (x ==) ss) priority
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
module MasterPlan.DataSpec where
|
||||
|
||||
import Data.Bool (bool)
|
||||
import qualified Data.Map as M
|
||||
import MasterPlan.Data
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck hiding (sample)
|
||||
@ -29,63 +30,96 @@ instance Arbitrary Status where
|
||||
|
||||
arbitrary = oneof [ pure Ready, pure Blocked, pure InProgress, pure Done, pure Cancelled ]
|
||||
|
||||
testingKeys :: [String]
|
||||
testingKeys = ["a","b","c","d"]
|
||||
|
||||
rootKey :: String
|
||||
rootKey = "root"
|
||||
|
||||
instance Arbitrary ProjectSystem where
|
||||
|
||||
arbitrary = do bs <- replicateM (length testingKeys) arbitrary
|
||||
let arbitraryExpr = ExpressionProj <$> arbitrary <*> arbitrary
|
||||
rootB <- frequency [ (1, arbitrary), (10, arbitraryExpr) ]
|
||||
let bindings = M.insert rootKey rootB $ M.fromList $ zip testingKeys bs
|
||||
pure $ ProjectSystem bindings
|
||||
|
||||
shrink (ProjectSystem bs) =
|
||||
map ProjectSystem $ concatMap shrinkOne testingKeys
|
||||
where
|
||||
shrinkOne :: String -> [M.Map String ProjectBinding]
|
||||
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
|
||||
|
||||
-- NOTE: ProjectBinding arbitrary are always tasks (no expression)
|
||||
-- to avoid generating cycles
|
||||
arbitrary =
|
||||
let unitGen = choose (0.0, 1.0)
|
||||
in TaskProj <$> arbitrary
|
||||
<*> unitGen
|
||||
<*> unitGen
|
||||
<*> arbitrary
|
||||
<*> unitGen
|
||||
|
||||
instance Arbitrary Project where
|
||||
|
||||
arbitrary =
|
||||
let shrinkFactor n = 2 * n `quot` 5
|
||||
unitGen = choose (0.0, 1.0)
|
||||
in oneof [ SumProj <$> arbitrary <*> scale shrinkFactor arbitrary
|
||||
, ProductProj <$> arbitrary <*> scale shrinkFactor arbitrary
|
||||
, SequenceProj <$> arbitrary <*> scale shrinkFactor arbitrary
|
||||
, TaskProj <$> arbitrary
|
||||
<*> unitGen
|
||||
<*> unitGen
|
||||
<*> arbitrary
|
||||
<*> unitGen ]
|
||||
in oneof [ SumProj <$> scale shrinkFactor arbitrary
|
||||
, ProductProj <$> scale shrinkFactor arbitrary
|
||||
, SequenceProj <$> scale shrinkFactor arbitrary
|
||||
, RefProj <$> elements testingKeys ]
|
||||
|
||||
shrink (SumProj p ps) = map (SumProj p) (shrink ps) ++ NE.toList ps
|
||||
shrink (ProductProj p ps) = map (ProductProj p) (shrink ps) ++ NE.toList ps
|
||||
shrink (SequenceProj p ps) = map (SequenceProj p) (shrink ps) ++ NE.toList ps
|
||||
shrink TaskProj {} = []
|
||||
shrink (SumProj ps) = map SumProj (shrink ps) ++ NE.toList ps
|
||||
shrink (ProductProj ps) = map ProductProj (shrink ps) ++ NE.toList ps
|
||||
shrink (SequenceProj ps) = map SequenceProj (shrink ps) ++ NE.toList ps
|
||||
shrink (RefProj _) = []
|
||||
|
||||
average :: RandomGen g => State g Float -> Int -> State g Float
|
||||
average sample n = do total <- replicateM n sample
|
||||
pure $ sum total / fromIntegral n
|
||||
|
||||
simulate :: RandomGen g => Project -> State g (Bool, Cost)
|
||||
simulate TaskProj { reportedConfidence=t, reportedCost=c } =
|
||||
do n <- state $ randomR (0, 1)
|
||||
pure (t > n, c)
|
||||
simulate :: RandomGen g => ProjectSystem -> Project -> State g (Bool, Cost)
|
||||
simulate sys (RefProj n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just TaskProj { reportedTrust=t, reportedCost=c } ->
|
||||
do r <- state $ randomR (0, 1)
|
||||
pure (t > r, c)
|
||||
Just ExpressionProj { expression=p} -> simulate sys p -- TODO: avoid cyclic
|
||||
Nothing -> pure (False, 0) -- should not happen
|
||||
|
||||
simulate SequenceProj { subprojects=ps } = simulateConjunction $ NE.dropWhile isClosed ps
|
||||
simulate ProductProj { subprojects=ps } = simulateConjunction $ NE.filter isOpen ps
|
||||
simulate SumProj { subprojects=ps } =
|
||||
simulate sys SequenceProj { subprojects=ps } = simulateConjunction sys $ NE.dropWhile (isClosed sys) ps
|
||||
simulate sys ProductProj { subprojects=ps } = simulateConjunction sys $ NE.filter (isOpen sys) ps
|
||||
simulate sys SumProj { subprojects=ps } =
|
||||
if null opens then pure (True, 0) else simulate' opens
|
||||
where
|
||||
opens = NE.filter isOpen ps
|
||||
opens = NE.filter (isOpen sys) ps
|
||||
simulate' :: RandomGen g => [Project] -> State g (Bool, Cost)
|
||||
simulate' [] = pure (False, 0)
|
||||
simulate' (p:rest) = do (success, c) <- simulate p
|
||||
simulate' (p:rest) = do (success, c) <- simulate sys p
|
||||
if success then
|
||||
pure (True, c)
|
||||
else
|
||||
do (success', c') <- simulate' rest
|
||||
pure (success', c + c')
|
||||
|
||||
simulateConjunction :: RandomGen g => [Project] -> State g (Bool, Cost)
|
||||
simulateConjunction [] = pure (True, 0)
|
||||
simulateConjunction (p:rest) = do (success, c) <- simulate p
|
||||
if success then do
|
||||
(success', c') <- simulateConjunction rest
|
||||
pure (success', c + c')
|
||||
else
|
||||
pure (False, c)
|
||||
simulateConjunction :: RandomGen g => ProjectSystem -> [Project] -> State g (Bool, Cost)
|
||||
simulateConjunction _ [] = pure (True, 0)
|
||||
simulateConjunction sys (p:rest) = do (success, c) <- simulate sys p
|
||||
if success then do
|
||||
(success', c') <- simulateConjunction sys rest
|
||||
pure (success', c + c')
|
||||
else
|
||||
pure (False, c)
|
||||
|
||||
monteCarloConfidenceAndCost :: RandomGen g => Int -> Project -> State g (Percentage, Cost)
|
||||
monteCarloConfidenceAndCost n p = do results <- replicateM n $ simulate p
|
||||
let confidences = map (bool 0 1 . fst) results
|
||||
monteCarloTrusteAndCost :: RandomGen g => Int -> ProjectSystem -> Project -> State g (Trust, Cost)
|
||||
monteCarloTrusteAndCost n sys p = do results <- replicateM n $ simulate sys p
|
||||
let trusts = map (bool 0 1 . fst) results
|
||||
let costs = map snd results
|
||||
pure (sum confidences / fromIntegral n,
|
||||
pure (sum trusts / fromIntegral n,
|
||||
sum costs / fromIntegral n)
|
||||
|
||||
aproximatelyEqual :: Float -> Float -> Property
|
||||
@ -101,45 +135,53 @@ spec = do
|
||||
let g = mkStdGen 837183
|
||||
|
||||
it "monte-carlo and analytical implementations should agree on cost" $ do
|
||||
let propertyMCAndAnalyticalEq :: Project -> Property
|
||||
propertyMCAndAnalyticalEq p =
|
||||
cost' `aproximatelyEqual` cost p
|
||||
let propertyMCAndAnalyticalEq :: ProjectSystem -> Property
|
||||
propertyMCAndAnalyticalEq sys =
|
||||
cost' `aproximatelyEqual` cost sys p
|
||||
where
|
||||
(_, cost') = evalState (monteCarloConfidenceAndCost 10000 p) g
|
||||
p = RefProj rootKey
|
||||
(_, cost') = evalState (monteCarloTrusteAndCost 10000 sys p) g
|
||||
|
||||
property propertyMCAndAnalyticalEq
|
||||
|
||||
it "monte-carlo and analytical implementations should agree on confidence" $ do
|
||||
let propertyMCAndAnalyticalEq :: Project -> Property
|
||||
propertyMCAndAnalyticalEq p =
|
||||
confidence' `aproximatelyEqual` confidence p
|
||||
it "monte-carlo and analytical implementations should agree on trust" $ do
|
||||
let propertyMCAndAnalyticalEq :: ProjectSystem -> Property
|
||||
propertyMCAndAnalyticalEq sys =
|
||||
trust' `aproximatelyEqual` trust sys p
|
||||
where
|
||||
(confidence', _) = evalState (monteCarloConfidenceAndCost 10000 p) g
|
||||
p = RefProj rootKey
|
||||
(trust', _) = evalState (monteCarloTrusteAndCost 10000 sys p) g
|
||||
|
||||
property propertyMCAndAnalyticalEq
|
||||
|
||||
describe "cost" $ do
|
||||
let p1 = defaultTaskProj { reportedCost = 10
|
||||
, reportedConfidence = 0.8
|
||||
, reportedProgress=1
|
||||
, reportedStatus = Done }
|
||||
let p2 = defaultTaskProj { reportedCost = 5
|
||||
, reportedConfidence = 1
|
||||
, reportedProgress = 0.2
|
||||
, reportedStatus = InProgress }
|
||||
let p3 = defaultTaskProj { reportedCost = 7
|
||||
, reportedConfidence = 1
|
||||
, reportedProgress = 0
|
||||
, reportedStatus = Ready }
|
||||
let p4 = defaultTaskProj { reportedCost = 2
|
||||
, reportedConfidence = 1
|
||||
, reportedProgress = 0
|
||||
, reportedStatus = Ready }
|
||||
let p1 = TaskProj { props=defaultProjectProps
|
||||
, reportedCost = 10
|
||||
, reportedTrust = 0.8
|
||||
, reportedProgress=1
|
||||
, reportedStatus = Done }
|
||||
let p2 = TaskProj { props=defaultProjectProps
|
||||
, reportedCost = 5
|
||||
, reportedTrust = 1
|
||||
, reportedProgress = 0.2
|
||||
, reportedStatus = InProgress }
|
||||
let p3 = TaskProj { props=defaultProjectProps
|
||||
, reportedCost = 7
|
||||
, reportedTrust = 1
|
||||
, reportedProgress = 0
|
||||
, reportedStatus = Ready }
|
||||
let p4 = TaskProj { props=defaultProjectProps
|
||||
, reportedCost = 2
|
||||
, reportedTrust = 1
|
||||
, reportedProgress = 0
|
||||
, reportedStatus = Ready }
|
||||
|
||||
it "is correct for sequences" $ do
|
||||
let p = SequenceProj defaultProjectProps $ NE.fromList [p1, p2, p3, p4]
|
||||
cost p `shouldBe` 14
|
||||
let p = SequenceProj $ NE.fromList $ map RefProj ["p1", "p2", "p3", "p4"]
|
||||
sys = ProjectSystem $ M.fromList $ zip ["p1", "p2", "p3", "p4"] [p1, p2, p3, p4]
|
||||
cost sys p `shouldBe` 14
|
||||
|
||||
it "is correct for products" $ do
|
||||
let p = ProductProj defaultProjectProps $ NE.fromList [p1, p2, p3, p4]
|
||||
cost p `shouldBe` 14
|
||||
let p = ProductProj $ NE.fromList $ map RefProj ["p1", "p2", "p3", "p4"]
|
||||
sys = ProjectSystem $ M.fromList $ zip ["p1", "p2", "p3", "p4"] [p1, p2, p3, p4]
|
||||
cost sys p `shouldBe` 14
|
||||
|
||||
Loading…
Reference in New Issue
Block a user