master-plan-0.3.1: src/MasterPlan/Backend/Graph.hs
{-|
Module : MasterPlan.Backend.Graph
Description : a backend that renders to PNG diagram
Copyright : (c) Rodrigo Setti, 2017
License : MIT
Maintainer : rodrigosetti@gmail.com
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnicodeSyntax #-}
module MasterPlan.Backend.Graph ( render
, renderText
, RenderOptions(..)) where
import Control.Monad.State
import Data.List (intersperse, isSuffixOf)
import Data.Maybe
import Diagrams.Backend.Rasterific
import Diagrams.Prelude hiding (Product, Sum, render)
import Diagrams.TwoD.Text
import MasterPlan.Data
import Text.Printf (printf)
-- text :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any
-- text = texterific
leftText :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any
leftText = alignedText 0 0.5
rightText :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any
rightText = alignedText 1 0.5
-- |Render multiline text
multilineText' :: (TypeableFloat n, Renderable (Text n) b)
=> FontSlant
-> FontWeight
-> n -- ^line spacing
-> [String] -- ^the lines of text to render
-> QDiagram b V2 n Any
multilineText' fs fw lineSpace = vsep lineSpace . map (texterific' fs fw)
-- |Render multiline text
multilineText :: (TypeableFloat n, Renderable (Text n) b)
=> n -- ^line spacing
-> [String] -- ^the lines of text to render
-> QDiagram b V2 n Any
multilineText = multilineText' FontSlantNormal FontWeightNormal
-- |Render text with possible overflow by breaking lines and truncating with ...
textOverflow' :: (TypeableFloat n, Renderable (Text n) b)
=> FontSlant
-> FontWeight
-> Int -- ^maximum number of lines to break
-> Int -- ^maximum number of chars per line
-> n -- ^line spacing
-> String -- ^the text
-> QDiagram b V2 n Any
textOverflow' fs fw maxLines maxLineSize lineSpace txt =
vsep lineSpace $ map (texterific' fs fw) ss
where
ss = reverse $ foldl processWord [] $ words txt
processWord (l:ls) w
| length (l ++ w) > maxLineSize = if length ls >= maxLines
then (if "..." `isSuffixOf` l then l:ls else (l ++ " ..."):ls)
else w:l:ls
| otherwise = (l ++ " " ++ w):ls
processWord [] w = [w]
-- |Render text with possible overflow by breaking lines and truncating with ...
textOverflow :: (TypeableFloat n, Renderable (Text n) b)
=> Int -- ^maximum number of lines to break
-> Int -- ^maximum number of chars per line
-> n -- ^line spacing
-> String -- ^the text
-> QDiagram b V2 n Any
textOverflow = textOverflow' FontSlantNormal FontWeightNormal
-- |Options for rendering
data RenderOptions = RenderOptions { colorByProgress :: Bool -- ^Whether to color boxes depending on progress
, renderWidth :: Integer -- ^The width of the output image
, renderHeight :: Integer -- ^The height of the output image
, whitelistedAttrs :: [ProjAttribute] -- ^Attributes that should be rendered
} deriving (Eq, Show)
-- | The main rendering function
render ∷ FilePath -> RenderOptions-> ProjectExpr → IO ()
render fp (RenderOptions colorByP w h attrs) proj =
let dia = evalState (renderProject colorByP attrs proj) []
in renderRasterific fp (dims2D (fromInteger w) (fromInteger h)) $ bgFrame 1 white $ centerXY dia
-- |Render a multi-line text to file
renderText ∷ FilePath -> RenderOptions-> [String] → IO ()
renderText fp RenderOptions { renderWidth=w, renderHeight=h } ss =
let dia = multilineText (0.1 :: Float) ss
in renderRasterific fp (dims2D (fromInteger w) (fromInteger h)) $ bgFrame 1 white $ centerXY dia
-- |Monad that keep state of all projects rendered so far
type AvoidRedundancy = State [ProjectExpr]
renderProject :: Bool -> [ProjAttribute] -> ProjectExpr -> AvoidRedundancy (QDiagram B V2 Double Any)
renderProject _ _ (Annotated _) = undefined
renderProject colorByP attrs p@Atomic {} = pure $ alignL $ renderNode colorByP attrs p
renderProject colorByP attrs proj =
do alreadyRendered <- gets (proj `elem`)
case title =<< properties proj of
Just n | alreadyRendered -> pure $ renderReference n
_ -> do modify (proj:)
subtrees <- mapM renderSubTree $ subprojects proj
let sizesY = map (diameter unitY) subtrees
let headBar = case sizesY of
[] -> mempty
s:_ -> strutY (s/2)
pure $ (strutY (sum sizesY) <> alignL (centerY $ renderNode colorByP attrs proj))
||| (translateX 2 typeSymbol # withEnvelope (mempty :: D V2 Double) <> hrule 4 # lwO 2)
||| centerY (headBar === treeBar sizesY)
||| centerY (vcat subtrees)
where
renderSubTree subtree = (hrule 4 # lwO 2 |||) <$> renderProject colorByP attrs subtree
renderReference refName = text refName <> roundedRect 30 2 0.5 # lwO 2 # fc white # dashingN [0.005, 0.005] 0
treeBar :: [Double] -> QDiagram B V2 Double Any
treeBar (s1:s2:ss) = vrule (s1/2) # lwO 2 === vrule (s2/2) # lwO 2 === treeBar (s2:ss)
treeBar [s1] = strutY (s1/2)
treeBar _ = mempty
typeSymbol =
let txt = case proj of
Sum {} -> text "+"
Product {} -> text "x"
Sequence {} -> text "->"
_ -> mempty
in txt # fontSizeL 2 # bold <> extrudeTop 2 (extrudeBottom 2 (roundedRect 3 2 1 # fc white # lwO 1))
renderNode :: Bool -> [ProjAttribute] -> ProjectExpr -> QDiagram B V2 Double Any
renderNode colorByP attrs proj =
centerY $ extrudeTop 2 $ extrudeBottom 2 nodeDia
where
c = cost proj
t = trust proj
p = progress proj
prop = properties proj
nodeDia =
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` attrs then x else Nothing
headerSection = case [progressHeader, titleHeader, costHeader] of
[Nothing, Nothing, Nothing] -> Nothing
l -> Just $ strutY 2 <> strutX nodeW <> mconcat (catMaybes l)
progressHeader = givenProp PProgress $ Just $ displayProgress p # translateX (-nodeW/2 + 1)
titleHeader :: Maybe (QDiagram B V2 Double Any)
titleHeader = givenProp PTitle $ prop
>>= title
>>= (pure . centerXY . textOverflow' FontSlantNormal FontWeightBold 1 30 0.1)
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 . centerX . frame 0.3 . textOverflow 3 40 0.1)
urlSection = givenProp PUrl $ prop
>>= url
>>= (pure . centerX . frame 0.3 . textOverflow 1 20 0)
bottomSection = case [trustHeader, ownerHeader] of
[Nothing, Nothing] -> Nothing
l -> Just $ strutY 2 <> strutX nodeW <> mconcat (catMaybes l)
ownerHeader = prop >>= owner >>= (pure . translateX (nodeW/2 -1) . rightText)
trustHeader = translateX (-nodeW/2+1) <$> trustHeader' leftText
trustHeader' txt = case t of
_ | PTrust `notElem` attrs -> Nothing
t' | t' == defaultTrust -> Nothing
t' | t' == 0 -> Just $ txt "impossible"
_ -> Just $ txt ("trust = " ++ percentageText (getTrust t))
displayCost c'
| c' == defaultCost = mempty
| otherwise = rightText $ "(" ++ printf "%.1f" (getCost c') ++ ")"
displayProgress p'
| p' == defaultProgress = mempty
| p' == 1 = leftText "done"
| otherwise = leftText $ percentageText $ getProgress p'
-- color is red if the project hasn't started, green if it's done, or yellow
-- otherwise (i.e. in progress)
projColor =
if colorByP then
(if p == 0 then pink else if p == 1 then lightgreen else lightyellow)
else white
percentageText pct = printf "%.1f%%" (pct * 100)