{-# LANGUAGE OverloadedStrings #-}

{- | This module contains functions for visualizing derivations using LaTeX and TikZ.
 These functions are generic over slice and transition contents and are thus somewhat limited.
 For protovoice derivations,
 an alternative to plotting a derivation would be to export an 'Analysis' to JSON
 and view it interactively in the
 [protovoice annotation tool](https://dcmlab.github.io/protovoice-annotation-tool/)
 (not implemented yet).

 Plotting happens in two steps.
 First, a the derivation is "replayed" using a (generic or grammar-specific) "player"
 to construct a 'DerivationGraph',
 which contains all graphical objects and their positions explicitly.
 The 'DerivationGraph' can then be plotted using different backends
 (currently only TikZ, but a diagrams/SVG backed would be useful too).
-}
module Display
  ( DerivationGraph (..)
  , DerivSlice (..)
  , DerivTrans

    -- * Replaying Derivations
  , replayDerivation
  , replayDerivation'
  , replayDerivationFull
  , unfoldDerivation
  , unfoldDerivation'

    -- * Derivation Players
  , DerivationPlayer (..)
  , derivationPlayerUnit
  , derivationPlayerEmpty
  , Empty

    -- * Plotting Derivation Graphs with TikZ
  , tikzDerivationGraph
  , tikzPic
  , tikzStandalone
  , writeGraph
  , writeGraphs
  , viewGraph
  , viewGraphs
  ) where

import Common

import Data.Set qualified as S

import Control.Monad (mzero)
import Control.Monad.State qualified as ST
import Control.Monad.Trans (lift)
import Data.Foldable (foldl')
import Data.List qualified as L
import Data.Map qualified as M
import Data.Text qualified as T
import Data.Text.IO qualified as T
import System.Process (callCommand)

import Data.Bifunctor (bimap)
import Data.String (IsString)
import System.FilePath qualified as FP

-- derivation graphs
-- =================

-- | A slice together with a depth and an ID
data DerivSlice slc = DerivSlice
  { forall slc. DerivSlice slc -> Int
dslDepth :: !Int
  , forall slc. DerivSlice slc -> Int
dslId :: !Int
  , forall slc. DerivSlice slc -> StartStop slc
dslContent :: !(StartStop slc)
  }
  deriving (DerivSlice slc -> DerivSlice slc -> Bool
(DerivSlice slc -> DerivSlice slc -> Bool)
-> (DerivSlice slc -> DerivSlice slc -> Bool)
-> Eq (DerivSlice slc)
forall slc. Eq slc => DerivSlice slc -> DerivSlice slc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall slc. Eq slc => DerivSlice slc -> DerivSlice slc -> Bool
== :: DerivSlice slc -> DerivSlice slc -> Bool
$c/= :: forall slc. Eq slc => DerivSlice slc -> DerivSlice slc -> Bool
/= :: DerivSlice slc -> DerivSlice slc -> Bool
Eq, Eq (DerivSlice slc)
Eq (DerivSlice slc) =>
(DerivSlice slc -> DerivSlice slc -> Ordering)
-> (DerivSlice slc -> DerivSlice slc -> Bool)
-> (DerivSlice slc -> DerivSlice slc -> Bool)
-> (DerivSlice slc -> DerivSlice slc -> Bool)
-> (DerivSlice slc -> DerivSlice slc -> Bool)
-> (DerivSlice slc -> DerivSlice slc -> DerivSlice slc)
-> (DerivSlice slc -> DerivSlice slc -> DerivSlice slc)
-> Ord (DerivSlice slc)
DerivSlice slc -> DerivSlice slc -> Bool
DerivSlice slc -> DerivSlice slc -> Ordering
DerivSlice slc -> DerivSlice slc -> DerivSlice slc
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall slc. Ord slc => Eq (DerivSlice slc)
forall slc. Ord slc => DerivSlice slc -> DerivSlice slc -> Bool
forall slc. Ord slc => DerivSlice slc -> DerivSlice slc -> Ordering
forall slc.
Ord slc =>
DerivSlice slc -> DerivSlice slc -> DerivSlice slc
$ccompare :: forall slc. Ord slc => DerivSlice slc -> DerivSlice slc -> Ordering
compare :: DerivSlice slc -> DerivSlice slc -> Ordering
$c< :: forall slc. Ord slc => DerivSlice slc -> DerivSlice slc -> Bool
< :: DerivSlice slc -> DerivSlice slc -> Bool
$c<= :: forall slc. Ord slc => DerivSlice slc -> DerivSlice slc -> Bool
<= :: DerivSlice slc -> DerivSlice slc -> Bool
$c> :: forall slc. Ord slc => DerivSlice slc -> DerivSlice slc -> Bool
> :: DerivSlice slc -> DerivSlice slc -> Bool
$c>= :: forall slc. Ord slc => DerivSlice slc -> DerivSlice slc -> Bool
>= :: DerivSlice slc -> DerivSlice slc -> Bool
$cmax :: forall slc.
Ord slc =>
DerivSlice slc -> DerivSlice slc -> DerivSlice slc
max :: DerivSlice slc -> DerivSlice slc -> DerivSlice slc
$cmin :: forall slc.
Ord slc =>
DerivSlice slc -> DerivSlice slc -> DerivSlice slc
min :: DerivSlice slc -> DerivSlice slc -> DerivSlice slc
Ord, Int -> DerivSlice slc -> ShowS
[DerivSlice slc] -> ShowS
DerivSlice slc -> String
(Int -> DerivSlice slc -> ShowS)
-> (DerivSlice slc -> String)
-> ([DerivSlice slc] -> ShowS)
-> Show (DerivSlice slc)
forall slc. Show slc => Int -> DerivSlice slc -> ShowS
forall slc. Show slc => [DerivSlice slc] -> ShowS
forall slc. Show slc => DerivSlice slc -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall slc. Show slc => Int -> DerivSlice slc -> ShowS
showsPrec :: Int -> DerivSlice slc -> ShowS
$cshow :: forall slc. Show slc => DerivSlice slc -> String
show :: DerivSlice slc -> String
$cshowList :: forall slc. Show slc => [DerivSlice slc] -> ShowS
showList :: [DerivSlice slc] -> ShowS
Show)

-- | A transition between two 'DerivSlice's.
type DerivTrans slc tr = (DerivSlice slc, tr, DerivSlice slc)

{- | A derivation graph.
 Contains the graphical objects of a derivation plot
 as well as intermediate information that is used during a replay.
-}
data DerivationGraph slc tr = DGraph
  { forall slc tr. DerivationGraph slc tr -> Int
dgNextId :: !Int
  -- ^ a counter for generating new IDs (used during replay)
  , forall slc tr. DerivationGraph slc tr -> Set (DerivSlice slc)
dgSlices :: !(S.Set (DerivSlice slc))
  -- ^ the positioned slices of the derivation graph
  , forall slc tr. DerivationGraph slc tr -> Set (DerivTrans slc tr)
dgTransitions :: !(S.Set (DerivTrans slc tr))
  -- ^ the positioned transitionn in the derivation graph
  , forall slc tr.
DerivationGraph slc tr -> Set (DerivSlice slc, DerivSlice slc)
dgHoriEdges :: !(S.Set (DerivSlice slc, DerivSlice slc))
  -- ^ the "horizontalization" edges
  -- (connecting the parent slice of a spread to its children)
  , forall slc tr. DerivationGraph slc tr -> [DerivTrans slc tr]
dgOpen :: ![DerivTrans slc tr]
  -- ^ the open transitions of the current surface
  , forall slc tr. DerivationGraph slc tr -> [DerivTrans slc tr]
dgFrozen :: ![DerivTrans slc tr]
  -- ^ the frozen transitions of the current surface in reverse order
  , forall slc tr. DerivationGraph slc tr -> [DerivTrans slc tr]
dgRoot :: ![DerivTrans slc tr]
  -- ^ the root transitions
  }
  deriving (DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
(DerivationGraph slc tr -> DerivationGraph slc tr -> Bool)
-> (DerivationGraph slc tr -> DerivationGraph slc tr -> Bool)
-> Eq (DerivationGraph slc tr)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall slc tr.
(Eq slc, Eq tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
$c== :: forall slc tr.
(Eq slc, Eq tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
== :: DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
$c/= :: forall slc tr.
(Eq slc, Eq tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
/= :: DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
Eq, Eq (DerivationGraph slc tr)
Eq (DerivationGraph slc tr) =>
(DerivationGraph slc tr -> DerivationGraph slc tr -> Ordering)
-> (DerivationGraph slc tr -> DerivationGraph slc tr -> Bool)
-> (DerivationGraph slc tr -> DerivationGraph slc tr -> Bool)
-> (DerivationGraph slc tr -> DerivationGraph slc tr -> Bool)
-> (DerivationGraph slc tr -> DerivationGraph slc tr -> Bool)
-> (DerivationGraph slc tr
    -> DerivationGraph slc tr -> DerivationGraph slc tr)
-> (DerivationGraph slc tr
    -> DerivationGraph slc tr -> DerivationGraph slc tr)
-> Ord (DerivationGraph slc tr)
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
DerivationGraph slc tr -> DerivationGraph slc tr -> Ordering
DerivationGraph slc tr
-> DerivationGraph slc tr -> DerivationGraph slc tr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall slc tr. (Ord slc, Ord tr) => Eq (DerivationGraph slc tr)
forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Ordering
forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr
-> DerivationGraph slc tr -> DerivationGraph slc tr
$ccompare :: forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Ordering
compare :: DerivationGraph slc tr -> DerivationGraph slc tr -> Ordering
$c< :: forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
< :: DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
$c<= :: forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
<= :: DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
$c> :: forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
> :: DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
$c>= :: forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
>= :: DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
$cmax :: forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr
-> DerivationGraph slc tr -> DerivationGraph slc tr
max :: DerivationGraph slc tr
-> DerivationGraph slc tr -> DerivationGraph slc tr
$cmin :: forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr
-> DerivationGraph slc tr -> DerivationGraph slc tr
min :: DerivationGraph slc tr
-> DerivationGraph slc tr -> DerivationGraph slc tr
Ord, Int -> DerivationGraph slc tr -> ShowS
[DerivationGraph slc tr] -> ShowS
DerivationGraph slc tr -> String
(Int -> DerivationGraph slc tr -> ShowS)
-> (DerivationGraph slc tr -> String)
-> ([DerivationGraph slc tr] -> ShowS)
-> Show (DerivationGraph slc tr)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall slc tr.
(Show slc, Show tr) =>
Int -> DerivationGraph slc tr -> ShowS
forall slc tr.
(Show slc, Show tr) =>
[DerivationGraph slc tr] -> ShowS
forall slc tr.
(Show slc, Show tr) =>
DerivationGraph slc tr -> String
$cshowsPrec :: forall slc tr.
(Show slc, Show tr) =>
Int -> DerivationGraph slc tr -> ShowS
showsPrec :: Int -> DerivationGraph slc tr -> ShowS
$cshow :: forall slc tr.
(Show slc, Show tr) =>
DerivationGraph slc tr -> String
show :: DerivationGraph slc tr -> String
$cshowList :: forall slc tr.
(Show slc, Show tr) =>
[DerivationGraph slc tr] -> ShowS
showList :: [DerivationGraph slc tr] -> ShowS
Show)

-- | Alias for the type of a monadic action during derivation replay.
type DerivationOp slc tr = ST.StateT (DerivationGraph slc tr) (Either String)

-- | Removes and returns an open transition from the current surface.
popOpen :: DerivationOp slc tr (DerivTrans slc tr)
popOpen :: forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen = do
  graph <- StateT
  (DerivationGraph slc tr) (Either String) (DerivationGraph slc tr)
forall s (m :: * -> *). MonadState s m => m s
ST.get
  case dgOpen graph of
    [] -> Either String (DerivTrans slc tr)
-> StateT
     (DerivationGraph slc tr) (Either String) (DerivTrans slc tr)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DerivationGraph slc tr) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
ST.lift (Either String (DerivTrans slc tr)
 -> StateT
      (DerivationGraph slc tr) (Either String) (DerivTrans slc tr))
-> Either String (DerivTrans slc tr)
-> StateT
     (DerivationGraph slc tr) (Either String) (DerivTrans slc tr)
forall a b. (a -> b) -> a -> b
$ String -> Either String (DerivTrans slc tr)
forall a b. a -> Either a b
Left String
"popOpen: no transition to pop"
    DerivTrans slc tr
t : [DerivTrans slc tr]
ts -> do
      DerivationGraph slc tr
-> StateT (DerivationGraph slc tr) (Either String) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
ST.put DerivationGraph slc tr
graph{dgOpen = ts}
      DerivTrans slc tr
-> StateT
     (DerivationGraph slc tr) (Either String) (DerivTrans slc tr)
forall a. a -> StateT (DerivationGraph slc tr) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivTrans slc tr
t

-- | Adds a list of new open transitions to the current surface and the derivation graph.
pushOpen :: (Ord slc, Ord tr) => [DerivTrans slc tr] -> DerivationOp slc tr ()
pushOpen :: forall slc tr.
(Ord slc, Ord tr) =>
[DerivTrans slc tr] -> DerivationOp slc tr ()
pushOpen [DerivTrans slc tr]
newts = do
  graph <- StateT
  (DerivationGraph slc tr) (Either String) (DerivationGraph slc tr)
forall s (m :: * -> *). MonadState s m => m s
ST.get
  let trans' = [DerivTrans slc tr] -> Set (DerivTrans slc tr)
forall a. Ord a => [a] -> Set a
S.fromList [DerivTrans slc tr]
newts Set (DerivTrans slc tr)
-> Set (DerivTrans slc tr) -> Set (DerivTrans slc tr)
forall a. Semigroup a => a -> a -> a
<> DerivationGraph slc tr -> Set (DerivTrans slc tr)
forall slc tr. DerivationGraph slc tr -> Set (DerivTrans slc tr)
dgTransitions DerivationGraph slc tr
graph
      surf' = [DerivTrans slc tr]
newts [DerivTrans slc tr] -> [DerivTrans slc tr] -> [DerivTrans slc tr]
forall a. Semigroup a => a -> a -> a
<> DerivationGraph slc tr -> [DerivTrans slc tr]
forall slc tr. DerivationGraph slc tr -> [DerivTrans slc tr]
dgOpen DerivationGraph slc tr
graph
  ST.put $ graph{dgTransitions = trans', dgOpen = surf'}

-- | Adds a frozen transition to the current surface and the derivation graph.
pushClosed :: (Ord slc, Ord tr) => DerivTrans slc tr -> DerivationOp slc tr ()
pushClosed :: forall slc tr.
(Ord slc, Ord tr) =>
DerivTrans slc tr -> DerivationOp slc tr ()
pushClosed DerivTrans slc tr
newt = do
  graph <- StateT
  (DerivationGraph slc tr) (Either String) (DerivationGraph slc tr)
forall s (m :: * -> *). MonadState s m => m s
ST.get
  let trans' = DerivTrans slc tr
-> Set (DerivTrans slc tr) -> Set (DerivTrans slc tr)
forall a. Ord a => a -> Set a -> Set a
S.insert DerivTrans slc tr
newt (Set (DerivTrans slc tr) -> Set (DerivTrans slc tr))
-> Set (DerivTrans slc tr) -> Set (DerivTrans slc tr)
forall a b. (a -> b) -> a -> b
$ DerivationGraph slc tr -> Set (DerivTrans slc tr)
forall slc tr. DerivationGraph slc tr -> Set (DerivTrans slc tr)
dgTransitions DerivationGraph slc tr
graph
      frozen' = DerivTrans slc tr
newt DerivTrans slc tr -> [DerivTrans slc tr] -> [DerivTrans slc tr]
forall a. a -> [a] -> [a]
: DerivationGraph slc tr -> [DerivTrans slc tr]
forall slc tr. DerivationGraph slc tr -> [DerivTrans slc tr]
dgFrozen DerivationGraph slc tr
graph
  ST.put $ graph{dgTransitions = trans', dgFrozen = frozen'}

-- | Adds a new slice to the derivation graph.
addSlice :: (Ord slc) => slc -> Int -> DerivationOp slc tr (DerivSlice slc)
addSlice :: forall slc tr.
Ord slc =>
slc -> Int -> DerivationOp slc tr (DerivSlice slc)
addSlice slc
sliceContent Int
depth = do
  graph <- StateT
  (DerivationGraph slc tr) (Either String) (DerivationGraph slc tr)
forall s (m :: * -> *). MonadState s m => m s
ST.get
  let i = DerivationGraph slc tr -> Int
forall slc tr. DerivationGraph slc tr -> Int
dgNextId DerivationGraph slc tr
graph
      newSlice = Int -> Int -> StartStop slc -> DerivSlice slc
forall slc. Int -> Int -> StartStop slc -> DerivSlice slc
DerivSlice Int
depth Int
i (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sliceContent)
      slices' = DerivSlice slc -> Set (DerivSlice slc) -> Set (DerivSlice slc)
forall a. Ord a => a -> Set a -> Set a
S.insert DerivSlice slc
newSlice (Set (DerivSlice slc) -> Set (DerivSlice slc))
-> Set (DerivSlice slc) -> Set (DerivSlice slc)
forall a b. (a -> b) -> a -> b
$ DerivationGraph slc tr -> Set (DerivSlice slc)
forall slc tr. DerivationGraph slc tr -> Set (DerivSlice slc)
dgSlices DerivationGraph slc tr
graph
  ST.put $ graph{dgNextId = i + 1, dgSlices = slices'}
  pure newSlice

-- | Adds a new horizontalization edge to the derivation graph.
addHoriEdge :: (Ord slc) => (DerivSlice slc, DerivSlice slc) -> DerivationOp slc tr ()
addHoriEdge :: forall slc tr.
Ord slc =>
(DerivSlice slc, DerivSlice slc) -> DerivationOp slc tr ()
addHoriEdge (DerivSlice slc, DerivSlice slc)
edge = do
  graph <- StateT
  (DerivationGraph slc tr) (Either String) (DerivationGraph slc tr)
forall s (m :: * -> *). MonadState s m => m s
ST.get
  let horis' = (DerivSlice slc, DerivSlice slc)
-> Set (DerivSlice slc, DerivSlice slc)
-> Set (DerivSlice slc, DerivSlice slc)
forall a. Ord a => a -> Set a -> Set a
S.insert (DerivSlice slc, DerivSlice slc)
edge (Set (DerivSlice slc, DerivSlice slc)
 -> Set (DerivSlice slc, DerivSlice slc))
-> Set (DerivSlice slc, DerivSlice slc)
-> Set (DerivSlice slc, DerivSlice slc)
forall a b. (a -> b) -> a -> b
$ DerivationGraph slc tr -> Set (DerivSlice slc, DerivSlice slc)
forall slc tr.
DerivationGraph slc tr -> Set (DerivSlice slc, DerivSlice slc)
dgHoriEdges DerivationGraph slc tr
graph
  ST.put $ graph{dgHoriEdges = horis'}

{- | A derivation player.
 Contains functions for replaying derivations of a particular grammar,
 i.e. for deriving child elements from parent elements.
-}
data DerivationPlayer s f h slc tr = DerivationPlayer
  { forall s f h slc tr. DerivationPlayer s f h slc tr -> tr
dpTopTrans :: !tr
  -- ^ the grammars default starting transition for @⋊——⋉@
  , forall s f h slc tr.
DerivationPlayer s f h slc tr
-> s -> tr -> Either String (tr, slc, tr)
dpSplit :: !(s -> tr -> Either String (tr, slc, tr))
  -- ^ replay a split operation
  , forall s f h slc tr.
DerivationPlayer s f h slc tr -> f -> tr -> Either String tr
dpFreeze :: !(f -> tr -> Either String tr)
  -- ^ replay a freeze operation
  , forall s f h slc tr.
DerivationPlayer s f h slc tr
-> h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr)
dpSpread :: !(h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr))
  -- ^ replay a spread operation
  }

-- | Replays a single derivation step and applies it to the derivation graph.
replayDerivationStep
  :: (Ord slc, Ord tr)
  => DerivationPlayer s f h slc tr
  -- ^ the derivation player
  -> Leftmost s f h
  -- ^ the operation to be applied
  -> DerivationOp slc tr ()
replayDerivationStep :: forall slc tr s f h.
(Ord slc, Ord tr) =>
DerivationPlayer s f h slc tr
-> Leftmost s f h -> DerivationOp slc tr ()
replayDerivationStep DerivationPlayer s f h slc tr
player = Leftmost s f h
-> StateT (DerivationGraph slc tr) (Either String) ()
applyRule
 where
  applyRule :: Leftmost s f h
-> StateT (DerivationGraph slc tr) (Either String) ()
applyRule (LMSplitLeft s
s) = do
    (pl, pt, pr) <- DerivationOp slc tr (DerivSlice slc, tr, DerivSlice slc)
forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen
    (cl, cm, cr) <- lift $ dpSplit player s pt
    sm <- addSlice cm $ max (dslDepth pl) (dslDepth pr) + 1
    pushOpen [(pl, cl, sm), (sm, cr, pr)]
  applyRule (LMSplitOnly s
s) = Leftmost s f h
-> StateT (DerivationGraph slc tr) (Either String) ()
applyRule (Leftmost s f h
 -> StateT (DerivationGraph slc tr) (Either String) ())
-> Leftmost s f h
-> StateT (DerivationGraph slc tr) (Either String) ()
forall a b. (a -> b) -> a -> b
$ s -> Leftmost s f h
forall s f h. s -> Leftmost s f h
LMSplitLeft s
s
  applyRule (LMSplitRight s
s) = do
    l <- DerivationOp slc tr (DerivSlice slc, tr, DerivSlice slc)
forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen
    (pl, pt, pr) <- popOpen
    (cl, cm, cr) <- lift $ dpSplit player s pt
    sm <- addSlice cm $ max (dslDepth pl) (dslDepth pr) + 1
    pushOpen [l, (pl, cl, sm), (sm, cr, pr)]
  applyRule (LMFreezeLeft f
f) = do
    (pl, pt, pr) <- DerivationOp slc tr (DerivSlice slc, tr, DerivSlice slc)
forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen
    t <- lift $ dpFreeze player f pt
    pushClosed (pl, t, pr)
  applyRule (LMFreezeOnly f
f) = Leftmost s f h
-> StateT (DerivationGraph slc tr) (Either String) ()
applyRule (Leftmost s f h
 -> StateT (DerivationGraph slc tr) (Either String) ())
-> Leftmost s f h
-> StateT (DerivationGraph slc tr) (Either String) ()
forall a b. (a -> b) -> a -> b
$ f -> Leftmost s f h
forall f s h. f -> Leftmost s f h
LMFreezeLeft f
f
  applyRule (LMSpread h
h) = do
    (lpl, lpt, pm) <- DerivationOp slc tr (DerivSlice slc, tr, DerivSlice slc)
forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen
    (_, rpt, rpr) <- popOpen
    let depth' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslDepth DerivSlice slc
lpl) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslDepth DerivSlice slc
pm) (DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslDepth DerivSlice slc
rpr)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    pmInner <- lift $ getInnerE (dslContent pm)
    (l, lc, m, rc, r) <- lift $ dpSpread player h lpt pmInner rpt
    ls <- addSlice lc depth'
    rs <- addSlice rc depth'
    addHoriEdge (pm, ls)
    addHoriEdge (pm, rs)
    pushOpen [(lpl, l, ls), (ls, m, rs), (rs, r, rpr)]

-- | Creates the initial state of the derivation graph.
initialGraph
  :: (Ord slc, Ord tr)
  => Path tr slc -- DerivationPlayer s f h slc tr
  -> DerivationGraph slc tr
initialGraph :: forall slc tr.
(Ord slc, Ord tr) =>
Path tr slc -> DerivationGraph slc tr
initialGraph Path tr slc
topPath =
  Int
-> Set (DerivSlice slc)
-> Set (DerivTrans slc tr)
-> Set (DerivSlice slc, DerivSlice slc)
-> [DerivTrans slc tr]
-> [DerivTrans slc tr]
-> [DerivTrans slc tr]
-> DerivationGraph slc tr
forall slc tr.
Int
-> Set (DerivSlice slc)
-> Set (DerivTrans slc tr)
-> Set (DerivSlice slc, DerivSlice slc)
-> [DerivTrans slc tr]
-> [DerivTrans slc tr]
-> [DerivTrans slc tr]
-> DerivationGraph slc tr
DGraph
    (Path tr slc -> Int
forall a b. Path a b -> Int
pathLen Path tr slc
topPath Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    ([DerivSlice slc] -> Set (DerivSlice slc)
forall a. Ord a => [a] -> Set a
S.fromList [DerivSlice slc]
topSlices)
    ([DerivTrans slc tr] -> Set (DerivTrans slc tr)
forall a. Ord a => [a] -> Set a
S.fromList [DerivTrans slc tr]
top)
    Set (DerivSlice slc, DerivSlice slc)
forall a. Set a
S.empty
    [DerivTrans slc tr]
top
    []
    [DerivTrans slc tr]
top
 where
  topStart :: DerivSlice slc
topStart = Int -> Int -> StartStop slc -> DerivSlice slc
forall slc. Int -> Int -> StartStop slc -> DerivSlice slc
DerivSlice Int
0 Int
0 StartStop slc
forall a. StartStop a
Start
  -- collect initial slices (+ Start / Stop)
  topContents :: [StartStop slc]
topContents = (slc -> StartStop slc
forall a. a -> StartStop a
Inner (slc -> StartStop slc) -> [slc] -> [StartStop slc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path tr slc -> [slc]
forall a b. Path a b -> [b]
pathBetweens Path tr slc
topPath) [StartStop slc] -> [StartStop slc] -> [StartStop slc]
forall a. Semigroup a => a -> a -> a
<> [StartStop slc
forall a. StartStop a
Stop]
  -- assign depth=0 and running IDs to initial slices
  topSlicesTail :: [DerivSlice slc]
topSlicesTail = (Int -> StartStop slc -> DerivSlice slc)
-> [Int] -> [StartStop slc] -> [DerivSlice slc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> StartStop slc -> DerivSlice slc
forall slc. Int -> Int -> StartStop slc -> DerivSlice slc
DerivSlice Int
0) [Int
1 ..] [StartStop slc]
topContents
  topSlices :: [DerivSlice slc]
topSlices = DerivSlice slc
forall {slc}. DerivSlice slc
topStart DerivSlice slc -> [DerivSlice slc] -> [DerivSlice slc]
forall a. a -> [a] -> [a]
: [DerivSlice slc]
topSlicesTail
  top :: [DerivTrans slc tr]
top = [DerivSlice slc] -> [tr] -> [DerivSlice slc] -> [DerivTrans slc tr]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [DerivSlice slc]
topSlices (Path tr slc -> [tr]
forall a b. Path a b -> [a]
pathArounds Path tr slc
topPath) [DerivSlice slc]
topSlicesTail

-- | Replay a derivation from @n@ top-level transitions.
replayDerivation'
  :: (Foldable t, Ord slc, Ord tr)
  => Path tr slc
  -- ^ the starting point of the derivation
  -> DerivationPlayer s f h slc tr
  -- ^ the derivation player
  -> t (Leftmost s f h)
  -- ^ the derivation
  -> Either String (DerivationGraph slc tr)
replayDerivation' :: forall (t :: * -> *) slc tr s f h.
(Foldable t, Ord slc, Ord tr) =>
Path tr slc
-> DerivationPlayer s f h slc tr
-> t (Leftmost s f h)
-> Either String (DerivationGraph slc tr)
replayDerivation' Path tr slc
topPath DerivationPlayer s f h slc tr
player t (Leftmost s f h)
deriv =
  StateT (DerivationGraph slc tr) (Either String) ()
-> DerivationGraph slc tr -> Either String (DerivationGraph slc tr)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
ST.execStateT
    ((Leftmost s f h
 -> StateT (DerivationGraph slc tr) (Either String) ())
-> t (Leftmost s f h)
-> StateT (DerivationGraph slc tr) (Either String) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DerivationPlayer s f h slc tr
-> Leftmost s f h
-> StateT (DerivationGraph slc tr) (Either String) ()
forall slc tr s f h.
(Ord slc, Ord tr) =>
DerivationPlayer s f h slc tr
-> Leftmost s f h -> DerivationOp slc tr ()
replayDerivationStep DerivationPlayer s f h slc tr
player) t (Leftmost s f h)
deriv)
    (Path tr slc -> DerivationGraph slc tr
forall slc tr.
(Ord slc, Ord tr) =>
Path tr slc -> DerivationGraph slc tr
initialGraph Path tr slc
topPath)

-- | Replay a derivation from @⋊——⋉@.
replayDerivation
  :: (Foldable t, Ord slc, Ord tr)
  => DerivationPlayer s f h slc tr
  -- ^ the derivation player
  -> t (Leftmost s f h)
  -- ^ the derivation
  -> Either String (DerivationGraph slc tr)
replayDerivation :: forall (t :: * -> *) slc tr s f h.
(Foldable t, Ord slc, Ord tr) =>
DerivationPlayer s f h slc tr
-> t (Leftmost s f h) -> Either String (DerivationGraph slc tr)
replayDerivation DerivationPlayer s f h slc tr
player = Path tr slc
-> DerivationPlayer s f h slc tr
-> t (Leftmost s f h)
-> Either String (DerivationGraph slc tr)
forall (t :: * -> *) slc tr s f h.
(Foldable t, Ord slc, Ord tr) =>
Path tr slc
-> DerivationPlayer s f h slc tr
-> t (Leftmost s f h)
-> Either String (DerivationGraph slc tr)
replayDerivation' Path tr slc
forall {between}. Path tr between
topPath DerivationPlayer s f h slc tr
player
 where
  topPath :: Path tr between
topPath = tr -> Path tr between
forall around between. around -> Path around between
PathEnd (tr -> Path tr between) -> tr -> Path tr between
forall a b. (a -> b) -> a -> b
$ DerivationPlayer s f h slc tr -> tr
forall s f h slc tr. DerivationPlayer s f h slc tr -> tr
dpTopTrans DerivationPlayer s f h slc tr
player

{- | Replay a derivation from @⋊——⋉@
 and ensure that the dervation is complete (freezing all transitions).
 Return an error message if not.
-}
replayDerivationFull
  :: (Foldable t, Ord slc, Ord tr)
  => DerivationPlayer s f h slc tr
  -- ^ the derivation player
  -> t (Leftmost s f h)
  -- ^ the derivation
  -> Either String (DerivationGraph slc tr)
replayDerivationFull :: forall (t :: * -> *) slc tr s f h.
(Foldable t, Ord slc, Ord tr) =>
DerivationPlayer s f h slc tr
-> t (Leftmost s f h) -> Either String (DerivationGraph slc tr)
replayDerivationFull DerivationPlayer s f h slc tr
player t (Leftmost s f h)
deriv = do
  graph <- DerivationPlayer s f h slc tr
-> t (Leftmost s f h) -> Either String (DerivationGraph slc tr)
forall (t :: * -> *) slc tr s f h.
(Foldable t, Ord slc, Ord tr) =>
DerivationPlayer s f h slc tr
-> t (Leftmost s f h) -> Either String (DerivationGraph slc tr)
replayDerivation DerivationPlayer s f h slc tr
player t (Leftmost s f h)
deriv
  if L.null $ dgOpen graph
    then Right graph
    else Left "Not all open transitions have been frozen!"

-- TODO: this should work with foldM and a Foldable input:

{- | Replays a derivation from @n@ top-level transitions
 and returns every intermediate derivation graph.
-}
unfoldDerivation'
  :: (Ord slc, Ord tr)
  => Path tr slc
  -- ^ the starting point of the derivation
  -> DerivationPlayer s f h slc tr
  -- ^ the derivation player
  -> [Leftmost s f h]
  -- ^ the derivation
  -> [Either String (DerivationGraph slc tr)]
unfoldDerivation' :: forall slc tr s f h.
(Ord slc, Ord tr) =>
Path tr slc
-> DerivationPlayer s f h slc tr
-> [Leftmost s f h]
-> [Either String (DerivationGraph slc tr)]
unfoldDerivation' Path tr slc
topPath DerivationPlayer s f h slc tr
player = DerivationGraph slc tr
-> [Either String (DerivationGraph slc tr)]
-> [Leftmost s f h]
-> [Either String (DerivationGraph slc tr)]
go (Path tr slc -> DerivationGraph slc tr
forall slc tr.
(Ord slc, Ord tr) =>
Path tr slc -> DerivationGraph slc tr
initialGraph Path tr slc
topPath) []
 where
  go :: DerivationGraph slc tr
-> [Either String (DerivationGraph slc tr)]
-> [Leftmost s f h]
-> [Either String (DerivationGraph slc tr)]
go DerivationGraph slc tr
g [Either String (DerivationGraph slc tr)]
acc [] = DerivationGraph slc tr -> Either String (DerivationGraph slc tr)
forall a b. b -> Either a b
Right DerivationGraph slc tr
g Either String (DerivationGraph slc tr)
-> [Either String (DerivationGraph slc tr)]
-> [Either String (DerivationGraph slc tr)]
forall a. a -> [a] -> [a]
: [Either String (DerivationGraph slc tr)]
acc
  go DerivationGraph slc tr
g [Either String (DerivationGraph slc tr)]
acc (Leftmost s f h
step : [Leftmost s f h]
rest) =
    case StateT (DerivationGraph slc tr) (Either String) ()
-> DerivationGraph slc tr -> Either String (DerivationGraph slc tr)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
ST.execStateT (DerivationPlayer s f h slc tr
-> Leftmost s f h
-> StateT (DerivationGraph slc tr) (Either String) ()
forall slc tr s f h.
(Ord slc, Ord tr) =>
DerivationPlayer s f h slc tr
-> Leftmost s f h -> DerivationOp slc tr ()
replayDerivationStep DerivationPlayer s f h slc tr
player Leftmost s f h
step) DerivationGraph slc tr
g of
      Left String
err -> String -> Either String (DerivationGraph slc tr)
forall a b. a -> Either a b
Left String
err Either String (DerivationGraph slc tr)
-> [Either String (DerivationGraph slc tr)]
-> [Either String (DerivationGraph slc tr)]
forall a. a -> [a] -> [a]
: [Either String (DerivationGraph slc tr)]
acc
      Right DerivationGraph slc tr
g' -> DerivationGraph slc tr
-> [Either String (DerivationGraph slc tr)]
-> [Leftmost s f h]
-> [Either String (DerivationGraph slc tr)]
go DerivationGraph slc tr
g' (DerivationGraph slc tr -> Either String (DerivationGraph slc tr)
forall a b. b -> Either a b
Right DerivationGraph slc tr
g Either String (DerivationGraph slc tr)
-> [Either String (DerivationGraph slc tr)]
-> [Either String (DerivationGraph slc tr)]
forall a. a -> [a] -> [a]
: [Either String (DerivationGraph slc tr)]
acc) [Leftmost s f h]
rest

{- | Replays a derivation from @⋊——⋉@
 and returns every intermediate derivation graph.
-}
unfoldDerivation
  :: (Ord slc, Ord tr)
  => DerivationPlayer s f h slc tr
  -- ^ the derivation player
  -> [Leftmost s f h]
  -- ^ the derivation
  -> [Either String (DerivationGraph slc tr)]
unfoldDerivation :: forall slc tr s f h.
(Ord slc, Ord tr) =>
DerivationPlayer s f h slc tr
-> [Leftmost s f h] -> [Either String (DerivationGraph slc tr)]
unfoldDerivation DerivationPlayer s f h slc tr
player = Path tr slc
-> DerivationPlayer s f h slc tr
-> [Leftmost s f h]
-> [Either String (DerivationGraph slc tr)]
forall slc tr s f h.
(Ord slc, Ord tr) =>
Path tr slc
-> DerivationPlayer s f h slc tr
-> [Leftmost s f h]
-> [Either String (DerivationGraph slc tr)]
unfoldDerivation' Path tr slc
forall {between}. Path tr between
topPath DerivationPlayer s f h slc tr
player
 where
  topPath :: Path tr between
topPath = tr -> Path tr between
forall around between. around -> Path around between
PathEnd (tr -> Path tr between) -> tr -> Path tr between
forall a b. (a -> b) -> a -> b
$ DerivationPlayer s f h slc tr -> tr
forall s f h slc tr. DerivationPlayer s f h slc tr -> tr
dpTopTrans DerivationPlayer s f h slc tr
player

{- | A derivation player that uses @()@ for slice and transition contents.
 The actual derivation operations are ignored, so only the outer structure is produced.
-}
derivationPlayerUnit :: DerivationPlayer s f h () ()
derivationPlayerUnit :: forall s f h. DerivationPlayer s f h () ()
derivationPlayerUnit = ()
-> (s -> () -> Either String ((), (), ()))
-> (f -> () -> Either String ())
-> (h -> () -> () -> () -> Either String ((), (), (), (), ()))
-> DerivationPlayer s f h () ()
forall s f h slc tr.
tr
-> (s -> tr -> Either String (tr, slc, tr))
-> (f -> tr -> Either String tr)
-> (h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr))
-> DerivationPlayer s f h slc tr
DerivationPlayer () s -> () -> Either String ((), (), ())
forall {p} {p} {a}. p -> p -> Either a ((), (), ())
usplit f -> () -> Either String ()
forall {p} {p} {a}. p -> p -> Either a ()
ufreeze h -> () -> () -> () -> Either String ((), (), (), (), ())
forall {p} {p} {p} {p} {a}.
p -> p -> p -> p -> Either a ((), (), (), (), ())
uspread
 where
  usplit :: p -> p -> Either a ((), (), ())
usplit p
_ p
_ = ((), (), ()) -> Either a ((), (), ())
forall a b. b -> Either a b
Right ((), (), ())
  ufreeze :: p -> p -> Either a ()
ufreeze p
_ p
_ = () -> Either a ()
forall a b. b -> Either a b
Right ()
  uspread :: p -> p -> p -> p -> Either a ((), (), (), (), ())
uspread p
_ p
_ p
_ p
_ = ((), (), (), (), ()) -> Either a ((), (), (), (), ())
forall a b. b -> Either a b
Right ((), (), (), (), ())

-- | A helper type that is like @()@ but has a 'Show' instance that returns the empty string.
data Empty = Empty
  deriving (Empty -> Empty -> Bool
(Empty -> Empty -> Bool) -> (Empty -> Empty -> Bool) -> Eq Empty
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Empty -> Empty -> Bool
== :: Empty -> Empty -> Bool
$c/= :: Empty -> Empty -> Bool
/= :: Empty -> Empty -> Bool
Eq, Eq Empty
Eq Empty =>
(Empty -> Empty -> Ordering)
-> (Empty -> Empty -> Bool)
-> (Empty -> Empty -> Bool)
-> (Empty -> Empty -> Bool)
-> (Empty -> Empty -> Bool)
-> (Empty -> Empty -> Empty)
-> (Empty -> Empty -> Empty)
-> Ord Empty
Empty -> Empty -> Bool
Empty -> Empty -> Ordering
Empty -> Empty -> Empty
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Empty -> Empty -> Ordering
compare :: Empty -> Empty -> Ordering
$c< :: Empty -> Empty -> Bool
< :: Empty -> Empty -> Bool
$c<= :: Empty -> Empty -> Bool
<= :: Empty -> Empty -> Bool
$c> :: Empty -> Empty -> Bool
> :: Empty -> Empty -> Bool
$c>= :: Empty -> Empty -> Bool
>= :: Empty -> Empty -> Bool
$cmax :: Empty -> Empty -> Empty
max :: Empty -> Empty -> Empty
$cmin :: Empty -> Empty -> Empty
min :: Empty -> Empty -> Empty
Ord)

instance Show Empty where
  show :: Empty -> String
show Empty
Empty = String
""

{- | A derivation player that uses 'Empty' for slice and transition content.
 The actual derivation operations are ignored, so only the outer structure is produced.
-}
derivationPlayerEmpty :: DerivationPlayer s f h Empty Empty
derivationPlayerEmpty :: forall s f h. DerivationPlayer s f h Empty Empty
derivationPlayerEmpty = Empty
-> (s -> Empty -> Either String (Empty, Empty, Empty))
-> (f -> Empty -> Either String Empty)
-> (h
    -> Empty
    -> Empty
    -> Empty
    -> Either String (Empty, Empty, Empty, Empty, Empty))
-> DerivationPlayer s f h Empty Empty
forall s f h slc tr.
tr
-> (s -> tr -> Either String (tr, slc, tr))
-> (f -> tr -> Either String tr)
-> (h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr))
-> DerivationPlayer s f h slc tr
DerivationPlayer Empty
Empty s -> Empty -> Either String (Empty, Empty, Empty)
forall {p} {p} {a}. p -> p -> Either a (Empty, Empty, Empty)
nsplit f -> Empty -> Either String Empty
forall {p} {p} {a}. p -> p -> Either a Empty
nfreeze h
-> Empty
-> Empty
-> Empty
-> Either String (Empty, Empty, Empty, Empty, Empty)
forall {p} {p} {p} {p} {a}.
p -> p -> p -> p -> Either a (Empty, Empty, Empty, Empty, Empty)
nspread
 where
  nsplit :: p -> p -> Either a (Empty, Empty, Empty)
nsplit p
_ p
_ = (Empty, Empty, Empty) -> Either a (Empty, Empty, Empty)
forall a b. b -> Either a b
Right (Empty
Empty, Empty
Empty, Empty
Empty)
  nfreeze :: p -> p -> Either a Empty
nfreeze p
_ p
_ = Empty -> Either a Empty
forall a b. b -> Either a b
Right Empty
Empty
  nspread :: p -> p -> p -> p -> Either a (Empty, Empty, Empty, Empty, Empty)
nspread p
_ p
_ p
_ p
_ = (Empty, Empty, Empty, Empty, Empty)
-> Either a (Empty, Empty, Empty, Empty, Empty)
forall a b. b -> Either a b
Right (Empty
Empty, Empty
Empty, Empty
Empty, Empty
Empty, Empty
Empty)

-- plotting derivation graphs
-- ==========================

-- | Convert a derivation graph into a series of TikZ commands.
tikzDerivationGraph
  :: (Eq slc, Eq tr)
  => (slc -> T.Text)
  -- ^ a function for displaying slice contents
  -> (tr -> T.Text)
  -- ^ a function for displaying transitions contents
  -> DerivationGraph slc tr
  -- ^ the derivation graph
  -> T.Text
tikzDerivationGraph :: forall slc tr.
(Eq slc, Eq tr) =>
(slc -> Text) -> (tr -> Text) -> DerivationGraph slc tr -> Text
tikzDerivationGraph slc -> Text
showS tr -> Text
showT (DGraph Int
_ Set (DerivSlice slc)
slices Set (DerivTrans slc tr)
trans Set (DerivSlice slc, DerivSlice slc)
horis [DerivTrans slc tr]
openTrans [DerivTrans slc tr]
frozenTrans [DerivTrans slc tr]
_) =
  Text -> [Text] -> Text
T.intercalate
    Text
"\n"
    ( ((Double, Int, Int, StartStop slc) -> Text
forall {slc} {slc} {slc}.
(Show slc, Show slc, Show slc, Num slc) =>
(slc, slc, slc, StartStop slc) -> Text
showNode ((Double, Int, Int, StartStop slc) -> Text)
-> [(Double, Int, Int, StartStop slc)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Double, Int, Int, StartStop slc)]
tikzNodes)
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((DerivTrans slc tr, Bool) -> Text
forall {slc} {slc}.
((DerivSlice slc, tr, DerivSlice slc), Bool) -> Text
showTrans ((DerivTrans slc tr, Bool) -> Text)
-> [(DerivTrans slc tr, Bool)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(DerivTrans slc tr, Bool)]
trans')
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((DerivSlice slc, DerivSlice slc) -> Text
forall {slc} {slc}. (DerivSlice slc, DerivSlice slc) -> Text
showHori ((DerivSlice slc, DerivSlice slc) -> Text)
-> [(DerivSlice slc, DerivSlice slc)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (DerivSlice slc, DerivSlice slc)
-> [(DerivSlice slc, DerivSlice slc)]
forall a. Set a -> [a]
S.toList Set (DerivSlice slc, DerivSlice slc)
horis)
    )
 where
  showText :: (Show slc) => slc -> T.Text
  showText :: forall slc. Show slc => slc -> Text
showText = String -> Text
T.pack (String -> Text) -> (slc -> String) -> slc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. slc -> String
forall a. Show a => a -> String
show
  -- printing nodes and edges
  showSlice :: StartStop slc -> Text
showSlice StartStop slc
Start = Text
"$\\rtimes$"
  showSlice StartStop slc
Stop = Text
"$\\ltimes$"
  showSlice (Inner slc
s) = slc -> Text
showS slc
s
  showNode :: (slc, slc, slc, StartStop slc) -> Text
showNode (slc
x, slc
y, slc
i, StartStop slc
c) =
    Text
"\\node[slice] (slice"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> slc -> Text
forall slc. Show slc => slc -> Text
showText slc
i
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") at ("
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> slc -> Text
forall slc. Show slc => slc -> Text
showText slc
x
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
","
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> slc -> Text
forall slc. Show slc => slc -> Text
showText (-slc
y)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") {"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StartStop slc -> Text
showSlice StartStop slc
c
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"};"
  showTrans :: ((DerivSlice slc, tr, DerivSlice slc), Bool) -> Text
showTrans ((DerivSlice slc
nl, tr
e, DerivSlice slc
nr), Bool
frozen) =
    Text
"\\draw[transition,"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Bool
frozen then Text
"terminal" else Text
"non-terminal")
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] (slice"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall slc. Show slc => slc -> Text
showText (DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslId DerivSlice slc
nl)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") -- (slice"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall slc. Show slc => slc -> Text
showText (DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslId DerivSlice slc
nr)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") node[midway,below,sloped] {"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> tr -> Text
showT tr
e
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"};"
  showHori :: (DerivSlice slc, DerivSlice slc) -> Text
showHori (DerivSlice slc
p, DerivSlice slc
c) =
    Text
"\\draw[hori] (slice"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall slc. Show slc => slc -> Text
showText (DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslId DerivSlice slc
p)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") -- (slice"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall slc. Show slc => slc -> Text
showText (DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslId DerivSlice slc
c)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
");"
  -- helpers
  leftNode :: (a, b, c) -> a
leftNode (a
n, b
_, c
_) = a
n
  rightNode :: (a, b, c) -> c
rightNode (a
_, b
_, c
n) = c
n
  -- computing node locations
  nodeChildren :: Map Int [Int]
nodeChildren =
    ([Int] -> [Int] -> [Int]) -> [(Int, [Int])] -> Map Int [Int]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(++) ([(Int, [Int])] -> Map Int [Int])
-> [(Int, [Int])] -> Map Int [Int]
forall a b. (a -> b) -> a -> b
$ (DerivSlice slc -> Int)
-> (DerivSlice slc -> [Int])
-> (DerivSlice slc, DerivSlice slc)
-> (Int, [Int])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslId ((Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: []) (Int -> [Int])
-> (DerivSlice slc -> Int) -> DerivSlice slc -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslId) ((DerivSlice slc, DerivSlice slc) -> (Int, [Int]))
-> [(DerivSlice slc, DerivSlice slc)] -> [(Int, [Int])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (DerivSlice slc, DerivSlice slc)
-> [(DerivSlice slc, DerivSlice slc)]
forall a. Set a -> [a]
S.toList Set (DerivSlice slc, DerivSlice slc)
horis
  surface :: [DerivTrans slc tr]
surface = [DerivTrans slc tr] -> [DerivTrans slc tr]
forall a. [a] -> [a]
reverse [DerivTrans slc tr]
frozenTrans [DerivTrans slc tr] -> [DerivTrans slc tr] -> [DerivTrans slc tr]
forall a. Semigroup a => a -> a -> a
<> [DerivTrans slc tr]
openTrans
  trans' :: [(DerivTrans slc tr, Bool)]
trans' = (\DerivTrans slc tr
t -> (DerivTrans slc tr
t, DerivTrans slc tr
t DerivTrans slc tr -> [DerivTrans slc tr] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [DerivTrans slc tr]
frozenTrans)) (DerivTrans slc tr -> (DerivTrans slc tr, Bool))
-> [DerivTrans slc tr] -> [(DerivTrans slc tr, Bool)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (DerivTrans slc tr) -> [DerivTrans slc tr]
forall a. Set a -> [a]
S.toList Set (DerivTrans slc tr)
trans
  surfaceNodes :: [Int]
surfaceNodes = case [DerivTrans slc tr]
surface of
    [] -> []
    (DerivTrans slc tr
t0 : [DerivTrans slc tr]
_) -> (DerivSlice slc -> Int) -> [DerivSlice slc] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslId ([DerivSlice slc] -> [Int]) -> [DerivSlice slc] -> [Int]
forall a b. (a -> b) -> a -> b
$ DerivTrans slc tr -> DerivSlice slc
forall {a} {b} {c}. (a, b, c) -> a
leftNode (DerivTrans slc tr
t0) DerivSlice slc -> [DerivSlice slc] -> [DerivSlice slc]
forall a. a -> [a] -> [a]
: (DerivTrans slc tr -> DerivSlice slc)
-> [DerivTrans slc tr] -> [DerivSlice slc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DerivTrans slc tr -> DerivSlice slc
forall {a} {b} {c}. (a, b, c) -> c
rightNode [DerivTrans slc tr]
surface
  allNodes :: [Int]
allNodes = DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslId (DerivSlice slc -> Int) -> [DerivSlice slc] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DerivSlice slc -> Int) -> [DerivSlice slc] -> [DerivSlice slc]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn DerivSlice slc -> Int
forall slc. DerivSlice slc -> Int
dslDepth (Set (DerivSlice slc) -> [DerivSlice slc]
forall a. Set a -> [a]
S.toList Set (DerivSlice slc)
slices)
  -- compute x locations
  xloc :: Map Int Double
xloc = (Map Int Double -> Int -> Map Int Double)
-> Map Int Double -> [Int] -> Map Int Double
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Int Double -> Int -> Map Int Double
forall {a}. Fractional a => Map Int a -> Int -> Map Int a
findX Map Int Double
xlocInit [Int]
allNodes
   where
    xlocInit :: Map Int Double
xlocInit = [(Int, Double)] -> Map Int Double
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int, Double)] -> Map Int Double)
-> [(Int, Double)] -> Map Int Double
forall a b. (a -> b) -> a -> b
$ [Int] -> [Double] -> [(Int, Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
surfaceNodes [Double
0.0 :: Double ..]
    mean :: t a -> a
mean t a
xs = t a -> a
forall a. Num a => t a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum t a
xs a -> a -> a
forall a. Fractional a => a -> a -> a
/ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs)
    -- findX :: M.Map Int Double -> Int -> M.Map Int Double
    findX :: Map Int a -> Int -> Map Int a
findX Map Int a
locs Int
i = case Int -> Map Int a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
i Map Int a
locs of
      Just a
_ -> Map Int a
locs
      Maybe a
Nothing ->
        let children :: [Int]
children = Map Int [Int]
nodeChildren Map Int [Int] -> Int -> [Int]
forall k a. Ord k => Map k a -> k -> a
M.! Int
i
            childxs :: [a]
childxs = (\Int
c -> Map Int a -> Int -> Map Int a
findX Map Int a
locs Int
c Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
c) (Int -> a) -> [Int] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
children
            x :: a
x = [a] -> a
forall {a} {t :: * -> *}. (Fractional a, Foldable t) => t a -> a
mean [a]
childxs
         in Int -> a -> Map Int a -> Map Int a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
i a
x Map Int a
locs
  tikzNodes :: [(Double, Int, Int, StartStop slc)]
tikzNodes = DerivSlice slc -> (Double, Int, Int, StartStop slc)
forall {slc}. DerivSlice slc -> (Double, Int, Int, StartStop slc)
mkNode (DerivSlice slc -> (Double, Int, Int, StartStop slc))
-> [DerivSlice slc] -> [(Double, Int, Int, StartStop slc)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (DerivSlice slc) -> [DerivSlice slc]
forall a. Set a -> [a]
S.toList Set (DerivSlice slc)
slices
   where
    mkNode :: DerivSlice slc -> (Double, Int, Int, StartStop slc)
mkNode (DerivSlice Int
depth Int
i StartStop slc
content) = (Map Int Double
xloc Map Int Double -> Int -> Double
forall k a. Ord k => Map k a -> k -> a
M.! Int
i, Int
depth, Int
i, StartStop slc
content)

-- | Wraps TikZ commands in a @tikzpicture@ environment.
tikzPic :: (Semigroup a, IsString a) => a -> a
tikzPic :: forall a. (Semigroup a, IsString a) => a -> a
tikzPic a
content =
  a
"\\begin{tikzpicture}\n" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
content a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\n\\end{tikzpicture}"

{- | Wraps latex code (e.g. a @tikzpicture@) in a complete standalone document.
 This environment includes default styles for slices, transitions, and hori edges.
-}
tikzStandalone
  :: (Semigroup a, IsString a)
  => Bool
  -- ^ a flag for using the the @varwidth@ option of @standalone@ (needed for multiline content)
  -> a
  -- ^ the document content
  -> a
tikzStandalone :: forall a. (Semigroup a, IsString a) => Bool -> a -> a
tikzStandalone Bool
varwidth a
content =
  a
"\\documentclass"
    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (if Bool
varwidth then a
"[varwidth]" else a
"")
    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"{standalone}\n\
       \\\usepackage[svgnames]{xcolor}\n\
       \\\usepackage{tikz}\n\
       \\\usepackage{amssymb}\n\
       \\\begin{document}\n\
       \\\tikzstyle{slice} = [rectangle,draw,fill=WhiteSmoke,semithick,minimum size=0.4cm,inner xsep=0,inner ysep=3pt,align=center]\n\
       \\\tikzstyle{transition} = [line width=2pt,draw=lightgray]\n\
       \\\tikzstyle{non-terminal} = []\n\
       \\\tikzstyle{terminal} = [double]\n\
       \\\tikzstyle{hori} = [lightgray,dashed,line width=2pt]\n\n"
    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
content
    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\n\\end{document}"

-- | Write a single derivation graph to a @tex@ file.
writeGraph
  :: (Show slc, Eq slc, Eq tr, Show tr) => FilePath -> DerivationGraph slc tr -> IO ()
writeGraph :: forall slc tr.
(Show slc, Eq slc, Eq tr, Show tr) =>
String -> DerivationGraph slc tr -> IO ()
writeGraph String
fn DerivationGraph slc tr
g =
  String -> Text -> IO ()
T.writeFile String
fn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
    Bool -> Text -> Text
forall a. (Semigroup a, IsString a) => Bool -> a -> a
tikzStandalone Bool
False (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
      Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
tikzPic (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
        (slc -> Text) -> (tr -> Text) -> DerivationGraph slc tr -> Text
forall slc tr.
(Eq slc, Eq tr) =>
(slc -> Text) -> (tr -> Text) -> DerivationGraph slc tr -> Text
tikzDerivationGraph
          slc -> Text
forall slc. Show slc => slc -> Text
showTexT
          tr -> Text
forall slc. Show slc => slc -> Text
showTexT
          DerivationGraph slc tr
g

-- | Write a single derivation graph to a @tex@ file and compile the file using @pdflatex@.
viewGraph
  :: (Eq slc, Eq tr, Show slc, Show tr) => FilePath -> DerivationGraph slc tr -> IO ()
viewGraph :: forall slc tr.
(Eq slc, Eq tr, Show slc, Show tr) =>
String -> DerivationGraph slc tr -> IO ()
viewGraph String
fn DerivationGraph slc tr
g = do
  String -> DerivationGraph slc tr -> IO ()
forall slc tr.
(Show slc, Eq slc, Eq tr, Show tr) =>
String -> DerivationGraph slc tr -> IO ()
writeGraph String
fn DerivationGraph slc tr
g
  String -> IO ()
callCommand (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"pdflatex -output-directory=\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
FP.takeDirectory String
fn String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fn

-- | Write a several derivation graphs to a @tex@ file.
writeGraphs
  :: (Show tr, Show slc, Eq slc, Eq tr) => FilePath -> [DerivationGraph slc tr] -> IO ()
writeGraphs :: forall tr slc.
(Show tr, Show slc, Eq slc, Eq tr) =>
String -> [DerivationGraph slc tr] -> IO ()
writeGraphs String
fn [DerivationGraph slc tr]
gs =
  String -> Text -> IO ()
T.writeFile String
fn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
    Bool -> Text -> Text
forall a. (Semigroup a, IsString a) => Bool -> a -> a
tikzStandalone Bool
True (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
      Text -> [Text] -> Text
T.intercalate Text
"\n\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
tikzPic
          (Text -> Text)
-> (DerivationGraph slc tr -> Text)
-> DerivationGraph slc tr
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (slc -> Text) -> (tr -> Text) -> DerivationGraph slc tr -> Text
forall slc tr.
(Eq slc, Eq tr) =>
(slc -> Text) -> (tr -> Text) -> DerivationGraph slc tr -> Text
tikzDerivationGraph slc -> Text
forall slc. Show slc => slc -> Text
showTexT tr -> Text
forall slc. Show slc => slc -> Text
showTexT
          (DerivationGraph slc tr -> Text)
-> [DerivationGraph slc tr] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DerivationGraph slc tr]
gs

-- | Write a several derivation graphs to a @tex@ file and compile the file using @pdflatex@.
viewGraphs
  :: (Show tr, Show slc, Eq slc, Eq tr) => FilePath -> [DerivationGraph slc tr] -> IO ()
viewGraphs :: forall tr slc.
(Show tr, Show slc, Eq slc, Eq tr) =>
String -> [DerivationGraph slc tr] -> IO ()
viewGraphs String
fn [DerivationGraph slc tr]
gs = do
  String -> [DerivationGraph slc tr] -> IO ()
forall tr slc.
(Show tr, Show slc, Eq slc, Eq tr) =>
String -> [DerivationGraph slc tr] -> IO ()
writeGraphs String
fn [DerivationGraph slc tr]
gs
  String -> IO ()
callCommand (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"pdflatex -output-directory=\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
FP.takeDirectory String
fn String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fn