diff --git a/examples/example1.plan b/examples/example1.plan index aa0896a..2bc44c3 100644 --- a/examples/example1.plan +++ b/examples/example1.plan @@ -13,7 +13,7 @@ x { description "can we build the technology ourselves" } h * b; -h hire + acquihire; +h = hire + acquihire; hire { title "hire" diff --git a/examples/example1.png b/examples/example1.png index f36c620..d3e6e19 100644 Binary files a/examples/example1.png and b/examples/example1.png differ diff --git a/src/MasterPlan/Backend/Graph.hs b/src/MasterPlan/Backend/Graph.hs index 8a22e87..65df267 100644 --- a/src/MasterPlan/Backend/Graph.hs +++ b/src/MasterPlan/Backend/Graph.hs @@ -10,7 +10,6 @@ Portability : POSIX {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnicodeSyntax #-} module MasterPlan.Backend.Graph (render, RenderOptions(..)) where @@ -20,7 +19,7 @@ import Control.Monad.State import Data.List (intersperse) import qualified Data.List.NonEmpty as NE import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe import Data.Tree import Diagrams.Backend.Rasterific import Diagrams.Prelude hiding (Product, Sum, render) @@ -90,10 +89,10 @@ toRenderModel sys rootK = case M.lookup rootK (bindings sys) of then pure $ Node (AtomicNode, NodeRef $ ProjectKey $ bindingTitle b) [] else modify (n:) >> bindingToRM n b --- |how many children -treeSize :: Tree a -> Double -treeSize (Node _ []) = 1 -treeSize (Node _ ts) = sum $ treeSize <$> ts +-- |how many leaf nodes +leafCount :: Tree a -> Double +leafCount (Node _ []) = 1 +leafCount (Node _ ts) = sum $ leafCount <$> ts -- |Options for rendering data RenderOptions = RenderOptions { colorByProgress :: Bool -- ^Whether to color boxes depending on progress @@ -113,15 +112,15 @@ render fp (RenderOptions colorByP w h rootK props) sys = renderTree :: Bool -> [ProjAttribute] -> RenderModel -> QDiagram B V2 Double Any renderTree colorByP props (Node (_, n) []) = alignL $ renderNode colorByP props n renderTree colorByP props x@(Node (ty, n) ts@(t:_)) = - (strutY (12 * treeSize x) <> alignL (centerY $ renderNode colorByP props n)) + (strutY (12 * leafCount x) <> alignL (centerY $ renderNode colorByP props n)) ||| (translateX 2 typeSymbol # withEnvelope (mempty :: D V2 Double) <> hrule 4 # lwO 2) ||| centerY (headBar === treeBar sizes) ||| centerY (vcat $ map renderSubTree ts) where - sizes = map ((* 6) . treeSize) ts + sizes = map ((* 6) . leafCount) ts renderSubTree subtree = hrule 4 # lwO 2 ||| renderTree colorByP props subtree - headBar = strutY $ treeSize t * 6 + headBar = strutY $ leafCount t * 6 treeBar :: [Double] -> QDiagram B V2 Double Any treeBar (s1:s2:ss) = vrule s1 # lwO 2 === vrule s2 # lwO 2 === treeBar (s2:ss) @@ -134,49 +133,56 @@ renderTree colorByP props x@(Node (ty, n) ts@(t:_)) = ProductNode -> text "x" SequenceNode -> text "->" AtomicNode -> mempty - in txt # fontSizeL 2 # bold <> circle 2 # fc white # lwO 1 + in txt # fontSizeL 2 # bold <> roundedRect 3 2 1 # fc white # lwO 1 renderNode :: Bool -> [ProjAttribute] -> PNode -> QDiagram B V2 Double Any 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) + centerY nodeDia <> strutY 12 where nodeDia = - let hSizeAndSections = catMaybes [ (,2) <$> headerSection - , (,6) <$> descriptionSection - , (,2) <$> urlSection - , (,2) <$> bottomSection] - sections = map (\s -> strutY (snd s) <> fst s) hSizeAndSections - outerRect = rect 30 (sum $ map snd hSizeAndSections) # lwO 2 - sectionsWithSep = vcat (intersperse (hrule 30 # dashingN [0.005, 0.005] 0 # lwO 1) sections) - in outerRect # fcColor `beneath` centerY sectionsWithSep + let sections = if isJust titleHeader + then catMaybes [ headerSection + , descriptionSection + , urlSection + , bottomSection] + else maybeToList simplifiedNode + sectionsWithSep = vcat (intersperse (hrule nodeW # dashingN [0.005, 0.005] 0 # lwO 1) sections) + in centerY (sectionsWithSep <> boundingRect sectionsWithSep # fc projColor # lwO 2) + + nodeW = 30 + + simplifiedNode = case [progressHeader, trustHeader' text, costHeader] of + [Nothing, Nothing, Nothing] -> Nothing + l -> Just $ strutY 2 <> strutX nodeW <> mconcat (catMaybes l) givenProp :: ProjAttribute -> Maybe a -> Maybe a givenProp pro x = if pro `elem` props then x else Nothing headerSection = case [progressHeader, titleHeader, costHeader] of [Nothing, Nothing, Nothing] -> Nothing - l -> Just $ strutX 30 <> mconcat (catMaybes l) - progressHeader = givenProp PProgress $ Just $ displayProgress p # translateX (-14) + l -> Just $ strutY 2 <> strutX nodeW <> mconcat (catMaybes l) + progressHeader = givenProp PProgress $ Just $ displayProgress p # translateX (-nodeW/2 + 1) titleHeader = givenProp PTitle $ (bold . text . title) <$> prop - costHeader = givenProp PCost $ Just $ displayCost c # translateX 14 + costHeader = givenProp PCost $ Just $ displayCost c # translateX (nodeW/2 - 1) descriptionSection, urlSection, bottomSection :: Maybe (QDiagram B V2 Double Any) - descriptionSection = givenProp PDescription $ prop >>= description >>= (pure . text) -- TODO:50 line breaks - urlSection = givenProp PUrl $ prop >>= url >>= (pure . text) -- TODO:40 ellipsis + descriptionSection = givenProp PDescription $ prop >>= description >>= (pure . (strutY 6 <>) . text) -- TODO:50 line breaks + urlSection = givenProp PUrl $ prop >>= url >>= (pure . (strutY 2 <>) . text) -- TODO:40 ellipsis - bottomSection = case [trustSubSection, ownerSubSection] of + bottomSection = case [trustHeader, ownerHeader] of [Nothing, Nothing] -> Nothing - l -> Just $ strutX 30 <> mconcat (catMaybes l) + l -> Just $ strutY 2 <> strutX nodeW <> mconcat (catMaybes l) - ownerSubSection = prop >>= owner >>= (pure . translateX 14 . rightText) - trustSubSection = translateX (-14) <$> - case t of - _ | PTrust `notElem` props -> Nothing - t' | t' == 1 -> Nothing - t' | t' == 0 -> Just $ leftText "impossible" - _ -> Just $ leftText ("trust = " ++ percentageText t) + ownerHeader = prop >>= owner >>= (pure . translateX (nodeW/2 -1) . rightText) + trustHeader = translateX (-nodeW/2+1) <$> trustHeader' leftText + + trustHeader' txt = case t of + _ | PTrust `notElem` props -> Nothing + t' | t' == 1 -> Nothing + t' | t' == 0 -> Just $ txt "impossible" + _ -> Just $ txt ("trust = " ++ percentageText t) displayCost c' | c' == 0 = mempty @@ -188,9 +194,9 @@ renderNode colorByP props (PNode _ prop c t p) = -- color is red if the project hasn't started, green if it's done, or yellow -- otherwise (i.e. in progress) - fcColor = - fc $ if colorByP then - (if p == 0 then pink else if p == 1 then lightgreen else lightyellow) - else white + projColor = + if colorByP then + (if p == 0 then pink else if p == 1 then lightgreen else lightyellow) + else white percentageText pct = show ((round $ pct * 100) :: Integer) ++ "%" diff --git a/src/MasterPlan/Data.hs b/src/MasterPlan/Data.hs index 2100605..620b415 100644 --- a/src/MasterPlan/Data.hs +++ b/src/MasterPlan/Data.hs @@ -7,11 +7,11 @@ Maintainer : rodrigosetti@gmail.com Stability : experimental Portability : POSIX -} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UnicodeSyntax #-} module MasterPlan.Data ( ProjectExpr(..) , ProjectProperties(..) , ProjectSystem(..) @@ -39,7 +39,7 @@ 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) +import Data.String (IsString) -- * Types @@ -118,8 +118,8 @@ cost ∷ ProjectSystem → ProjectExpr → Cost cost sys (Reference n) = case M.lookup n (bindings sys) of 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 + 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) = @@ -140,8 +140,8 @@ trust ∷ ProjectSystem → ProjectExpr → Trust trust sys (Reference n) = case M.lookup n (bindings sys) of 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 + 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) =