{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}

{- | /This module is deprecated, use "Scoring.FunTyped" instead./

 Semiring scores with "holes".
 Holes are used to express "partially applied" scores that occur
 when the score of a verticalization (unspread) is distributed to two parent edges.
 The full score of the operation is restored when the two parent edges are eventually combined again.

 This module implements partial scores using lists,
 which is slow and not very elegant.
 The grammar combinators are partial and will fail if used incorrectly,
 indicating parser bugs.
-}
module Scoring.Deprecated.Flat
  ( -- * The Score Type
    Score (..)
  , Holes
  , val
  , LeftId (..)
  , RightId (..)
  , leftSide
  , rightSide
  , showScore

    -- * Semiring operations

    -- | Semiring operations can be lifted to partial scores,
    -- but since it is not guaranteed that their arguments can be combined,
    -- they are partial.
  , times
  , plus

    -- * grammatical combinators

    -- | The following combinators correspond to the unsplit and unspread operations
    -- of the path-graph grammar.
  , unsplitScores
  , unspreadScoresLeft
  , unspreadScoresRight
  , addScores
  , getScoreVal
  ) where

import Control.DeepSeq (NFData)
import Data.Bifunctor (first)
import Data.Foldable (foldl')
import Data.Hashable (Hashable)
import Data.List qualified as L
import Data.Maybe (fromMaybe)
import Data.Semiring qualified as R
import GHC.Generics (Generic)

----------------
-- Score type --
----------------

-- | Newtype for the left ID of a partial score.
newtype LeftId i = LeftId i
  deriving (LeftId i -> LeftId i -> Bool
forall i. Eq i => LeftId i -> LeftId i -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LeftId i -> LeftId i -> Bool
$c/= :: forall i. Eq i => LeftId i -> LeftId i -> Bool
== :: LeftId i -> LeftId i -> Bool
$c== :: forall i. Eq i => LeftId i -> LeftId i -> Bool
Eq, LeftId i -> LeftId i -> Bool
LeftId i -> LeftId i -> Ordering
LeftId i -> LeftId i -> LeftId i
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 {i}. Ord i => Eq (LeftId i)
forall i. Ord i => LeftId i -> LeftId i -> Bool
forall i. Ord i => LeftId i -> LeftId i -> Ordering
forall i. Ord i => LeftId i -> LeftId i -> LeftId i
min :: LeftId i -> LeftId i -> LeftId i
$cmin :: forall i. Ord i => LeftId i -> LeftId i -> LeftId i
max :: LeftId i -> LeftId i -> LeftId i
$cmax :: forall i. Ord i => LeftId i -> LeftId i -> LeftId i
>= :: LeftId i -> LeftId i -> Bool
$c>= :: forall i. Ord i => LeftId i -> LeftId i -> Bool
> :: LeftId i -> LeftId i -> Bool
$c> :: forall i. Ord i => LeftId i -> LeftId i -> Bool
<= :: LeftId i -> LeftId i -> Bool
$c<= :: forall i. Ord i => LeftId i -> LeftId i -> Bool
< :: LeftId i -> LeftId i -> Bool
$c< :: forall i. Ord i => LeftId i -> LeftId i -> Bool
compare :: LeftId i -> LeftId i -> Ordering
$ccompare :: forall i. Ord i => LeftId i -> LeftId i -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall i x. Rep (LeftId i) x -> LeftId i
forall i x. LeftId i -> Rep (LeftId i) x
$cto :: forall i x. Rep (LeftId i) x -> LeftId i
$cfrom :: forall i x. LeftId i -> Rep (LeftId i) x
Generic)
  deriving anyclass (forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {i}. Hashable i => Eq (LeftId i)
forall i. Hashable i => Int -> LeftId i -> Int
forall i. Hashable i => LeftId i -> Int
hash :: LeftId i -> Int
$chash :: forall i. Hashable i => LeftId i -> Int
hashWithSalt :: Int -> LeftId i -> Int
$chashWithSalt :: forall i. Hashable i => Int -> LeftId i -> Int
Hashable, forall i. NFData i => LeftId i -> ()
forall a. (a -> ()) -> NFData a
rnf :: LeftId i -> ()
$crnf :: forall i. NFData i => LeftId i -> ()
NFData)

instance Show i => Show (LeftId i) where
  show :: LeftId i -> String
show (LeftId i
i) = forall a. Show a => a -> String
show i
i

-- | Newtype for the right ID of a partial score.
newtype RightId i = RightId i
  deriving (RightId i -> RightId i -> Bool
forall i. Eq i => RightId i -> RightId i -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RightId i -> RightId i -> Bool
$c/= :: forall i. Eq i => RightId i -> RightId i -> Bool
== :: RightId i -> RightId i -> Bool
$c== :: forall i. Eq i => RightId i -> RightId i -> Bool
Eq, RightId i -> RightId i -> Bool
RightId i -> RightId i -> Ordering
RightId i -> RightId i -> RightId i
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 {i}. Ord i => Eq (RightId i)
forall i. Ord i => RightId i -> RightId i -> Bool
forall i. Ord i => RightId i -> RightId i -> Ordering
forall i. Ord i => RightId i -> RightId i -> RightId i
min :: RightId i -> RightId i -> RightId i
$cmin :: forall i. Ord i => RightId i -> RightId i -> RightId i
max :: RightId i -> RightId i -> RightId i
$cmax :: forall i. Ord i => RightId i -> RightId i -> RightId i
>= :: RightId i -> RightId i -> Bool
$c>= :: forall i. Ord i => RightId i -> RightId i -> Bool
> :: RightId i -> RightId i -> Bool
$c> :: forall i. Ord i => RightId i -> RightId i -> Bool
<= :: RightId i -> RightId i -> Bool
$c<= :: forall i. Ord i => RightId i -> RightId i -> Bool
< :: RightId i -> RightId i -> Bool
$c< :: forall i. Ord i => RightId i -> RightId i -> Bool
compare :: RightId i -> RightId i -> Ordering
$ccompare :: forall i. Ord i => RightId i -> RightId i -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall i x. Rep (RightId i) x -> RightId i
forall i x. RightId i -> Rep (RightId i) x
$cto :: forall i x. Rep (RightId i) x -> RightId i
$cfrom :: forall i x. RightId i -> Rep (RightId i) x
Generic)
  deriving anyclass (forall i. NFData i => RightId i -> ()
forall a. (a -> ()) -> NFData a
rnf :: RightId i -> ()
$crnf :: forall i. NFData i => RightId i -> ()
NFData, forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {i}. Hashable i => Eq (RightId i)
forall i. Hashable i => Int -> RightId i -> Int
forall i. Hashable i => RightId i -> Int
hash :: RightId i -> Int
$chash :: forall i. Hashable i => RightId i -> Int
hashWithSalt :: Int -> RightId i -> Int
$chashWithSalt :: forall i. Hashable i => Int -> RightId i -> Int
Hashable)

instance Show i => Show (RightId i) where
  show :: RightId i -> String
show (RightId i
i) = forall a. Show a => a -> String
show i
i

match :: Eq a => RightId a -> LeftId a -> Bool
match :: forall a. Eq a => RightId a -> LeftId a -> Bool
match (RightId a
ir) (LeftId a
il) = a
il forall a. Eq a => a -> a -> Bool
== a
ir

-- | A type alias for the holes in a 'Score'.
type Holes s = [s]

{- | A partially applied score of type @s@.
 Comes in four variants,
 depending on whether the score is fully applied
 or needs to be combined on either or both sides.
 Values that need to be combined are lists that represent scores with holes.
 Each variant carries IDs of type @i@ that determine which objects fit on either of its sides.
 Only score objects with matching IDs can be combined.

 As a shorthand notation, we use @a-b@ to indicate a value
 that depends on @a@ on its left and on @b@ on its right.
 If the value does not depend on anything on either side, we use @()@,
 i.e. @()-a@ stands for @SLeft _ a@ and @()-()@ stands for @SVal _@.
-}
data Score s i
  = -- | Carries a fully applied value
    SVal !s
  | -- | The right part of a combination, expects an argument to its left.
    -- Implemented as a list of right elements
    SRight !(LeftId i) ![Holes s]
  | -- | The left part of a combination, expects an argument to its right.
    -- Implemented as a list of right elements
    SLeft ![Holes s] !(RightId i)
  | -- | A combination of 'SLeft' and 'SRight' that expects arguments on both sides.
    -- Implemented as a list of right elements on the left
    -- and a list of left elements to the right
    SBoth !(LeftId i) ![(Holes s, Holes s)] !(RightId i)
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s i x. Rep (Score s i) x -> Score s i
forall s i x. Score s i -> Rep (Score s i) x
$cto :: forall s i x. Rep (Score s i) x -> Score s i
$cfrom :: forall s i x. Score s i -> Rep (Score s i) x
Generic, forall a. (a -> ()) -> NFData a
forall s i. (NFData s, NFData i) => Score s i -> ()
rnf :: Score s i -> ()
$crnf :: forall s i. (NFData s, NFData i) => Score s i -> ()
NFData)

-- | Creates a simple value score of type ()-().
val :: s -> Score s i
val :: forall s i. s -> Score s i
val = forall s i. s -> Score s i
SVal

{- | Returns the ID on the left side of an 'Score',
 or 'Nothing' for 'SVal' and 'SLeft'.

 > a-b -> a
-}
leftSide :: Score s i -> Maybe (LeftId i)
leftSide :: forall s i. Score s i -> Maybe (LeftId i)
leftSide (SVal s
_) = forall a. Maybe a
Nothing
leftSide (SLeft [Holes s]
_ RightId i
_) = forall a. Maybe a
Nothing
leftSide (SRight LeftId i
i [Holes s]
_) = forall a. a -> Maybe a
Just LeftId i
i
leftSide (SBoth LeftId i
i [(Holes s, Holes s)]
_ RightId i
_) = forall a. a -> Maybe a
Just LeftId i
i

{- | Returns the ID on the right side of an 'Score',
 or 'Nothing' for 'SVal' and 'SRight'.

 > a-b -> b
-}
rightSide :: Score s i -> Maybe (RightId i)
rightSide :: forall s i. Score s i -> Maybe (RightId i)
rightSide (SVal s
_) = forall a. Maybe a
Nothing
rightSide (SLeft [Holes s]
_ RightId i
i) = forall a. a -> Maybe a
Just RightId i
i
rightSide (SRight LeftId i
_ [Holes s]
_) = forall a. Maybe a
Nothing
rightSide (SBoth LeftId i
_ [(Holes s, Holes s)]
_ RightId i
i) = forall a. a -> Maybe a
Just RightId i
i

-- Show instance

showLeftHoles :: Show a => [a] -> [Char]
showLeftHoles :: forall a. Show a => [a] -> String
showLeftHoles [a]
ls = forall a. [a] -> [[a]] -> [a]
L.intercalate String
" _ " (forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
ls) forall a. Semigroup a => a -> a -> a
<> String
" _"

showRightHoles :: Show a => [a] -> [Char]
showRightHoles :: forall a. Show a => [a] -> String
showRightHoles [a]
rs = String
"_ " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
L.intercalate String
" _ " (forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
rs)

showBothHoles :: (Show a1, Show a2) => ([a1], [a2]) -> [Char]
showBothHoles :: forall a1 a2. (Show a1, Show a2) => ([a1], [a2]) -> String
showBothHoles ([a1]
ls, [a2]
rs) = forall a. Show a => [a] -> String
showLeftHoles [a1]
ls forall a. Semigroup a => a -> a -> a
<> String
" | " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => [a] -> String
showRightHoles [a2]
rs

showOpts :: (a -> [Char]) -> [a] -> [Char]
showOpts :: forall a. (a -> String) -> [a] -> String
showOpts a -> String
shower [a]
opts = String
"-[" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
L.intercalate String
" / " (a -> String
shower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
opts) forall a. Semigroup a => a -> a -> a
<> String
"]-"

instance (Show i, Show s) => Show (Score s i) where
  show :: Score s i -> String
show (SVal s
s) = String
"()-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show s
s forall a. Semigroup a => a -> a -> a
<> String
"-()"
  show (SLeft [Holes s]
ls RightId i
ir) = String
"()" forall a. Semigroup a => a -> a -> a
<> forall a. (a -> String) -> [a] -> String
showOpts forall a. Show a => [a] -> String
showLeftHoles [Holes s]
ls forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show RightId i
ir
  show (SRight LeftId i
il [Holes s]
rs) = forall a. Show a => a -> String
show LeftId i
il forall a. Semigroup a => a -> a -> a
<> forall a. (a -> String) -> [a] -> String
showOpts forall a. Show a => [a] -> String
showRightHoles [Holes s]
rs forall a. Semigroup a => a -> a -> a
<> String
"()"
  show (SBoth LeftId i
il [(Holes s, Holes s)]
bs RightId i
ir) = forall a. Show a => a -> String
show LeftId i
il forall a. Semigroup a => a -> a -> a
<> forall a. (a -> String) -> [a] -> String
showOpts forall a1 a2. (Show a1, Show a2) => ([a1], [a2]) -> String
showBothHoles [(Holes s, Holes s)]
bs forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show RightId i
ir

-- simplified showing (only "type")

{- | Returns a string representation of a 'Score'
 (more compact than it's 'Show' instance).
-}
showScore :: (Show s, Show i) => Score s i -> String
showScore :: forall s i. (Show s, Show i) => Score s i -> String
showScore (SVal s
v) = forall a. Show a => a -> String
show s
v
showScore (SLeft [Holes s]
_ RightId i
ir) = String
"()-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show RightId i
ir
showScore (SRight LeftId i
il [Holes s]
_) = forall a. Show a => a -> String
show LeftId i
il forall a. Semigroup a => a -> a -> a
<> String
"-()"
showScore (SBoth LeftId i
il [(Holes s, Holes s)]
_ RightId i
ir) = forall a. Show a => a -> String
show LeftId i
il forall a. Semigroup a => a -> a -> a
<> String
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show RightId i
ir

-------------------------
-- semiring operations --
-------------------------

zipHoles :: R.Semiring s => Holes s -> Holes s -> Maybe s
zipHoles :: forall s. Semiring s => Holes s -> Holes s -> Maybe s
zipHoles !Holes s
lefts !Holes s
rights = forall {t}. Semiring t => t -> [t] -> [t] -> Maybe t
go forall a. Semiring a => a
R.one Holes s
lefts Holes s
rights
 where
  go :: t -> [t] -> [t] -> Maybe t
go !t
acc [] [] = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! t
acc
  go !t
acc (t
l : [t]
ls) (t
r : [t]
rs) = t -> [t] -> [t] -> Maybe t
go (t
acc forall a. Semiring a => a -> a -> a
R.* (t
l forall a. Semiring a => a -> a -> a
R.* t
r)) [t]
ls [t]
rs
  go t
_ [t]
_ [t]
_ = forall a. Maybe a
Nothing

combineAlts :: (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c]
combineAlts :: forall a b c. (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c]
combineAlts a -> b -> Maybe c
f [a]
ls [b]
rs = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ a -> b -> Maybe c
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
ls forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [b]
rs

appendRight :: R.Semiring s => s -> Holes s -> Holes s
appendRight :: forall s. Semiring s => s -> Holes s -> Holes s
appendRight !s
s [] = [s
s]
appendRight !s
s [!s
a] = [s
a forall a. Semiring a => a -> a -> a
R.* s
s]
appendRight !s
s (s
a : [s]
as) = s
a forall a. a -> [a] -> [a]
: forall s. Semiring s => s -> Holes s -> Holes s
appendRight s
s [s]
as

prependLeft :: R.Semiring s => s -> Holes s -> Holes s
prependLeft :: forall s. Semiring s => s -> Holes s -> Holes s
prependLeft !s
s [] = [s
s]
prependLeft !s
s (s
a : [s]
as) = (s
s forall a. Semiring a => a -> a -> a
R.* s
a) forall a. a -> [a] -> [a]
: [s]
as

addHoleLeft :: s -> Holes s -> Holes s
addHoleLeft :: forall a. a -> [a] -> [a]
addHoleLeft = (:)

{- | Combines two partially applied 'Score's
 by applying them to each other and/or multiplying the underlying semiring values.
 Shapes and IDs at the adjacent sides must match, otherwise 'Nothing' is returned.

 > a-b × b-c -> a-c
-}
times
  :: (R.Semiring s, Eq i, Show i) => Score s i -> Score s i -> Maybe (Score s i)
-- creates value
times :: forall s i.
(Semiring s, Eq i, Show i) =>
Score s i -> Score s i -> Maybe (Score s i)
times (SVal !s
s1) (SVal !s
s2) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s i. s -> Score s i
SVal forall a b. (a -> b) -> a -> b
$! s
s1 forall a. Semiring a => a -> a -> a
R.* s
s2
times (SLeft ![Holes s]
ls !RightId i
il) (SRight !LeftId i
ir ![Holes s]
rs)
  | RightId i
il forall a. Eq a => RightId a -> LeftId a -> Bool
`match` LeftId i
ir =
      forall s i. s -> Score s i
SVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Semiring a => a -> a -> a
R.plus forall a. Semiring a => a
R.zero forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b c. (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c]
combineAlts forall s. Semiring s => Holes s -> Holes s -> Maybe s
zipHoles [Holes s]
ls [Holes s]
rs
-- creates right
times (SRight !LeftId i
i ![Holes s]
rs) (SVal !s
s) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
i forall a b. (a -> b) -> a -> b
$! forall s. Semiring s => s -> Holes s -> Holes s
appendRight s
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Holes s]
rs
times (SBoth !LeftId i
il ![(Holes s, Holes s)]
bs !RightId i
ir) (SRight !LeftId i
i ![Holes s]
rs)
  | RightId i
ir forall a. Eq a => RightId a -> LeftId a -> Bool
`match` LeftId i
i =
      forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
il forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b c. (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c]
combineAlts forall {a}.
Semiring a =>
(Holes a, Holes a) -> Holes a -> Maybe (Holes a)
bplusr [(Holes s, Holes s)]
bs [Holes s]
rs
 where
  bplusr :: (Holes a, Holes a) -> Holes a -> Maybe (Holes a)
bplusr (Holes a
bl, Holes a
br) Holes a
r = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. Semiring s => s -> Holes s -> Holes s
appendRight Holes a
bl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Semiring s => Holes s -> Holes s -> Maybe s
zipHoles Holes a
br Holes a
r
-- creates left
times (SVal !s
s) (SLeft ![Holes s]
ls !RightId i
i) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s i. [Holes s] -> RightId i -> Score s i
SLeft (forall s. Semiring s => s -> Holes s -> Holes s
prependLeft s
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Holes s]
ls) RightId i
i
times (SLeft ![Holes s]
ls !RightId i
i) (SBoth !LeftId i
il ![(Holes s, Holes s)]
bs !RightId i
ir) | RightId i
i forall a. Eq a => RightId a -> LeftId a -> Bool
`match` LeftId i
il =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s i. [Holes s] -> RightId i -> Score s i
`SLeft` RightId i
ir) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ do
    !Holes s
l <- [Holes s]
ls
    (!Holes s
bl, !Holes s
br) <- [(Holes s, Holes s)]
bs
    let !vl :: Maybe s
vl = forall s. Semiring s => Holes s -> Holes s -> Maybe s
zipHoles Holes s
l Holes s
bl
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. Semiring s => s -> Holes s -> Holes s
prependLeft Holes s
br forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe s
vl
-- creates both
times (SRight !LeftId i
il ![Holes s]
rs) (SLeft ![Holes s]
ls !RightId i
ir) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s i.
LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
SBoth LeftId i
il [(Holes s, Holes s)]
bs RightId i
ir
 where
  bs :: [(Holes s, Holes s)]
bs = do
    !Holes s
l <- [Holes s]
rs
    !Holes s
r <- [Holes s]
ls
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Holes s
l, Holes s
r)
times (SBoth !LeftId i
il ![(Holes s, Holes s)]
as !RightId i
ia) (SBoth !LeftId i
ib ![(Holes s, Holes s)]
bs !RightId i
ir) | RightId i
ia forall a. Eq a => RightId a -> LeftId a -> Bool
`match` LeftId i
ib = do
  -- Maybe
  [(Holes s, Holes s)]
cs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ do
    -- []
    (!Holes s
al, !Holes s
ar) <- [(Holes s, Holes s)]
as
    (!Holes s
bl, !Holes s
br) <- [(Holes s, Holes s)]
bs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! do
      -- Maybe
      !s
vm <- forall s. Semiring s => Holes s -> Holes s -> Maybe s
zipHoles Holes s
ar Holes s
bl
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Holes s
al, forall s. Semiring s => s -> Holes s -> Holes s
prependLeft s
vm Holes s
br)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall s i.
LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
SBoth LeftId i
il [(Holes s, Holes s)]
cs RightId i
ir
-- otherwise
times Score s i
_ Score s i
_ = forall a. Maybe a
Nothing

{- | Adds two partially applied 'Score's
 by adding their underlying (or resulting) semiring values.
 This operation is only admitted
 if the two scores are of the same shape and have matching IDs.
 Otherwise, 'Nothing' is returned.

 > a-b + a-b -> a-b
-}
plus :: (R.Semiring s, Eq i) => Score s i -> Score s i -> Maybe (Score s i)
plus :: forall s i.
(Semiring s, Eq i) =>
Score s i -> Score s i -> Maybe (Score s i)
plus (SVal !s
s1) (SVal !s
s2) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s i. s -> Score s i
SVal (s
s1 forall a. Semiring a => a -> a -> a
R.+ s
s2)
plus (SRight !LeftId i
i ![Holes s]
rs1) (SRight !LeftId i
i' ![Holes s]
rs2)
  | LeftId i
i forall a. Eq a => a -> a -> Bool
== LeftId i
i' =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
i ([Holes s]
rs1 forall a. Semigroup a => a -> a -> a
<> [Holes s]
rs2)
plus (SLeft ![Holes s]
ls1 !RightId i
i) (SLeft ![Holes s]
ls2 !RightId i
i') | RightId i
i forall a. Eq a => a -> a -> Bool
== RightId i
i' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s i. [Holes s] -> RightId i -> Score s i
SLeft ([Holes s]
ls1 forall a. Semigroup a => a -> a -> a
<> [Holes s]
ls2) RightId i
i
plus (SBoth !LeftId i
il ![(Holes s, Holes s)]
bs1 !RightId i
ir) (SBoth !LeftId i
il' ![(Holes s, Holes s)]
bs2 !RightId i
ir')
  | LeftId i
il forall a. Eq a => a -> a -> Bool
== LeftId i
il' Bool -> Bool -> Bool
&& RightId i
ir forall a. Eq a => a -> a -> Bool
== RightId i
ir' =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s i.
LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
SBoth LeftId i
il ([(Holes s, Holes s)]
bs1 forall a. Semigroup a => a -> a -> a
<> [(Holes s, Holes s)]
bs2) RightId i
ir
plus Score s i
_ Score s i
_ = forall a. Maybe a
Nothing

-----------
-- rules --
-----------

{- | Extracts the value from a fully applied 'Score'.
 This function is intended to be used to extract the final score of the parser.
 If the score is not fully applied,
 throws an exception to indicate parser bugs.
-}
getScoreVal :: Score s i -> s
getScoreVal :: forall s i. Score s i -> s
getScoreVal (SVal s
s) = s
s
getScoreVal Score s i
_ = forall a. HasCallStack => String -> a
error String
"cannot get value from partial score"

{- | Adds two 'Score's that are alternative derivations of the same transition.
 This is expected to be called on compatible scores
 and will throw an error otherwise to indicate parser bugs.

 > a-b   a-b
 > --------- add
 >    a-b
-}
addScores :: (R.Semiring s, Eq i) => Score s i -> Score s i -> Score s i
addScores :: forall s i.
(Semiring s, Eq i) =>
Score s i -> Score s i -> Score s i
addScores Score s i
a Score s i
b = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"illegal times") forall a b. (a -> b) -> a -> b
$ forall s i.
(Semiring s, Eq i) =>
Score s i -> Score s i -> Maybe (Score s i)
plus Score s i
a Score s i
b

{- | Combines the 'Score's of two edges with a @split@ operation into the score of the parent edge.
 This is expected to be called on compatible scores
 and will throw an error otherwise to indicate parser bugs.

 > a-b   b-c
 > --------- unsplit
 >    a-c
-}
unsplitScores
  :: (R.Semiring s, Eq i, Show i, Show s)
  => s
  -- ^ The score of the split operation.
  -> Score s i
  -- ^ The 'Score' of the left child edge.
  -> Score s i
  -- ^ The 'Score' of the right child edge.
  -> Score s i
  -- ^ The 'Score' of the parent edge, if it exists.
unsplitScores :: forall s i.
(Semiring s, Eq i, Show i, Show s) =>
s -> Score s i -> Score s i -> Score s i
unsplitScores s
op Score s i
left Score s i
right = forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err forall a b. (a -> b) -> a -> b
$ forall s i.
(Semiring s, Eq i, Show i) =>
Score s i -> Score s i -> Maybe (Score s i)
times Score s i
left' Score s i
right
 where
  err :: a
err =
    forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
      String
"Attempting illegal unsplit: left="
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Score s i
left
        forall a. Semigroup a => a -> a -> a
<> String
", right="
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Score s i
right
  left' :: Score s i
left' = case Score s i
left of
    SVal s
s -> forall s i. s -> Score s i
SVal (s
op forall a. Semiring a => a -> a -> a
R.* s
s)
    SLeft [Holes s]
ls RightId i
i -> forall s i. [Holes s] -> RightId i -> Score s i
SLeft (forall s. Semiring s => s -> Holes s -> Holes s
prependLeft s
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Holes s]
ls) RightId i
i
    SRight LeftId i
i [Holes s]
rs -> forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
i (forall s. Semiring s => s -> Holes s -> Holes s
prependLeft s
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Holes s]
rs)
    SBoth LeftId i
il [(Holes s, Holes s)]
bs RightId i
ir -> forall s i.
LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
SBoth LeftId i
il (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall s. Semiring s => s -> Holes s -> Holes s
prependLeft s
op) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Holes s, Holes s)]
bs) RightId i
ir

{- | Creates the 'Score' of a left parent edge from a left child edge of an @unspread@.
 Will throw an error if called on invalid input to indicate parser bugs.
-}
unspreadScoresLeft
  :: (Eq i, Show i, R.Semiring s, Show s)
  => i
  -- ^ The new ID that marks both parent edges
  -> Score s i
  -- ^ The 'Score' of the left child edge.
  -> Score s i
  -- ^ The 'Score' of the left parent edge, if it exists.
unspreadScoresLeft :: forall i s.
(Eq i, Show i, Semiring s, Show s) =>
i -> Score s i -> Score s i
unspreadScoresLeft i
newid = forall {s} {i}.
(Semiring s, Show i, Show s) =>
Score s i -> Score s i
wrap
 where
  newir :: RightId i
newir = forall i. i -> RightId i
RightId i
newid
  -- wrap the left input score into a new layer with a new ID
  wrap :: Score s i -> Score s i
wrap (SVal s
v) = forall s i. [Holes s] -> RightId i -> Score s i
SLeft [[forall a. Semiring a => a
R.one, s
v]] RightId i
newir
  wrap (SLeft [Holes s]
ls RightId i
_) = forall s i. [Holes s] -> RightId i -> Score s i
SLeft (forall a. a -> [a] -> [a]
addHoleLeft forall a. Semiring a => a
R.one forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Holes s]
ls) RightId i
newir
  wrap Score s i
other = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Attempting illegal left-unspread on " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Score s i
other

{- | Creates the 'Score' of a right parent edge
 from the middle and right child edges of an @unspread@
 and a @spread@ operation.
-}
unspreadScoresRight
  :: (Eq i, R.Semiring s, Show i, Show s)
  => i
  -- ^ The new ID that marks both parent edges.
  -> s
  -- ^ The score of the @spread@ operation.
  -> Score s i
  -- ^ The 'Score' of the middle child edge.
  -> Score s i
  -- ^ The 'Score' of the right child edge.
  -> Score s i
  -- ^ The 'Score' of the right parent edge, if it exists.
unspreadScoresRight :: forall i s.
(Eq i, Semiring s, Show i, Show s) =>
i -> s -> Score s i -> Score s i -> Score s i
unspreadScoresRight i
newid s
op Score s i
m Score s i
r = forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err forall a b. (a -> b) -> a -> b
$ do
  Score s i
mr <- forall s i.
(Semiring s, Eq i, Show i) =>
Score s i -> Score s i -> Maybe (Score s i)
times Score s i
m Score s i
r
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Score s i -> Score s i
unwrap Score s i
mr
 where
  err :: a
err =
    forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
      String
"Attempting illegal right-unspread: m="
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Score s i
m
        forall a. Semigroup a => a -> a -> a
<> String
", r="
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Score s i
r
  -- generate a value on the right
  -- that consumes the left parent edge's value when supplied
  -- and combines with m on the right
  newil :: LeftId i
newil = forall i. i -> LeftId i
LeftId i
newid
  unwrap :: Score s i -> Score s i
unwrap (SVal s
s) = forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
newil [[s
op, s
s]]
  unwrap (SRight LeftId i
_ [Holes s]
rs) = forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
newil (forall a. a -> [a] -> [a]
addHoleLeft s
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Holes s]
rs)
  unwrap (SLeft [Holes s]
ls RightId i
ir) = forall s i.
LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
SBoth LeftId i
newil (([s
op, forall a. Semiring a => a
R.one],) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Holes s]
ls) RightId i
ir
  unwrap (SBoth LeftId i
_ [(Holes s, Holes s)]
bs RightId i
ir) = forall s i.
LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
SBoth LeftId i
newil (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. a -> [a] -> [a]
addHoleLeft s
op) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Holes s, Holes s)]
bs) RightId i
ir