{-# 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.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
  )
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)

-- 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
forall slc. Eq slc => Slice slc -> Slice slc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Slice slc -> Slice slc -> Bool
$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
Eq, Slice slc -> Slice slc -> Bool
Slice slc -> Slice slc -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {slc}. Ord slc => Eq (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
min :: Slice slc -> Slice slc -> Slice slc
$cmin :: forall slc. Ord slc => Slice slc -> Slice slc -> Slice slc
max :: Slice slc -> Slice slc -> Slice slc
$cmax :: forall slc. Ord slc => Slice slc -> Slice slc -> Slice slc
>= :: 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
$c< :: forall slc. Ord slc => Slice slc -> Slice slc -> Bool
compare :: Slice slc -> Slice slc -> Ordering
$ccompare :: forall slc. Ord slc => Slice slc -> Slice slc -> Ordering
Ord, 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
$cto :: forall slc x. Rep (Slice slc) x -> Slice slc
$cfrom :: forall slc x. Slice slc -> Rep (Slice slc) x
Generic, forall slc. NFData slc => Slice slc -> ()
forall a. (a -> ()) -> NFData a
rnf :: Slice slc -> ()
$crnf :: forall slc. NFData slc => 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
_) = 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) =
    forall a. Show a => a -> String
show Int
f forall a. Semigroup a => a -> a -> a
<> String
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show StartStop slc
c forall a. Semigroup a => a -> a -> a
<> String
"@" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i forall a. Semigroup a => a -> a -> a
<> String
"-" forall a. Semigroup a => a -> a -> a
<> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
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
$c== :: forall tr slc.
(Eq slc, Eq tr) =>
Transition tr slc -> Transition tr slc -> Bool
Eq, Transition tr slc -> Transition tr slc -> Bool
Transition tr slc -> Transition tr slc -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {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
min :: 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
max :: Transition tr slc -> Transition tr slc -> Transition tr slc
$cmax :: forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Transition tr slc
>= :: 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
$c< :: forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Bool
compare :: Transition tr slc -> Transition tr slc -> Ordering
$ccompare :: forall tr slc.
(Ord slc, Ord tr) =>
Transition tr slc -> Transition tr slc -> Ordering
Ord, 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
$cto :: forall tr slc x. Rep (Transition tr slc) x -> Transition tr slc
$cfrom :: forall tr slc x. Transition tr slc -> Rep (Transition tr slc) x
Generic, forall a. (a -> ()) -> NFData a
forall tr slc. (NFData slc, NFData tr) => Transition tr slc -> ()
rnf :: Transition tr slc -> ()
$crnf :: forall tr slc. (NFData slc, NFData tr) => Transition tr slc -> ()
NFData, 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
hash :: Transition tr slc -> Int
$chash :: forall tr slc. (Eq slc, Hashable tr) => Transition tr slc -> Int
hashWithSalt :: Int -> Transition tr slc -> Int
$chashWithSalt :: forall tr slc.
(Eq slc, Hashable tr) =>
Int -> 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
"<"
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Slice a
l
      forall a. Semigroup a => a -> a -> a
<> String
","
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show e
c
      forall a. Semigroup a => a -> a -> a
<> String
","
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Slice a
r
      forall a. Semigroup a => a -> a -> a
<> String
">"
      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
_) = forall slc. Slice slc -> Int
sLast Slice a
r forall a. Num a => a -> a -> a
- forall slc. Slice slc -> Int
sFirst Slice a
l 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 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
$cto :: forall i v x. Rep (Item i v) x -> Item i v
$cfrom :: forall i v x. Item i v -> Rep (Item i v) x
Generic, forall a. (a -> ()) -> NFData a
forall i v. (NFData i, NFData v) => Item i v -> ()
rnf :: Item i v -> ()
$crnf :: forall i v. (NFData i, NFData v) => 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) = forall a. Show a => a -> String
show i
i forall a. Semigroup a => a -> a -> a
<> String
" := " forall a. Semigroup a => a -> a -> a
<> 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 v = Vert
  { forall tr slc v. Vert tr slc v -> Slice slc
vTop :: !(Slice slc)
  , forall tr slc v. Vert tr slc v -> v
vOp :: !v
  , forall tr slc v. Vert tr slc v -> TItem tr slc v
vMiddle :: !(TItem tr slc v)
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tr slc v x. Rep (Vert tr slc v) x -> Vert tr slc v
forall tr slc v x. Vert tr slc v -> Rep (Vert tr slc v) x
$cto :: forall tr slc v x. Rep (Vert tr slc v) x -> Vert tr slc v
$cfrom :: forall tr slc v x. Vert tr slc v -> Rep (Vert tr slc v) x
Generic, forall a. (a -> ()) -> NFData a
forall tr slc v.
(NFData slc, NFData v, NFData tr) =>
Vert tr slc v -> ()
rnf :: Vert tr slc v -> ()
$crnf :: forall tr slc v.
(NFData slc, NFData v, NFData tr) =>
Vert tr slc v -> ()
NFData)

instance (Show e, Show a, Show v) => Show (Vert e a v) where
  show :: Vert e a v -> String
show (Vert Slice a
top v
op TItem e a v
m) =
    String
"Vert"
      forall a. Semigroup a => a -> a -> a
<> String
"\n top: "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Slice a
top
      forall a. Semigroup a => a -> a -> a
<> String
"\n op:  "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show v
op
      forall a. Semigroup a => a -> a -> a
<> String
"\n m:   "
      forall a. Semigroup a => a -> a -> a
<> 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 v = VChart
  { forall tr slc v. VChart tr slc v -> Int
vcNextId :: !Int
  -- ^ next free ID
  , forall tr slc v. VChart tr slc 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 v. VChart tr slc v -> IntMap [Vert tr slc v]
vcByLength :: !(IM.IntMap [Vert tr slc v])
  -- ^ maps surface length to the 'Vert' with that length
  , forall tr slc v.
VChart tr slc v -> IntMap (Set (Slice slc, Slice slc))
vcByLengthLeft :: !(IM.IntMap (Set.Set (Slice slc, Slice slc)))
  -- ^ maps surface length to the "left borders" of 'Vert' objects with that length
  -- (parent slice, left child slice)
  , forall tr slc v.
VChart tr slc v -> HashMap (Int, Int) (Set (Slice slc))
vcByLeftChild :: !(HM.HashMap (Int, Int) (Set.Set (Slice slc)))
  -- ^ maps a left child slice ID and the surface length of the middle transition
  -- to its potential parent slices
  , forall tr slc v.
VChart tr slc v -> HashMap (Int, Int) [Vert tr slc v]
vcByRightChild :: !(HM.HashMap (Int, Int) [Vert tr slc 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 a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tr slc v x. Rep (VChart tr slc v) x -> VChart tr slc v
forall tr slc v x. VChart tr slc v -> Rep (VChart tr slc v) x
$cto :: forall tr slc v x. Rep (VChart tr slc v) x -> VChart tr slc v
$cfrom :: forall tr slc v x. VChart tr slc v -> Rep (VChart tr slc v) x
Generic, forall a. (a -> ()) -> NFData a
forall tr slc v.
(NFData slc, NFData v, NFData tr) =>
VChart tr slc v -> ()
rnf :: VChart tr slc v -> ()
$crnf :: forall tr slc v.
(NFData slc, NFData v, NFData tr) =>
VChart tr slc v -> ()
NFData)

instance (Show e, Show a, Show v) => Show (VChart e a v) where
  show :: VChart e a v -> String
show (VChart Int
n HashMap (Int, Int) Int
_ IntMap [Vert e a v]
is IntMap (Set (Slice a, Slice a))
_ HashMap (Int, Int) (Set (Slice a))
_ HashMap (Int, Int) [Vert e a v]
_) = String
"VChart (next id: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n forall a. Semigroup a => a -> a -> a
<> String
")" forall a. Semigroup a => a -> a -> a
<> String
levels
   where
    levels :: String
levels = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {t :: * -> *} {a}.
(Show a, Foldable t, Show a) =>
(a, t a) -> String
showLevel forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> [(Int, a)]
IM.toAscList IntMap [Vert e a v]
is
    showLevel :: (a, t a) -> String
showLevel (a
l, t a
items) = String
"\nlevel " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
l forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> String
sitems
     where
      sitems :: String
sitems = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String
"\n  " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 e a v
vcEmpty :: forall e a v. Int -> VChart e a v
vcEmpty Int
n = forall tr slc v.
Int
-> HashMap (Int, Int) Int
-> IntMap [Vert tr slc v]
-> IntMap (Set (Slice slc, Slice slc))
-> HashMap (Int, Int) (Set (Slice slc))
-> HashMap (Int, Int) [Vert tr slc v]
-> VChart tr slc v
VChart (Int
n forall a. Num a => a -> a -> a
+ Int
1) forall k v. HashMap k v
HM.empty forall a. IntMap a
IM.empty forall a. IntMap a
IM.empty forall k v. HashMap k v
HM.empty forall k v. HashMap k v
HM.empty

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

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

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

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

{- | Returns the all potential parents of a left child slice
 up to a certain middle transition length.
-}
vcGetByLeftChild
  :: (Ord slc, Hashable slc)
  => Int
  -- ^ maximum middle transition length
  -> VChart tr slc v
  -- ^ the chart
  -> Slice slc
  -- ^ the left child slice
  -> [Slice slc]
  -- ^ all potential parent slices
vcGetByLeftChild :: forall slc tr v.
(Ord slc, Hashable slc) =>
Int -> VChart tr slc v -> Slice slc -> [Slice slc]
vcGetByLeftChild Int
maxn VChart tr slc v
chart Slice slc
left =
  forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Int -> Maybe (Set (Slice slc))
getN [Int
2 .. Int
maxn]
 where
  getN :: Int -> Maybe (Set (Slice slc))
getN Int
n = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (forall slc. Slice slc -> Int
sID Slice slc
left, Int
n) forall a b. (a -> b) -> a -> b
$ forall tr slc v.
VChart tr slc v -> HashMap (Int, Int) (Set (Slice slc))
vcByLeftChild VChart tr slc 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 v
  -> Slice slc
  -> [Vert tr slc v]
vcGetByRightChild :: forall slc tr v.
(Ord slc, Hashable slc) =>
Int -> VChart tr slc v -> Slice slc -> [Vert tr slc v]
vcGetByRightChild Int
maxn VChart tr slc v
chart Slice slc
right =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Int -> Maybe [Vert tr slc v]
getN [Int
2 .. Int
maxn]
 where
  getN :: Int -> Maybe [Vert tr slc v]
getN Int
n = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (forall slc. Slice slc -> Int
sID Slice slc
right, Int
n) forall a b. (a -> b) -> a -> b
$ forall tr slc v.
VChart tr slc v -> HashMap (Int, Int) [Vert tr slc v]
vcByRightChild VChart tr slc 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
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
showList :: [TChart tr slc v] -> ShowS
$cshowList :: forall tr slc v. (Show slc, Show tr) => [TChart tr slc v] -> ShowS
show :: TChart tr slc v -> String
$cshow :: forall tr slc v. (Show slc, Show tr) => TChart tr slc v -> String
showsPrec :: Int -> TChart tr slc v -> ShowS
$cshowsPrec :: forall tr slc v.
(Show slc, Show tr) =>
Int -> TChart tr slc v -> ShowS
Show, 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
$cto :: forall tr slc v x. Rep (TChart tr slc v) x -> TChart tr slc v
$cfrom :: forall tr slc v x. TChart tr slc v -> Rep (TChart tr slc v) x
Generic, forall a. (a -> ()) -> NFData a
forall tr slc v.
(NFData slc, NFData tr, NFData v) =>
TChart tr slc v -> ()
rnf :: TChart tr slc v -> ()
$crnf :: forall tr slc v.
(NFData slc, NFData tr, NFData v) =>
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 = 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 forall a. IntMap a
IM.empty forall k v. HashMap k v
HM.empty 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 = forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton (Transition tr slc
t, forall s i. Score s i -> Maybe (LeftId i)
S.leftSide Score v Int
v, 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' = 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 (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' = 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 (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' = 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 (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 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 = forall k v.
(Eq k, Hashable 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 -> 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {i} {b} {c} {v}. ((i, b, c), Score v Int) -> Item i v
mkItem forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
HM.toList forall a b. (a -> b) -> a -> b
$ TContents tr slc v -> k -> m -> TContents tr slc v
getter forall k v. HashMap k v
HM.empty k
key 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 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 = 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 forall tr slc v. TChart tr slc v -> IntMap (TContents tr slc v)
tcByLength 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 = 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 forall tr slc v.
TChart tr slc v -> HashMap (Slice slc) (TContents tr slc v)
tcByLeft 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 = 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 forall tr slc v.
TChart tr slc v -> HashMap (Slice slc) (TContents tr slc v)
tcByRight 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 v
  -- ^ the UnspreadMiddle evaluator
  -> TItem tr slc v
  -- ^ the middle transition
  -> Maybe (slc, v, TItem tr slc v)
  -- ^ the top slice, unspread operation,
  -- and middle transition
unspreadMiddle :: forall tr slc v.
UnspreadMiddle tr slc v
-> TItem tr slc v -> Maybe (slc, v, TItem tr slc v)
unspreadMiddle UnspreadMiddle tr slc v
unspreadm im :: TItem tr slc v
im@((Transition Slice slc
l tr
m Slice slc
r Bool
_) := Score v Int
_) = do
  slc
il <- forall a. StartStop a -> Maybe a
getInner forall a b. (a -> b) -> a -> b
$ forall slc. Slice slc -> StartStop slc
sContent Slice slc
l
  slc
ir <- forall a. StartStop a -> Maybe a
getInner forall a b. (a -> b) -> a -> b
$ forall slc. Slice slc -> StartStop slc
sContent Slice slc
r
  (slc
top, v
op) <- UnspreadMiddle tr slc v
unspreadm (slc
il, tr
m, slc
ir)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (slc
top, v
op, TItem tr slc v
im)

-- | Infers the possible left parent transitions of an unspread.
unspreadLeft
  :: (Show slc, Show tr, R.Semiring v, Show v)
  => UnspreadLeft tr slc
  -- ^ the UnspreadLeft evaluator
  -> TItem tr slc v
  -- ^ the left child transition
  -> Slice slc
  -- ^ the Vert's top slice and ID
  -> [TItem tr slc v]
  -- ^ all possible left parent transitions
unspreadLeft :: forall slc tr v.
(Show slc, Show tr, Semiring v, Show v) =>
UnspreadLeft tr slc
-> TItem tr slc v -> Slice slc -> [TItem tr slc v]
unspreadLeft UnspreadLeft tr slc
unspreadl (tleft :: Transition tr slc
tleft@(Transition Slice slc
ll tr
lt Slice slc
lr Bool
is2nd) := Score v Int
vleft) Slice slc
top
  | Bool
is2nd = []
  | Bool
otherwise = forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err forall a b. (a -> b) -> a -> b
$ do
      slc
ir <- forall a. StartStop a -> Maybe a
getInner forall a b. (a -> b) -> a -> b
$ forall slc. Slice slc -> StartStop slc
sContent Slice slc
lr
      slc
itop <- forall a. StartStop a -> Maybe a
getInner forall a b. (a -> b) -> a -> b
$ forall slc. Slice slc -> StartStop slc
sContent Slice slc
top
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {v} {tr}. Score v Int -> tr -> Item (Transition tr slc) v
mkParent Score v Int
v' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnspreadLeft tr slc
unspreadl (tr
lt, slc
ir) slc
itop
 where
  err :: a
err =
    forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
      String
"Illegal left-unspread: left="
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Transition tr slc
tleft
        forall a. Semigroup a => a -> a -> a
<> String
", top="
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Slice slc
top
  v' :: Score v Int
v' = forall s i.
(Eq i, Show i, Semiring s, Show s) =>
i -> Score s i -> Score s i
S.unspreadScoresLeft (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 = forall tr slc.
Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
Transition Slice slc
ll tr
t Slice slc
top Bool
False 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)
  => UnspreadRight tr slc
  -- ^ the UnspreadRight evaluator
  -> Vert tr slc 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.
(Semiring v, NFData slc, NFData tr, NFData v, Show tr, Show slc,
 Show v) =>
UnspreadRight tr slc
-> Vert tr slc v -> TItem tr slc v -> [TItem tr slc v]
unspreadRight UnspreadRight tr slc
unspreadr vert :: Vert tr slc v
vert@(Vert Slice slc
top v
op (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) =
  forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err forall a b. (a -> b) -> a -> b
$ do
    slc
ir <- forall a. StartStop a -> Maybe a
getInner forall a b. (a -> b) -> a -> b
$ forall slc. Slice slc -> StartStop slc
sContent Slice slc
rl
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> a
force forall a b. (a -> b) -> a -> b
$ forall {v} {tr}. Score v Int -> tr -> Item (Transition tr slc) v
mkParent Score v Int
v' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnspreadRight tr slc
unspreadr (slc
ir, tr
rt) slc
ir
 where
  err :: a
err =
    forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
      String
"Illegal right-unspread: vert="
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Vert tr slc v
vert
        forall a. Semigroup a => a -> a -> a
<> String
", right="
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TItem tr slc v
tright
  v' :: Score v Int
v' = forall i s.
(Eq i, Semiring s, Show i, Show s) =>
i -> s -> Score s i -> Score s i -> Score s i
S.unspreadScoresRight (forall slc. Slice slc -> Int
sID Slice slc
top) v
op 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 = forall tr slc.
Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
Transition Slice slc
top tr
t Slice slc
rr Bool
True 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 forall a. StartStop a -> Maybe a
getInner forall a b. (a -> b) -> a -> b
$ forall slc. Slice slc -> StartStop slc
sContent Slice slc
lr of
    Just slc
m ->
      forall a. NFData a => a -> a
force forall a b. (a -> b) -> a -> b
$ forall {tr}. (tr, v) -> Item (Transition tr slc) v
mkItem forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unsplit tr slc v
mg (forall slc. Slice slc -> StartStop slc
sContent Slice slc
ll) tr
lt slc
m tr
rt (forall slc. Slice slc -> StartStop slc
sContent Slice slc
rr) SplitType
splitType
    Maybe slc
Nothing -> forall a. HasCallStack => String -> a
error String
"trying to unsplit at a non-content slice"
 where
  splitType :: SplitType
splitType
    | Bool
l2nd = SplitType
RightOfTwo
    | forall a. StartStop a -> Bool
isStop (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) = forall tr slc.
Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
Transition Slice slc
ll tr
top Slice slc
rr Bool
l2nd forall i v. i -> Score v Int -> Item i v
:= 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 = forall a. Strategy a -> a -> a
P.withStrategy (forall a. Strategy a -> Strategy [a]
P.parList forall a. NFData a => Strategy a
P.rdeepseq) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 v = (TChart tr slc v, VChart tr slc 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 v = Int -> ParseState tr slc v -> m (ParseState tr slc v)

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

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

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

    -- middle = n (and left < n)
    midn :: [[TItem tr slc v]]
midn =
      forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall slc tr v.
(Show slc, Show tr, Semiring v, Show v) =>
UnspreadLeft tr slc
-> TItem tr slc v -> Slice slc -> [TItem tr slc v]
unspreadLeft UnspreadLeft tr slc
evalLeft) forall a b. NFData a => (a -> b) -> a -> b
$!! do
        -- in list monad
        (Slice slc
top, Slice slc
lslice) <- forall tr slc v. VChart tr slc v -> Int -> [(Slice slc, Slice slc)]
vcGetByLengthLeft VChart tr slc v
vchart Int
n
        TItem tr slc v
left <-
          forall a. (a -> Bool) -> [a] -> [a]
filter (\TItem tr slc v
item -> forall e a. Transition e a -> Int
transLen (forall i v. Item i v -> i
iItem TItem tr slc v
item) forall a. Ord a => a -> a -> Bool
< Int
n) forall a b. (a -> b) -> a -> b
$
            forall slc tr v.
(Ord slc, Hashable slc) =>
TChart tr slc v -> Slice slc -> [TItem tr slc v]
tcGetByRight TChart tr slc v
tchart Slice slc
lslice
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (TItem tr slc v
left, Slice slc
top)

    -- insert new transitions into chart
    tchart' :: TChart tr slc v
tchart' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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
  forall (m :: * -> *) a. Monad m => a -> m a
return (TChart tr slc v
tchart', VChart tr slc v
vchart)

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

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

    -- insert new transitions into chart
    !tchart' :: TChart tr slc v
tchart' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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
  forall (m :: * -> *) a. Monad m => a -> m a
return (TChart tr slc v
tchart', VChart tr slc v
vchart)

-- | perform all unsplits where either @l@ or @r@ have length @n@
unsplitAll
  :: forall tr slc v m
   . (Monad m, Parsable tr slc v)
  => Unsplit tr slc v
  -> ParseOp m tr slc v
unsplitAll :: forall tr slc v (m :: * -> *).
(Monad m, Parsable tr slc v) =>
Unsplit tr slc v -> ParseOp m tr slc v
unsplitAll Unsplit tr slc v
unsplitter Int
n (!TChart tr slc v
tchart, !VChart tr slc v
vchart) = do
  let !byLen :: [TItem tr slc v]
byLen = forall a. NFData a => a -> a
force forall a b. (a -> b) -> a -> b
$ 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 =
        forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (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)) forall a b. NFData a => (a -> b) -> a -> b
$!! do
          TItem tr slc v
left <- [TItem tr slc v]
byLen
          TItem tr slc v
right <-
            forall a. (a -> Bool) -> [a] -> [a]
filter (\TItem tr slc v
r -> forall e a. Transition e a -> Int
transLen (forall i v. Item i v -> i
iItem TItem tr slc v
r) forall a. Ord a => a -> a -> Bool
<= Int
n) forall a b. (a -> b) -> a -> b
$
              forall slc tr v.
(Ord slc, Hashable slc) =>
TChart tr slc v -> Slice slc -> [TItem tr slc v]
tcGetByLeft TChart tr slc v
tchart (forall tr slc. Transition tr slc -> Slice slc
tRightSlice forall a b. (a -> b) -> a -> b
$ forall i v. Item i v -> i
iItem TItem tr slc v
left)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (TItem tr slc v
left, TItem tr slc v
right)

      -- right = n (and left < n)
      !rightn :: [[TItem tr slc v]]
rightn =
        forall b a. NFData b => (a -> b) -> [a] -> [b]
pmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (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)) forall a b. NFData a => (a -> b) -> a -> b
$!! do
          TItem tr slc v
right <- [TItem tr slc v]
byLen
          TItem tr slc v
left <-
            forall a. (a -> Bool) -> [a] -> [a]
filter (\TItem tr slc v
l -> forall e a. Transition e a -> Int
transLen (forall i v. Item i v -> i
iItem TItem tr slc v
l) forall a. Ord a => a -> a -> Bool
< Int
n) forall a b. (a -> b) -> a -> b
$
              forall slc tr v.
(Ord slc, Hashable slc) =>
TChart tr slc v -> Slice slc -> [TItem tr slc v]
tcGetByRight TChart tr slc v
tchart (forall tr slc. Transition tr slc -> Slice slc
tLeftSlice forall a b. (a -> b) -> a -> b
$ forall i v. Item i v -> i
iItem TItem tr slc v
right)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (TItem tr slc v
left, TItem tr slc v
right)

      -- insert new transitions into chart
      !tchart' :: TChart tr slc v
tchart' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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
  forall (m :: * -> *) a. Monad m => a -> m a
return (TChart tr slc v
tchart', VChart tr slc 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 v
  => (TChart tr slc v -> Either (VChart tr slc v) [Slice slc] -> Int -> IO ())
  -- ^ logging function
  -> Eval tr tr' slc slc' 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 v tr' slc'.
Parsable tr slc v =>
(TChart tr slc v
 -> Either (VChart tr slc v) [Slice slc] -> Int -> IO ())
-> Eval tr tr' slc slc' v -> Path slc' tr' -> IO v
parse TChart tr slc v
-> Either (VChart tr slc v) [Slice slc] -> Int -> IO ()
logCharts Eval tr tr' slc slc' v
eval Path slc' tr'
path = do
  TChart tr slc v
-> Either (VChart tr slc v) [Slice slc] -> Int -> IO ()
logCharts TChart tr slc v
tinit (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. Path a b -> [a]
pathArounds Path (Slice slc) (Maybe tr')
slicePath) Int
1
  (TChart tr slc v
tfinal, VChart tr slc v
vfinal) <-
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
      (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall tr slc v tr' slc'.
Parsable tr slc v =>
(TChart tr slc v -> VChart tr slc v -> Int -> IO ())
-> Eval tr tr' slc slc' v -> ParseOp IO tr slc v
parseStep (\TChart tr slc v
t VChart tr slc v
v Int
i -> TChart tr slc v
-> Either (VChart tr slc v) [Slice slc] -> Int -> IO ()
logCharts TChart tr slc v
t (forall a b. a -> Either a b
Left VChart tr slc v
v) Int
i) Eval tr tr' slc slc' v
eval)
      (TChart tr slc v
tinit, forall e a v. Int -> VChart e a v
vcEmpty Int
len)
      [Int
2 .. Int
len forall a. Num a => a -> a -> a
- Int
1]
  TChart tr slc v
-> Either (VChart tr slc v) [Slice slc] -> Int -> IO ()
logCharts TChart tr slc v
tfinal (forall a b. a -> Either a b
Left VChart tr slc v
vfinal) Int
len
  let goals :: [TItem tr slc v]
goals = forall tr slc v. TChart tr slc v -> Int -> [TItem tr slc v]
tcGetByLength TChart tr slc v
tfinal Int
len
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Semiring a) => t a -> a
R.sum forall a b. (a -> b) -> a -> b
$ forall s i. Score s i -> s
S.getScoreVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i v. Item i v -> Score v Int
iScore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TItem tr slc v]
goals
 where
  wrapPath :: Path a a -> Path (StartStop a) (Maybe a)
wrapPath (Path a
a a
e Path a a
rst) = forall around between.
around -> between -> Path around between -> Path around between
Path (forall a. a -> StartStop a
Inner a
a) (forall a. a -> Maybe a
Just a
e) forall a b. (a -> b) -> a -> b
$ Path a a -> Path (StartStop a) (Maybe a)
wrapPath Path a a
rst
  wrapPath (PathEnd a
a) = forall around between.
around -> between -> Path around between -> Path around between
Path (forall a. a -> StartStop a
Inner a
a) forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall around between. around -> Path around between
PathEnd forall a. StartStop a
Stop
  path' :: Path (StartStop slc') (Maybe tr')
path' = forall around between.
around -> between -> Path around between -> Path around between
Path forall a. StartStop a
Start forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall {a} {a}. Path a a -> Path (StartStop a) (Maybe a)
wrapPath Path slc' tr'
path
  len :: Int
len = forall a b. Path a b -> Int
pathLen Path (StartStop slc') (Maybe tr')
path'
  slicePath :: Path (Slice slc) (Maybe tr')
slicePath =
    forall a a' b. Int -> (Int -> a -> a') -> Path a b -> Path a' b
mapAroundsWithIndex
      Int
0
      (\Int
i StartStop slc'
notes -> forall slc. Int -> StartStop slc -> Int -> Int -> Slice slc
Slice Int
i (forall tr tr' slc slc' v. Eval tr tr' slc slc' v -> slc' -> slc
evalSlice Eval tr tr' slc slc' v
eval 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 =
    forall {tr} {v}. (tr, v) -> Item (Transition tr slc) v
mk
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall tr tr' slc slc' v.
Eval tr tr' slc slc' v
-> StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
evalUnfreeze
        Eval tr tr' slc slc' v
eval
        (forall slc. Slice slc -> StartStop slc
sContent Slice slc
l)
        Maybe tr'
esurf
        (forall slc. Slice slc -> StartStop slc
sContent Slice slc
r)
        (forall a. StartStop a -> Bool
isStop forall a b. (a -> b) -> a -> b
$ forall slc. Slice slc -> StartStop slc
sContent Slice slc
r)
   where
    mk :: (tr, v) -> Item (Transition tr slc) v
mk (tr
e, v
v) = forall tr slc.
Slice slc -> tr -> Slice slc -> Bool -> Transition tr slc
Transition Slice slc
l tr
e Slice slc
r Bool
False forall i v. i -> Score v Int -> Item i v
:= forall s i. s -> Score s i
S.val v
v
  trans0 :: [[TItem tr slc v]]
trans0 = 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 = 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 forall tr slc v. TChart tr slc v
tcEmpty forall a b. (a -> b) -> a -> b
$ 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 v2) [Slice slc2] -> Int -> IO ()
logSize :: forall tr1 slc1 v1 tr2 slc2 v2.
TChart tr1 slc1 v1
-> Either (VChart tr2 slc2 v2) [Slice slc2] -> Int -> IO ()
logSize TChart tr1 slc1 v1
tc Either (VChart tr2 slc2 v2) [Slice slc2]
vc Int
n = do
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"parsing level " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"transitions: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ 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 v2) [Slice slc2]
vc of
        Left VChart tr2 slc2 v2
chart -> forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall tr slc v. VChart tr slc v -> Int -> [Vert tr slc v]
vcGetByLength VChart tr2 slc2 v2
chart (Int
n forall a. Num a => a -> a -> a
- Int
1)
        Right [Slice slc2]
lst -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [Slice slc2]
lst
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"verts: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
nverts

-- | Parse a piece using the 'logSize' logging function.
parseSize :: Parsable tr slc v => Eval tr tr' slc slc' v -> Path slc' tr' -> IO v
parseSize :: forall tr slc v tr' slc'.
Parsable tr slc v =>
Eval tr tr' slc slc' v -> Path slc' tr' -> IO v
parseSize = forall tr slc v tr' slc'.
Parsable tr slc v =>
(TChart tr slc v
 -> Either (VChart tr slc v) [Slice slc] -> Int -> IO ())
-> Eval tr tr' slc slc' v -> Path slc' tr' -> IO v
parse forall tr1 slc1 v1 tr2 slc2 v2.
TChart tr1 slc1 v1
-> Either (VChart tr2 slc2 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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Parse a piece without logging.
parseSilent :: Parsable tr slc v => Eval tr tr' slc slc' v -> Path slc' tr' -> IO v
parseSilent :: forall tr slc v tr' slc'.
Parsable tr slc v =>
Eval tr tr' slc slc' v -> Path slc' tr' -> IO v
parseSilent = forall tr slc v tr' slc'.
Parsable tr slc v =>
(TChart tr slc v
 -> Either (VChart tr slc v) [Slice slc] -> Int -> IO ())
-> Eval tr tr' slc slc' v -> Path slc' tr' -> IO v
parse 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 forall a b. (a -> b) -> a -> b
$
    String
"    \\node[slice,align=center] (slice"
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
sid
      forall a. Semigroup a => a -> a -> a
<> String
") at ("
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
f forall a. Num a => a -> a -> a
+ Int
l) forall a. Fractional a => a -> a -> a
/ Double
2.0)
      forall a. Semigroup a => a -> a -> a
<> String
",0) {"
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
showTex StartStop slc
sc
      forall a. Semigroup a => a -> a -> a
<> String
"\\\\ "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
sid
      forall a. Semigroup a => a -> a -> a
<> String
"};"

-- | Generate TikZ code for a verticalization.
printTikzVert :: IntMap a -> Vert tr slc v -> IO (IntMap a)
printTikzVert IntMap a
neighbors (Vert top :: Slice slc
top@(Slice Int
f StartStop slc
c Int
i Int
l) v
_ TItem tr slc v
middle) = do
  let index :: Int
index = Int
f forall a. Num a => a -> a -> a
+ Int
l
      xpos :: Double
xpos = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
f forall a. Num a => a -> a -> a
+ Int
l) forall a. Fractional a => a -> a -> a
/ Double
2.0
      ypos :: a
ypos = forall a. a -> Int -> IntMap a -> a
IM.findWithDefault a
0 Int
index IntMap a
neighbors
      neighbors' :: IntMap a
neighbors' =
        forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter
          ( \case
              Just a
n -> forall a. a -> Maybe a
Just (a
n forall a. Num a => a -> a -> a
+ a
1)
              Maybe a
Nothing -> forall a. a -> Maybe a
Just a
1
          )
          Int
index
          IntMap a
neighbors
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
    String
"    \\node[slice,align=center] (slice"
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i
      forall a. Semigroup a => a -> a -> a
<> String
") at ("
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Double
xpos
      forall a. Semigroup a => a -> a -> a
<> String
","
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
ypos
      forall a. Semigroup a => a -> a -> a
<> String
") {"
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
showTex StartStop slc
c
      forall a. Semigroup a => a -> a -> a
<> String
"\\\\ ("
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall slc. Slice slc -> Int
sID forall a b. (a -> b) -> a -> b
$ forall tr slc. Transition tr slc -> Slice slc
tLeftSlice forall a b. (a -> b) -> a -> b
$ forall i v. Item i v -> i
iItem TItem tr slc v
middle)
      forall a. Semigroup a => a -> a -> a
<> String
") - "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i
      forall a. Semigroup a => a -> a -> a
<> String
" - ("
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall slc. Slice slc -> Int
sID forall a b. (a -> b) -> a -> b
$ forall tr slc. Transition tr slc -> Slice slc
tRightSlice forall a b. (a -> b) -> a -> b
$ forall i v. Item i v -> i
iItem TItem tr slc v
middle)
      forall a. Semigroup a => a -> a -> a
<> String
")};"
  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" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall a. Hashable a => a -> Int
hash Transition tr slc
t)
      index :: Int
index = forall slc. Slice slc -> Int
sFirst Slice slc
sl forall a. Num a => a -> a -> a
+ forall slc. Slice slc -> Int
sLast Slice slc
sr
      xpos :: Double
xpos = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index forall a. Fractional a => a -> a -> a
/ Double
2.0
      ypos :: a
ypos = forall a. a -> Int -> IntMap a -> a
IM.findWithDefault a
0 Int
index IntMap a
neighbors
      neighbors' :: IntMap a
neighbors' =
        forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter
          ( \case
              Just a
n -> forall a. a -> Maybe a
Just (a
n forall a. Num a => a -> a -> a
+ a
1)
              Maybe a
Nothing -> forall a. a -> Maybe a
Just a
1
          )
          Int
index
          IntMap a
neighbors
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
    String
"  \\begin{scope}[xshift="
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Double
xpos
      forall a. Semigroup a => a -> a -> a
<> String
"cm,yshift="
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
ypos
      forall a. Semigroup a => a -> a -> a
<> String
"cm]"
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
    String
"    \\node[slice] ("
      forall a. Semigroup a => a -> a -> a
<> String
tid
      forall a. Semigroup a => a -> a -> a
<> String
"left) at (-0.1,0) {"
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall slc. Slice slc -> Int
sID Slice slc
sl)
      forall a. Semigroup a => a -> a -> a
<> String
"};"
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
    String
"    \\node[slice] ("
      forall a. Semigroup a => a -> a -> a
<> String
tid
      forall a. Semigroup a => a -> a -> a
<> String
"right) at (0.1,0) {"
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall slc. Slice slc -> Int
sID Slice slc
sr)
      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 forall a b. (a -> b) -> a -> b
$
    String
"    \\draw[transition] ("
      forall a. Semigroup a => a -> a -> a
<> String
tid
      forall a. Semigroup a => a -> a -> a
<> String
"left) -- ("
      forall a. Semigroup a => a -> a -> a
<> String
tid
      forall a. Semigroup a => a -> a -> a
<> String
"right);"
  String -> IO ()
putStrLn String
"  \\end{scope}"
  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 v) (t (Slice slc)) -> Int -> IO ()
logTikz TChart tr slc v
tc Either (VChart tr slc v) (t (Slice slc))
vc Int
n = do
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"\n% level " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n
  let rel :: String
rel =
        if Int
n forall a. Ord a => a -> a -> Bool
<= Int
2
          then String
""
          else String
",shift={($(0,0 |- scope" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Int
n forall a. Num a => a -> a -> a
- Int
1) forall a. Semigroup a => a -> a -> a
<> String
".north)+(0,1cm)$)}"
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"\\begin{scope}[local bounding box=scope" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n forall a. Semigroup a => a -> a -> a
<> String
rel forall a. Semigroup a => a -> a -> a
<> String
"]"
  String -> IO ()
putStrLn String
"  % verticalizations:"
  case Either (VChart tr slc v) (t (Slice slc))
vc of
    Left VChart tr slc v
chart -> forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ forall {a} {slc} {tr} {v}.
(Show a, Show slc, Num a) =>
IntMap a -> Vert tr slc v -> IO (IntMap a)
printTikzVert forall a. IntMap a
IM.empty forall a b. (a -> b) -> a -> b
$ forall tr slc v. VChart tr slc v -> Int -> [Vert tr slc v]
vcGetByLength VChart tr slc v
chart (Int
n forall a. Num a => a -> a -> a
- Int
1)
    Right t (Slice slc)
lst -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall slc. Show slc => Slice slc -> IO ()
printTikzSlice t (Slice slc)
lst
  String -> IO ()
putStrLn String
"\n  % transitions:"
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ forall {a} {tr} {slc}.
(Show a, Num a, Hashable tr, Eq slc) =>
IntMap a -> Transition tr slc -> IO (IntMap a)
printTikzTrans forall a. IntMap a
IM.empty forall a b. (a -> b) -> a -> b
$ forall i v. Item i v -> i
iItem forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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}"