flow.hs

{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE ViewPatterns      #-}
import Diagrams.Prelude
import Diagrams.Backend.PGF.CmdLine
import Control.Monad (forM_)
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)

scaleT :: String -> Diagram B
scaleT s = scale 0.31 $ text s 

steps :: String -> [(Double,String)] -> Diagram B
steps n bs = hcat . centerY . concat $
  [ [strutX 0 & named (n ++ ".left")]
  , [scaleT s `atop` rect w 1 | (w,s) <- bs]
  , [strutX 0 & named (n ++ ".right")]
  ]

stepsNoBox :: String -> [(Double,String)] -> Diagram B
stepsNoBox n bs = hcat . centerY . concat $
  [ [strutX 0 & named (n ++ ".left")]
  , [scaleT s `atop` (strutY 1 `atop` strutX w) | (w,s) <- bs]
  , [strutX 0 & named (n ++ ".right")]
  ]

lwA = lwO 1

label :: String -> V2 Double -> String -> Diagram B -> Diagram B
label a v s
  = withName a $ \(location -> pa) ->
      atop (moveTo (pa .+^ v) $ scaleT s) 

attach' :: String -> String -> Diagram B -> Diagram B
attach' a b
   = withName a $ \(unp2 . location -> (ax,ay)) ->
     withName b $ \(unp2 . location -> (bx,by)) ->
        let m = (ax + bx) / 2
        in  atop ((ax ^& ay) ~~ (bx ^& by) & lwA)

attach :: String -> String -> Diagram B -> Diagram B
attach a b
   = withName a $ \(unp2 . location -> (ax,ay)) ->
     withName b $ \(unp2 . location -> (bx,by)) ->
        let m = (ax + bx) / 2
        in  atop (arrowBez (ax ^& ay) (m ^& ay) (m ^& by) (bx ^& by) & lwA)

attachN :: String -> V2 Double -> String -> V2 Double -> Diagram B -> Diagram B
attachN a an b bn
    = withName a $ \(unp2 . location -> (ax,ay)) ->
      withName b $ \(unp2 . location -> (bx,by)) ->
        let d = 1 -- (sqrt $ (ax - bx)^2 + (ay - by)^2) / 2
            ap = p2 (ax ^& ay)
            bp = p2 (bx ^& by)
        in  atop (arrowBez ap (ap .+^ (an ^* d)) (bp .+^ (bn ^* d)) bp & lwA)

attachV :: String -> String -> Diagram B -> Diagram B
attachV a b
   = withName a $ \(unp2 . location -> (ax,ay)) ->
     withName b $ \(unp2 . location -> (bx,by)) ->
        let mx = (ax + bx) / 2
            my = (ay + by) / 2
        in  atop (arrowBez (ax ^& ay) (mx ^& ay) (bx ^& my) (bx ^& by) & lwA)

-- Attach vertical with circle arc down.
attachVC :: String -> String -> Diagram B -> Diagram B
attachVC a b
   = withName a $ \(unp2 . location -> (ax,ay)) ->
     withName b $ \(unp2 . location -> (bx,by)) ->
        let d = ay - by
        in  atop (arrowBez (ax ^& ay) ((ax + d) ^& ay) ((bx + d) ^& by) (bx ^& by) & lwA)

fixedBez a b c d = strokeLocTrail . mapLoc (fromSegments . (:[])) . fromFixedSeg $ FCubic a b c d

arrowBez a b c d = (fixedBez a b c d & lwA)
                <> (triangle 0.20 & scaleY 2 & lwG 0 & fc black
                                  & rotate t & rotateBy (1/4) & moveTo d)
  where
    t = (c .-. d)^._theta

waypoints :: [(Double, String)] -> Diagram B
waypoints vs = hcat [strutX x ||| (named n $ strutY 0) | (x,n) <- vs]

d :: Int -> Diagram B
d tick
  = (vcat . map alignL $
      [ strutY 1
      , ph tFull (waypoints [(1,"atomic"), (0.3,"atomicA")])
      , strutY 1
      , waypoints [(1,"C"),(4,"D"),(4,"E"),(4,"F")]
      , strutY 1
      , ph tFull (htmFull ||| strutX 2 ||| successFull) ||| strutX 1.9 ||| ph tHtm (vf ||| strutX 1.2) ||| ph tStm vf
      , strutY 1
      , waypoints [(1,"A"),(4,"B")]
      , strutY 1
      , ph tHtm (htmCommit ||| strutX 2 ||| successHtm)
      , strutY 1
      , ph tStm (strutX 12 ||| stmCommit ||| strutX 2 ||| successStm)
      ])
      & phA tFull (attach "atomicA" "atomic")
      & phA tFull (label "atomicA" (1 ^& 0) "Atomically")
      & phA tFull (attachN "atomic" ((-2) ^& 0) "htmFull.left" ((-2) ^& 0))
      & phA tFull (attach "htmFull.right" "successFull.left")
      
      & phA (tFull + 1) (attach "D" "C")
      & phA (tFull + 1) (attachN "C" ((-2) ^& 0) "htmFull.left" ((-1) ^& 0))
      & phA (tFull + 1) (label "D" (3.1 ^& (-0.6)) "Conflict failure")
      & phA (tFull + 1) (attachN "htmFull.right" (1 ^& 0) "D" (2 ^& 0))
      
      & phA tHtm (attachN "htmFull.right" (1 ^& 0) "B" (2 ^& 0))
      & phA tHtm (attachN "A" ((-2) ^& 0) "htmCommit.left" ((-1) ^& 0))
      & phA tHtm (attach "B" "A")
      & phA tHtm (attach "E" "D")
      & phA tHtm (attachN "htmCommit.right" (2 ^& 0) "E" (4 ^& 0))
      & phA tHtm (attach "htmCommit.right" "stmCommit.left")
      & phA tHtm (attach "htmCommit.right" "successHtm.left")
      & phA tHtm (label "A" (2 ^& 0.4) "Capacity failure")
      & phA tHtm (label "A" (2 ^& (-0.4)) "or out of attempts")
      
      & phA tStm (attach "F" "E")
      & phA tStm (attachN "stmCommit.right" (2 ^& 0) "F" (4 ^& 0))
      & phA tStm (attach "stmCommit.right" "successStm.left")
      & phA tStm (label "stmCommit.left" ((-2) ^& 0) "Out of attempts")
      
  where
    tFull = 0
    tHtm  = 2
    tStm  = 3

    stm = steps "stm" [(8, "STM Haskell Atomic Block"), (4, "Commit with Lock")]
    htmFull = steps "htmFull" [(6, "HTM Haskell Atomic Block")]
    htmCommit = steps "htmCommit" [(6, "STM Haskell Atomic Block"), (4, "Commit in HTM")]
    stmCommit = steps "stmCommit" [(4,"Commit with lock")]

    successFull = stepsNoBox "successFull" [(2, "Success")]
    successHtm  = stepsNoBox "successHtm"  [(2, "Success")]
    successStm  = stepsNoBox "successStm"  [(2, "Success")]
    vf = stepsNoBox "vf" [(3, "Validation Failure")]
    
    ph i d
      | tick >= i = d
      | otherwise = strutX 0 & withEnvelope d
    
    phA i f d
      | tick >= i = f d
      | otherwise = d & withEnvelope (f d)

main = do
    forM_ [0..3] $ \i -> do
        withArgs [ "-w", "310"
                 , "-o", "flow" ++ show i ++ ".pgf"
                 ] $ mainWith (centerXY $ d i)
-- https://www.cs.rochester.edu/u/ryates/temp/flow-slides.pdf