Diagram with timelines.

parallel.hs

{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE FlexibleInstances #-}
import Diagrams.Prelude
import Diagrams.Backend.PGF.CmdLine
import Control.Lens
import Data.List (sortBy, groupBy)
import Data.Ord (comparing)
import Data.Default.Class

import Data.Maybe (isJust, listToMaybe)

import System.Environment (withArgs)

data Location = Above | On | Below
    deriving (Show, Read, Eq, Ord)

data Label a = Label 
    { _labelText      :: Diagram B
    , _labelLocation  :: Location
    , _labelOrder     :: a
    , _labelEnd       :: Maybe a
    , _labelPhantom   :: Bool
    }

sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f = map snd . sortBy (comparing fst) . map (\x -> let y = f x  in y `seq` (y,x))

groupOn :: Eq b => (a -> b) -> [a] -> [[a]]
groupOn f = groupBy ((==) `on2` f)
  where (.*.) `on2` f = \x -> let fx = f x in \y -> fx .*. f y

instance Default (Label Double) where
  def = Label mempty Above 0 Nothing False

makeLenses ''Label

---------------------

lh :: Double
lh = 12

type LineMetrics = V2 Double

lineMetrics :: OnlineTex LineMetrics
lineMetrics = do
    l <- hboxOnline "lj"

    let h = envelopeV unitY (l :: Diagram B)
        d = envelopeV unit_Y l

    return $ norm <$> V2 h d

lineText :: String -> OnlineTex (Diagram B)
lineText s = do
    V2 h d <- lineMetrics
    hs <- hboxOnline s
    return $ hs <> (translateY (h/2) $ strutY h) <> (translateY (-d/2) $ strutY d)

vcatLines :: [Diagram B] -> Diagram B
vcatLines = vcat' (with & sep .~ 2)

timeline :: (Ord a, IsName a) => String -> [Label a] -> OnlineTex (Diagram B)
timeline s ls = do
    V2 h d <- (1.6*^)<$>lineMetrics

    let render l = case l^.labelEnd of
           Just e  -> mempty & named (toName e)
           Nothing -> l^.labelText & al & named (toName $ l^.labelOrder)
         where
          al = case l^.labelLocation of
                   Above -> translateY h . alignB 
                   On | l^.labelPhantom -> id
                      | otherwise       ->
                          \dia -> withEnvelope dia $
                                let x = -w*0.01
                                in centerX (((x ^& (-d)) ~~ (x ^& h)) <> alignL dia)
                   Below -> alignT . (strutY d ===)
        w = width row
        axis = rect (w * 1.02) (h+d) & alignL & translate ((-w*0.005) ^& (h-(h+d)/2))
        row = alignL . hcat . map (mconcat . map render) $ columns
        columns = groupOn (^.labelOrder) . sortOn (^.labelOrder) $ ls
        ranges = [ makeRange (rule l) ps pe (l^.labelText) & atLabelLocation l
                 | l <- ls
                 , let s = l^.labelOrder
                 , Just e <- [l^.labelEnd]
                 , Just ps <- [listToMaybe =<< lookup (toName s) ns]
                 , Just pe <- [listToMaybe =<< lookup (toName e) ns]
                 ]
          where
            ns = names row

        rule l = case l^.labelLocation of
            Above -> vrule (17 + d) & translateY (-d-2)
            On    -> vrule 10
            Below -> vrule (17 + d) & translateY (d+2)

        atLabelLocation l = case l^.labelLocation of
            Above -> translateY h . alignB
            On    -> id
            Below -> translateY (-d) . alignT

    t <- if length s == 0
           then return mempty
           else lineText s
    return $ hcat' (with & sep .~ lh) [t, axis <> row <> mconcat ranges]

makeRange rule s e d = mconcat
                  [ rule & moveTo s 
                  , arrowBetween' opts l s
                  , centerXY d & moveTo m
                  , arrowBetween' opts r e
                  , rule & moveTo e
                  ]
  where
    label = centerXY d & frame 5 & moveTo m
    l = envelopeP ((-1) ^& 0) label
    r = envelopeP (1 ^& 0) label
    m = lerp 0.5 s e
    opts = def & arrowHead .~ tri & headLength .~ global 7

--------------------
--
--  Example that illustrates that version numbers for the read check to be
--  successful.
--
--    reads
--      x   v   x                  x  v
--      |   |   |                  |  |
--      V   V   V                  V  V
--  ----------------------------------------------------
--  | Validate       | Read check        | Update      |
--  ----------------------------------------------------
--
--          |<--- No writes to v ---->|
--
--
--          |<--- A --->|      |<--- B --->|
-- update --------------------------------------------
--          ^      ^    ^      ^       ^   ^
--          |      |    |      |       |   |
--         x=L    v++  x=z    x=L     v++ x=y
-- 
entry  o t   = (with :: Label Double) & labelText .~ t & labelOrder .~ o
entry' s e t = (with :: Label Double) & labelText .~ t & labelOrder .~ s & labelEnd .~ Just e
spacer o w   = (with :: Label Double) & labelText .~ (strutX w) 
                                      & labelOrder .~ o & labelPhantom .~ True

steps = sequence
        [ entry 0.0 <$> r "Execute"
        , entry 1.0 <$> r "Validate"
        , entry 2.0 <$> r "Read Check"
        , entry 3.0 <$> r "Update"
        ] <&> (<&> labelLocation .~ On)
  where
    r s = centerX . (||| strutX 10) <$> lineText s

readOps = sequence
        [ entry 0   <$> r "x"
        , entry 1.01<$> r "x"
        , entry 1.1 <$> r "v"
        , entry 1.2 <$> r "x"
        , entry 2.1 <$> r "x"
        , entry 2.2 <$> r "v"
        ] <&> (<&> labelLocation .~ Above)
  where
    r s = do
        hr <- lineText "read"
        hs <- lineText (wrapIn '$' s)

        return $ padX 1.4 $ centerX (vcatLines [centerX hr, centerX hs])
              === strutY (lh/2) === arrowV (0 ^& (-lh*3))

readRanges = sequence
           [ entry' 1.1 2.2 <$> r "V"
           ] <&> (<&> labelLocation .~ Below)
  where
    r s = padY 4 . centerXY <$> hboxOnline (wrapIn '$' s)

updateRanges = sequence
             [ entry' 0.1 0.3 <$> r "A"
             , entry' 1.1 1.3 <$> r "B"
             ] <&> (<&> labelLocation .~ Above)
  where
    r s = padY 4 . centerXY <$> hboxOnline (wrapIn '$' s)


updateSteps = sequence
            [ entry 0.0 <$> r "T_1"
            , return $ spacer 0.05 16
            , entry 1.0 <$> r "T_2" 
            , return $ spacer 1.01 140
            ] <&> (<&> labelLocation .~ On)
  where
    r s = centerX <$> lineText (wrapIn '$' s)


commits = sequence
          [ entry 0.1 <$> r ["write", "$x=L$"] (strutX 10)
          , entry 0.2 <$> r ["inc", "$v$"]     (strutX 5)
          , entry 0.3 <$> r ["write", "$x=y$"] mempty
          
          , entry 1.1 <$> r ["write", "$x=L$"] (strutX 10)
          , entry 1.2 <$> r ["inc", "$v$"]     (strutX 5)
          , entry 1.3 <$> r ["write", "$x=z$"] mempty
          ] <&> (<&> labelLocation .~ Below)
  where
    r ss pad = do
        hss <- (centerX <$>) <$> mapM lineText ss
        return $ (padX 1.4 $ arrowV (0 ^& (lh*3)) === strutY (lh/2) === vcatLines hss) ||| pad

wrapIn c ss = c : ss ++ [c]


d :: OnlineTex (Diagram B)
d = do
  t0 <- timeline "$T_0$" . concat =<< sequence [steps, readOps, readRanges]
  ts <- timeline ""    . concat =<< sequence [updateRanges, updateSteps, commits]
  return $ t0 === ts

main = withArgs [ "-w", "400"
                -- , "-o", "parallel-timeline.pgf"
                , "-o", "parallel-timeline.pdf"
                ] $ onlineMain (pad 1.1 . centerXY <$> d)