content: {-|
  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)
  