{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE LambdaCase #-}

{- | A chart-based semiring parser for path grammars (e.g. the PV grammar).
Path grammars operate on "paths"
consisting of nodes (slices) and edges (transitions),
both of which can contain arbitrary content.
Paths are elaborated through two operations,
@split@ting transitions and @spread@ing slices
(plus @freeze@, which terminates generation on a transition).

The parser is polymorphic in the grammar
as well as the contents of slices (path nodes) and transitions (path edges).
The grammar to parse is definend in an "evaluator" ('Common.Eval')
which provides completions for parsing the splits, spreads and freezes.
-}
module ChartParser
  ( -- * Parsing Interface
    parse
  , parseSize
  , parseSilent
  , logSize
  , logTikz

    -- * Charts

    -- ** Basic Elements
  , Slice
  , Transition
  , transLen
  , Item
  , TItem

    -- ** Transition Chart
  , TContents
  , TChart
  , tcGetByLength

    -- ** Verticalization Chart
  , Vert
  , VChart
  , vcGetByLength

    -- * Constraint Aliases
  , Parsable
  , Normal
  , Normal'
  ) where

import Common
import Scoring.FunTyped qualified as S

import Data.HashMap.Strict qualified as HM
import Data.IntMap.Strict qualified as IM
import Data.Semiring qualified as R

import Control.Monad (foldM, foldM_, mzero)
import Control.Monad.State as ST

import Control.DeepSeq
import Control.Parallel.Strategies qualified as P
import Data.Foldable (foldl')
import Data.Hashable
  ( Hashable
  , hash
  , hashWithSalt
  )
import Data.Kind (Constraint, Type)
import Data.Maybe
  ( catMaybes
  , fromMaybe
  , mapMaybe
  , maybeToList
  )
import Data.Set qualified as Set
import GHC.Generics (Generic)

-- Basic Types
-- ===========

-- | An alias for common constraints on slices and transitions
type Normal :: Type -> Constraint
type Normal x = (Eq x, Ord x, Show x, Hashable x, NFData x)

-- | An alias for common constraints on semiring values
type Normal' :: Type -> Constraint
type Normal' x = (Eq x, Show x, NFData x, R.Semiring x)

-- | A summary constraint for transitions, slices, and semiring values
type Parsable' :: Type -> Type -> Type -> Constraint
type Parsable' tr slc v = (Normal tr, Normal slc, Normal' v)

-- | A summary constraint for transitions, slices, hori-operations, and semiring values
type Parsable :: Type -> Type -> Type -> Type -> Constraint
type Parsable tr slc h v = (Normal tr, Normal slc, Normal h, Normal' v)

-- Slices
---------

{- | A slice during chart parsing.
 Besides the slice content (e.g., notes),
 it maintains indices to the first and last surface slice covered,
 as well as an ID that is used for matching compatible parents of a spread.
-}
data Slice slc = Slice
  { forall slc. Slice slc -> Int
sFirst :: !Int
  -- ^ index of the first surface slice covered
  , forall slc. Slice slc -> StartStop slc
sContent :: !(StartStop slc)
  -- ^ slice content (or 'Start'/'Stop')
  , forall slc. Slice slc -> Int
sID :: !Int
  -- ^ unique slice ID
  , forall slc. Slice slc -> Int
sLast :: !Int
  -- ^ index of the last surface slice covered
  }
  deriving (Slice slc -> Slice slc -> Bool
(Slice slc -> Slice slc -> Bool)
-> (Slice slc -> Slice slc -> Bool) -> Eq (Slice slc)
forall slc. Eq slc => Slice slc -> Slice slc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall slc. Eq slc => Slice slc -> Slice slc -> Bool
== :: Slice slc -> Slice slc -> Bool
$c/= :: forall slc. Eq slc => Slice slc -> Slice slc -> Bool
/= :: Slice slc -> Slice slc -> Bool
Eq, Eq (Slice slc)
Eq (Slice slc) =>
(Slice slc -> Slice slc -> Ordering)
-> (Slice slc -> Slice slc -> Bool)
-> (Slice slc -> Slice slc -> Bool)
-> (Slice slc -> Slice slc -> Bool)
-> (Slice slc -> Slice slc -> Bool)
-> (Slice slc -> Slice slc -> Slice slc)
-> (Slice slc -> Slice slc -> Slice slc)
-> Ord (Slice slc)
Slice slc -> Slice slc -> Bool
Slice slc -> Slice slc -> Ordering
Slice slc -> Slice slc -> Slice 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 (Slice slc)
forall slc. Ord slc => Slice slc -> Slice slc -> Bool
forall slc. Ord slc => Slice slc -> Slice slc -> Ordering
forall slc. Ord slc => Slice slc -> Slice slc -> Slice slc
$ccompare :: forall slc. Ord slc => Slice slc -> Slice slc -> Ordering
compare :: Slice slc -> Slice slc -> Ordering
$c< :: forall slc. Ord slc => Slice slc -> Slice slc -> Bool
< :: Slice slc -> Slice slc -> Bool
$c<= :: forall slc. Ord slc => Slice slc -> Slice slc -> Bool
<= :: Slice slc -> Slice slc -> Bool
$c> :: forall slc. Ord slc => Slice slc -> Slice slc -> Bool
> :: Slice slc -> Slice slc -> Bool
$c>= :: forall slc. Ord slc => Slice slc -> Slice slc -> Bool
>= :: Slice slc -> Slice slc -> Bool
$cmax :: forall slc. Ord slc => Slice slc -> Slice slc -> Slice slc
max :: Slice slc -> Slice slc -> Slice slc
$cmin :: forall slc. Ord slc => Slice slc -> Slice slc -> Slice slc
min :: Slice slc -> Slice slc -> Slice slc
Ord, (forall x. Slice slc -> Rep (Slice slc) x)
-> (forall x. Rep (Slice slc) x -> Slice slc)
-> Generic (Slice slc)
forall x. Rep (Slice slc) x -> Slice slc
forall x. Slice slc -> Rep (Slice slc) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall slc x. Rep (Slice slc) x -> Slice slc
forall slc x. Slice slc -> Rep (Slice slc) x
$cfrom :: forall slc x. Slice slc -> Rep (Slice slc) x
from :: forall x. Slice slc -> Rep (Slice slc) x
$cto :: forall slc x. Rep (Slice slc) x -> Slice slc
to :: forall x. Rep (Slice slc) x -> Slice slc
Generic, Slice slc -> ()
(Slice slc -> ()) -> NFData (Slice slc)
forall slc. NFData slc => Slice slc -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall slc. NFData slc => Slice slc -> ()
rnf :: Slice slc -> ()
NFData)

instance (Eq slc) => Hashable (Slice slc) where
  hashWithSalt :: Int -> Slice slc -> Int
hashWithSalt Int
s (Slice Int
_ StartStop slc
_ Int
i Int
_) = Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s Int
i

instance (Show slc) => Show (Slice slc) where
  show :: Slice slc -> String
show (Slice Int
f StartStop slc
c Int
i Int
l) =
    Int -> String
forall a. Show a => a -> String
show Int
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> StartStop slc -> String
forall a. Show a => a -> String
show StartStop slc
c String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
l

-- Transitions
--------------

{- | A transition during chart parsing.
 Has pointers to the two slices it connects,
 a content (e.g., protovoice connections),
 and a flag indicating whether it is the second (right) parent of a spread.
-}
data Transition tr slc = Transition
  { forall tr slc. Transition tr slc -> Slice slc
tLeftSlice :: !(Slice slc)
  , forall tr slc. Transition tr slc -> tr
tContent :: !tr
  , forall tr slc. Transition tr slc -> Slice slc
tRightSlice :: !(Slice slc)
  , forall tr slc. Transition tr slc -> Bool
t2nd :: !Bool
  }
  deriving (Transition tr slc -> Transition tr slc -> Bool
(Transition tr slc -> Transition tr slc -> Bool)
-> (Transition tr slc -> Transition tr slc -> Bool)
-> Eq (Transition tr slc)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall tr slc.
(Eq slc, Eq tr) =>
Transition tr slc -> Transition tr slc -> Bool
$c== :: forall tr slc.
(Eq slc, Eq tr) =>
Transition tr slc -> Transition tr slc -> Bool
== :: Transition tr slc -> Transition tr slc -> Bool
$c/= :: forall tr slc.
(Eq slc, Eq tr) =>
Transition tr slc -> Transition tr slc -> Bool
/= :: Transition tr slc -> Transition tr slc -> Bool
Eq, Eq (Transition tr slc)
Eq (Transition tr slc) =>
(Transition tr slc -> Transition tr slc -> Ordering)
-> (Transition tr slc -> Transition tr slc -> Bool)
-> (Transition tr slc -> Transition tr slc -> Bool)
-> (Transition tr slc -> Transition tr slc -> Bool)
-> (Transition tr slc -> Transition tr slc -> Bool)
-> (Transition tr slc -> Transition tr slc -> Transition tr slc)
-> (Transition tr slc -> Transition tr slc -> Transition tr slc)
-> Ord (Transition tr slc)
Transition tr slc -> Transition tr slc -> Bool
Transition tr slc -> Transition tr slc -> Ordering
Transition tr slc -> Transition tr slc -> Transition tr 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 tr slc. (Ord slc, Ord tr) => Eq (Transition tr slc)
forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Bool
forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Ordering
forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Transition tr slc
$ccompare :: forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Ordering
compare :: Transition tr slc -> Transition tr slc -> Ordering
$c< :: forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Bool
< :: Transition tr slc -> Transition tr slc -> Bool
$c<= :: forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Bool
<= :: Transition tr slc -> Transition tr slc -> Bool
$c> :: forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Bool
> :: Transition tr slc -> Transition tr slc -> Bool
$c>= :: forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Bool
>= :: Transition tr slc -> Transition tr slc -> Bool
$cmax :: forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Transition tr slc
max :: Transition tr slc -> Transition tr slc -> Transition tr slc
$cmin :: forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Transition tr slc
min :: Transition tr slc -> Transition tr slc -> Transition tr slc
Ord, (forall x. Transition tr slc -> Rep (Transition tr slc) x)
-> (forall x. Rep (Transition tr slc) x -> Transition tr slc)
-> Generic (Transition tr slc)
forall x. Rep (Transition tr slc) x -> Transition tr slc
forall x. Transition tr slc -> Rep (Transition tr slc) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tr slc x. Rep (Transition tr slc) x -> Transition tr slc
forall tr slc x. Transition tr slc -> Rep (Transition tr slc) x
$cfrom :: forall tr slc x. Transition tr slc -> Rep (Transition tr slc) x
from :: forall x. Transition tr slc -> Rep (Transition tr slc) x
$cto :: forall tr slc x. Rep (Transition tr slc) x -> Transition tr slc
to :: forall x. Rep (Transition tr slc) x -> Transition tr slc
Generic, Transition tr slc -> ()
(Transition tr slc -> ()) -> NFData (Transition tr slc)
forall a. (a -> ()) -> NFData a
forall tr slc. (NFData slc, NFData tr) => Transition tr slc -> ()
$crnf :: forall tr slc. (NFData slc, NFData tr) => Transition tr slc -> ()
rnf :: Transition tr slc -> ()
NFData, Eq (Transition tr slc)
Eq (Transition tr slc) =>
(Int -> Transition tr slc -> Int)
-> (Transition tr slc -> Int) -> Hashable (Transition tr slc)
Int -> Transition tr slc -> Int
Transition tr slc -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall tr slc. (Eq slc, Hashable tr) => Eq (Transition tr slc)
forall tr slc.
(Eq slc, Hashable tr) =>
Int -> Transition tr slc -> Int
forall tr slc. (Eq slc, Hashable tr) => Transition tr slc -> Int
$chashWithSalt :: forall tr slc.
(Eq slc, Hashable tr) =>
Int -> Transition tr slc -> Int
hashWithSalt :: Int -> Transition tr slc -> Int
$chash :: forall tr slc. (Eq slc, Hashable tr) => Transition tr slc -> Int
hash :: Transition tr slc -> Int
Hashable)

instance (Show a, Show e) => Show (Transition e a) where
  show :: Transition e a -> String
show (Transition Slice a
l e
c Slice a
r Bool
s) =
    String
"<"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Slice a -> String
forall a. Show a => a -> String
show Slice a
l
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
","
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> e -> String
forall a. Show a => a -> String
show e
c
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
","
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Slice a -> String
forall a. Show a => a -> String
show Slice a
r
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
">"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> if Bool
s
        then String
"2"
        else String
""

-- | Returns the "length" of the transition in terms of surface slices covered.
transLen :: Transition e a -> Int
transLen :: forall e a. Transition e a -> Int
transLen (Transition Slice a
l e
_ Slice a
r Bool
_) = Slice a -> Int
forall slc. Slice slc -> Int
sLast Slice a
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Slice a -> Int
forall slc. Slice slc -> Int
sFirst Slice a
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

-- Items
--------

{- | A parsing item.
 Combines an intermediate value (e.g. a transition) with a semiring score.
-}
data Item i v = (:=)
  { forall i v. Item i v -> i
iItem :: !i
  , forall i v. Item i v -> Score v Int
iScore :: !(S.Score v Int)
  }
  deriving ((forall x. Item i v -> Rep (Item i v) x)
-> (forall x. Rep (Item i v) x -> Item i v) -> Generic (Item i v)
forall x. Rep (Item i v) x -> Item i v
forall x. Item i v -> Rep (Item i v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall i v x. Rep (Item i v) x -> Item i v
forall i v x. Item i v -> Rep (Item i v) x
$cfrom :: forall i v x. Item i v -> Rep (Item i v) x
from :: forall x. Item i v -> Rep (Item i v) x
$cto :: forall i v x. Rep (Item i v) x -> Item i v
to :: forall x. Rep (Item i v) x -> Item i v
Generic, Item i v -> ()
(Item i v -> ()) -> NFData (Item i v)
forall a. (a -> ()) -> NFData a
forall i v. (NFData i, NFData v) => Item i v -> ()
$crnf :: forall i v. (NFData i, NFData v) => Item i v -> ()
rnf :: Item i v -> ()
NFData)

instance (Show i, Show v) => Show (Item i v) where
  show :: Item i v -> String
show (i
i := Score v Int
v) = i -> String
forall a. Show a => a -> String
show i
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" := " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Score v Int -> String
forall a. Show a => a -> String
show Score v Int
v

-- | A transition item.
type TItem tr slc v = Item (Transition tr slc) v

-- Vert Items

{- | Represents the middle part of an incomplete unspread ("verticalization").
 Expresses how the middle transition and the two child slices (@vMiddle@)
 are derived from the parent slice (@vTop@) using a spread operation (@vOp@).

 'Vert' objects are stored in the 'VChart'
 to record the intermediate steps of an unspread,
 which is found by first parsing the middle transition into the parent slice
 (generating a 'Vert')
 and then combining the 'Vert' with the left and right child transitions
 to generate the left and right parent transitions, respectively.
-}
data Vert tr slc h v = Vert
  { forall tr slc h v. Vert tr slc h v -> Slice slc
vTop :: !(Slice slc)
  , forall tr slc h v. Vert tr slc h v -> h
vOp :: !h
  , forall tr slc h v. Vert tr slc h v -> v
vVal :: !v
  , forall tr slc h v. Vert tr slc h v -> TItem tr slc v
vMiddle :: !(TItem tr slc v)
  }
  deriving ((forall x. Vert tr slc h v -> Rep (Vert tr slc h v) x)
-> (forall x. Rep (Vert tr slc h v) x -> Vert tr slc h v)
-> Generic (Vert tr slc h v)
forall x. Rep (Vert tr slc h v) x -> Vert tr slc h v
forall x. Vert tr slc h v -> Rep (Vert tr slc h v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tr slc h v x. Rep (Vert tr slc h v) x -> Vert tr slc h v
forall tr slc h v x. Vert tr slc h v -> Rep (Vert tr slc h v) x
$cfrom :: forall tr slc h v x. Vert tr slc h v -> Rep (Vert tr slc h v) x
from :: forall x. Vert tr slc h v -> Rep (Vert tr slc h v) x
$cto :: forall tr slc h v x. Rep (Vert tr slc h v) x -> Vert tr slc h v
to :: forall x. Rep (Vert tr slc h v) x -> Vert tr slc h v
Generic, Vert tr slc h v -> ()
(Vert tr slc h v -> ()) -> NFData (Vert tr slc h v)
forall a. (a -> ()) -> NFData a
forall tr slc h v.
(NFData slc, NFData h, NFData v, NFData tr) =>
Vert tr slc h v -> ()
$crnf :: forall tr slc h v.
(NFData slc, NFData h, NFData v, NFData tr) =>
Vert tr slc h v -> ()
rnf :: Vert tr slc h v -> ()
NFData)

instance (Show e, Show a, Show h, Show v) => Show (Vert e a h v) where
  show :: Vert e a h v -> String
show (Vert Slice a
top h
op v
val TItem e a v
m) =
    String
"Vert"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n top: "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Slice a -> String
forall a. Show a => a -> String
show Slice a
top
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n op:  "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> h -> String
forall a. Show a => a -> String
show h
op
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n val:  "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> String
forall a. Show a => a -> String
show v
val
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n m:   "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TItem e a v -> String
forall a. Show a => a -> String
show TItem e a v
m

-- slice and transition charts
-- ===========================

-- vert chart
-------------

-- ops:
-- - get all of len n
-- - get all with left child = x
-- - get all with right child = x
-- - check ID for (top,left,leftid)

{- | A verticalization chart.
 Stores 'Vert' objects at certain chart positions.
 To support efficient lookup of 'Vert' objects from different indices,
 each 'Vert' is redundantly stored in several hash maps,
 one for each index:

 - by surface length
 - by surface length (only left border of a 'Vert')
 - by left child slice ID and mid transition length
 - by right child ID

 In addition, the 'VChart' maintains IDs of new slices.
 (Every new slice is the parent of an unspread.)
-}
data VChart tr slc h v = VChart
  { forall tr slc h v. VChart tr slc h v -> Int
vcNextId :: !Int
  -- ^ next free ID
  , forall tr slc h v. VChart tr slc h v -> HashMap (Int, Int) Int
vcIDs :: !(HM.HashMap (Int, Int) Int)
  -- ^ a mapping from child slice ids to the corresponding parent id
  , forall tr slc h v. VChart tr slc h v -> IntMap [Vert tr slc h v]
vcByLength :: !(IM.IntMap [Vert tr slc h v])
  -- ^ maps surface length to the 'Vert' with that length
  , forall tr slc h v.
VChart tr slc h v -> IntMap (Set (Slice slc, Slice slc, h))
vcByLengthLeft :: !(IM.IntMap (Set.Set (Slice slc, Slice slc, h)))
  -- ^ maps surface length to the "left borders" of 'Vert' objects with that length
  -- (parent slice, left child slice)
  , forall tr slc h v.
VChart tr slc h v -> HashMap (Int, Int) (Set (Slice slc, h))
vcByLeftChild :: !(HM.HashMap (Int, Int) (Set.Set (Slice slc, h)))
  -- ^ maps a left child slice ID and the surface length of the middle transition
  -- to its potential parent slices
  , forall tr slc h v.
VChart tr slc h v -> HashMap (Int, Int) [Vert tr slc h v]
vcByRightChild :: !(HM.HashMap (Int, Int) [Vert tr slc h v])
  -- ^ maps a right child slice ID and the surface length of the middle transition
  -- to all 'Vert' objects it is part of.
  }
  deriving ((forall x. VChart tr slc h v -> Rep (VChart tr slc h v) x)
-> (forall x. Rep (VChart tr slc h v) x -> VChart tr slc h v)
-> Generic (VChart tr slc h v)
forall x. Rep (VChart tr slc h v) x -> VChart tr slc h v
forall x. VChart tr slc h v -> Rep (VChart tr slc h v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tr slc h v x. Rep (VChart tr slc h v) x -> VChart tr slc h v
forall tr slc h v x. VChart tr slc h v -> Rep (VChart tr slc h v) x
$cfrom :: forall tr slc h v x. VChart tr slc h v -> Rep (VChart tr slc h v) x
from :: forall x. VChart tr slc h v -> Rep (VChart tr slc h v) x
$cto :: forall tr slc h v x. Rep (VChart tr slc h v) x -> VChart tr slc h v
to :: forall x. Rep (VChart tr slc h v) x -> VChart tr slc h v
Generic, VChart tr slc h v -> ()
(VChart tr slc h v -> ()) -> NFData (VChart tr slc h v)
forall a. (a -> ()) -> NFData a
forall tr slc h v.
(NFData slc, NFData h, NFData v, NFData tr) =>
VChart tr slc h v -> ()
$crnf :: forall tr slc h v.
(NFData slc, NFData h, NFData v, NFData tr) =>
VChart tr slc h v -> ()
rnf :: VChart tr slc h v -> ()
NFData)

instance (Show tr, Show slc, Show h, Show v) => Show (VChart tr slc h v) where
  show :: VChart tr slc h v -> String
show (VChart Int
n HashMap (Int, Int) Int
_ IntMap [Vert tr slc h v]
is IntMap (Set (Slice slc, Slice slc, h))
_ HashMap (Int, Int) (Set (Slice slc, h))
_ HashMap (Int, Int) [Vert tr slc h v]
_) = String
"VChart (next id: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
levels
   where
    levels :: String
levels = ((Int, [Vert tr slc h v]) -> String)
-> [(Int, [Vert tr slc h v])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, [Vert tr slc h v]) -> String
forall {t :: * -> *} {a} {a}.
(Foldable t, Show a, Show a) =>
(a, t a) -> String
showLevel ([(Int, [Vert tr slc h v])] -> String)
-> [(Int, [Vert tr slc h v])] -> String
forall a b. (a -> b) -> a -> b
$ IntMap [Vert tr slc h v] -> [(Int, [Vert tr slc h v])]
forall a. IntMap a -> [(Int, a)]
IM.toAscList IntMap [Vert tr slc h v]
is
    showLevel :: (a, t a) -> String
showLevel (a
l, t a
items) = String
"\nlevel " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
l String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
sitems
     where
      sitems :: String
sitems = (a -> String) -> t a -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String
"\n  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) t a
items

-- | Returns an empty 'VChart' with the next free ID set to @n + 1@.
vcEmpty :: Int -> VChart tr slc h v
vcEmpty :: forall tr slc h v. Int -> VChart tr slc h v
vcEmpty Int
n = Int
-> HashMap (Int, Int) Int
-> IntMap [Vert tr slc h v]
-> IntMap (Set (Slice slc, Slice slc, h))
-> HashMap (Int, Int) (Set (Slice slc, h))
-> HashMap (Int, Int) [Vert tr slc h v]
-> VChart tr slc h v
forall tr slc h v.
Int
-> HashMap (Int, Int) Int
-> IntMap [Vert tr slc h v]
-> IntMap (Set (Slice slc, Slice slc, h))
-> HashMap (Int, Int) (Set (Slice slc, h))
-> HashMap (Int, Int) [Vert tr slc h v]
-> VChart tr slc h v
VChart (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) HashMap (Int, Int) Int
forall k v. HashMap k v
HM.empty IntMap [Vert tr slc h v]
forall a. IntMap a
IM.empty IntMap (Set (Slice slc, Slice slc, h))
forall a. IntMap a
IM.empty HashMap (Int, Int) (Set (Slice slc, h))
forall k v. HashMap k v
HM.empty HashMap (Int, Int) [Vert tr slc h v]
forall k v. HashMap k v
HM.empty

-- | Insert a new 'Vert' object into a 'VChart'.
vcInsert
  :: (Hashable slc, Ord slc, Ord h)
  => VChart tr slc h v
  -- ^ the old chart
  -> (slc, h, v, TItem tr slc v)
  -- ^ the new 'Vert' item's parent slice, operation, value, and middle child transition.
  -> VChart tr slc h v
  -- ^ the new chart
vcInsert :: forall slc h tr v.
(Hashable slc, Ord slc, Ord h) =>
VChart tr slc h v
-> (slc, h, v, TItem tr slc v) -> VChart tr slc h v
vcInsert (VChart Int
nextid HashMap (Int, Int) Int
ids IntMap [Vert tr slc h v]
bylen IntMap (Set (Slice slc, Slice slc, h))
bylenleft HashMap (Int, Int) (Set (Slice slc, h))
byleft HashMap (Int, Int) [Vert tr slc h v]
byright) (slc
topContent, h
op, v
val, mid :: TItem tr slc v
mid@(Transition tr slc
tmid := Score v Int
_)) =
  let left :: Slice slc
left = Transition tr slc -> Slice slc
forall tr slc. Transition tr slc -> Slice slc
tLeftSlice Transition tr slc
tmid
      right :: Slice slc
right = Transition tr slc -> Slice slc
forall tr slc. Transition tr slc -> Slice slc
tRightSlice Transition tr slc
tmid
      idKey :: (Int, Int)
idKey = (Slice slc -> Int
forall slc. Slice slc -> Int
sID Slice slc
left, Slice slc -> Int
forall slc. Slice slc -> Int
sID Slice slc
right)
      (Int
nextid', HashMap (Int, Int) Int
ids', Int
i) = case (Int, Int) -> HashMap (Int, Int) Int -> Maybe Int
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Int, Int)
idKey HashMap (Int, Int) Int
ids of
        Just Int
i' -> (Int
nextid, HashMap (Int, Int) Int
ids, Int
i')
        Maybe Int
Nothing -> (Int
nextid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, (Int, Int)
-> Int -> HashMap (Int, Int) Int -> HashMap (Int, Int) Int
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (Int, Int)
idKey Int
nextid HashMap (Int, Int) Int
ids, Int
nextid)
      top :: Slice slc
top = Int -> StartStop slc -> Int -> Int -> Slice slc
forall slc. Int -> StartStop slc -> Int -> Int -> Slice slc
Slice (Slice slc -> Int
forall slc. Slice slc -> Int
sFirst Slice slc
left) (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
topContent) Int
i (Slice slc -> Int
forall slc. Slice slc -> Int
sLast Slice slc
right)
      vert :: [Vert tr slc h v]
vert = [Slice slc -> h -> v -> TItem tr slc v -> Vert tr slc h v
forall tr slc h v.
Slice slc -> h -> v -> TItem tr slc v -> Vert tr slc h v
Vert Slice slc
top h
op v
val TItem tr slc v
mid]
      vert' :: Set (Slice slc, Slice slc, h)
vert' = (Slice slc, Slice slc, h) -> Set (Slice slc, Slice slc, h)
forall a. a -> Set a
Set.singleton (Slice slc
top, Transition tr slc -> Slice slc
forall tr slc. Transition tr slc -> Slice slc
tLeftSlice Transition tr slc
tmid, h
op)
      vertl :: Set (Slice slc, h)
vertl = (Slice slc, h) -> Set (Slice slc, h)
forall a. a -> Set a
Set.singleton (Slice slc
top, h
op)
      bylen' :: IntMap [Vert tr slc h v]
bylen' = ([Vert tr slc h v] -> [Vert tr slc h v] -> [Vert tr slc h v])
-> Int
-> [Vert tr slc h v]
-> IntMap [Vert tr slc h v]
-> IntMap [Vert tr slc h v]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith [Vert tr slc h v] -> [Vert tr slc h v] -> [Vert tr slc h v]
forall a. Semigroup a => a -> a -> a
(<>) (Transition tr slc -> Int
forall e a. Transition e a -> Int
transLen Transition tr slc
tmid) [Vert tr slc h v]
vert IntMap [Vert tr slc h v]
bylen
      bylenleft' :: IntMap (Set (Slice slc, Slice slc, h))
bylenleft' = (Set (Slice slc, Slice slc, h)
 -> Set (Slice slc, Slice slc, h) -> Set (Slice slc, Slice slc, h))
-> Int
-> Set (Slice slc, Slice slc, h)
-> IntMap (Set (Slice slc, Slice slc, h))
-> IntMap (Set (Slice slc, Slice slc, h))
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith Set (Slice slc, Slice slc, h)
-> Set (Slice slc, Slice slc, h) -> Set (Slice slc, Slice slc, h)
forall a. Semigroup a => a -> a -> a
(<>) (Transition tr slc -> Int
forall e a. Transition e a -> Int
transLen Transition tr slc
tmid) Set (Slice slc, Slice slc, h)
vert' IntMap (Set (Slice slc, Slice slc, h))
bylenleft
      byleft' :: HashMap (Int, Int) (Set (Slice slc, h))
byleft' = (Set (Slice slc, h) -> Set (Slice slc, h) -> Set (Slice slc, h))
-> (Int, Int)
-> Set (Slice slc, h)
-> HashMap (Int, Int) (Set (Slice slc, h))
-> HashMap (Int, Int) (Set (Slice slc, h))
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith Set (Slice slc, h) -> Set (Slice slc, h) -> Set (Slice slc, h)
forall a. Semigroup a => a -> a -> a
(<>) (Slice slc -> Int
forall slc. Slice slc -> Int
sID Slice slc
left, Transition tr slc -> Int
forall e a. Transition e a -> Int
transLen Transition tr slc
tmid) Set (Slice slc, h)
vertl HashMap (Int, Int) (Set (Slice slc, h))
byleft
      byright' :: HashMap (Int, Int) [Vert tr slc h v]
byright' = ([Vert tr slc h v] -> [Vert tr slc h v] -> [Vert tr slc h v])
-> (Int, Int)
-> [Vert tr slc h v]
-> HashMap (Int, Int) [Vert tr slc h v]
-> HashMap (Int, Int) [Vert tr slc h v]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith [Vert tr slc h v] -> [Vert tr slc h v] -> [Vert tr slc h v]
forall a. Semigroup a => a -> a -> a
(<>) (Slice slc -> Int
forall slc. Slice slc -> Int
sID Slice slc
right, Transition tr slc -> Int
forall e a. Transition e a -> Int
transLen Transition tr slc
tmid) [Vert tr slc h v]
vert HashMap (Int, Int) [Vert tr slc h v]
byright
   in Int
-> HashMap (Int, Int) Int
-> IntMap [Vert tr slc h v]
-> IntMap (Set (Slice slc, Slice slc, h))
-> HashMap (Int, Int) (Set (Slice slc, h))
-> HashMap (Int, Int) [Vert tr slc h v]
-> VChart tr slc h v
forall tr slc h v.
Int
-> HashMap (Int, Int) Int
-> IntMap [Vert tr slc h v]
-> IntMap (Set (Slice slc, Slice slc, h))
-> HashMap (Int, Int) (Set (Slice slc, h))
-> HashMap (Int, Int) [Vert tr slc h v]
-> VChart tr slc h v
VChart Int
nextid' HashMap (Int, Int) Int
ids' IntMap [Vert tr slc h v]
bylen' IntMap (Set (Slice slc, Slice slc, h))
bylenleft' HashMap (Int, Int) (Set (Slice slc, h))
byleft' HashMap (Int, Int) [Vert tr slc h v]
byright'

-- | Merge a sequence of new items into a 'VChart'
vcMerge
  :: (Foldable t, Ord slc, Hashable slc, Ord h)
  => VChart tr slc h v
  -> t (slc, h, v, TItem tr slc v)
  -> VChart tr slc h v
vcMerge :: forall (t :: * -> *) slc h tr v.
(Foldable t, Ord slc, Hashable slc, Ord h) =>
VChart tr slc h v
-> t (slc, h, v, TItem tr slc v) -> VChart tr slc h v
vcMerge = (VChart tr slc h v
 -> (slc, h, v, TItem tr slc v) -> VChart tr slc h v)
-> VChart tr slc h v
-> t (slc, h, v, TItem tr slc v)
-> VChart tr slc h v
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VChart tr slc h v
-> (slc, h, v, TItem tr slc v) -> VChart tr slc h v
forall slc h tr v.
(Hashable slc, Ord slc, Ord h) =>
VChart tr slc h v
-> (slc, h, v, TItem tr slc v) -> VChart tr slc h v
vcInsert

-- | Returns all 'Vert' objects in the 'VChart' with the same length.
vcGetByLength
  :: VChart tr slc h v
  -- ^ the chart
  -> Int
  -- ^ surface length of a middle transition
  -> [Vert tr slc h v]
  -- ^ all corresponding 'Vert' objects
vcGetByLength :: forall tr slc h v. VChart tr slc h v -> Int -> [Vert tr slc h v]
vcGetByLength VChart tr slc h v
chart Int
len = [Vert tr slc h v] -> Maybe [Vert tr slc h v] -> [Vert tr slc h v]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Vert tr slc h v] -> [Vert tr slc h v])
-> Maybe [Vert tr slc h v] -> [Vert tr slc h v]
forall a b. (a -> b) -> a -> b
$ Int -> IntMap [Vert tr slc h v] -> Maybe [Vert tr slc h v]
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
len (IntMap [Vert tr slc h v] -> Maybe [Vert tr slc h v])
-> IntMap [Vert tr slc h v] -> Maybe [Vert tr slc h v]
forall a b. (a -> b) -> a -> b
$ VChart tr slc h v -> IntMap [Vert tr slc h v]
forall tr slc h v. VChart tr slc h v -> IntMap [Vert tr slc h v]
vcByLength VChart tr slc h v
chart

-- | Returns the "left borders" of all 'Vert' objects in the 'VChart' with the same length.
vcGetByLengthLeft
  :: VChart tr slc h v
  -- ^ the chart
  -> Int
  -- ^ the surface length of a middle transition
  -> [(Slice slc, Slice slc, h)]
  -- ^ (parent slice, left slice, op) of all corresponding 'Vert' objects (without duplicates)
vcGetByLengthLeft :: forall tr slc h v.
VChart tr slc h v -> Int -> [(Slice slc, Slice slc, h)]
vcGetByLengthLeft VChart tr slc h v
chart Int
len =
  [(Slice slc, Slice slc, h)]
-> (Set (Slice slc, Slice slc, h) -> [(Slice slc, Slice slc, h)])
-> Maybe (Set (Slice slc, Slice slc, h))
-> [(Slice slc, Slice slc, h)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Set (Slice slc, Slice slc, h) -> [(Slice slc, Slice slc, h)]
forall a. Set a -> [a]
Set.toList (Maybe (Set (Slice slc, Slice slc, h))
 -> [(Slice slc, Slice slc, h)])
-> Maybe (Set (Slice slc, Slice slc, h))
-> [(Slice slc, Slice slc, h)]
forall a b. (a -> b) -> a -> b
$ Int
-> IntMap (Set (Slice slc, Slice slc, h))
-> Maybe (Set (Slice slc, Slice slc, h))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
len (VChart tr slc h v -> IntMap (Set (Slice slc, Slice slc, h))
forall tr slc h v.
VChart tr slc h v -> IntMap (Set (Slice slc, Slice slc, h))
vcByLengthLeft VChart tr slc h v
chart)

{- | Returns the all potential parents of a left child slice
 up to a certain middle transition length.
-}
vcGetByLeftChild
  :: (Ord slc, Hashable slc, Ord h)
  => Int
  -- ^ maximum middle transition length
  -> VChart tr slc h v
  -- ^ the chart
  -> Slice slc
  -- ^ the left child slice
  -> [(Slice slc, h)]
  -- ^ all potential parent slices
vcGetByLeftChild :: forall slc h tr v.
(Ord slc, Hashable slc, Ord h) =>
Int -> VChart tr slc h v -> Slice slc -> [(Slice slc, h)]
vcGetByLeftChild Int
maxn VChart tr slc h v
chart Slice slc
left =
  Set (Slice slc, h) -> [(Slice slc, h)]
forall a. Set a -> [a]
Set.toList (Set (Slice slc, h) -> [(Slice slc, h)])
-> Set (Slice slc, h) -> [(Slice slc, h)]
forall a b. (a -> b) -> a -> b
$ [Set (Slice slc, h)] -> Set (Slice slc, h)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set (Slice slc, h)] -> Set (Slice slc, h))
-> [Set (Slice slc, h)] -> Set (Slice slc, h)
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe (Set (Slice slc, h)))
-> [Int] -> [Set (Slice slc, h)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Int -> Maybe (Set (Slice slc, h))
getN [Int
2 .. Int
maxn]
 where
  getN :: Int -> Maybe (Set (Slice slc, h))
getN Int
n = (Int, Int)
-> HashMap (Int, Int) (Set (Slice slc, h))
-> Maybe (Set (Slice slc, h))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Slice slc -> Int
forall slc. Slice slc -> Int
sID Slice slc
left, Int
n) (HashMap (Int, Int) (Set (Slice slc, h))
 -> Maybe (Set (Slice slc, h)))
-> HashMap (Int, Int) (Set (Slice slc, h))
-> Maybe (Set (Slice slc, h))
forall a b. (a -> b) -> a -> b
$ VChart tr slc h v -> HashMap (Int, Int) (Set (Slice slc, h))
forall tr slc h v.
VChart tr slc h v -> HashMap (Int, Int) (Set (Slice slc, h))
vcByLeftChild VChart tr slc h v
chart

{- | Returns all 'Vert' objects with the same right child
 up to a certain middle transition length.
-}
vcGetByRightChild
  :: (Ord slc, Hashable slc)
  => Int
  -- ^ ID of the right child
  -> VChart tr slc h v
  -> Slice slc
  -> [Vert tr slc h v]
vcGetByRightChild :: forall slc tr h v.
(Ord slc, Hashable slc) =>
Int -> VChart tr slc h v -> Slice slc -> [Vert tr slc h v]
vcGetByRightChild Int
maxn VChart tr slc h v
chart Slice slc
right =
  [[Vert tr slc h v]] -> [Vert tr slc h v]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Vert tr slc h v]] -> [Vert tr slc h v])
-> [[Vert tr slc h v]] -> [Vert tr slc h v]
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe [Vert tr slc h v]) -> [Int] -> [[Vert tr slc h v]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Int -> Maybe [Vert tr slc h v]
getN [Int
2 .. Int
maxn]
 where
  getN :: Int -> Maybe [Vert tr slc h v]
getN Int
n = (Int, Int)
-> HashMap (Int, Int) [Vert tr slc h v] -> Maybe [Vert tr slc h v]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Slice slc -> Int
forall slc. Slice slc -> Int
sID Slice slc
right, Int
n) (HashMap (Int, Int) [Vert tr slc h v] -> Maybe [Vert tr slc h v])
-> HashMap (Int, Int) [Vert tr slc h v] -> Maybe [Vert tr slc h v]
forall a b. (a -> b) -> a -> b
$ VChart tr slc h v -> HashMap (Int, Int) [Vert tr slc h v]
forall tr slc h v.
VChart tr slc h v -> HashMap (Int, Int) [Vert tr slc h v]
vcByRightChild VChart tr slc h v
chart

-- transition chart
-------------------

-- ops:
-- - get all of length n
-- - get all with left slice l
-- - get all with right slice r

{- | The contents of a transition chart (under a particular index).
 A mapping from transitions (with score ID constraints left and right)
 to (partial) semiring scores.
 This mapping usually contains all transition items that satisfy a certain criterion,
 irrespective of their position in the chart (which is encoded in the transitions themselves).

 When new transition items are added, if the transition already exists in the chart
 (as the result of a different partial parse),
 the scores of the new and existing items are "added" (this also requires the score IDs to match).
-}
type TContents tr slc v =
  HM.HashMap
    (Transition tr slc, Maybe (S.LeftId Int), Maybe (S.RightId Int))
    (S.Score v Int)

{- | A transition chart.
 Stores intermediate transition items redundantly under several indices:

 - by surface length
 - by left slice
 - by right slice
-}
data TChart tr slc v = TChart
  { forall tr slc v. TChart tr slc v -> IntMap (TContents tr slc v)
tcByLength :: !(IM.IntMap (TContents tr slc v))
  , forall tr slc v.
TChart tr slc v -> HashMap (Slice slc) (TContents tr slc v)
tcByLeft :: !(HM.HashMap (Slice slc) (TContents tr slc v))
  , forall tr slc v.
TChart tr slc v -> HashMap (Slice slc) (TContents tr slc v)
tcByRight :: !(HM.HashMap (Slice slc) (TContents tr slc v))
  }
  deriving (Int -> TChart tr slc v -> ShowS
[TChart tr slc v] -> ShowS
TChart tr slc v -> String
(Int -> TChart tr slc v -> ShowS)
-> (TChart tr slc v -> String)
-> ([TChart tr slc v] -> ShowS)
-> Show (TChart tr slc v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall tr slc v.
(Show slc, Show tr) =>
Int -> TChart tr slc v -> ShowS
forall tr slc v. (Show slc, Show tr) => [TChart tr slc v] -> ShowS
forall tr slc v. (Show slc, Show tr) => TChart tr slc v -> String
$cshowsPrec :: forall tr slc v.
(Show slc, Show tr) =>
Int -> TChart tr slc v -> ShowS
showsPrec :: Int -> TChart tr slc v -> ShowS
$cshow :: forall tr slc v. (Show slc, Show tr) => TChart tr slc v -> String
show :: TChart tr slc v -> String
$cshowList :: forall tr slc v. (Show slc, Show tr) => [TChart tr slc v] -> ShowS
showList :: [TChart tr slc v] -> ShowS
Show, (forall x. TChart tr slc v -> Rep (TChart tr slc v) x)
-> (forall x. Rep (TChart tr slc v) x -> TChart tr slc v)
-> Generic (TChart tr slc v)
forall x. Rep (TChart tr slc v) x -> TChart tr slc v
forall x. TChart tr slc v -> Rep (TChart tr slc v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tr slc v x. Rep (TChart tr slc v) x -> TChart tr slc v
forall tr slc v x. TChart tr slc v -> Rep (TChart tr slc v) x
$cfrom :: forall tr slc v x. TChart tr slc v -> Rep (TChart tr slc v) x
from :: forall x. TChart tr slc v -> Rep (TChart tr slc v) x
$cto :: forall tr slc v x. Rep (TChart tr slc v) x -> TChart tr slc v
to :: forall x. Rep (TChart tr slc v) x -> TChart tr slc v
Generic, TChart tr slc v -> ()
(TChart tr slc v -> ()) -> NFData (TChart tr slc v)
forall a. (a -> ()) -> NFData a
forall tr slc v.
(NFData slc, NFData tr, NFData v) =>
TChart tr slc v -> ()
$crnf :: forall tr slc v.
(NFData slc, NFData tr, NFData v) =>
TChart tr slc v -> ()
rnf :: TChart tr slc v -> ()
NFData)

-- | Returns an empty transition chart.
tcEmpty :: TChart tr slc v
tcEmpty :: forall tr slc v. TChart tr slc v
tcEmpty = IntMap (TContents tr slc v)
-> HashMap (Slice slc) (TContents tr slc v)
-> HashMap (Slice slc) (TContents tr slc v)
-> TChart tr slc v
forall tr slc v.
IntMap (TContents tr slc v)
-> HashMap (Slice slc) (TContents tr slc v)
-> HashMap (Slice slc) (TContents tr slc v)
-> TChart tr slc v
TChart IntMap (TContents tr slc v)
forall a. IntMap a
IM.empty HashMap (Slice slc) (TContents tr slc v)
forall k v. HashMap k v
HM.empty HashMap (Slice slc) (TContents tr slc v)
forall k v. HashMap k v
HM.empty

-- TODO: there might be room for improvement here

{- | Insert a new transition item into the transition chart.
 If the item's transition already exists, the existing and new score are "added".
-}
tcInsert :: (Parsable' tr slc v) => TChart tr slc v -> TItem tr slc v -> TChart tr slc v
tcInsert :: forall tr slc v.
Parsable' tr slc v =>
TChart tr slc v -> TItem tr slc v -> TChart tr slc v
tcInsert (TChart IntMap (TContents tr slc v)
len HashMap (Slice slc) (TContents tr slc v)
left HashMap (Slice slc) (TContents tr slc v)
right) (Transition tr slc
t := Score v Int
v) =
  let new :: TContents tr slc v
new = (Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int))
-> Score v Int -> TContents tr slc v
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton (Transition tr slc
t, Score v Int -> Maybe (LeftId Int)
forall s i. Score s i -> Maybe (LeftId i)
S.leftSide Score v Int
v, Score v Int -> Maybe (RightId Int)
forall s i. Score s i -> Maybe (RightId i)
S.rightSide Score v Int
v) Score v Int
v
      len' :: IntMap (TContents tr slc v)
len' = (TContents tr slc v -> TContents tr slc v -> TContents tr slc v)
-> Int
-> TContents tr slc v
-> IntMap (TContents tr slc v)
-> IntMap (TContents tr slc v)
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith TContents tr slc v -> TContents tr slc v -> TContents tr slc v
insert (Transition tr slc -> Int
forall e a. Transition e a -> Int
transLen Transition tr slc
t) TContents tr slc v
new IntMap (TContents tr slc v)
len
      left' :: HashMap (Slice slc) (TContents tr slc v)
left' = (TContents tr slc v -> TContents tr slc v -> TContents tr slc v)
-> Slice slc
-> TContents tr slc v
-> HashMap (Slice slc) (TContents tr slc v)
-> HashMap (Slice slc) (TContents tr slc v)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith TContents tr slc v -> TContents tr slc v -> TContents tr slc v
insert (Transition tr slc -> Slice slc
forall tr slc. Transition tr slc -> Slice slc
tLeftSlice Transition tr slc
t) TContents tr slc v
new HashMap (Slice slc) (TContents tr slc v)
left
      right' :: HashMap (Slice slc) (TContents tr slc v)
right' = (TContents tr slc v -> TContents tr slc v -> TContents tr slc v)
-> Slice slc
-> TContents tr slc v
-> HashMap (Slice slc) (TContents tr slc v)
-> HashMap (Slice slc) (TContents tr slc v)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith TContents tr slc v -> TContents tr slc v -> TContents tr slc v
insert (Transition tr slc -> Slice slc
forall tr slc. Transition tr slc -> Slice slc
tRightSlice Transition tr slc
t) TContents tr slc v
new HashMap (Slice slc) (TContents tr slc v)
right
   in IntMap (TContents tr slc v)
-> HashMap (Slice slc) (TContents tr slc v)
-> HashMap (Slice slc) (TContents tr slc v)
-> TChart tr slc v
forall tr slc v.
IntMap (TContents tr slc v)
-> HashMap (Slice slc) (TContents tr slc v)
-> HashMap (Slice slc) (TContents tr slc v)
-> TChart tr slc v
TChart IntMap (TContents tr slc v)
len' HashMap (Slice slc) (TContents tr slc v)
left' HashMap (Slice slc) (TContents tr slc v)
right'
 where
  insert :: TContents tr slc v -> TContents tr slc v -> TContents tr slc v
insert = ((Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int))
 -> Score v Int -> Score v Int -> Score v Int)
-> TContents tr slc v -> TContents tr slc v -> TContents tr slc v
forall k v.
Eq k =>
(k -> v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWithKey (\(Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int))
_ Score v Int
s1 Score v Int
s2 -> Score v Int -> Score v Int -> Score v Int
forall s i.
(Semiring s, Eq i) =>
Score s i -> Score s i -> Score s i
S.addScores Score v Int
s1 Score v Int
s2)

-- | Insert several transition items into the transition chart.
tcMerge
  :: (Foldable t, Parsable' tr slc v)
  => TChart tr slc v
  -> t (TItem tr slc v)
  -> TChart tr slc v
tcMerge :: forall (t :: * -> *) tr slc v.
(Foldable t, Parsable' tr slc v) =>
TChart tr slc v -> t (TItem tr slc v) -> TChart tr slc v
tcMerge = (TChart tr slc v -> TItem tr slc v -> TChart tr slc v)
-> TChart tr slc v -> t (TItem tr slc v) -> TChart tr slc v
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TChart tr slc v -> TItem tr slc v -> TChart tr slc v
forall tr slc v.
Parsable' tr slc v =>
TChart tr slc v -> TItem tr slc v -> TChart tr slc v
tcInsert

-- | Helper function for getting transition items from the transition chart.
tcGetAny
  :: (TChart tr slc v -> m)
  -> (TContents tr slc v -> k -> m -> TContents tr slc v)
  -> TChart tr slc v
  -> k
  -> [TItem tr slc v]
tcGetAny :: forall tr slc v m k.
(TChart tr slc v -> m)
-> (TContents tr slc v -> k -> m -> TContents tr slc v)
-> TChart tr slc v
-> k
-> [TItem tr slc v]
tcGetAny TChart tr slc v -> m
field TContents tr slc v -> k -> m -> TContents tr slc v
getter TChart tr slc v
chart k
key =
  (((Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int)),
  Score v Int)
 -> TItem tr slc v)
-> [((Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int)),
     Score v Int)]
-> [TItem tr slc v]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int)),
 Score v Int)
-> TItem tr slc v
forall {i} {b} {c} {v}. ((i, b, c), Score v Int) -> Item i v
mkItem ([((Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int)),
   Score v Int)]
 -> [TItem tr slc v])
-> [((Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int)),
     Score v Int)]
-> [TItem tr slc v]
forall a b. (a -> b) -> a -> b
$ TContents tr slc v
-> [((Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int)),
     Score v Int)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (TContents tr slc v
 -> [((Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int)),
      Score v Int)])
-> TContents tr slc v
-> [((Transition tr slc, Maybe (LeftId Int), Maybe (RightId Int)),
     Score v Int)]
forall a b. (a -> b) -> a -> b
$ TContents tr slc v -> k -> m -> TContents tr slc v
getter TContents tr slc v
forall k v. HashMap k v
HM.empty k
key (m -> TContents tr slc v) -> m -> TContents tr slc v
forall a b. (a -> b) -> a -> b
$ TChart tr slc v -> m
field TChart tr slc v
chart
 where
  mkItem :: ((i, b, c), Score v Int) -> Item i v
mkItem ((i
t, b
_, c
_), Score v Int
v) = i
t i -> Score v Int -> Item i v
forall i v. i -> Score v Int -> Item i v
:= Score v Int
v

-- | Returns all transition items with the same length.
tcGetByLength :: TChart tr slc v -> Int -> [TItem tr slc v]
tcGetByLength :: forall tr slc v. TChart tr slc v -> Int -> [TItem tr slc v]
tcGetByLength = (TChart tr slc v -> IntMap (TContents tr slc v))
-> (TContents tr slc v
    -> Int -> IntMap (TContents tr slc v) -> TContents tr slc v)
-> TChart tr slc v
-> Int
-> [TItem tr slc v]
forall tr slc v m k.
(TChart tr slc v -> m)
-> (TContents tr slc v -> k -> m -> TContents tr slc v)
-> TChart tr slc v
-> k
-> [TItem tr slc v]
tcGetAny TChart tr slc v -> IntMap (TContents tr slc v)
forall tr slc v. TChart tr slc v -> IntMap (TContents tr slc v)
tcByLength TContents tr slc v
-> Int -> IntMap (TContents tr slc v) -> TContents tr slc v
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault

-- | Returns all transition items with the same left slice.
tcGetByLeft :: (Ord slc, Hashable slc) => TChart tr slc v -> Slice slc -> [TItem tr slc v]
tcGetByLeft :: forall slc tr v.
(Ord slc, Hashable slc) =>
TChart tr slc v -> Slice slc -> [TItem tr slc v]
tcGetByLeft = (TChart tr slc v -> HashMap (Slice slc) (TContents tr slc v))
-> (TContents tr slc v
    -> Slice slc
    -> HashMap (Slice slc) (TContents tr slc v)
    -> TContents tr slc v)
-> TChart tr slc v
-> Slice slc
-> [TItem tr slc v]
forall tr slc v m k.
(TChart tr slc v -> m)
-> (TContents tr slc v -> k -> m -> TContents tr slc v)
-> TChart tr slc v
-> k
-> [TItem tr slc v]
tcGetAny TChart tr slc v -> HashMap (Slice slc) (TContents tr slc v)
forall tr slc v.
TChart tr slc v -> HashMap (Slice slc) (TContents tr slc v)
tcByLeft TContents tr slc v
-> Slice slc
-> HashMap (Slice slc) (TContents tr slc v)
-> TContents tr slc v
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HM.findWithDefault

-- | Returns all transition items with the same right slice.
tcGetByRight :: (Ord slc, Hashable slc) => TChart tr slc v -> Slice slc -> [TItem tr slc v]
tcGetByRight :: forall slc tr v.
(Ord slc, Hashable slc) =>
TChart tr slc v -> Slice slc -> [TItem tr slc v]
tcGetByRight = (TChart tr slc v -> HashMap (Slice slc) (TContents tr slc v))
-> (TContents tr slc v
    -> Slice slc
    -> HashMap (Slice slc) (TContents tr slc v)
    -> TContents tr slc v)
-> TChart tr slc v
-> Slice slc
-> [TItem tr slc v]
forall tr slc v m k.
(TChart tr slc v -> m)
-> (TContents tr slc v -> k -> m -> TContents tr slc v)
-> TChart tr slc v
-> k
-> [TItem tr slc v]
tcGetAny TChart tr slc v -> HashMap (Slice slc) (TContents tr slc v)
forall tr slc v.
TChart tr slc v -> HashMap (Slice slc) (TContents tr slc v)
tcByRight TContents tr slc v
-> Slice slc
-> HashMap (Slice slc) (TContents tr slc v)
-> TContents tr slc v
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HM.findWithDefault

-- parsing machinery
-- =================

-- applying evaluators
----------------------
-- TODO: add checks that adjacent transitions and slices match?

-- | Unspreads the two slices of a (middle) transition, if possible.
unspreadMiddle
  :: UnspreadMiddle tr slc h v
  -- ^ the UnspreadMiddle evaluator
  -> TItem tr slc v
  -- ^ the middle transition
  -> [(slc, h, v, TItem tr slc v)]
  -- ^ the top slice, unspread operation,
  -- and middle transition
unspreadMiddle :: forall tr slc h v.
UnspreadMiddle tr slc h v
-> TItem tr slc v -> [(slc, h, v, TItem tr slc v)]
unspreadMiddle UnspreadMiddle tr slc h v
unspreadm im :: TItem tr slc v
im@((Transition Slice slc
l tr
m Slice slc
r Bool
_) := Score v Int
_) = do
  il <- Maybe slc -> [slc]
forall a. Maybe a -> [a]
maybeToList (Maybe slc -> [slc]) -> Maybe slc -> [slc]
forall a b. (a -> b) -> a -> b
$ StartStop slc -> Maybe slc
forall a. StartStop a -> Maybe a
getInner (StartStop slc -> Maybe slc) -> StartStop slc -> Maybe slc
forall a b. (a -> b) -> a -> b
$ Slice slc -> StartStop slc
forall slc. Slice slc -> StartStop slc
sContent Slice slc
l
  ir <- maybeToList $ getInner $ sContent r
  (top, op, val) <- unspreadm (il, m, ir)
  pure (top, op, val, im)

-- | Infers the possible left parent transitions of an unspread.
unspreadLeft
  :: (Show slc, Show tr, R.Semiring v, Show v)
  => UnspreadLeft tr slc h
  -- ^ the UnspreadLeft evaluator
  -> TItem tr slc v
  -- ^ the left child transition
  -> Slice slc
  -- ^ the Vert's top slice and ID
  -> h
  -- ^ the Vert's operation
  -> [TItem tr slc v]
  -- ^ all possible left parent transitions
unspreadLeft :: forall slc tr v h.
(Show slc, Show tr, Semiring v, Show v) =>
UnspreadLeft tr slc h
-> TItem tr slc v -> Slice slc -> h -> [TItem tr slc v]
unspreadLeft UnspreadLeft tr slc h
unspreadl (tleft :: Transition tr slc
tleft@(Transition Slice slc
ll tr
lt Slice slc
lr Bool
is2nd) := Score v Int
vleft) Slice slc
top h
op
  | Bool
is2nd = []
  | Bool
otherwise = [Item (Transition tr slc) v]
-> Maybe [Item (Transition tr slc) v]
-> [Item (Transition tr slc) v]
forall a. a -> Maybe a -> a
fromMaybe [Item (Transition tr slc) v]
forall {a}. a
err (Maybe [Item (Transition tr slc) v]
 -> [Item (Transition tr slc) v])
-> Maybe [Item (Transition tr slc) v]
-> [Item (Transition tr slc) v]
forall a b. (a -> b) -> a -> b
$ do
      ir <- StartStop slc -> Maybe slc
forall a. StartStop a -> Maybe a
getInner (StartStop slc -> Maybe slc) -> StartStop slc -> Maybe slc
forall a b. (a -> b) -> a -> b
$ Slice slc -> StartStop slc
forall slc. Slice slc -> StartStop slc
sContent Slice slc
lr
      itop <- getInner $ sContent top
      pure $ mkParent v' <$> unspreadl (lt, ir) itop op
 where
  err :: a
err =
    String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
      String
"Illegal left-unspread: left="
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Transition tr slc -> String
forall a. Show a => a -> String
show Transition tr slc
tleft
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", top="
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Slice slc -> String
forall a. Show a => a -> String
show Slice slc
top
  v' :: Score v Int
v' = Int -> Score v Int -> Score v Int
forall s i.
(Eq i, Show i, Semiring s, Show s) =>
i -> Score s i -> Score s i
S.unspreadScoresLeft (Slice slc -> Int
forall slc. Slice slc -> Int
sID Slice slc
top) Score v Int
vleft
  mkParent :: Score v Int -> tr -> Item (Transition tr slc) v
mkParent Score v Int
v tr
t = Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
forall tr slc.
Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
Transition Slice slc
ll tr
t Slice slc
top Bool
False Transition tr slc -> Score v Int -> Item (Transition tr slc) v
forall i v. i -> Score v Int -> Item i v
:= Score v Int
v

-- | Infers the possible right parent transitions of an unspread.
unspreadRight
  :: (R.Semiring v, NFData slc, NFData tr, NFData v, Show tr, Show slc, Show v, Show h)
  => UnspreadRight tr slc h
  -- ^ the UnspreadRight evaluator
  -> Vert tr slc h v
  -- ^ the center 'Vert'
  -> TItem tr slc v
  -- ^ the right child transition
  -> [TItem tr slc v]
  -- ^ all possible right parent transitions
unspreadRight :: forall v slc tr h.
(Semiring v, NFData slc, NFData tr, NFData v, Show tr, Show slc,
 Show v, Show h) =>
UnspreadRight tr slc h
-> Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v]
unspreadRight UnspreadRight tr slc h
unspreadr vert :: Vert tr slc h v
vert@(Vert Slice slc
top h
op v
val (Transition tr slc
_ := Score v Int
vm)) tright :: TItem tr slc v
tright@((Transition Slice slc
rl tr
rt Slice slc
rr Bool
_) := Score v Int
vr) =
  [TItem tr slc v] -> Maybe [TItem tr slc v] -> [TItem tr slc v]
forall a. a -> Maybe a -> a
fromMaybe [TItem tr slc v]
forall {a}. a
err (Maybe [TItem tr slc v] -> [TItem tr slc v])
-> Maybe [TItem tr slc v] -> [TItem tr slc v]
forall a b. (a -> b) -> a -> b
$ do
    ir <- StartStop slc -> Maybe slc
forall a. StartStop a -> Maybe a
getInner (StartStop slc -> Maybe slc) -> StartStop slc -> Maybe slc
forall a b. (a -> b) -> a -> b
$ Slice slc -> StartStop slc
forall slc. Slice slc -> StartStop slc
sContent Slice slc
rl
    pure $ force $ mkParent v' <$> unspreadr (ir, rt) ir op
 where
  err :: a
err =
    String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
      String
"Illegal right-unspread: vert="
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Vert tr slc h v -> String
forall a. Show a => a -> String
show Vert tr slc h v
vert
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", right="
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TItem tr slc v -> String
forall a. Show a => a -> String
show TItem tr slc v
tright
  v' :: Score v Int
v' = Int -> v -> Score v Int -> Score v Int -> Score v Int
forall i s.
(Eq i, Semiring s, Show i, Show s) =>
i -> s -> Score s i -> Score s i -> Score s i
S.unspreadScoresRight (Slice slc -> Int
forall slc. Slice slc -> Int
sID Slice slc
top) v
val Score v Int
vm Score v Int
vr
  mkParent :: Score v Int -> tr -> Item (Transition tr slc) v
mkParent Score v Int
v tr
t = Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
forall tr slc.
Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
Transition Slice slc
top tr
t Slice slc
rr Bool
True Transition tr slc -> Score v Int -> Item (Transition tr slc) v
forall i v. i -> Score v Int -> Item i v
:= Score v Int
v

-- | Infers the possible parent transitions of a split.
unsplit
  :: (R.Semiring v, NFData slc, NFData tr, NFData v, Show v)
  => Unsplit tr slc v
  -- ^ the Unsplit evaluator
  -> TItem tr slc v
  -- ^ the left child transition
  -> TItem tr slc v
  -- ^ the right child transition
  -> [TItem tr slc v]
  -- ^ all possible parent transitions
unsplit :: forall v slc tr.
(Semiring v, NFData slc, NFData tr, NFData v, Show v) =>
Unsplit tr slc v
-> TItem tr slc v -> TItem tr slc v -> [TItem tr slc v]
unsplit Unsplit tr slc v
mg ((Transition Slice slc
ll tr
lt Slice slc
lr Bool
l2nd) := Score v Int
vl) ((Transition Slice slc
_ !tr
rt !Slice slc
rr Bool
_) := Score v Int
vr) =
  case StartStop slc -> Maybe slc
forall a. StartStop a -> Maybe a
getInner (StartStop slc -> Maybe slc) -> StartStop slc -> Maybe slc
forall a b. (a -> b) -> a -> b
$ Slice slc -> StartStop slc
forall slc. Slice slc -> StartStop slc
sContent Slice slc
lr of
    Just slc
m ->
      [TItem tr slc v] -> [TItem tr slc v]
forall a. NFData a => a -> a
force ([TItem tr slc v] -> [TItem tr slc v])
-> [TItem tr slc v] -> [TItem tr slc v]
forall a b. (a -> b) -> a -> b
$ (tr, v) -> TItem tr slc v
forall {tr}. (tr, v) -> Item (Transition tr slc) v
mkItem ((tr, v) -> TItem tr slc v) -> [(tr, v)] -> [TItem tr slc v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unsplit tr slc v
mg (Slice slc -> StartStop slc
forall slc. Slice slc -> StartStop slc
sContent Slice slc
ll) tr
lt slc
m tr
rt (Slice slc -> StartStop slc
forall slc. Slice slc -> StartStop slc
sContent Slice slc
rr) SplitType
splitType
    Maybe slc
Nothing -> String -> [TItem tr slc v]
forall a. HasCallStack => String -> a
error String
"trying to unsplit at a non-content slice"
 where
  splitType :: SplitType
splitType
    | Bool
l2nd = SplitType
RightOfTwo
    | StartStop slc -> Bool
forall a. StartStop a -> Bool
isStop (Slice slc -> StartStop slc
forall slc. Slice slc -> StartStop slc
sContent Slice slc
rr) = SplitType
SingleOfOne
    | Bool
otherwise = SplitType
LeftOfTwo
  mkItem :: (tr, v) -> Item (Transition tr slc) v
mkItem (!tr
top, !v
op) = Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
forall tr slc.
Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
Transition Slice slc
ll tr
top Slice slc
rr Bool
l2nd Transition tr slc -> Score v Int -> Item (Transition tr slc) v
forall i v. i -> Score v Int -> Item i v
:= v -> Score v Int -> Score v Int -> Score v Int
forall s i.
(Semiring s, Eq i, Show i, Show s) =>
s -> Score s i -> Score s i -> Score s i
S.unsplitScores v
op Score v Int
vl Score v Int
vr

-- the parsing main loop
------------------------

-- | parallelized map
pmap :: (NFData b) => (a -> b) -> [a] -> [b]
pmap :: forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap a -> b
f = Strategy [b] -> [b] -> [b]
forall a. Strategy a -> a -> a
P.withStrategy (Strategy b -> Strategy [b]
forall a. Strategy a -> Strategy [a]
P.parList Strategy b
forall a. NFData a => Strategy a
P.rdeepseq) ([b] -> [b]) -> ([a] -> [b]) -> [a] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f

-- pmap = map

{- | A type alias for  pair of transition chart ('TChart')
 and verticalization chart ('VChart').
-}
type ParseState tr slc h v = (TChart tr slc v, VChart tr slc h v)

{- | Type alias for a monadic parsing operation.
 A function that takes a level and a 'ParseState'
 and produces a monadic parsing action yielding a new state.

 Used to express the main parsing loop
 as well as all substeps that transform the charts on a specific level.
-}
type ParseOp m tr slc h v = Int -> ParseState tr slc h v -> m (ParseState tr slc h v)

-- | A single level iteration of the chart parser.
parseStep
  :: (Parsable tr slc h v)
  => (TChart tr slc v -> VChart tr slc h v -> Int -> IO ())
  -- ^ a logging function that takes charts and level number.
  -> Eval tr tr' slc slc' h v
  -- ^ the grammar's evaluator
  -> ParseOp IO tr slc h v
  -- ^ the parsing operation (from level number and charts to new charts).
parseStep :: forall tr slc h v tr' slc'.
Parsable tr slc h v =>
(TChart tr slc v -> VChart tr slc h v -> Int -> IO ())
-> Eval tr tr' slc slc' h v -> ParseOp IO tr slc h v
parseStep TChart tr slc v -> VChart tr slc h v -> Int -> IO ()
logCharts (Eval UnspreadMiddle tr slc h v
eMid UnspreadLeft tr slc h
eLeft UnspreadRight tr slc h
eRight Unsplit tr slc v
eUnsplit StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
_ slc' -> slc
_) Int
n ParseState tr slc h v
charts = do
  (TChart tr slc v -> VChart tr slc h v -> Int -> IO ())
-> ParseState tr slc h v -> Int -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TChart tr slc v -> VChart tr slc h v -> Int -> IO ()
logCharts ParseState tr slc h v
charts Int
n
  UnspreadMiddle tr slc h v -> ParseOp IO tr slc h v
forall (m :: * -> *) tr slc h v.
(Monad m, Parsable tr slc h v) =>
UnspreadMiddle tr slc h v -> ParseOp m tr slc h v
unspreadAllMiddles UnspreadMiddle tr slc h v
eMid Int
n ParseState tr slc h v
charts
    IO (ParseState tr slc h v)
-> (ParseState tr slc h v -> IO (ParseState tr slc h v))
-> IO (ParseState tr slc h v)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnspreadLeft tr slc h -> ParseOp IO tr slc h v
forall (m :: * -> *) tr slc h v.
(Monad m, Parsable tr slc h v) =>
UnspreadLeft tr slc h -> ParseOp m tr slc h v
unspreadAllLefts UnspreadLeft tr slc h
eLeft Int
n
    IO (ParseState tr slc h v)
-> (ParseState tr slc h v -> IO (ParseState tr slc h v))
-> IO (ParseState tr slc h v)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnspreadRight tr slc h -> ParseOp IO tr slc h v
forall (m :: * -> *) tr slc h v.
(Monad m, Parsable tr slc h v) =>
UnspreadRight tr slc h -> ParseOp m tr slc h v
unspreadAllRights UnspreadRight tr slc h
eRight Int
n
    IO (ParseState tr slc h v)
-> (ParseState tr slc h v -> IO (ParseState tr slc h v))
-> IO (ParseState tr slc h v)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Unsplit tr slc v -> ParseOp IO tr slc h v
forall tr slc h v (m :: * -> *).
(Monad m, Parsable tr slc h v) =>
Unsplit tr slc v -> ParseOp m tr slc h v
unsplitAll Unsplit tr slc v
eUnsplit Int
n

-- | Verticalizes all edges of length @n@.
unspreadAllMiddles
  :: (Monad m, Parsable tr slc h v) => UnspreadMiddle tr slc h v -> ParseOp m tr slc h v
unspreadAllMiddles :: forall (m :: * -> *) tr slc h v.
(Monad m, Parsable tr slc h v) =>
UnspreadMiddle tr slc h v -> ParseOp m tr slc h v
unspreadAllMiddles UnspreadMiddle tr slc h v
evalMid Int
n (!TChart tr slc v
tchart, !VChart tr slc h v
vchart) = do
  let ts :: [TItem tr slc v]
ts = TChart tr slc v -> Int -> [TItem tr slc v]
forall tr slc v. TChart tr slc v -> Int -> [TItem tr slc v]
tcGetByLength TChart tr slc v
tchart Int
n
      !newVerts :: [(slc, h, v, TItem tr slc v)]
newVerts = [[(slc, h, v, TItem tr slc v)]] -> [(slc, h, v, TItem tr slc v)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(slc, h, v, TItem tr slc v)]] -> [(slc, h, v, TItem tr slc v)])
-> [[(slc, h, v, TItem tr slc v)]] -> [(slc, h, v, TItem tr slc v)]
forall a b. (a -> b) -> a -> b
$ (TItem tr slc v -> [(slc, h, v, TItem tr slc v)])
-> [TItem tr slc v] -> [[(slc, h, v, TItem tr slc v)]]
forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap (UnspreadMiddle tr slc h v
-> TItem tr slc v -> [(slc, h, v, TItem tr slc v)]
forall tr slc h v.
UnspreadMiddle tr slc h v
-> TItem tr slc v -> [(slc, h, v, TItem tr slc v)]
unspreadMiddle UnspreadMiddle tr slc h v
evalMid) ([TItem tr slc v] -> [[(slc, h, v, TItem tr slc v)]])
-> [TItem tr slc v] -> [[(slc, h, v, TItem tr slc v)]]
forall a b. NFData a => (a -> b) -> a -> b
$!! [TItem tr slc v]
ts
      vchart' :: VChart tr slc h v
vchart' = VChart tr slc h v
-> [(slc, h, v, TItem tr slc v)] -> VChart tr slc h v
forall (t :: * -> *) slc h tr v.
(Foldable t, Ord slc, Hashable slc, Ord h) =>
VChart tr slc h v
-> t (slc, h, v, TItem tr slc v) -> VChart tr slc h v
vcMerge VChart tr slc h v
vchart [(slc, h, v, TItem tr slc v)]
newVerts
  (TChart tr slc v, VChart tr slc h v)
-> m (TChart tr slc v, VChart tr slc h v)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TChart tr slc v
tchart, VChart tr slc h v
vchart')

-- | Perform all left unspreads where either @l@ or @m@ have length @n@.
unspreadAllLefts
  :: (Monad m, Parsable tr slc h v) => UnspreadLeft tr slc h -> ParseOp m tr slc h v
unspreadAllLefts :: forall (m :: * -> *) tr slc h v.
(Monad m, Parsable tr slc h v) =>
UnspreadLeft tr slc h -> ParseOp m tr slc h v
unspreadAllLefts UnspreadLeft tr slc h
evalLeft Int
n (!TChart tr slc v
tchart, !VChart tr slc h v
vchart) = do
  let
    -- left = n (and middle <= n)
    leftn :: [[TItem tr slc v]]
leftn =
      ((TItem tr slc v, Slice slc, h) -> [TItem tr slc v])
-> [(TItem tr slc v, Slice slc, h)] -> [[TItem tr slc v]]
forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap (TItem tr slc v, Slice slc, h) -> [TItem tr slc v]
forall {v}.
(Semiring v, Show v) =>
(TItem tr slc v, Slice slc, h) -> [TItem tr slc v]
unleft ([(TItem tr slc v, Slice slc, h)] -> [[TItem tr slc v]])
-> [(TItem tr slc v, Slice slc, h)] -> [[TItem tr slc v]]
forall a b. NFData a => (a -> b) -> a -> b
$!! do
        -- in list monad
        left <- TChart tr slc v -> Int -> [TItem tr slc v]
forall tr slc v. TChart tr slc v -> Int -> [TItem tr slc v]
tcGetByLength TChart tr slc v
tchart Int
n
        (top, op) <- vcGetByLeftChild n vchart (tRightSlice $ iItem left)
        pure (left, top, op)

    -- middle = n (and left < n)
    midn :: [[TItem tr slc v]]
midn =
      ((TItem tr slc v, Slice slc, h) -> [TItem tr slc v])
-> [(TItem tr slc v, Slice slc, h)] -> [[TItem tr slc v]]
forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap (TItem tr slc v, Slice slc, h) -> [TItem tr slc v]
forall {v}.
(Semiring v, Show v) =>
(TItem tr slc v, Slice slc, h) -> [TItem tr slc v]
unleft ([(TItem tr slc v, Slice slc, h)] -> [[TItem tr slc v]])
-> [(TItem tr slc v, Slice slc, h)] -> [[TItem tr slc v]]
forall a b. NFData a => (a -> b) -> a -> b
$!! do
        -- in list monad
        (top, lslice, op) <- VChart tr slc h v -> Int -> [(Slice slc, Slice slc, h)]
forall tr slc h v.
VChart tr slc h v -> Int -> [(Slice slc, Slice slc, h)]
vcGetByLengthLeft VChart tr slc h v
vchart Int
n
        left <-
          filter (\TItem tr slc v
item -> Transition tr slc -> Int
forall e a. Transition e a -> Int
transLen (TItem tr slc v -> Transition tr slc
forall i v. Item i v -> i
iItem TItem tr slc v
item) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n) $
            tcGetByRight tchart lslice
        pure (left, top, op)

    -- insert new transitions into chart
    tchart' :: TChart tr slc v
tchart' = (TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v)
-> TChart tr slc v -> [[TItem tr slc v]] -> TChart tr slc v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v
forall (t :: * -> *) tr slc v.
(Foldable t, Parsable' tr slc v) =>
TChart tr slc v -> t (TItem tr slc v) -> TChart tr slc v
tcMerge ((TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v)
-> TChart tr slc v -> [[TItem tr slc v]] -> TChart tr slc v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v
forall (t :: * -> *) tr slc v.
(Foldable t, Parsable' tr slc v) =>
TChart tr slc v -> t (TItem tr slc v) -> TChart tr slc v
tcMerge TChart tr slc v
tchart [[TItem tr slc v]]
leftn) [[TItem tr slc v]]
midn
  (TChart tr slc v, VChart tr slc h v)
-> m (TChart tr slc v, VChart tr slc h v)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TChart tr slc v
tchart', VChart tr slc h v
vchart)
 where
  unleft :: (TItem tr slc v, Slice slc, h) -> [TItem tr slc v]
unleft (TItem tr slc v
left, Slice slc
top, h
op) = UnspreadLeft tr slc h
-> TItem tr slc v -> Slice slc -> h -> [TItem tr slc v]
forall slc tr v h.
(Show slc, Show tr, Semiring v, Show v) =>
UnspreadLeft tr slc h
-> TItem tr slc v -> Slice slc -> h -> [TItem tr slc v]
unspreadLeft UnspreadLeft tr slc h
evalLeft TItem tr slc v
left Slice slc
top h
op

-- | Perform all right unspreads where either @r@ or @m@ have length @n@
unspreadAllRights
  :: (Monad m, Parsable tr slc h v) => UnspreadRight tr slc h -> ParseOp m tr slc h v
unspreadAllRights :: forall (m :: * -> *) tr slc h v.
(Monad m, Parsable tr slc h v) =>
UnspreadRight tr slc h -> ParseOp m tr slc h v
unspreadAllRights UnspreadRight tr slc h
evalRight Int
n (!TChart tr slc v
tchart, !VChart tr slc h v
vchart) = do
  let
    -- right = n (and middle <= n)
    !rightn :: [[TItem tr slc v]]
rightn =
      [[TItem tr slc v]] -> [[TItem tr slc v]]
forall a. NFData a => a -> a
force ([[TItem tr slc v]] -> [[TItem tr slc v]])
-> [[TItem tr slc v]] -> [[TItem tr slc v]]
forall a b. (a -> b) -> a -> b
$ ((Vert tr slc h v, TItem tr slc v) -> [TItem tr slc v])
-> [(Vert tr slc h v, TItem tr slc v)] -> [[TItem tr slc v]]
forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap ((Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v])
-> (Vert tr slc h v, TItem tr slc v) -> [TItem tr slc v]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v])
 -> (Vert tr slc h v, TItem tr slc v) -> [TItem tr slc v])
-> (Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v])
-> (Vert tr slc h v, TItem tr slc v)
-> [TItem tr slc v]
forall a b. (a -> b) -> a -> b
$ UnspreadRight tr slc h
-> Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v]
forall v slc tr h.
(Semiring v, NFData slc, NFData tr, NFData v, Show tr, Show slc,
 Show v, Show h) =>
UnspreadRight tr slc h
-> Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v]
unspreadRight UnspreadRight tr slc h
evalRight) ([(Vert tr slc h v, TItem tr slc v)] -> [[TItem tr slc v]])
-> [(Vert tr slc h v, TItem tr slc v)] -> [[TItem tr slc v]]
forall a b. NFData a => (a -> b) -> a -> b
$!! do
        -- in list monad
        right <- TChart tr slc v -> Int -> [TItem tr slc v]
forall tr slc v. TChart tr slc v -> Int -> [TItem tr slc v]
tcGetByLength TChart tr slc v
tchart Int
n
        vert <- vcGetByRightChild n vchart (tLeftSlice $ iItem right)
        pure (vert, right)

    -- middle = n (and left < n)
    !midn :: [[TItem tr slc v]]
midn =
      [[TItem tr slc v]] -> [[TItem tr slc v]]
forall a. NFData a => a -> a
force ([[TItem tr slc v]] -> [[TItem tr slc v]])
-> [[TItem tr slc v]] -> [[TItem tr slc v]]
forall a b. (a -> b) -> a -> b
$ ((Vert tr slc h v, TItem tr slc v) -> [TItem tr slc v])
-> [(Vert tr slc h v, TItem tr slc v)] -> [[TItem tr slc v]]
forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap ((Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v])
-> (Vert tr slc h v, TItem tr slc v) -> [TItem tr slc v]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v])
 -> (Vert tr slc h v, TItem tr slc v) -> [TItem tr slc v])
-> (Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v])
-> (Vert tr slc h v, TItem tr slc v)
-> [TItem tr slc v]
forall a b. (a -> b) -> a -> b
$ UnspreadRight tr slc h
-> Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v]
forall v slc tr h.
(Semiring v, NFData slc, NFData tr, NFData v, Show tr, Show slc,
 Show v, Show h) =>
UnspreadRight tr slc h
-> Vert tr slc h v -> TItem tr slc v -> [TItem tr slc v]
unspreadRight UnspreadRight tr slc h
evalRight) ([(Vert tr slc h v, TItem tr slc v)] -> [[TItem tr slc v]])
-> [(Vert tr slc h v, TItem tr slc v)] -> [[TItem tr slc v]]
forall a b. NFData a => (a -> b) -> a -> b
$!! do
        -- in list monad
        vert <- VChart tr slc h v -> Int -> [Vert tr slc h v]
forall tr slc h v. VChart tr slc h v -> Int -> [Vert tr slc h v]
vcGetByLength VChart tr slc h v
vchart Int
n
        right <-
          filter (\TItem tr slc v
i -> Transition tr slc -> Int
forall e a. Transition e a -> Int
transLen (TItem tr slc v -> Transition tr slc
forall i v. Item i v -> i
iItem TItem tr slc v
i) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n) $
            tcGetByLeft tchart (tRightSlice $ iItem $ vMiddle vert)
        pure (vert, right)

    -- insert new transitions into chart
    !tchart' :: TChart tr slc v
tchart' = (TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v)
-> TChart tr slc v -> [[TItem tr slc v]] -> TChart tr slc v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v
forall (t :: * -> *) tr slc v.
(Foldable t, Parsable' tr slc v) =>
TChart tr slc v -> t (TItem tr slc v) -> TChart tr slc v
tcMerge ((TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v)
-> TChart tr slc v -> [[TItem tr slc v]] -> TChart tr slc v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v
forall (t :: * -> *) tr slc v.
(Foldable t, Parsable' tr slc v) =>
TChart tr slc v -> t (TItem tr slc v) -> TChart tr slc v
tcMerge TChart tr slc v
tchart [[TItem tr slc v]]
rightn) [[TItem tr slc v]]
midn
  (TChart tr slc v, VChart tr slc h v)
-> m (TChart tr slc v, VChart tr slc h v)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TChart tr slc v
tchart', VChart tr slc h v
vchart)

-- | perform all unsplits where either @l@ or @r@ have length @n@
unsplitAll
  :: forall tr slc h v m
   . (Monad m, Parsable tr slc h v)
  => Unsplit tr slc v
  -> ParseOp m tr slc h v
unsplitAll :: forall tr slc h v (m :: * -> *).
(Monad m, Parsable tr slc h v) =>
Unsplit tr slc v -> ParseOp m tr slc h v
unsplitAll Unsplit tr slc v
unsplitter Int
n (!TChart tr slc v
tchart, !VChart tr slc h v
vchart) = do
  let !byLen :: [TItem tr slc v]
byLen = [TItem tr slc v] -> [TItem tr slc v]
forall a. NFData a => a -> a
force ([TItem tr slc v] -> [TItem tr slc v])
-> [TItem tr slc v] -> [TItem tr slc v]
forall a b. (a -> b) -> a -> b
$ TChart tr slc v -> Int -> [TItem tr slc v]
forall tr slc v. TChart tr slc v -> Int -> [TItem tr slc v]
tcGetByLength TChart tr slc v
tchart Int
n

      -- left = n (and right <= n)
      !leftn :: [[TItem tr slc v]]
leftn =
        ((TItem tr slc v, TItem tr slc v) -> [TItem tr slc v])
-> [(TItem tr slc v, TItem tr slc v)] -> [[TItem tr slc v]]
forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap ((TItem tr slc v -> TItem tr slc v -> [TItem tr slc v])
-> (TItem tr slc v, TItem tr slc v) -> [TItem tr slc v]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Unsplit tr slc v
-> TItem tr slc v -> TItem tr slc v -> [TItem tr slc v]
forall v slc tr.
(Semiring v, NFData slc, NFData tr, NFData v, Show v) =>
Unsplit tr slc v
-> TItem tr slc v -> TItem tr slc v -> [TItem tr slc v]
unsplit Unsplit tr slc v
unsplitter)) ([(TItem tr slc v, TItem tr slc v)] -> [[TItem tr slc v]])
-> [(TItem tr slc v, TItem tr slc v)] -> [[TItem tr slc v]]
forall a b. NFData a => (a -> b) -> a -> b
$!! do
          left <- [TItem tr slc v]
byLen
          right <-
            filter (\TItem tr slc v
r -> Transition tr slc -> Int
forall e a. Transition e a -> Int
transLen (TItem tr slc v -> Transition tr slc
forall i v. Item i v -> i
iItem TItem tr slc v
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n) $
              tcGetByLeft tchart (tRightSlice $ iItem left)
          pure (left, right)

      -- right = n (and left < n)
      !rightn :: [[TItem tr slc v]]
rightn =
        ((TItem tr slc v, TItem tr slc v) -> [TItem tr slc v])
-> [(TItem tr slc v, TItem tr slc v)] -> [[TItem tr slc v]]
forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap ((TItem tr slc v -> TItem tr slc v -> [TItem tr slc v])
-> (TItem tr slc v, TItem tr slc v) -> [TItem tr slc v]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Unsplit tr slc v
-> TItem tr slc v -> TItem tr slc v -> [TItem tr slc v]
forall v slc tr.
(Semiring v, NFData slc, NFData tr, NFData v, Show v) =>
Unsplit tr slc v
-> TItem tr slc v -> TItem tr slc v -> [TItem tr slc v]
unsplit Unsplit tr slc v
unsplitter)) ([(TItem tr slc v, TItem tr slc v)] -> [[TItem tr slc v]])
-> [(TItem tr slc v, TItem tr slc v)] -> [[TItem tr slc v]]
forall a b. NFData a => (a -> b) -> a -> b
$!! do
          right <- [TItem tr slc v]
byLen
          left <-
            filter (\TItem tr slc v
l -> Transition tr slc -> Int
forall e a. Transition e a -> Int
transLen (TItem tr slc v -> Transition tr slc
forall i v. Item i v -> i
iItem TItem tr slc v
l) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n) $
              tcGetByRight tchart (tLeftSlice $ iItem right)
          pure (left, right)

      -- insert new transitions into chart
      !tchart' :: TChart tr slc v
tchart' = (TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v)
-> TChart tr slc v -> [[TItem tr slc v]] -> TChart tr slc v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v
forall (t :: * -> *) tr slc v.
(Foldable t, Parsable' tr slc v) =>
TChart tr slc v -> t (TItem tr slc v) -> TChart tr slc v
tcMerge ((TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v)
-> TChart tr slc v -> [[TItem tr slc v]] -> TChart tr slc v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v
forall (t :: * -> *) tr slc v.
(Foldable t, Parsable' tr slc v) =>
TChart tr slc v -> t (TItem tr slc v) -> TChart tr slc v
tcMerge TChart tr slc v
tchart [[TItem tr slc v]]
leftn) [[TItem tr slc v]]
rightn
  (TChart tr slc v, VChart tr slc h v)
-> m (TChart tr slc v, VChart tr slc h v)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TChart tr slc v
tchart', VChart tr slc h v
vchart)

-- parsing entry point
----------------------

{- | The main entrypoint to the parser.
 Expects an evaluator for the specific grammar
 and an input path.
 Returns the combined semiring value of all full derivations.
-}
parse
  :: (Parsable tr slc h v)
  => (TChart tr slc v -> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ())
  -- ^ logging function
  -> Eval tr tr' slc slc' h v
  -- ^ the grammar's evaluator
  -> Path slc' tr'
  -- ^ the input path (from first to last slice, excluding 'Start' and 'Stop')
  -> IO v
  -- ^ the semiring value at the top
parse :: forall tr slc h v tr' slc'.
Parsable tr slc h v =>
(TChart tr slc v
 -> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ())
-> Eval tr tr' slc slc' h v -> Path slc' tr' -> IO v
parse TChart tr slc v
-> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ()
logCharts Eval tr tr' slc slc' h v
eval Path slc' tr'
path = do
  TChart tr slc v
-> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ()
logCharts TChart tr slc v
tinit ([Slice slc] -> Either (VChart tr slc h v) [Slice slc]
forall a b. b -> Either a b
Right ([Slice slc] -> Either (VChart tr slc h v) [Slice slc])
-> [Slice slc] -> Either (VChart tr slc h v) [Slice slc]
forall a b. (a -> b) -> a -> b
$ Path (Slice slc) (Maybe tr') -> [Slice slc]
forall a b. Path a b -> [a]
pathArounds Path (Slice slc) (Maybe tr')
slicePath) Int
1
  (tfinal, vfinal) <-
    ((TChart tr slc v, VChart tr slc h v)
 -> Int -> IO (TChart tr slc v, VChart tr slc h v))
-> (TChart tr slc v, VChart tr slc h v)
-> [Int]
-> IO (TChart tr slc v, VChart tr slc h v)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
      ((Int
 -> (TChart tr slc v, VChart tr slc h v)
 -> IO (TChart tr slc v, VChart tr slc h v))
-> (TChart tr slc v, VChart tr slc h v)
-> Int
-> IO (TChart tr slc v, VChart tr slc h v)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int
  -> (TChart tr slc v, VChart tr slc h v)
  -> IO (TChart tr slc v, VChart tr slc h v))
 -> (TChart tr slc v, VChart tr slc h v)
 -> Int
 -> IO (TChart tr slc v, VChart tr slc h v))
-> (Int
    -> (TChart tr slc v, VChart tr slc h v)
    -> IO (TChart tr slc v, VChart tr slc h v))
-> (TChart tr slc v, VChart tr slc h v)
-> Int
-> IO (TChart tr slc v, VChart tr slc h v)
forall a b. (a -> b) -> a -> b
$ (TChart tr slc v -> VChart tr slc h v -> Int -> IO ())
-> Eval tr tr' slc slc' h v
-> Int
-> (TChart tr slc v, VChart tr slc h v)
-> IO (TChart tr slc v, VChart tr slc h v)
forall tr slc h v tr' slc'.
Parsable tr slc h v =>
(TChart tr slc v -> VChart tr slc h v -> Int -> IO ())
-> Eval tr tr' slc slc' h v -> ParseOp IO tr slc h v
parseStep (\TChart tr slc v
t VChart tr slc h v
v Int
i -> TChart tr slc v
-> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ()
logCharts TChart tr slc v
t (VChart tr slc h v -> Either (VChart tr slc h v) [Slice slc]
forall a b. a -> Either a b
Left VChart tr slc h v
v) Int
i) Eval tr tr' slc slc' h v
eval)
      (TChart tr slc v
tinit, Int -> VChart tr slc h v
forall tr slc h v. Int -> VChart tr slc h v
vcEmpty Int
len)
      [Int
2 .. Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  logCharts tfinal (Left vfinal) len
  let goals = TChart tr slc v -> Int -> [TItem tr slc v]
forall tr slc v. TChart tr slc v -> Int -> [TItem tr slc v]
tcGetByLength TChart tr slc v
tfinal Int
len
  return $ R.sum $ S.getScoreVal . iScore <$> goals
 where
  wrapPath :: Path a a -> Path (StartStop a) (Maybe a)
wrapPath (Path a
a a
e Path a a
rst) = StartStop a
-> Maybe a
-> Path (StartStop a) (Maybe a)
-> Path (StartStop a) (Maybe a)
forall around between.
around -> between -> Path around between -> Path around between
Path (a -> StartStop a
forall a. a -> StartStop a
Inner a
a) (a -> Maybe a
forall a. a -> Maybe a
Just a
e) (Path (StartStop a) (Maybe a) -> Path (StartStop a) (Maybe a))
-> Path (StartStop a) (Maybe a) -> Path (StartStop a) (Maybe a)
forall a b. (a -> b) -> a -> b
$ Path a a -> Path (StartStop a) (Maybe a)
wrapPath Path a a
rst
  wrapPath (PathEnd a
a) = StartStop a
-> Maybe a
-> Path (StartStop a) (Maybe a)
-> Path (StartStop a) (Maybe a)
forall around between.
around -> between -> Path around between -> Path around between
Path (a -> StartStop a
forall a. a -> StartStop a
Inner a
a) Maybe a
forall a. Maybe a
Nothing (Path (StartStop a) (Maybe a) -> Path (StartStop a) (Maybe a))
-> Path (StartStop a) (Maybe a) -> Path (StartStop a) (Maybe a)
forall a b. (a -> b) -> a -> b
$ StartStop a -> Path (StartStop a) (Maybe a)
forall around between. around -> Path around between
PathEnd StartStop a
forall a. StartStop a
Stop
  path' :: Path (StartStop slc') (Maybe tr')
path' = StartStop slc'
-> Maybe tr'
-> Path (StartStop slc') (Maybe tr')
-> Path (StartStop slc') (Maybe tr')
forall around between.
around -> between -> Path around between -> Path around between
Path StartStop slc'
forall a. StartStop a
Start Maybe tr'
forall a. Maybe a
Nothing (Path (StartStop slc') (Maybe tr')
 -> Path (StartStop slc') (Maybe tr'))
-> Path (StartStop slc') (Maybe tr')
-> Path (StartStop slc') (Maybe tr')
forall a b. (a -> b) -> a -> b
$ Path slc' tr' -> Path (StartStop slc') (Maybe tr')
forall {a} {a}. Path a a -> Path (StartStop a) (Maybe a)
wrapPath Path slc' tr'
path
  len :: Int
len = Path (StartStop slc') (Maybe tr') -> Int
forall a b. Path a b -> Int
pathLen Path (StartStop slc') (Maybe tr')
path'
  slicePath :: Path (Slice slc) (Maybe tr')
slicePath =
    Int
-> (Int -> StartStop slc' -> Slice slc)
-> Path (StartStop slc') (Maybe tr')
-> Path (Slice slc) (Maybe tr')
forall a a' b. Int -> (Int -> a -> a') -> Path a b -> Path a' b
mapAroundsWithIndex
      Int
0
      (\Int
i StartStop slc'
notes -> Int -> StartStop slc -> Int -> Int -> Slice slc
forall slc. Int -> StartStop slc -> Int -> Int -> Slice slc
Slice Int
i (Eval tr tr' slc slc' h v -> slc' -> slc
forall tr tr' slc slc' h v. Eval tr tr' slc slc' h v -> slc' -> slc
evalSlice Eval tr tr' slc slc' h v
eval (slc' -> slc) -> StartStop slc' -> StartStop slc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StartStop slc'
notes) Int
i Int
i)
      Path (StartStop slc') (Maybe tr')
path'
  mkTrans :: Slice slc -> Maybe tr' -> Slice slc -> [TItem tr slc v]
mkTrans Slice slc
l Maybe tr'
esurf Slice slc
r =
    (tr, v) -> TItem tr slc v
forall {tr} {v}. (tr, v) -> Item (Transition tr slc) v
mk
      ((tr, v) -> TItem tr slc v) -> [(tr, v)] -> [TItem tr slc v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval tr tr' slc slc' h v
-> StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v
-> StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
evalUnfreeze
        Eval tr tr' slc slc' h v
eval
        (Slice slc -> StartStop slc
forall slc. Slice slc -> StartStop slc
sContent Slice slc
l)
        Maybe tr'
esurf
        (Slice slc -> StartStop slc
forall slc. Slice slc -> StartStop slc
sContent Slice slc
r)
        (StartStop slc -> Bool
forall a. StartStop a -> Bool
isStop (StartStop slc -> Bool) -> StartStop slc -> Bool
forall a b. (a -> b) -> a -> b
$ Slice slc -> StartStop slc
forall slc. Slice slc -> StartStop slc
sContent Slice slc
r)
   where
    mk :: (tr, v) -> Item (Transition tr slc) v
mk (tr
e, v
v) = Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
forall tr slc.
Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
Transition Slice slc
l tr
e Slice slc
r Bool
False Transition tr slc -> Score v Int -> Item (Transition tr slc) v
forall i v. i -> Score v Int -> Item i v
:= v -> Score v Int
forall s i. s -> Score s i
S.val v
v
  trans0 :: [[TItem tr slc v]]
trans0 = (Slice slc -> Maybe tr' -> Slice slc -> [TItem tr slc v])
-> Path (Slice slc) (Maybe tr') -> [[TItem tr slc v]]
forall a b c. (a -> b -> a -> c) -> Path a b -> [c]
mapBetweens Slice slc -> Maybe tr' -> Slice slc -> [TItem tr slc v]
mkTrans Path (Slice slc) (Maybe tr')
slicePath
  tinit :: TChart tr slc v
tinit = TChart tr slc v -> [TItem tr slc v] -> TChart tr slc v
forall (t :: * -> *) tr slc v.
(Foldable t, Parsable' tr slc v) =>
TChart tr slc v -> t (TItem tr slc v) -> TChart tr slc v
tcMerge TChart tr slc v
forall tr slc v. TChart tr slc v
tcEmpty ([TItem tr slc v] -> TChart tr slc v)
-> [TItem tr slc v] -> TChart tr slc v
forall a b. (a -> b) -> a -> b
$ [[TItem tr slc v]] -> [TItem tr slc v]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TItem tr slc v]]
trans0

-- | A logging function that logs the sice of the charts at each level.
logSize
  :: TChart tr1 slc1 v1 -> Either (VChart tr2 slc2 h2 v2) [Slice slc2] -> Int -> IO ()
logSize :: forall tr1 slc1 v1 tr2 slc2 h2 v2.
TChart tr1 slc1 v1
-> Either (VChart tr2 slc2 h2 v2) [Slice slc2] -> Int -> IO ()
logSize TChart tr1 slc1 v1
tc Either (VChart tr2 slc2 h2 v2) [Slice slc2]
vc Int
n = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"parsing level " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"transitions: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([TItem tr1 slc1 v1] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TItem tr1 slc1 v1] -> Int) -> [TItem tr1 slc1 v1] -> Int
forall a b. (a -> b) -> a -> b
$ TChart tr1 slc1 v1 -> Int -> [TItem tr1 slc1 v1]
forall tr slc v. TChart tr slc v -> Int -> [TItem tr slc v]
tcGetByLength TChart tr1 slc1 v1
tc Int
n)
  let nverts :: Int
nverts = case Either (VChart tr2 slc2 h2 v2) [Slice slc2]
vc of
        Left VChart tr2 slc2 h2 v2
chart -> [Vert tr2 slc2 h2 v2] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Vert tr2 slc2 h2 v2] -> Int) -> [Vert tr2 slc2 h2 v2] -> Int
forall a b. (a -> b) -> a -> b
$ VChart tr2 slc2 h2 v2 -> Int -> [Vert tr2 slc2 h2 v2]
forall tr slc h v. VChart tr slc h v -> Int -> [Vert tr slc h v]
vcGetByLength VChart tr2 slc2 h2 v2
chart (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        Right [Slice slc2]
lst -> [Slice slc2] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Slice slc2]
lst
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"verts: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
nverts

-- | Parse a piece using the 'logSize' logging function.
parseSize :: (Parsable tr slc h v) => Eval tr tr' slc slc' h v -> Path slc' tr' -> IO v
parseSize :: forall tr slc h v tr' slc'.
Parsable tr slc h v =>
Eval tr tr' slc slc' h v -> Path slc' tr' -> IO v
parseSize = (TChart tr slc v
 -> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ())
-> Eval tr tr' slc slc' h v -> Path slc' tr' -> IO v
forall tr slc h v tr' slc'.
Parsable tr slc h v =>
(TChart tr slc v
 -> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ())
-> Eval tr tr' slc slc' h v -> Path slc' tr' -> IO v
parse TChart tr slc v
-> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ()
forall tr1 slc1 v1 tr2 slc2 h2 v2.
TChart tr1 slc1 v1
-> Either (VChart tr2 slc2 h2 v2) [Slice slc2] -> Int -> IO ()
logSize

-- | A logging function that does nothing.
logNone :: (Applicative f) => p1 -> p2 -> p3 -> f ()
logNone :: forall (f :: * -> *) p1 p2 p3.
Applicative f =>
p1 -> p2 -> p3 -> f ()
logNone p1
_ p2
_ p3
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Parse a piece without logging.
parseSilent :: (Parsable tr slc h v) => Eval tr tr' slc slc' h v -> Path slc' tr' -> IO v
parseSilent :: forall tr slc h v tr' slc'.
Parsable tr slc h v =>
Eval tr tr' slc slc' h v -> Path slc' tr' -> IO v
parseSilent = (TChart tr slc v
 -> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ())
-> Eval tr tr' slc slc' h v -> Path slc' tr' -> IO v
forall tr slc h v tr' slc'.
Parsable tr slc h v =>
(TChart tr slc v
 -> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ())
-> Eval tr tr' slc slc' h v -> Path slc' tr' -> IO v
parse TChart tr slc v
-> Either (VChart tr slc h v) [Slice slc] -> Int -> IO ()
forall (f :: * -> *) p1 p2 p3.
Applicative f =>
p1 -> p2 -> p3 -> f ()
logNone

-- fancier logging
-- ---------------

-- | Generate TikZ code for a slice.
printTikzSlice :: (Show slc) => Slice slc -> IO ()
printTikzSlice :: forall slc. Show slc => Slice slc -> IO ()
printTikzSlice (Slice Int
f StartStop slc
sc Int
sid Int
l) = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"    \\node[slice,align=center] (slice"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
sid
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") at ("
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
",0) {"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> StartStop slc -> String
forall a. Show a => a -> String
showTex StartStop slc
sc
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\\\\ "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
sid
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"};"

-- | Generate TikZ code for a verticalization.
printTikzVert :: IntMap a -> Vert tr slc h v -> IO (IntMap a)
printTikzVert IntMap a
neighbors (Vert top :: Slice slc
top@(Slice Int
f StartStop slc
c Int
i Int
l) h
_ v
_ TItem tr slc v
middle) = do
  let index :: Int
index = Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l
      xpos :: Double
xpos = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0
      ypos :: a
ypos = a -> Int -> IntMap a -> a
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault a
0 Int
index IntMap a
neighbors
      neighbors' :: IntMap a
neighbors' =
        (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter
          ( \case
              Just a
n -> a -> Maybe a
forall a. a -> Maybe a
Just (a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
              Maybe a
Nothing -> a -> Maybe a
forall a. a -> Maybe a
Just a
1
          )
          Int
index
          IntMap a
neighbors
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"    \\node[slice,align=center] (slice"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") at ("
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show Double
xpos
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
","
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
ypos
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") {"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> StartStop slc -> String
forall a. Show a => a -> String
showTex StartStop slc
c
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\\\\ ("
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Slice slc -> Int
forall slc. Slice slc -> Int
sID (Slice slc -> Int) -> Slice slc -> Int
forall a b. (a -> b) -> a -> b
$ Transition tr slc -> Slice slc
forall tr slc. Transition tr slc -> Slice slc
tLeftSlice (Transition tr slc -> Slice slc) -> Transition tr slc -> Slice slc
forall a b. (a -> b) -> a -> b
$ TItem tr slc v -> Transition tr slc
forall i v. Item i v -> i
iItem TItem tr slc v
middle)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") - "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" - ("
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Slice slc -> Int
forall slc. Slice slc -> Int
sID (Slice slc -> Int) -> Slice slc -> Int
forall a b. (a -> b) -> a -> b
$ Transition tr slc -> Slice slc
forall tr slc. Transition tr slc -> Slice slc
tRightSlice (Transition tr slc -> Slice slc) -> Transition tr slc -> Slice slc
forall a b. (a -> b) -> a -> b
$ TItem tr slc v -> Transition tr slc
forall i v. Item i v -> i
iItem TItem tr slc v
middle)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")};"
  IntMap a -> IO (IntMap a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntMap a
neighbors'

-- | Generate TikZ code for a transition.
printTikzTrans :: IntMap a -> Transition tr slc -> IO (IntMap a)
printTikzTrans IntMap a
neighbors t :: Transition tr slc
t@(Transition Slice slc
sl tr
tc Slice slc
sr Bool
_) = do
  let tid :: String
tid = String
"t" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Transition tr slc -> Int
forall a. Hashable a => a -> Int
hash Transition tr slc
t)
      index :: Int
index = Slice slc -> Int
forall slc. Slice slc -> Int
sFirst Slice slc
sl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Slice slc -> Int
forall slc. Slice slc -> Int
sLast Slice slc
sr
      xpos :: Double
xpos = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0
      ypos :: a
ypos = a -> Int -> IntMap a -> a
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault a
0 Int
index IntMap a
neighbors
      neighbors' :: IntMap a
neighbors' =
        (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter
          ( \case
              Just a
n -> a -> Maybe a
forall a. a -> Maybe a
Just (a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
              Maybe a
Nothing -> a -> Maybe a
forall a. a -> Maybe a
Just a
1
          )
          Int
index
          IntMap a
neighbors
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"  \\begin{scope}[xshift="
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show Double
xpos
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"cm,yshift="
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
ypos
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"cm]"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"    \\node[slice] ("
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
tid
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"left) at (-0.1,0) {"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Slice slc -> Int
forall slc. Slice slc -> Int
sID Slice slc
sl)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"};"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"    \\node[slice] ("
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
tid
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"right) at (0.1,0) {"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Slice slc -> Int
forall slc. Slice slc -> Int
sID Slice slc
sr)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"};"
  -- printTikzSlice sl (tid <> "left")  "(-0.2,0)"
  -- printTikzSlice sr (tid <> "right") "(0.2,0)"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"    \\draw[transition] ("
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
tid
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"left) -- ("
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
tid
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"right);"
  String -> IO ()
putStrLn String
"  \\end{scope}"
  IntMap a -> IO (IntMap a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntMap a
neighbors'

-- | A logging function that emits the state of the chart in TikZ code at every level.
logTikz :: TChart tr slc v
-> Either (VChart tr slc h v) (t (Slice slc)) -> Int -> IO ()
logTikz TChart tr slc v
tc Either (VChart tr slc h v) (t (Slice slc))
vc Int
n = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\n% level " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n
  let rel :: String
rel =
        if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2
          then String
""
          else String
",shift={($(0,0 |- scope" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".north)+(0,1cm)$)}"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\\begin{scope}[local bounding box=scope" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
rel String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]"
  String -> IO ()
putStrLn String
"  % verticalizations:"
  case Either (VChart tr slc h v) (t (Slice slc))
vc of
    Left VChart tr slc h v
chart -> (IntMap Integer -> Vert tr slc h v -> IO (IntMap Integer))
-> IntMap Integer -> [Vert tr slc h v] -> IO ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ IntMap Integer -> Vert tr slc h v -> IO (IntMap Integer)
forall {a} {slc} {tr} {h} {v}.
(Show a, Show slc, Num a) =>
IntMap a -> Vert tr slc h v -> IO (IntMap a)
printTikzVert IntMap Integer
forall a. IntMap a
IM.empty ([Vert tr slc h v] -> IO ()) -> [Vert tr slc h v] -> IO ()
forall a b. (a -> b) -> a -> b
$ VChart tr slc h v -> Int -> [Vert tr slc h v]
forall tr slc h v. VChart tr slc h v -> Int -> [Vert tr slc h v]
vcGetByLength VChart tr slc h v
chart (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    Right t (Slice slc)
lst -> (Slice slc -> IO ()) -> t (Slice slc) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Slice slc -> IO ()
forall slc. Show slc => Slice slc -> IO ()
printTikzSlice t (Slice slc)
lst
  String -> IO ()
putStrLn String
"\n  % transitions:"
  (IntMap Integer -> Transition tr slc -> IO (IntMap Integer))
-> IntMap Integer -> [Transition tr slc] -> IO ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ IntMap Integer -> Transition tr slc -> IO (IntMap Integer)
forall {a} {tr} {slc}.
(Show a, Num a, Hashable tr, Eq slc) =>
IntMap a -> Transition tr slc -> IO (IntMap a)
printTikzTrans IntMap Integer
forall a. IntMap a
IM.empty ([Transition tr slc] -> IO ()) -> [Transition tr slc] -> IO ()
forall a b. (a -> b) -> a -> b
$ Item (Transition tr slc) v -> Transition tr slc
forall i v. Item i v -> i
iItem (Item (Transition tr slc) v -> Transition tr slc)
-> [Item (Transition tr slc) v] -> [Transition tr slc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChart tr slc v -> Int -> [Item (Transition tr slc) v]
forall tr slc v. TChart tr slc v -> Int -> [TItem tr slc v]
tcGetByLength TChart tr slc v
tc Int
n
  String -> IO ()
putStrLn String
"\\end{scope}"