{-|
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 UnicodeSyntax #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TupleSections             #-}
module MasterPlan.Backend.Graph (render, RenderOptions(..)) where

import           MasterPlan.Data
import           Diagrams.Prelude hiding (render, Product, Sum)
import           Diagrams.Backend.Rasterific
import           Data.List (intersperse)
import           Control.Applicative ((<|>))
import           Control.Monad.State
import qualified Data.Map  as M
import           Data.Tree
import           Data.Maybe (fromMaybe, catMaybes)
import qualified Data.List.NonEmpty as NE
import           Text.Printf (printf)
import           Diagrams.TwoD.Text (Text)

-- 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

-- * Types

data NodeType = SumNode | ProductNode | SequenceNode | AtomicNode

-- |Data type used by the tree
data PNode = PNode (Maybe ProjectKey)
                 (Maybe ProjectProperties)
                 Cost
                 Trust
                 Progress
          | NodeRef ProjectKey

type RenderModel = Tree (NodeType, PNode)

mkLeaf :: PNode -> RenderModel
mkLeaf a = Node (AtomicNode, a) []

-- |Translates a ProjectSystem into a Tree PNode
toRenderModel :: ProjectSystem -> ProjectKey -> State [ProjectKey] (Maybe RenderModel)
toRenderModel sys rootK = case M.lookup rootK (bindings sys) of
                            Nothing -> pure Nothing
                            Just b -> Just <$> bindingToRM rootK b
  where
    bindingToRM :: ProjectKey -> Binding -> State [ProjectKey] RenderModel
    bindingToRM key (BindingExpr prop p) = projToRM p (Just key) (Just prop)
    bindingToRM key (BindingAtomic prop c t p) = pure $ mkLeaf $ PNode (Just key)
                                                                       (Just prop)
                                                                       c t p
    bindingToRM key (BindingPlaceholder prop) = pure $ mkLeaf $ PNode (Just key)
                                                                      (Just prop)
                                                                      defaultCost
                                                                      defaultTrust
                                                                      defaultProgress

    mkNode :: (PNode -> [RenderModel] -> RenderModel)
           -> ProjectExpr
           -> NE.NonEmpty ProjectExpr
           -> Maybe ProjectKey
           -> Maybe ProjectProperties
           -> State [ProjectKey] RenderModel
    mkNode f p ps key prop = f (PNode key prop
                                     (cost sys p)
                                     (trust sys p)
                                     (progress sys p))
                               <$> mapM (\p' -> projToRM p' Nothing Nothing) (NE.toList ps)

    projToRM :: ProjectExpr -> Maybe ProjectKey -> Maybe ProjectProperties -> State [ProjectKey] RenderModel
    projToRM p@(Sum ps) = mkNode (\x -> Node (SumNode, x)) p ps
    projToRM p@(Sequence ps) = mkNode (\x -> Node (SequenceNode, x)) p ps
    projToRM p@(Product ps) = mkNode (\x -> Node (ProductNode, x)) p ps
    projToRM (Reference n) =
      \k p -> case M.lookup n $ bindings sys of
                Nothing -> pure $ Node (AtomicNode, PNode k (p <|> pure defaultProjectProps {title=n}) defaultCost defaultTrust defaultProgress) []
                Just b -> do alreadyProcessed <- gets (n `elem`)
                             if alreadyProcessed
                               then pure $ Node (AtomicNode, NodeRef $ bindingTitle b) []
                               else modify (n:) >> bindingToRM n b

-- |how many children
treeSize :: Tree a -> Double
treeSize (Node _ []) = 1
treeSize (Node _ ts) = sum $ treeSize <$> ts

-- |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
                                   , rootKey :: ProjectKey -- ^The name of the root project
                                   , whitelistedProps :: [ProjProperty] -- ^Properties that should be rendered
                                   } deriving (Eq, Show)

-- | The main rendering function
render ∷ FilePath -> RenderOptions-> ProjectSystem → IO ()
render fp (RenderOptions colorByP w h rootK props) sys =
  let noRootEroor = text $ "no project named \"" ++ rootK ++ "\" found."
      dia = fromMaybe noRootEroor $ renderTree colorByP props <$> evalState (toRenderModel sys rootK) []
  in renderRasterific fp (dims2D (fromInteger w) (fromInteger h)) $ bgFrame 1 white $ centerXY dia

renderTree :: Bool -> [ProjProperty] -> 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))
    |||  (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
    renderSubTree subtree = hrule 4 # lwO 2 ||| renderTree colorByP props subtree

    headBar = strutY $ treeSize t * 6

    treeBar :: [Double] -> QDiagram B V2 Double Any
    treeBar (s1:s2:ss) = vrule s1 # lwO 2 === vrule s2 # lwO 2 === treeBar (s2:ss)
    treeBar [s1] = strutY s1
    treeBar _ = mempty

    typeSymbol =
      let txt = case ty of
                    SumNode -> text "+"
                    ProductNode -> text "x"
                    SequenceNode -> text "->"
                    AtomicNode -> mempty
      in txt # fontSizeL 2 # bold <> circle 2 # fc white # lwO 1

renderNode :: Bool -> [ProjProperty] -> PNode -> QDiagram B V2 Double Any
renderNode _        _     (NodeRef 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)
  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

    givenProp :: ProjProperty -> 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)
    titleHeader = givenProp PTitle $ (bold . text . title) <$> prop
    costHeader = givenProp PCost $ Just $ displayCost c # translateX 14

    descriptionSection, urlSection, bottomSection :: Maybe (QDiagram B V2 Double Any)
    descriptionSection = givenProp PDescription $ prop >>= description >>= (pure . text) -- TODO line breaks
    urlSection = givenProp PUrl $ prop >>= url >>= (pure . text) -- TODO ellipsis

    bottomSection = case [trustSubSection, ownerSubSection] of
                      [Nothing, Nothing] -> Nothing
                      l -> Just $ strutX 30 <> 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)

    displayCost c'
      | c' == 0   = mempty
      | otherwise = rightText $ "(" ++ printf "%.1f" c' ++ ")"
    displayProgress p'
      | p' == 0 = mempty
      | p' == 1 = leftText "done"
      | otherwise = leftText $ percentageText 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

    percentageText pct = show ((round $ pct * 100) :: Integer) ++ "%"