module MasterPlan.Data ( ProjectExpr(..)
, ProjectProperties(..)
, ProjectSystem(..)
, Binding(..)
, ProjectKey
, ProjProperty(..)
, Trust
, Cost
, Progress
, defaultProjectProps
, defaultCost
, defaultTrust
, defaultProgress
, defaultTaskProj
, bindingTitle
, cost
, progress
, trust
, simplify
, simplifyProj
, prioritizeSys
, prioritizeProj ) where
import Data.Generics
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
type Trust = Float
type Cost = Float
type Progress = Float
type ProjectKey = String
data ProjectExpr = Sum (NE.NonEmpty ProjectExpr)
| Product (NE.NonEmpty ProjectExpr)
| Sequence (NE.NonEmpty ProjectExpr)
| Reference ProjectKey
deriving (Eq, Show, Data, Typeable)
data Binding = BindingAtomic ProjectProperties Cost Trust Progress
| BindingExpr ProjectProperties ProjectExpr
| BindingPlaceholder ProjectProperties
deriving (Eq, Show, Data, Typeable)
data ProjectProperties = ProjectProperties { title :: String
, description :: Maybe String
, url :: Maybe String
, owner :: Maybe String
} deriving (Eq, Show, Data, Typeable)
data ProjProperty = PTitle | PDescription | PUrl | POwner | PCost | PTrust | PProgress
deriving (Eq, Enum, Bounded)
instance Show ProjProperty where
show PTitle = "title"
show PDescription = "description"
show PUrl = "url"
show POwner = "owner"
show PCost = "cost"
show PTrust = "trust"
show PProgress = "progress"
newtype ProjectSystem = ProjectSystem { bindings :: M.Map ProjectKey Binding }
deriving (Eq, Show, Data, Typeable)
defaultProjectProps ∷ ProjectProperties
defaultProjectProps = ProjectProperties { title = "?"
, description = Nothing
, url = Nothing
, owner = Nothing }
defaultCost ∷ Cost
defaultCost = 0
defaultTrust ∷ Trust
defaultTrust = 1
defaultProgress ∷ Progress
defaultProgress = 0
defaultTaskProj ∷ ProjectProperties → Binding
defaultTaskProj pr = BindingAtomic pr defaultCost defaultTrust defaultProgress
bindingTitle ∷ Binding → String
bindingTitle (BindingAtomic ProjectProperties { title=t} _ _ _) = t
bindingTitle (BindingExpr ProjectProperties { title=t} _) = t
bindingTitle (BindingPlaceholder ProjectProperties { title=t}) = t
cost ∷ ProjectSystem → ProjectExpr → Cost
cost sys (Reference n) =
case M.lookup n (bindings sys) of
Just (BindingAtomic _ c _ p) -> c * (1p)
Just (BindingExpr _ p) -> cost sys p
Just (BindingPlaceholder _) -> defaultCost
Nothing -> defaultCost
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*(1a)) 0 $ trust sys <$> ps
costs = NE.toList $ cost sys <$> ps
costConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Cost
costConjunction sys ps =
sum $ zipWith (*) costs accTrusts
where
costs = NE.toList $ cost sys <$> ps
accTrusts = NE.toList $ product <$> NE.inits (trust sys <$> ps)
trust ∷ ProjectSystem → ProjectExpr → Trust
trust sys (Reference n) =
case M.lookup n (bindings sys) of
Just (BindingAtomic _ _ t p) -> p + t * (1p)
Just (BindingExpr _ p) -> trust sys p
Just (BindingPlaceholder _) -> defaultTrust
Nothing -> defaultTrust
trust sys (Sequence ps) = trustConjunction sys ps
trust sys (Product ps) = trustConjunction sys ps
trust sys (Sum ps) =
foldl (\a b -> a + b*(1a)) 0 $ trust sys <$> ps
trustConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Trust
trustConjunction sys ps = product $ trust sys <$> ps
progress ∷ ProjectSystem → ProjectExpr → Progress
progress sys (Reference n) =
case M.lookup n (bindings sys) of
Just (BindingAtomic _ _ _ p) -> p
Just (BindingExpr _ p) -> progress sys p
Just (BindingPlaceholder _) -> defaultProgress
Nothing -> defaultProgress
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 ProjectExpr → Progress
progressConjunction sys ps = sum (progress sys <$> ps) / fromIntegral (length ps)
simplify ∷ ProjectSystem → ProjectSystem
simplify = everywhere (mkT simplifyProj)
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 (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 (Sequence ps) =
Sequence $ (reduce . simplifyProj) =<< ps
where
reduce (Sequence ps') = reduce =<< ps'
reduce p = [simplifyProj p]
simplifyProj p@Reference {} = p
prioritizeSys ∷ ProjectSystem → ProjectSystem
prioritizeSys sys = everywhere (mkT $ prioritizeProj sys) sys
prioritizeProj ∷ ProjectSystem → ProjectExpr → ProjectExpr
prioritizeProj sys (Sum ps) =
let f p = cost sys p / 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)
in Product $ NE.sortWith (nanToInf . f) $ prioritizeProj sys <$> ps
prioritizeProj _ p = p
nanToInf :: RealFloat a => a -> a
nanToInf x = if isNaN x then 1/0 else x