{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

{-|
Provides the ability to render Petri nets.
-}
module Modelling.PetriNet.Diagram (
  cacheNet,
  drawNet,
  getDefaultNet,
  getNet,
  isNetDrawable,
  ) where

import qualified Diagrams.TwoD.GraphViz           as GV (getGraph)
import qualified Data.Map                         as M (foldlWithKey, lookupMin)

import Capabilities.Cache               (MonadCache, cache, short)
import Capabilities.Diagrams            (MonadDiagrams (lin, renderDiagram))
import Capabilities.Graphviz            (MonadGraphviz (layoutGraph))
import Modelling.Auxiliary.Common       (Object)
import Modelling.Auxiliary.Diagrams (
  connectOutside'',
  nonEmptyPathBetween,
  text',
  trailBetween,
  )
import Modelling.PetriNet.Parser (
  netToGr,
  parseNet,
  simpleRenameWith,
  )
import Modelling.PetriNet.Types (
  DrawSettings (..),
  Net (traverseNet, nodes),
  )

import Control.Monad.Catch (
  Exception,
  MonadCatch,
  MonadThrow (throwM),
  handle,
  )
import Data.Graph.Inductive             (Gr)
import Data.GraphViz                    (AttributeNode, AttributeEdge)
import Data.GraphViz.Exception          (GraphvizException)
import Data.List                        (foldl')
import Data.Data (
  Data,
  Typeable,
  dataTypeName,
  dataTypeOf,
  )
import Diagrams.Backend.SVG             (B, svgClass)
import Diagrams.Prelude
import Graphics.SVGFonts.ReadFont       (PreparedFont)
import Language.Alloy.Call              (AlloyInstance)

{-|
Uses 'cache' in order to cache the provided Petri net like graph ('Net').
by distributing places and transitions using GraphViz.
The provided 'GraphvizCommand' is used for this distribution.
-}
cacheNet
  :: (
    Data (n String),
    Data (p n String),
    MonadCache m,
    MonadDiagrams m,
    MonadGraphviz m,
    MonadThrow m,
    Net p n,
    Typeable n,
    Typeable p
    )
  => FilePath
  -- ^ a prefix to use for resulting files
  -> p n String
  -- ^ the graph to draw
  -> DrawSettings
  -- ^ how to draw the graph
  -> m FilePath
cacheNet :: forall (n :: * -> *) (p :: (* -> *) -> * -> *) (m :: * -> *).
(Data (n String), Data (p n String), MonadCache m, MonadDiagrams m,
 MonadGraphviz m, MonadThrow m, Net p n, Typeable n, Typeable p) =>
String -> p n String -> DrawSettings -> m String
cacheNet String
path p n String
pl drawSettings :: DrawSettings
drawSettings@DrawSettings {Bool
GraphvizCommand
withPlaceNames :: Bool
withSvgHighlighting :: Bool
withTransitionNames :: Bool
with1Weights :: Bool
withGraphvizCommand :: GraphvizCommand
$sel:withPlaceNames:DrawSettings :: DrawSettings -> Bool
$sel:withSvgHighlighting:DrawSettings :: DrawSettings -> Bool
$sel:withTransitionNames:DrawSettings :: DrawSettings -> Bool
$sel:with1Weights:DrawSettings :: DrawSettings -> Bool
$sel:withGraphvizCommand:DrawSettings :: DrawSettings -> GraphvizCommand
..} =
  String
-> String
-> String
-> p n String
-> (p n String -> m ByteString)
-> m String
forall (m :: * -> *) a.
(MonadCache m, Show a) =>
String -> String -> String -> a -> (a -> m ByteString) -> m String
cache String
path String
ext String
prefix p n String
pl ((p n String -> m ByteString) -> m String)
-> (p n String -> m ByteString) -> m String
forall a b. (a -> b) -> a -> b
$ \p n String
pl' -> do
    QDiagram SVG V2 Double Any
dia <- p n String -> DrawSettings -> m (Diagram SVG)
forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *).
(MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n) =>
p n String -> DrawSettings -> m (Diagram SVG)
drawNet p n String
pl' DrawSettings
drawSettings
    QDiagram SVG V2 Double Any -> m ByteString
forall n o.
(Show n, Typeable n, RealFloat n, Monoid o) =>
QDiagram SVG V2 n o -> m ByteString
forall (m :: * -> *) n o.
(MonadDiagrams m, Show n, Typeable n, RealFloat n, Monoid o) =>
QDiagram SVG V2 n o -> m ByteString
renderDiagram QDiagram SVG V2 Double Any
dia
  where
    prefix :: String
prefix =
      String
"petri-"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
petriType
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nodeType
    petriType :: String
petriType = DataType -> String
dataTypeName (DataType -> String)
-> (p n String -> DataType) -> p n String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p n String -> DataType
forall a. Data a => a -> DataType
dataTypeOf (p n String -> String) -> p n String -> String
forall a b. (a -> b) -> a -> b
$ p n String
pl
    nodeType :: String
nodeType = String
-> ((String, n String) -> String)
-> Maybe (String, n String)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      String
""
      ((Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String)
-> ((String, n String) -> String) -> (String, n String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataType -> String
dataTypeName (DataType -> String)
-> ((String, n String) -> DataType) -> (String, n String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n String -> DataType
forall a. Data a => a -> DataType
dataTypeOf (n String -> DataType)
-> ((String, n String) -> n String)
-> (String, n String)
-> DataType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, n String) -> n String
forall a b. (a, b) -> b
snd)
      (Maybe (String, n String) -> String)
-> Maybe (String, n String) -> String
forall a b. (a -> b) -> a -> b
$ Map String (n String) -> Maybe (String, n String)
forall k a. Map k a -> Maybe (k, a)
M.lookupMin (Map String (n String) -> Maybe (String, n String))
-> Map String (n String) -> Maybe (String, n String)
forall a b. (a -> b) -> a -> b
$ p n String -> Map String (n String)
forall a. Ord a => p n a -> Map a (n a)
forall (p :: (* -> *) -> * -> *) (n :: * -> *) a.
(Net p n, Ord a) =>
p n a -> Map a (n a)
nodes p n String
pl
    ext :: String
ext = Bool -> String
forall a. Enum a => a -> String
short Bool
withPlaceNames
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Enum a => a -> String
short Bool
withTransitionNames
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Enum a => a -> String
short Bool
with1Weights
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Enum a => a -> String
short Bool
withSvgHighlighting
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ GraphvizCommand -> String
forall a. Enum a => a -> String
short GraphvizCommand
withGraphvizCommand
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".svg"

newtype UnknownPetriNetNodeException
  = CouldNotFindNodeWithinGraph String
  deriving Int -> UnknownPetriNetNodeException -> String -> String
[UnknownPetriNetNodeException] -> String -> String
UnknownPetriNetNodeException -> String
(Int -> UnknownPetriNetNodeException -> String -> String)
-> (UnknownPetriNetNodeException -> String)
-> ([UnknownPetriNetNodeException] -> String -> String)
-> Show UnknownPetriNetNodeException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UnknownPetriNetNodeException -> String -> String
showsPrec :: Int -> UnknownPetriNetNodeException -> String -> String
$cshow :: UnknownPetriNetNodeException -> String
show :: UnknownPetriNetNodeException -> String
$cshowList :: [UnknownPetriNetNodeException] -> String -> String
showList :: [UnknownPetriNetNodeException] -> String -> String
Show

instance Exception UnknownPetriNetNodeException

{-| Create a 'Diagram's graph of a Petri net like graph definition ('Net')
by distributing places and transitions using GraphViz.
The provided 'GraphvizCommand' is used for this distribution.
-}
drawNet
  :: (MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n)
  => p n String
  -- ^ the graph definition
  -> DrawSettings
  -- ^ how to draw the graph
  -> m (Diagram B)
drawNet :: forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *).
(MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n) =>
p n String -> DrawSettings -> m (Diagram SVG)
drawNet p n String
pl drawSettings :: DrawSettings
drawSettings@DrawSettings {Bool
GraphvizCommand
$sel:withPlaceNames:DrawSettings :: DrawSettings -> Bool
$sel:withSvgHighlighting:DrawSettings :: DrawSettings -> Bool
$sel:withTransitionNames:DrawSettings :: DrawSettings -> Bool
$sel:with1Weights:DrawSettings :: DrawSettings -> Bool
$sel:withGraphvizCommand:DrawSettings :: DrawSettings -> GraphvizCommand
withPlaceNames :: Bool
withSvgHighlighting :: Bool
withTransitionNames :: Bool
with1Weights :: Bool
withGraphvizCommand :: GraphvizCommand
..} = do
  Gr (String, Maybe Int) Int
gr <- (String -> m (Gr (String, Maybe Int) Int))
-> (Gr (String, Maybe Int) Int -> m (Gr (String, Maybe Int) Int))
-> Either String (Gr (String, Maybe Int) Int)
-> m (Gr (String, Maybe Int) Int)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (UnknownPetriNetNodeException -> m (Gr (String, Maybe Int) Int)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UnknownPetriNetNodeException -> m (Gr (String, Maybe Int) Int))
-> (String -> UnknownPetriNetNodeException)
-> String
-> m (Gr (String, Maybe Int) Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnknownPetriNetNodeException
CouldNotFindNodeWithinGraph) Gr (String, Maybe Int) Int -> m (Gr (String, Maybe Int) Int)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Either String (Gr (String, Maybe Int) Int)
 -> m (Gr (String, Maybe Int) Int))
-> Either String (Gr (String, Maybe Int) Int)
-> m (Gr (String, Maybe Int) Int)
forall a b. (a -> b) -> a -> b
$ p n String -> Either String (Gr (String, Maybe Int) Int)
forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *) a.
(Monad m, Net p n, Ord a) =>
p n a -> m (Gr (a, Maybe Int) Int)
netToGr p n String
pl
  Gr (AttributeNode (String, Maybe Int)) (AttributeEdge Int)
graph <- GraphvizCommand
-> Gr (String, Maybe Int) Int
-> m (Gr (AttributeNode (String, Maybe Int)) (AttributeEdge Int))
forall (m :: * -> *) (gr :: * -> * -> *) v e.
(MonadGraphviz m, Graph gr) =>
GraphvizCommand
-> gr v e -> m (gr (AttributeNode v) (AttributeEdge e))
forall (gr :: * -> * -> *) v e.
Graph gr =>
GraphvizCommand
-> gr v e -> m (gr (AttributeNode v) (AttributeEdge e))
layoutGraph GraphvizCommand
withGraphvizCommand Gr (String, Maybe Int) Int
gr
  PreparedFont Double
preparedFont <- m (PreparedFont Double)
forall n. (Read n, RealFloat n) => m (PreparedFont n)
forall (m :: * -> *) n.
(MonadDiagrams m, Read n, RealFloat n) =>
m (PreparedFont n)
lin
  return $ DrawSettings
-> PreparedFont Double
-> Gr (AttributeNode (String, Maybe Int)) (AttributeEdge Int)
-> Diagram SVG
drawGraph DrawSettings
drawSettings PreparedFont Double
preparedFont Gr (AttributeNode (String, Maybe Int)) (AttributeEdge Int)
graph

{-|
Attempts to draw the net.
As Graphviz might fail to layout the net,
this function indicates such failure by returning 'False' if that is the case
or 'True' in case of success.
-}
isNetDrawable
  :: (MonadCatch m, MonadDiagrams m, MonadGraphviz m, Net p n)
  => p n String
  -- ^ the net to attempt to draw
  -> DrawSettings
  -- ^ settings to use
  -> m Bool
isNetDrawable :: forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *).
(MonadCatch m, MonadDiagrams m, MonadGraphviz m, Net p n) =>
p n String -> DrawSettings -> m Bool
isNetDrawable p n String
pl =
  (GraphvizException -> m Bool) -> m Bool -> m Bool
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (m Bool -> GraphvizException -> m Bool
forall a b. a -> b -> a
const (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (GraphvizException -> m Bool)
-> (GraphvizException -> GraphvizException)
-> GraphvizException
-> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a
id @GraphvizException)
  (m Bool -> m Bool)
-> (DrawSettings -> m Bool) -> DrawSettings -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (QDiagram SVG V2 Double Any) -> m Bool -> m Bool
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) (m (QDiagram SVG V2 Double Any) -> m Bool)
-> (DrawSettings -> m (QDiagram SVG V2 Double Any))
-> DrawSettings
-> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p n String -> DrawSettings -> m (Diagram SVG)
forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *).
(MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n) =>
p n String -> DrawSettings -> m (Diagram SVG)
drawNet p n String
pl

getNet
  :: (MonadThrow m, Net p n, Traversable t)
  => (AlloyInstance -> m (t Object))
  -> AlloyInstance
  -> m (p n String, t String)
getNet :: forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *)
       (t :: * -> *).
(MonadThrow m, Net p n, Traversable t) =>
(AlloyInstance -> m (t Object))
-> AlloyInstance -> m (p n String, t String)
getNet AlloyInstance -> m (t Object)
parseSpecial AlloyInstance
inst = do
  (p n String
net, Object -> m String
rename) <-
    String
-> String -> AlloyInstance -> m (p n String, Object -> m String)
forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *).
(MonadThrow m, Net p n) =>
String
-> String -> AlloyInstance -> m (p n String, Object -> m String)
getNetWith String
"flow" String
"tokens" AlloyInstance
inst
  t Object
special <- AlloyInstance -> m (t Object)
parseSpecial AlloyInstance
inst
  t String
renamedSpecial <- (Object -> m String) -> t Object -> m (t String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse Object -> m String
rename t Object
special
  return (p n String
net, t String
renamedSpecial)

getDefaultNet
  :: (MonadThrow m, Net p n)
  => AlloyInstance
  -> m (p n String)
getDefaultNet :: forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *).
(MonadThrow m, Net p n) =>
AlloyInstance -> m (p n String)
getDefaultNet AlloyInstance
inst= (p n String, Object -> m String) -> p n String
forall a b. (a, b) -> a
fst ((p n String, Object -> m String) -> p n String)
-> m (p n String, Object -> m String) -> m (p n String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  String
-> String -> AlloyInstance -> m (p n String, Object -> m String)
forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *).
(MonadThrow m, Net p n) =>
String
-> String -> AlloyInstance -> m (p n String, Object -> m String)
getNetWith String
"defaultFlow" String
"defaultTokens" AlloyInstance
inst

{-|
Returns a Petri net like graph using 'parseNet'.
It additionally parses another part of the instance.
All nodes are renamed using the 'simpleRenameWith' function.
The renaming is also applied to the additionally parsed instance.
-}
getNetWith
  :: (MonadThrow m, Net p n)
  => String
  -- ^ flow
  -> String
  -- ^ tokens
  -> AlloyInstance
  -- ^ the instance to parse
  -> m (p n String, Object -> m String)
getNetWith :: forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *).
(MonadThrow m, Net p n) =>
String
-> String -> AlloyInstance -> m (p n String, Object -> m String)
getNetWith String
f String
t AlloyInstance
inst = do
  p n Object
pl <- String -> String -> AlloyInstance -> m (p n Object)
forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *).
(MonadThrow m, Net p n) =>
String -> String -> AlloyInstance -> m (p n Object)
parseNet String
f String
t AlloyInstance
inst
  let rename :: Object -> m String
rename = p n Object -> Object -> m String
forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *) a.
(MonadThrow m, Net p n, Ord a) =>
p n a -> a -> m String
simpleRenameWith p n Object
pl
  p n String
pl' <- (Object -> m String) -> p n Object -> m (p n String)
forall (f :: * -> *) b a.
(Applicative f, Ord b) =>
(a -> f b) -> p n a -> f (p n b)
forall (p :: (* -> *) -> * -> *) (n :: * -> *) (f :: * -> *) b a.
(Net p n, Applicative f, Ord b) =>
(a -> f b) -> p n a -> f (p n b)
traverseNet Object -> m String
rename p n Object
pl
  return (p n String
pl', Object -> m String
rename)

{-|
Obtain the Petri net like graph by drawing Nodes and connections between them
using the specific functions @drawNode@ and @drawEdge@.
-}
drawGraph
  :: DrawSettings
  -- ^ how to draw the graph
  -> PreparedFont Double
  -- ^ the font to be used for labels
  -> Gr (AttributeNode (String, Maybe Int)) (AttributeEdge Int)
  -- ^ the graph consisting of nodes and edges
  -> Diagram B
drawGraph :: DrawSettings
-> PreparedFont Double
-> Gr (AttributeNode (String, Maybe Int)) (AttributeEdge Int)
-> Diagram SVG
drawGraph drawSettings :: DrawSettings
drawSettings@DrawSettings {Bool
GraphvizCommand
$sel:withPlaceNames:DrawSettings :: DrawSettings -> Bool
$sel:withSvgHighlighting:DrawSettings :: DrawSettings -> Bool
$sel:withTransitionNames:DrawSettings :: DrawSettings -> Bool
$sel:with1Weights:DrawSettings :: DrawSettings -> Bool
$sel:withGraphvizCommand:DrawSettings :: DrawSettings -> GraphvizCommand
withPlaceNames :: Bool
withSvgHighlighting :: Bool
withTransitionNames :: Bool
with1Weights :: Bool
withGraphvizCommand :: GraphvizCommand
..} PreparedFont Double
preparedFont Gr (AttributeNode (String, Maybe Int)) (AttributeEdge Int)
graph =
  QDiagram SVG V2 Double Any
graphEdges' QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# Double -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> QDiagram b v n m -> QDiagram b v n m
frame Double
1
  where
    (Map (String, Maybe Int) (P2 Double)
nodes', [((String, Maybe Int), (String, Maybe Int), Int, Path V2 Double)]
edges) = Gr (AttributeNode (String, Maybe Int)) (AttributeEdge Int)
-> (Map (String, Maybe Int) (P2 Double),
    [((String, Maybe Int), (String, Maybe Int), Int, Path V2 Double)])
forall v e.
Ord v =>
Gr (AttributeNode v) (AttributeEdge e)
-> (Map v (P2 Double), [(v, v, e, Path V2 Double)])
GV.getGraph Gr (AttributeNode (String, Maybe Int)) (AttributeEdge Int)
graph
    graphNodes' :: QDiagram SVG V2 Double Any
graphNodes' = (QDiagram SVG V2 Double Any
 -> (String, Maybe Int) -> P2 Double -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
-> Map (String, Maybe Int) (P2 Double)
-> QDiagram SVG V2 Double Any
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey
      (\QDiagram SVG V2 Double Any
g (String, Maybe Int)
l P2 Double
p -> QDiagram SVG V2 Double Any
g
        QDiagram SVG V2 Double Any
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
`atop`
        DrawSettings
-> PreparedFont Double
-> (String, Maybe Int)
-> P2 Double
-> Diagram SVG
drawNode DrawSettings
drawSettings PreparedFont Double
preparedFont (String, Maybe Int)
l P2 Double
p)
      QDiagram SVG V2 Double Any
forall a. Monoid a => a
mempty
      Map (String, Maybe Int) (P2 Double)
nodes'
    graphEdges' :: QDiagram SVG V2 Double Any
graphEdges' = (QDiagram SVG V2 Double Any
 -> ((String, Maybe Int), (String, Maybe Int), Int, Path V2 Double)
 -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
-> [((String, Maybe Int), (String, Maybe Int), Int,
     Path V2 Double)]
-> QDiagram SVG V2 Double Any
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
      (\QDiagram SVG V2 Double Any
g ((String, Maybe Int)
s, (String, Maybe Int)
t, Int
l, Path V2 Double
p) ->
        let ls :: String
ls = (String, Maybe Int) -> String
forall a b. (a, b) -> a
labelOnly (String, Maybe Int)
s
            lt :: String
lt = (String, Maybe Int) -> String
forall a b. (a, b) -> a
labelOnly (String, Maybe Int)
t
        in QDiagram SVG V2 Double Any
g QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# Bool
-> PreparedFont Double
-> Int
-> String
-> String
-> Path V2 Double
-> Diagram SVG
-> Diagram SVG
drawEdge
          (Bool -> Bool
not Bool
with1Weights)
          PreparedFont Double
preparedFont
          Int
l
          String
ls
          String
lt
          (Path V2 Double
-> String -> String -> QDiagram SVG V2 Double Any -> Path V2 Double
forall p1 p2 (v :: * -> *) n m b.
(IsName p1, IsName p2, Metric v, RealFloat n, Semigroup m) =>
Path v n -> p1 -> p2 -> QDiagram b v n m -> Path v n
nonEmptyPathBetween Path V2 Double
p String
ls String
lt QDiagram SVG V2 Double Any
g)
      )
      QDiagram SVG V2 Double Any
graphNodes'
      [((String, Maybe Int), (String, Maybe Int), Int, Path V2 Double)]
edges
    labelOnly :: (a, b) -> a
labelOnly = (a, b) -> a
forall a b. (a, b) -> a
fst

{-|
Nodes are either Places (having 'Just' tokens), or Transitions (having
'Nothing').
Transitions are drawn as squares.
Places are drawn as circles.
Places contain circled tokens layout as a ring of tokens or numbered
if 5 or more tokens are within.
Each node gets a label.
-}
drawNode
  :: DrawSettings
  -- ^ how to draw
  -> PreparedFont Double
  -- ^ the font to use
  -> (String, Maybe Int)
  -- ^ a node (the first part is used for its label)
  -> Point V2 Double
  -- ^ where to place the node
  -> Diagram B
drawNode :: DrawSettings
-> PreparedFont Double
-> (String, Maybe Int)
-> P2 Double
-> Diagram SVG
drawNode DrawSettings {Bool
GraphvizCommand
$sel:withPlaceNames:DrawSettings :: DrawSettings -> Bool
$sel:withSvgHighlighting:DrawSettings :: DrawSettings -> Bool
$sel:withTransitionNames:DrawSettings :: DrawSettings -> Bool
$sel:with1Weights:DrawSettings :: DrawSettings -> Bool
$sel:withGraphvizCommand:DrawSettings :: DrawSettings -> GraphvizCommand
withPlaceNames :: Bool
withSvgHighlighting :: Bool
withTransitionNames :: Bool
with1Weights :: Bool
withGraphvizCommand :: GraphvizCommand
..} PreparedFont Double
preparedFont (String
l, Maybe Int
Nothing) P2 Double
p  = QDiagram SVG V2 Double Any
-> P2 Double -> QDiagram SVG V2 Double Any
forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
t -> Point v n -> t
place
  (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
addTransitionName (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall a b. (a -> b) -> a -> b
$ Double -> Double -> QDiagram SVG V2 Double Any
forall n t. (InSpace V2 n t, TrailLike t) => n -> n -> t
rect Double
20 Double
20 QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# Double -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL Double
0.5 QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# String -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall nm (v :: * -> *) n m b.
(IsName nm, Metric v, OrderedField n, Semigroup m) =>
nm -> QDiagram b v n m -> QDiagram b v n m
named String
l QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# String -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n.
SVGFloat n =>
String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgClass String
"rect" QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
additionalLabel)
  P2 Double
p
  where
    additionalLabel :: QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
additionalLabel
      | Bool
withSvgHighlighting = QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall a. a -> a
id
      | Bool
otherwise = String -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n.
SVGFloat n =>
String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgClass (String
 -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> String
-> QDiagram SVG V2 Double Any
-> QDiagram SVG V2 Double Any
forall a b. (a -> b) -> a -> b
$ Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
l
    addTransitionName :: QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
addTransitionName
      | Bool -> Bool
not Bool
withTransitionNames = QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall a. a -> a
id
      | Bool
otherwise = (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Traversable v, Alignable a,
 HasOrigin a) =>
a -> a
center (PreparedFont Double -> Double -> String -> Diagram SVG
text' PreparedFont Double
preparedFont Double
18 String
l) QDiagram SVG V2 Double Any
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
`atop`)
drawNode DrawSettings {Bool
GraphvizCommand
$sel:withPlaceNames:DrawSettings :: DrawSettings -> Bool
$sel:withSvgHighlighting:DrawSettings :: DrawSettings -> Bool
$sel:withTransitionNames:DrawSettings :: DrawSettings -> Bool
$sel:with1Weights:DrawSettings :: DrawSettings -> Bool
$sel:withGraphvizCommand:DrawSettings :: DrawSettings -> GraphvizCommand
withPlaceNames :: Bool
withSvgHighlighting :: Bool
withTransitionNames :: Bool
with1Weights :: Bool
withGraphvizCommand :: GraphvizCommand
..} PreparedFont Double
preparedFont (String
l, Just Int
i) P2 Double
p
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5
  = QDiagram SVG V2 Double Any
-> P2 Double -> QDiagram SVG V2 Double Any
forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
t -> Point v n -> t
place ((QDiagram SVG V2 Double Any
 -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
-> [QDiagram SVG V2 Double Any]
-> QDiagram SVG V2 Double Any
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' QDiagram SVG V2 Double Any
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
atop QDiagram SVG V2 Double Any
label ([QDiagram SVG V2 Double Any] -> QDiagram SVG V2 Double Any)
-> [QDiagram SVG V2 Double Any] -> QDiagram SVG V2 Double Any
forall a b. (a -> b) -> a -> b
$ [Int -> QDiagram SVG V2 Double Any
forall {a}. Integral a => a -> QDiagram SVG V2 Double Any
placeToken Int
j | Int
j <- [Int
1..Int
i]] [QDiagram SVG V2 Double Any]
-> [QDiagram SVG V2 Double Any] -> [QDiagram SVG V2 Double Any]
forall a. [a] -> [a] -> [a]
++ [QDiagram SVG V2 Double Any
emptyPlace]) P2 Double
p
  | Bool
otherwise
  = QDiagram SVG V2 Double Any
-> P2 Double -> QDiagram SVG V2 Double Any
forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
t -> Point v n -> t
place
    ((QDiagram SVG V2 Double Any
 -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
-> [QDiagram SVG V2 Double Any]
-> QDiagram SVG V2 Double Any
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' QDiagram SVG V2 Double Any
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
atop QDiagram SVG V2 Double Any
label [
        QDiagram SVG V2 Double Any
token QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# Vn (QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall t. Transformable t => Vn t -> t -> t
translate ((Double, Double) -> V2 Double
forall n. (n, n) -> V2 n
r2 (Double
spacer,Double
0)),
        PreparedFont Double -> Double -> String -> Diagram SVG
text' PreparedFont Double
preparedFont Double
20 (Int -> String
forall a. Show a => a -> String
show Int
i) QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# Vn (QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall t. Transformable t => Vn t -> t -> t
translate ((Double, Double) -> V2 Double
forall n. (n, n) -> V2 n
r2 (-Double
spacer,-Double
4)),
        QDiagram SVG V2 Double Any
emptyPlace
        ])
    P2 Double
p
  where
    additionalLabel :: QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
additionalLabel
      | Bool
withSvgHighlighting = QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall a. a -> a
id
      | Bool
otherwise = String -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n.
SVGFloat n =>
String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgClass (String
 -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> String
-> QDiagram SVG V2 Double Any
-> QDiagram SVG V2 Double Any
forall a b. (a -> b) -> a -> b
$ Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
l
    spacer :: Double
spacer = Double
9
    emptyPlace :: QDiagram SVG V2 Double Any
emptyPlace = Double -> QDiagram SVG V2 Double Any
forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Transformable t) =>
n -> t
circle Double
20 QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# Double -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL Double
0.5 QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# String -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall nm (v :: * -> *) n m b.
(IsName nm, Metric v, OrderedField n, Semigroup m) =>
nm -> QDiagram b v n m -> QDiagram b v n m
named String
l QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# String -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n.
SVGFloat n =>
String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgClass String
"node" QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
additionalLabel
    label :: QDiagram SVG V2 Double Any
label
      | Bool -> Bool
not Bool
withPlaceNames = QDiagram SVG V2 Double Any
forall a. Monoid a => a
mempty
      | Bool
otherwise = QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Traversable v, Alignable a,
 HasOrigin a) =>
a -> a
center (PreparedFont Double -> Double -> String -> Diagram SVG
text' PreparedFont Double
preparedFont Double
18 String
l)
        # translate (r2 (0, - (3 * spacer)))
        # svgClass "nlabel"
    tokenGrey :: Colour Double
tokenGrey = Word8 -> Word8 -> Word8 -> Colour Double
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
136 Word8
136 Word8
136
    token :: QDiagram SVG V2 Double Any
token = Double -> QDiagram SVG V2 Double Any
forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Transformable t) =>
n -> t
circle Double
4.5 QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# Colour Double
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
tokenGrey QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# Colour Double
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc Colour Double
tokenGrey QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# Double -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL Double
0 QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# String -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n.
SVGFloat n =>
String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgClass String
"token"
    placeToken :: a -> QDiagram SVG V2 Double Any
placeToken a
j = QDiagram SVG V2 Double Any
token
      # translate (r2 (8 * sqrt(fromIntegral (i - 1)), 0))
      # rotateBy (fromIntegral j / fromIntegral i)

{-|
Edges are drawn as arcs between nodes (identified by labels).
-}
drawEdge
  :: Bool
  -- ^ whether to hide weight of 1
  -> PreparedFont Double
  -- ^ the font to use
  -> Int
  -- ^ the edges label
  -> String
  -- ^ label of start node
  -> String
  -- ^ label of end node
  -> Path V2 Double
  -- ^ the path along which to align the edge
  -> Diagram B
  -- ^ the diagram which contains labelled nodes already
  -> Diagram B
drawEdge :: Bool
-> PreparedFont Double
-> Int
-> String
-> String
-> Path V2 Double
-> Diagram SVG
-> Diagram SVG
drawEdge Bool
hide1 PreparedFont Double
f Int
l String
l1 String
l2 Path V2 Double
path Diagram SVG
d =
  let opts :: ArrowOpts Double
opts = ArrowOpts Double
forall d. Default d => d
with
        ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (Trail V2 Double -> Identity (Trail V2 Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(Trail V2 n -> f (Trail V2 n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowShaft ((Trail V2 Double -> Identity (Trail V2 Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> Trail V2 Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Located (Trail V2 Double) -> Trail V2 Double
forall a. Located a -> a
unLoc Located (Trail V2 Double)
trail
        ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (ArrowHT Double -> Identity (ArrowHT Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(ArrowHT n -> f (ArrowHT n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowHead ((ArrowHT Double -> Identity (ArrowHT Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> ArrowHT Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Angle Double -> ArrowHT Double
forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadTriangle (Double
150 Double -> AReview (Angle Double) Double -> Angle Double
forall b a. b -> AReview a b -> a
@@ AReview (Angle Double) Double
forall n. Floating n => Iso' (Angle n) n
Iso' (Angle Double) Double
deg)
        ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (Measure Double -> Identity (Measure Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headGap ((Measure Double -> Identity (Measure Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> Measure Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double -> Measure Double
forall n. Num n => n -> Measure n
local Double
0.005
        ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (Measure Double -> Identity (Measure Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headLength ((Measure Double -> Identity (Measure Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> Measure Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double -> Measure Double
forall n. Num n => n -> Measure n
local Double
10
      labelPoint :: Point V2 Double
      labelPoint :: P2 Double
labelPoint = Located (Trail V2 Double)
trail Located (Trail V2 Double)
-> N (Located (Trail V2 Double))
-> Codomain
     (Located (Trail V2 Double)) (N (Located (Trail V2 Double)))
forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` Double
N (Located (Trail V2 Double))
0.4 P2 Double -> Diff (Point V2) Double -> P2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.-^ Double
8 Double -> V2 Double -> V2 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ V2 Double
n
        where
          n :: V2 Double
n = Located (Trail V2 Double)
trail Located (Trail V2 Double) -> Double -> V2 Double
forall n t.
(InSpace V2 n t, Parametric (Tangent t), Floating n) =>
t -> n -> V2 n
`normalAtParam` Double
0.4
      addLabel :: QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
addLabel
        | Bool
hide1 Bool -> Bool -> Bool
&& Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall a. a -> a
id
        | Bool
otherwise = QDiagram SVG V2 Double Any
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
atop (QDiagram SVG V2 Double Any
-> P2 Double -> QDiagram SVG V2 Double Any
forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
t -> Point v n -> t
place (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall (v :: * -> *) n a.
(InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) =>
a -> a
centerXY (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall a b. (a -> b) -> a -> b
$ PreparedFont Double -> Double -> String -> Diagram SVG
text' PreparedFont Double
f Double
20 (String -> Diagram SVG) -> String -> Diagram SVG
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
l) P2 Double
labelPoint QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# String -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n.
SVGFloat n =>
String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgClass String
"elabel")
  in QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
addLabel (ArrowOpts Double
-> String
-> String
-> QDiagram SVG V2 Double Any
-> QDiagram SVG V2 Double Any
forall n1 n2 n.
(IsName n1, IsName n2, RealFloat n, Show n, Typeable n) =>
ArrowOpts n
-> n1 -> n2 -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
connectOutside'' ArrowOpts Double
opts String
l1 String
l2 Diagram SVG
QDiagram SVG V2 Double Any
d QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# Double -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL Double
0.5) QDiagram SVG V2 Double Any
-> (QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any)
-> QDiagram SVG V2 Double Any
forall a b. a -> (a -> b) -> b
# String -> QDiagram SVG V2 Double Any -> QDiagram SVG V2 Double Any
forall n.
SVGFloat n =>
String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgClass String
"."
  where
    trail :: Located (Trail V2 Double)
trail = Path V2 Double
-> String
-> String
-> QDiagram SVG V2 Double Any
-> Located (Trail V2 Double)
forall n1 n2 m b.
(IsName n1, IsName n2, Semigroup m) =>
Path V2 Double
-> n1 -> n2 -> QDiagram b V2 Double m -> Located (Trail V2 Double)
trailBetween Path V2 Double
path String
l1 String
l2 Diagram SVG
QDiagram SVG V2 Double Any
d