{-# 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 qualified Data.Set as S

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

import Data.Bifunctor (bimap)
import Data.String (IsString)

-- 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
forall slc. Eq slc => DerivSlice slc -> DerivSlice slc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DerivSlice slc -> DerivSlice slc -> Bool
$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
Eq, DerivSlice slc -> DerivSlice slc -> Bool
DerivSlice slc -> DerivSlice slc -> Ordering
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
min :: DerivSlice slc -> DerivSlice slc -> DerivSlice slc
$cmin :: forall slc.
Ord slc =>
DerivSlice slc -> DerivSlice slc -> DerivSlice slc
max :: DerivSlice slc -> DerivSlice slc -> DerivSlice slc
$cmax :: forall slc.
Ord slc =>
DerivSlice slc -> DerivSlice slc -> DerivSlice slc
>= :: 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
$c< :: forall slc. Ord slc => DerivSlice slc -> DerivSlice slc -> Bool
compare :: DerivSlice slc -> DerivSlice slc -> Ordering
$ccompare :: forall slc. Ord slc => DerivSlice slc -> DerivSlice slc -> Ordering
Ord, Int -> DerivSlice slc -> ShowS
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
showList :: [DerivSlice slc] -> ShowS
$cshowList :: forall slc. Show slc => [DerivSlice slc] -> ShowS
show :: DerivSlice slc -> String
$cshow :: forall slc. Show slc => DerivSlice slc -> String
showsPrec :: Int -> DerivSlice slc -> ShowS
$cshowsPrec :: forall slc. Show slc => Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
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
$c== :: forall slc tr.
(Eq slc, Eq tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
Eq, DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
DerivationGraph slc tr -> DerivationGraph slc tr -> Ordering
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
min :: 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
max :: DerivationGraph slc tr
-> DerivationGraph slc tr -> DerivationGraph slc tr
$cmax :: forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr
-> DerivationGraph slc tr -> DerivationGraph slc tr
>= :: 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
$c< :: forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Bool
compare :: DerivationGraph slc tr -> DerivationGraph slc tr -> Ordering
$ccompare :: forall slc tr.
(Ord slc, Ord tr) =>
DerivationGraph slc tr -> DerivationGraph slc tr -> Ordering
Ord, Int -> DerivationGraph slc tr -> ShowS
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
showList :: [DerivationGraph slc tr] -> ShowS
$cshowList :: forall slc tr.
(Show slc, Show tr) =>
[DerivationGraph slc tr] -> ShowS
show :: DerivationGraph slc tr -> String
$cshow :: forall slc tr.
(Show slc, Show tr) =>
DerivationGraph slc tr -> String
showsPrec :: Int -> DerivationGraph slc tr -> ShowS
$cshowsPrec :: forall slc tr.
(Show slc, Show tr) =>
Int -> 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
  DerivationGraph slc tr
graph <- forall s (m :: * -> *). MonadState s m => m s
ST.get
  case forall slc tr. DerivationGraph slc tr -> [DerivTrans slc tr]
dgOpen DerivationGraph slc tr
graph of
    [] -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
    DerivTrans slc tr
t : [DerivTrans slc tr]
ts -> do
      forall s (m :: * -> *). MonadState s m => s -> m ()
ST.put DerivationGraph slc tr
graph{dgOpen :: [DerivTrans slc tr]
dgOpen = [DerivTrans slc tr]
ts}
      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
  DerivationGraph slc tr
graph <- forall s (m :: * -> *). MonadState s m => m s
ST.get
  let trans' :: Set (DerivTrans slc tr)
trans' = forall a. Ord a => [a] -> Set a
S.fromList [DerivTrans slc tr]
newts forall a. Semigroup a => a -> a -> a
<> forall slc tr. DerivationGraph slc tr -> Set (DerivTrans slc tr)
dgTransitions DerivationGraph slc tr
graph
      surf' :: [DerivTrans slc tr]
surf' = [DerivTrans slc tr]
newts forall a. Semigroup a => a -> a -> a
<> forall slc tr. DerivationGraph slc tr -> [DerivTrans slc tr]
dgOpen DerivationGraph slc tr
graph
  forall s (m :: * -> *). MonadState s m => s -> m ()
ST.put forall a b. (a -> b) -> a -> b
$ DerivationGraph slc tr
graph{dgTransitions :: Set (DerivTrans slc tr)
dgTransitions = Set (DerivTrans slc tr)
trans', dgOpen :: [DerivTrans slc tr]
dgOpen = [DerivTrans slc tr]
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
  DerivationGraph slc tr
graph <- forall s (m :: * -> *). MonadState s m => m s
ST.get
  let trans' :: Set (DerivTrans slc tr)
trans' = forall a. Ord a => a -> Set a -> Set a
S.insert DerivTrans slc tr
newt forall a b. (a -> b) -> a -> b
$ forall slc tr. DerivationGraph slc tr -> Set (DerivTrans slc tr)
dgTransitions DerivationGraph slc tr
graph
      frozen' :: [DerivTrans slc tr]
frozen' = DerivTrans slc tr
newt forall a. a -> [a] -> [a]
: forall slc tr. DerivationGraph slc tr -> [DerivTrans slc tr]
dgFrozen DerivationGraph slc tr
graph
  forall s (m :: * -> *). MonadState s m => s -> m ()
ST.put forall a b. (a -> b) -> a -> b
$ DerivationGraph slc tr
graph{dgTransitions :: Set (DerivTrans slc tr)
dgTransitions = Set (DerivTrans slc tr)
trans', dgFrozen :: [DerivTrans slc tr]
dgFrozen = [DerivTrans slc tr]
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
  DerivationGraph slc tr
graph <- forall s (m :: * -> *). MonadState s m => m s
ST.get
  let i :: Int
i = forall slc tr. DerivationGraph slc tr -> Int
dgNextId DerivationGraph slc tr
graph
      newSlice :: DerivSlice slc
newSlice = forall slc. Int -> Int -> StartStop slc -> DerivSlice slc
DerivSlice Int
depth Int
i (forall a. a -> StartStop a
Inner slc
sliceContent)
      slices' :: Set (DerivSlice slc)
slices' = forall a. Ord a => a -> Set a -> Set a
S.insert DerivSlice slc
newSlice forall a b. (a -> b) -> a -> b
$ forall slc tr. DerivationGraph slc tr -> Set (DerivSlice slc)
dgSlices DerivationGraph slc tr
graph
  forall s (m :: * -> *). MonadState s m => s -> m ()
ST.put forall a b. (a -> b) -> a -> b
$ DerivationGraph slc tr
graph{dgNextId :: Int
dgNextId = Int
i forall a. Num a => a -> a -> a
+ Int
1, dgSlices :: Set (DerivSlice slc)
dgSlices = Set (DerivSlice slc)
slices'}
  forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivSlice slc
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
  DerivationGraph slc tr
graph <- forall s (m :: * -> *). MonadState s m => m s
ST.get
  let horis' :: Set (DerivSlice slc, DerivSlice slc)
horis' = forall a. Ord a => a -> Set a -> Set a
S.insert (DerivSlice slc, DerivSlice slc)
edge forall a b. (a -> b) -> a -> b
$ forall slc tr.
DerivationGraph slc tr -> Set (DerivSlice slc, DerivSlice slc)
dgHoriEdges DerivationGraph slc tr
graph
  forall s (m :: * -> *). MonadState s m => s -> m ()
ST.put forall a b. (a -> b) -> a -> b
$ DerivationGraph slc tr
graph{dgHoriEdges :: Set (DerivSlice slc, DerivSlice slc)
dgHoriEdges = Set (DerivSlice slc, DerivSlice slc)
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
    (DerivSlice slc
pl, tr
pt, DerivSlice slc
pr) <- forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen
    (tr
cl, slc
cm, tr
cr) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s f h slc tr.
DerivationPlayer s f h slc tr
-> s -> tr -> Either String (tr, slc, tr)
dpSplit DerivationPlayer s f h slc tr
player s
s tr
pt
    DerivSlice slc
sm <- forall slc tr.
Ord slc =>
slc -> Int -> DerivationOp slc tr (DerivSlice slc)
addSlice slc
cm forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max (forall slc. DerivSlice slc -> Int
dslDepth DerivSlice slc
pl) (forall slc. DerivSlice slc -> Int
dslDepth DerivSlice slc
pr) forall a. Num a => a -> a -> a
+ Int
1
    forall slc tr.
(Ord slc, Ord tr) =>
[DerivTrans slc tr] -> DerivationOp slc tr ()
pushOpen [(DerivSlice slc
pl, tr
cl, DerivSlice slc
sm), (DerivSlice slc
sm, tr
cr, DerivSlice slc
pr)]
  applyRule (LMSplitOnly s
s) = Leftmost s f h
-> StateT (DerivationGraph slc tr) (Either String) ()
applyRule forall a b. (a -> b) -> a -> b
$ forall s f h. s -> Leftmost s f h
LMSplitLeft s
s
  applyRule (LMSplitRight s
s) = do
    (DerivSlice slc, tr, DerivSlice slc)
l <- forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen
    (DerivSlice slc
pl, tr
pt, DerivSlice slc
pr) <- forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen
    (tr
cl, slc
cm, tr
cr) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s f h slc tr.
DerivationPlayer s f h slc tr
-> s -> tr -> Either String (tr, slc, tr)
dpSplit DerivationPlayer s f h slc tr
player s
s tr
pt
    DerivSlice slc
sm <- forall slc tr.
Ord slc =>
slc -> Int -> DerivationOp slc tr (DerivSlice slc)
addSlice slc
cm forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max (forall slc. DerivSlice slc -> Int
dslDepth DerivSlice slc
pl) (forall slc. DerivSlice slc -> Int
dslDepth DerivSlice slc
pr) forall a. Num a => a -> a -> a
+ Int
1
    forall slc tr.
(Ord slc, Ord tr) =>
[DerivTrans slc tr] -> DerivationOp slc tr ()
pushOpen [(DerivSlice slc, tr, DerivSlice slc)
l, (DerivSlice slc
pl, tr
cl, DerivSlice slc
sm), (DerivSlice slc
sm, tr
cr, DerivSlice slc
pr)]
  applyRule (LMFreezeLeft f
f) = do
    (DerivSlice slc
pl, tr
pt, DerivSlice slc
pr) <- forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen
    tr
t <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s f h slc tr.
DerivationPlayer s f h slc tr -> f -> tr -> Either String tr
dpFreeze DerivationPlayer s f h slc tr
player f
f tr
pt
    forall slc tr.
(Ord slc, Ord tr) =>
DerivTrans slc tr -> DerivationOp slc tr ()
pushClosed (DerivSlice slc
pl, tr
t, DerivSlice slc
pr)
  applyRule (LMFreezeOnly f
f) = Leftmost s f h
-> StateT (DerivationGraph slc tr) (Either String) ()
applyRule forall a b. (a -> b) -> a -> b
$ forall f s h. f -> Leftmost s f h
LMFreezeLeft f
f
  applyRule (LMSpread h
h) = do
    (DerivSlice slc
lpl, tr
lpt, DerivSlice slc
pm) <- forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen
    (DerivSlice slc
_, tr
rpt, DerivSlice slc
rpr) <- forall slc tr. DerivationOp slc tr (DerivTrans slc tr)
popOpen
    let depth' :: Int
depth' = forall a. Ord a => a -> a -> a
max (forall slc. DerivSlice slc -> Int
dslDepth DerivSlice slc
lpl) (forall a. Ord a => a -> a -> a
max (forall slc. DerivSlice slc -> Int
dslDepth DerivSlice slc
pm) (forall slc. DerivSlice slc -> Int
dslDepth DerivSlice slc
rpr)) forall a. Num a => a -> a -> a
+ Int
1
    slc
pmInner <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. StartStop a -> Either String a
getInnerE (forall slc. DerivSlice slc -> StartStop slc
dslContent DerivSlice slc
pm)
    (tr
l, slc
lc, tr
m, slc
rc, tr
r) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s f h slc tr.
DerivationPlayer s f h slc tr
-> h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr)
dpSpread DerivationPlayer s f h slc tr
player h
h tr
lpt slc
pmInner tr
rpt
    DerivSlice slc
ls <- forall slc tr.
Ord slc =>
slc -> Int -> DerivationOp slc tr (DerivSlice slc)
addSlice slc
lc Int
depth'
    DerivSlice slc
rs <- forall slc tr.
Ord slc =>
slc -> Int -> DerivationOp slc tr (DerivSlice slc)
addSlice slc
rc Int
depth'
    forall slc tr.
Ord slc =>
(DerivSlice slc, DerivSlice slc) -> DerivationOp slc tr ()
addHoriEdge (DerivSlice slc
pm, DerivSlice slc
ls)
    forall slc tr.
Ord slc =>
(DerivSlice slc, DerivSlice slc) -> DerivationOp slc tr ()
addHoriEdge (DerivSlice slc
pm, DerivSlice slc
rs)
    forall slc tr.
(Ord slc, Ord tr) =>
[DerivTrans slc tr] -> DerivationOp slc tr ()
pushOpen [(DerivSlice slc
lpl, tr
l, DerivSlice slc
ls), (DerivSlice slc
ls, tr
m, DerivSlice slc
rs), (DerivSlice slc
rs, tr
r, DerivSlice slc
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 =
  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
    (forall a b. Path a b -> Int
pathLen Path tr slc
topPath forall a. Num a => a -> a -> a
+ Int
1)
    (forall a. Ord a => [a] -> Set a
S.fromList [DerivSlice slc]
topSlices)
    (forall a. Ord a => [a] -> Set a
S.fromList [DerivTrans slc tr]
top)
    forall a. Set a
S.empty
    [DerivTrans slc tr]
top
    []
    [DerivTrans slc tr]
top
 where
  -- collect initial slices (+ Start / Stop)
  topContents :: [StartStop slc]
topContents = forall a. StartStop a
Start forall a. a -> [a] -> [a]
: (forall a. a -> StartStop a
Inner forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Path a b -> [b]
pathBetweens Path tr slc
topPath) forall a. Semigroup a => a -> a -> a
<> [forall a. StartStop a
Stop]
  -- assign depth=0 and running IDs to initial slices
  topSlices :: [DerivSlice slc]
topSlices = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall slc. Int -> Int -> StartStop slc -> DerivSlice slc
DerivSlice Int
0) [Int
0 ..] [StartStop slc]
topContents
  top :: [DerivTrans slc tr]
top = forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [DerivSlice slc]
topSlices (forall a b. Path a b -> [a]
pathArounds Path tr slc
topPath) (forall a. [a] -> [a]
tail [DerivSlice slc]
topSlices)

-- | 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 =
  forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
ST.execStateT
    (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (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)
    (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 = 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' forall {between}. Path tr between
topPath DerivationPlayer s f h slc tr
player
 where
  topPath :: Path tr between
topPath = forall around between. around -> Path around between
PathEnd forall a b. (a -> b) -> a -> b
$ 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
  DerivationGraph slc tr
graph <- 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null forall a b. (a -> b) -> a -> b
$ forall slc tr. DerivationGraph slc tr -> [DerivTrans slc tr]
dgOpen DerivationGraph slc tr
graph
    then forall a b. b -> Either a b
Right DerivationGraph slc tr
graph
    else forall a b. a -> Either a b
Left String
"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 (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 [] = forall a b. b -> Either a b
Right DerivationGraph slc tr
g 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 forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
ST.execStateT (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 -> forall a b. a -> Either a b
Left String
err 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' (forall a b. b -> Either a b
Right DerivationGraph slc tr
g 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 = 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' forall {between}. Path tr between
topPath DerivationPlayer s f h slc tr
player
 where
  topPath :: Path tr between
topPath = forall around between. around -> Path around between
PathEnd forall a b. (a -> b) -> a -> b
$ 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 = 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 () forall {p} {p} {a}. p -> p -> Either a ((), (), ())
usplit forall {p} {p} {a}. p -> p -> Either a ()
ufreeze forall {p} {p} {p} {p} {a}.
p -> p -> p -> p -> Either a ((), (), (), (), ())
uspread
 where
  usplit :: p -> p -> Either a ((), (), ())
usplit p
_ p
_ = forall a b. b -> Either a b
Right ((), (), ())
  ufreeze :: p -> p -> Either a ()
ufreeze p
_ p
_ = forall a b. b -> Either a b
Right ()
  uspread :: p -> p -> p -> p -> Either a ((), (), (), (), ())
uspread p
_ p
_ p
_ p
_ = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Empty -> Empty -> Bool
$c/= :: Empty -> Empty -> Bool
== :: Empty -> Empty -> Bool
$c== :: Empty -> Empty -> Bool
Eq, Eq 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
min :: Empty -> Empty -> Empty
$cmin :: Empty -> Empty -> Empty
max :: Empty -> Empty -> Empty
$cmax :: Empty -> Empty -> Empty
>= :: Empty -> Empty -> Bool
$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
compare :: Empty -> Empty -> Ordering
$ccompare :: Empty -> Empty -> Ordering
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 = 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 forall {p} {p} {a}. p -> p -> Either a (Empty, Empty, Empty)
nsplit forall {p} {p} {a}. p -> p -> Either a Empty
nfreeze 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
_ = forall a b. b -> Either a b
Right (Empty
Empty, Empty
Empty, Empty
Empty)
  nfreeze :: p -> p -> Either a Empty
nfreeze p
_ p
_ = 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
_ = 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"
    ( (forall {slc} {slc} {slc}.
(Show slc, Show slc, Show slc, Num slc) =>
(slc, slc, slc, StartStop slc) -> Text
showNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Double, Int, Int, StartStop slc)]
tikzNodes)
        forall a. Semigroup a => a -> a -> a
<> (forall {slc} {slc}.
((DerivSlice slc, tr, DerivSlice slc), Bool) -> Text
showTrans forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(DerivTrans slc tr, Bool)]
trans')
        forall a. Semigroup a => a -> a -> a
<> (forall {slc} {slc}. (DerivSlice slc, DerivSlice slc) -> Text
showHori forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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"
      forall a. Semigroup a => a -> a -> a
<> forall slc. Show slc => slc -> Text
showText slc
i
      forall a. Semigroup a => a -> a -> a
<> Text
") at ("
      forall a. Semigroup a => a -> a -> a
<> forall slc. Show slc => slc -> Text
showText slc
x
      forall a. Semigroup a => a -> a -> a
<> Text
","
      forall a. Semigroup a => a -> a -> a
<> forall slc. Show slc => slc -> Text
showText (-slc
y)
      forall a. Semigroup a => a -> a -> a
<> Text
") {"
      forall a. Semigroup a => a -> a -> a
<> StartStop slc -> Text
showSlice StartStop slc
c
      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,"
      forall a. Semigroup a => a -> a -> a
<> (if Bool
frozen then Text
"terminal" else Text
"non-terminal")
      forall a. Semigroup a => a -> a -> a
<> Text
"] (slice"
      forall a. Semigroup a => a -> a -> a
<> forall slc. Show slc => slc -> Text
showText (forall slc. DerivSlice slc -> Int
dslId DerivSlice slc
nl)
      forall a. Semigroup a => a -> a -> a
<> Text
") -- (slice"
      forall a. Semigroup a => a -> a -> a
<> forall slc. Show slc => slc -> Text
showText (forall slc. DerivSlice slc -> Int
dslId DerivSlice slc
nr)
      forall a. Semigroup a => a -> a -> a
<> Text
") node[midway,below,sloped] {"
      forall a. Semigroup a => a -> a -> a
<> tr -> Text
showT tr
e
      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"
      forall a. Semigroup a => a -> a -> a
<> forall slc. Show slc => slc -> Text
showText (forall slc. DerivSlice slc -> Int
dslId DerivSlice slc
p)
      forall a. Semigroup a => a -> a -> a
<> Text
") -- (slice"
      forall a. Semigroup a => a -> a -> a
<> forall slc. Show slc => slc -> Text
showText (forall slc. DerivSlice slc -> Int
dslId DerivSlice slc
c)
      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 =
    forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall slc. DerivSlice slc -> Int
dslId ((forall a. a -> [a] -> [a]
: []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall slc. DerivSlice slc -> Int
dslId) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
S.toList Set (DerivSlice slc, DerivSlice slc)
horis
  surface :: [DerivTrans slc tr]
surface = forall a. [a] -> [a]
reverse [DerivTrans slc tr]
frozenTrans 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [DerivTrans slc tr]
frozenTrans)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
S.toList Set (DerivTrans slc tr)
trans
  surfaceNodes :: [Int]
surfaceNodes = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall slc. DerivSlice slc -> Int
dslId forall a b. (a -> b) -> a -> b
$ forall {a} {b} {c}. (a, b, c) -> a
leftNode (forall a. [a] -> a
head [DerivTrans slc tr]
surface) forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {b} {c}. (a, b, c) -> c
rightNode [DerivTrans slc tr]
surface
  allNodes :: [Int]
allNodes = forall slc. DerivSlice slc -> Int
dslId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn forall slc. DerivSlice slc -> Int
dslDepth (forall a. Set a -> [a]
S.toList Set (DerivSlice slc)
slices)
  -- compute x locations
  xloc :: Map Int Double
xloc = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Fractional a => Map Int a -> Int -> Map Int a
findX Map Int Double
xlocInit [Int]
allNodes
   where
    xlocInit :: Map Int Double
xlocInit = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
surfaceNodes [Double
0.0 :: Double ..]
    mean :: t a -> a
mean t a
xs = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum t a
xs forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 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 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 forall k a. Ord k => Map k a -> k -> a
M.! Int
c) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
children
            x :: a
x = forall {a} {t :: * -> *}. (Fractional a, Foldable t) => t a -> a
mean [a]
childxs
         in 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 = forall {slc}. DerivSlice slc -> (Double, Int, Int, StartStop slc)
mkNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 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" forall a. Semigroup a => a -> a -> a
<> a
content 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"
    forall a. Semigroup a => a -> a -> a
<> (if Bool
varwidth then a
"[varwidth]" else 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"
    forall a. Semigroup a => a -> a -> a
<> a
content
    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 forall a b. (a -> b) -> a -> b
$
    forall a. (Semigroup a, IsString a) => Bool -> a -> a
tikzStandalone Bool
False forall a b. (a -> b) -> a -> b
$
      forall a. (Semigroup a, IsString a) => a -> a
tikzPic forall a b. (a -> b) -> a -> b
$
        forall slc tr.
(Eq slc, Eq tr) =>
(slc -> Text) -> (tr -> Text) -> DerivationGraph slc tr -> Text
tikzDerivationGraph
          forall slc. Show slc => slc -> Text
showTexT
          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
  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 forall a b. (a -> b) -> a -> b
$ String
"pdflatex " 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 forall a b. (a -> b) -> a -> b
$
    forall a. (Semigroup a, IsString a) => Bool -> a -> a
tikzStandalone Bool
True forall a b. (a -> b) -> a -> b
$
      Text -> [Text] -> Text
T.intercalate Text
"\n\n" forall a b. (a -> b) -> a -> b
$
        forall a. (Semigroup a, IsString a) => a -> a
tikzPic
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall slc tr.
(Eq slc, Eq tr) =>
(slc -> Text) -> (tr -> Text) -> DerivationGraph slc tr -> Text
tikzDerivationGraph forall slc. Show slc => slc -> Text
showTexT forall slc. Show slc => slc -> Text
showTexT
          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
  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 forall a b. (a -> b) -> a -> b
$ String
"pdflatex " forall a. Semigroup a => a -> a -> a
<> String
fn