{-# 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
(LeftId i -> LeftId i -> Bool)
-> (LeftId i -> LeftId i -> Bool) -> Eq (LeftId i)
forall i. Eq i => LeftId i -> LeftId i -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: LeftId i -> LeftId i -> Bool
Eq, Eq (LeftId i)
Eq (LeftId i) =>
(LeftId i -> LeftId i -> Ordering)
-> (LeftId i -> LeftId i -> Bool)
-> (LeftId i -> LeftId i -> Bool)
-> (LeftId i -> LeftId i -> Bool)
-> (LeftId i -> LeftId i -> Bool)
-> (LeftId i -> LeftId i -> LeftId i)
-> (LeftId i -> LeftId i -> LeftId i)
-> Ord (LeftId i)
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
$ccompare :: forall i. Ord i => LeftId i -> LeftId i -> Ordering
compare :: LeftId i -> LeftId i -> Ordering
$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
>= :: LeftId i -> LeftId i -> Bool
$cmax :: forall i. Ord i => LeftId i -> LeftId i -> LeftId i
max :: LeftId i -> LeftId i -> LeftId i
$cmin :: forall i. Ord i => LeftId i -> LeftId i -> LeftId i
min :: LeftId i -> LeftId i -> LeftId i
Ord, (forall x. LeftId i -> Rep (LeftId i) x)
-> (forall x. Rep (LeftId i) x -> LeftId i) -> Generic (LeftId i)
forall x. Rep (LeftId i) x -> LeftId i
forall x. LeftId i -> Rep (LeftId i) x
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
$cfrom :: forall i x. LeftId i -> Rep (LeftId i) x
from :: forall x. LeftId i -> Rep (LeftId i) x
$cto :: forall i x. Rep (LeftId i) x -> LeftId i
to :: forall x. Rep (LeftId i) x -> LeftId i
Generic)
  deriving anyclass (Eq (LeftId i)
Eq (LeftId i) =>
(Int -> LeftId i -> Int)
-> (LeftId i -> Int) -> Hashable (LeftId i)
Int -> LeftId i -> Int
LeftId i -> Int
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
$chashWithSalt :: forall i. Hashable i => Int -> LeftId i -> Int
hashWithSalt :: Int -> LeftId i -> Int
$chash :: forall i. Hashable i => LeftId i -> Int
hash :: LeftId i -> Int
Hashable, LeftId i -> ()
(LeftId i -> ()) -> NFData (LeftId i)
forall i. NFData i => LeftId i -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall i. NFData i => LeftId i -> ()
rnf :: LeftId i -> ()
NFData)

instance Show i => Show (LeftId i) where
  show :: LeftId i -> String
show (LeftId i
i) = i -> String
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
(RightId i -> RightId i -> Bool)
-> (RightId i -> RightId i -> Bool) -> Eq (RightId i)
forall i. Eq i => RightId i -> RightId i -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: RightId i -> RightId i -> Bool
Eq, Eq (RightId i)
Eq (RightId i) =>
(RightId i -> RightId i -> Ordering)
-> (RightId i -> RightId i -> Bool)
-> (RightId i -> RightId i -> Bool)
-> (RightId i -> RightId i -> Bool)
-> (RightId i -> RightId i -> Bool)
-> (RightId i -> RightId i -> RightId i)
-> (RightId i -> RightId i -> RightId i)
-> Ord (RightId i)
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
$ccompare :: forall i. Ord i => RightId i -> RightId i -> Ordering
compare :: RightId i -> RightId i -> Ordering
$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
>= :: RightId i -> RightId i -> Bool
$cmax :: forall i. Ord i => RightId i -> RightId i -> RightId i
max :: RightId i -> RightId i -> RightId i
$cmin :: forall i. Ord i => RightId i -> RightId i -> RightId i
min :: RightId i -> RightId i -> RightId i
Ord, (forall x. RightId i -> Rep (RightId i) x)
-> (forall x. Rep (RightId i) x -> RightId i)
-> Generic (RightId i)
forall x. Rep (RightId i) x -> RightId i
forall x. RightId i -> Rep (RightId i) x
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
$cfrom :: forall i x. RightId i -> Rep (RightId i) x
from :: forall x. RightId i -> Rep (RightId i) x
$cto :: forall i x. Rep (RightId i) x -> RightId i
to :: forall x. Rep (RightId i) x -> RightId i
Generic)
  deriving anyclass (RightId i -> ()
(RightId i -> ()) -> NFData (RightId i)
forall i. NFData i => RightId i -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall i. NFData i => RightId i -> ()
rnf :: RightId i -> ()
NFData, Eq (RightId i)
Eq (RightId i) =>
(Int -> RightId i -> Int)
-> (RightId i -> Int) -> Hashable (RightId i)
Int -> RightId i -> Int
RightId i -> Int
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
$chashWithSalt :: forall i. Hashable i => Int -> RightId i -> Int
hashWithSalt :: Int -> RightId i -> Int
$chash :: forall i. Hashable i => RightId i -> Int
hash :: RightId i -> Int
Hashable)

instance Show i => Show (RightId i) where
  show :: RightId i -> String
show (RightId i
i) = i -> String
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 a -> a -> Bool
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 x. Score s i -> Rep (Score s i) x)
-> (forall x. Rep (Score s i) x -> Score s i)
-> Generic (Score s i)
forall x. Rep (Score s i) x -> Score s i
forall x. Score s i -> Rep (Score s i) x
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
$cfrom :: forall s i x. Score s i -> Rep (Score s i) x
from :: forall x. Score s i -> Rep (Score s i) x
$cto :: forall s i x. Rep (Score s i) x -> Score s i
to :: forall x. Rep (Score s i) x -> Score s i
Generic, Score s i -> ()
(Score s i -> ()) -> NFData (Score s i)
forall a. (a -> ()) -> NFData a
forall s i. (NFData s, NFData i) => Score s i -> ()
$crnf :: forall s i. (NFData s, NFData i) => Score s i -> ()
rnf :: 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 = s -> Score s i
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
_) = Maybe (LeftId i)
forall a. Maybe a
Nothing
leftSide (SLeft [Holes s]
_ RightId i
_) = Maybe (LeftId i)
forall a. Maybe a
Nothing
leftSide (SRight LeftId i
i [Holes s]
_) = LeftId i -> Maybe (LeftId i)
forall a. a -> Maybe a
Just LeftId i
i
leftSide (SBoth LeftId i
i [(Holes s, Holes s)]
_ RightId i
_) = LeftId i -> Maybe (LeftId 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
_) = Maybe (RightId i)
forall a. Maybe a
Nothing
rightSide (SLeft [Holes s]
_ RightId i
i) = RightId i -> Maybe (RightId i)
forall a. a -> Maybe a
Just RightId i
i
rightSide (SRight LeftId i
_ [Holes s]
_) = Maybe (RightId i)
forall a. Maybe a
Nothing
rightSide (SBoth LeftId i
_ [(Holes s, Holes s)]
_ RightId i
i) = RightId i -> Maybe (RightId 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 = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
" _ " (a -> String
forall a. Show a => a -> String
show (a -> String) -> [a] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
ls) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" _"

showRightHoles :: Show a => [a] -> [Char]
showRightHoles :: forall a. Show a => [a] -> String
showRightHoles [a]
rs = String
"_ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
" _ " (a -> String
forall a. Show a => a -> String
show (a -> String) -> [a] -> [String]
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) = [a1] -> String
forall a. Show a => [a] -> String
showLeftHoles [a1]
ls String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" | " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [a2] -> String
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
"-[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
" / " (a -> String
shower (a -> String) -> [a] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
opts) String -> ShowS
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
"()-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> s -> String
forall a. Show a => a -> String
show s
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-()"
  show (SLeft [Holes s]
ls RightId i
ir) = String
"()" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Holes s -> String) -> [Holes s] -> String
forall a. (a -> String) -> [a] -> String
showOpts Holes s -> String
forall a. Show a => [a] -> String
showLeftHoles [Holes s]
ls String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RightId i -> String
forall a. Show a => a -> String
show RightId i
ir
  show (SRight LeftId i
il [Holes s]
rs) = LeftId i -> String
forall a. Show a => a -> String
show LeftId i
il String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Holes s -> String) -> [Holes s] -> String
forall a. (a -> String) -> [a] -> String
showOpts Holes s -> String
forall a. Show a => [a] -> String
showRightHoles [Holes s]
rs String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"()"
  show (SBoth LeftId i
il [(Holes s, Holes s)]
bs RightId i
ir) = LeftId i -> String
forall a. Show a => a -> String
show LeftId i
il String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ((Holes s, Holes s) -> String) -> [(Holes s, Holes s)] -> String
forall a. (a -> String) -> [a] -> String
showOpts (Holes s, Holes s) -> String
forall a1 a2. (Show a1, Show a2) => ([a1], [a2]) -> String
showBothHoles [(Holes s, Holes s)]
bs String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RightId i -> String
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) = s -> String
forall a. Show a => a -> String
show s
v
showScore (SLeft [Holes s]
_ RightId i
ir) = String
"()-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RightId i -> String
forall a. Show a => a -> String
show RightId i
ir
showScore (SRight LeftId i
il [Holes s]
_) = LeftId i -> String
forall a. Show a => a -> String
show LeftId i
il String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-()"
showScore (SBoth LeftId i
il [(Holes s, Holes s)]
_ RightId i
ir) = LeftId i -> String
forall a. Show a => a -> String
show LeftId i
il String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RightId i -> String
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 = s -> Holes s -> Holes s -> Maybe s
forall {t}. Semiring t => t -> [t] -> [t] -> Maybe t
go s
forall a. Semiring a => a
R.one Holes s
lefts Holes s
rights
 where
  go :: t -> [t] -> [t] -> Maybe t
go !t
acc [] [] = t -> Maybe t
forall a. a -> Maybe a
Just (t -> Maybe t) -> t -> Maybe t
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 t -> t -> t
forall a. Semiring a => a -> a -> a
R.* (t
l t -> t -> t
forall a. Semiring a => a -> a -> a
R.* t
r)) [t]
ls [t]
rs
  go t
_ [t]
_ [t]
_ = Maybe 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 = [Maybe c] -> Maybe [c]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Maybe c] -> Maybe [c]) -> [Maybe c] -> Maybe [c]
forall a b. (a -> b) -> a -> b
$ a -> b -> Maybe c
f (a -> b -> Maybe c) -> [a] -> [b -> Maybe c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
ls [b -> Maybe c] -> [b] -> [Maybe c]
forall a b. [a -> b] -> [a] -> [b]
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 s -> s -> s
forall a. Semiring a => a -> a -> a
R.* s
s]
appendRight !s
s (s
a : [s]
as) = s
a s -> [s] -> [s]
forall a. a -> [a] -> [a]
: s -> [s] -> [s]
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 s -> s -> s
forall a. Semiring a => a -> a -> a
R.* s
a) s -> [s] -> [s]
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) = Score s i -> Maybe (Score s i)
forall a. a -> Maybe a
Just (Score s i -> Maybe (Score s i)) -> Score s i -> Maybe (Score s i)
forall a b. (a -> b) -> a -> b
$! s -> Score s i
forall s i. s -> Score s i
SVal (s -> Score s i) -> s -> Score s i
forall a b. (a -> b) -> a -> b
$! s
s1 s -> s -> s
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 RightId i -> LeftId i -> Bool
forall a. Eq a => RightId a -> LeftId a -> Bool
`match` LeftId i
ir =
      s -> Score s i
forall s i. s -> Score s i
SVal (s -> Score s i) -> (Holes s -> s) -> Holes s -> Score s i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s -> s) -> s -> Holes s -> s
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' s -> s -> s
forall a. Semiring a => a -> a -> a
R.plus s
forall a. Semiring a => a
R.zero (Holes s -> Score s i) -> Maybe (Holes s) -> Maybe (Score s i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Holes s -> Holes s -> Maybe s)
-> [Holes s] -> [Holes s] -> Maybe (Holes s)
forall a b c. (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c]
combineAlts Holes s -> Holes s -> Maybe s
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) = Score s i -> Maybe (Score s i)
forall a. a -> Maybe a
Just (Score s i -> Maybe (Score s i)) -> Score s i -> Maybe (Score s i)
forall a b. (a -> b) -> a -> b
$! LeftId i -> [Holes s] -> Score s i
forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
i ([Holes s] -> Score s i) -> [Holes s] -> Score s i
forall a b. (a -> b) -> a -> b
$! s -> Holes s -> Holes s
forall s. Semiring s => s -> Holes s -> Holes s
appendRight s
s (Holes s -> Holes s) -> [Holes s] -> [Holes 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 RightId i -> LeftId i -> Bool
forall a. Eq a => RightId a -> LeftId a -> Bool
`match` LeftId i
i =
      LeftId i -> [Holes s] -> Score s i
forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
il ([Holes s] -> Score s i) -> Maybe [Holes s] -> Maybe (Score s i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Holes s, Holes s) -> Holes s -> Maybe (Holes s))
-> [(Holes s, Holes s)] -> [Holes s] -> Maybe [Holes s]
forall a b c. (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c]
combineAlts (Holes s, Holes s) -> Holes s -> Maybe (Holes s)
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 = (a -> Holes a -> Holes a) -> Holes a -> a -> Holes a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Holes a -> Holes a
forall s. Semiring s => s -> Holes s -> Holes s
appendRight Holes a
bl (a -> Holes a) -> Maybe a -> Maybe (Holes a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Holes a -> Holes a -> Maybe a
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) = Score s i -> Maybe (Score s i)
forall a. a -> Maybe a
Just (Score s i -> Maybe (Score s i)) -> Score s i -> Maybe (Score s i)
forall a b. (a -> b) -> a -> b
$! [Holes s] -> RightId i -> Score s i
forall s i. [Holes s] -> RightId i -> Score s i
SLeft (s -> Holes s -> Holes s
forall s. Semiring s => s -> Holes s -> Holes s
prependLeft s
s (Holes s -> Holes s) -> [Holes s] -> [Holes 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 RightId i -> LeftId i -> Bool
forall a. Eq a => RightId a -> LeftId a -> Bool
`match` LeftId i
il =
  ([Holes s] -> Score s i) -> Maybe [Holes s] -> Maybe (Score s i)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Holes s] -> RightId i -> Score s i
forall s i. [Holes s] -> RightId i -> Score s i
`SLeft` RightId i
ir) (Maybe [Holes s] -> Maybe (Score s i))
-> Maybe [Holes s] -> Maybe (Score s i)
forall a b. (a -> b) -> a -> b
$ [Maybe (Holes s)] -> Maybe [Holes s]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Maybe (Holes s)] -> Maybe [Holes s])
-> [Maybe (Holes s)] -> Maybe [Holes s]
forall a b. (a -> b) -> a -> b
$ do
    !l <- [Holes s]
ls
    (!bl, !br) <- bs
    let !vl = Holes s -> Holes s -> Maybe s
forall s. Semiring s => Holes s -> Holes s -> Maybe s
zipHoles Holes s
l Holes s
bl
    pure $! flip prependLeft br <$> vl
-- creates both
times (SRight !LeftId i
il ![Holes s]
rs) (SLeft ![Holes s]
ls !RightId i
ir) = Score s i -> Maybe (Score s i)
forall a. a -> Maybe a
Just (Score s i -> Maybe (Score s i)) -> Score s i -> Maybe (Score s i)
forall a b. (a -> b) -> a -> b
$! LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
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
    !l <- [Holes s]
rs
    !r <- ls
    pure (l, 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 RightId i -> LeftId i -> Bool
forall a. Eq a => RightId a -> LeftId a -> Bool
`match` LeftId i
ib = do
  -- Maybe
  cs <- [Maybe (Holes s, Holes s)] -> Maybe [(Holes s, Holes s)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Maybe (Holes s, Holes s)] -> Maybe [(Holes s, Holes s)])
-> [Maybe (Holes s, Holes s)] -> Maybe [(Holes s, Holes s)]
forall a b. (a -> b) -> a -> b
$ do
    -- []
    (!al, !ar) <- [(Holes s, Holes s)]
as
    (!bl, !br) <- bs
    pure $! do
      -- Maybe
      !vm <- zipHoles ar bl
      pure (al, prependLeft vm br)
  pure $! SBoth il cs ir
-- otherwise
times Score s i
_ Score s i
_ = Maybe (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) = Score s i -> Maybe (Score s i)
forall a. a -> Maybe a
Just (Score s i -> Maybe (Score s i)) -> Score s i -> Maybe (Score s i)
forall a b. (a -> b) -> a -> b
$! s -> Score s i
forall s i. s -> Score s i
SVal (s
s1 s -> s -> s
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 LeftId i -> LeftId i -> Bool
forall a. Eq a => a -> a -> Bool
== LeftId i
i' =
      Score s i -> Maybe (Score s i)
forall a. a -> Maybe a
Just (Score s i -> Maybe (Score s i)) -> Score s i -> Maybe (Score s i)
forall a b. (a -> b) -> a -> b
$! LeftId i -> [Holes s] -> Score s i
forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
i ([Holes s]
rs1 [Holes s] -> [Holes s] -> [Holes s]
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 RightId i -> RightId i -> Bool
forall a. Eq a => a -> a -> Bool
== RightId i
i' = Score s i -> Maybe (Score s i)
forall a. a -> Maybe a
Just (Score s i -> Maybe (Score s i)) -> Score s i -> Maybe (Score s i)
forall a b. (a -> b) -> a -> b
$! [Holes s] -> RightId i -> Score s i
forall s i. [Holes s] -> RightId i -> Score s i
SLeft ([Holes s]
ls1 [Holes s] -> [Holes s] -> [Holes s]
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 LeftId i -> LeftId i -> Bool
forall a. Eq a => a -> a -> Bool
== LeftId i
il' Bool -> Bool -> Bool
&& RightId i
ir RightId i -> RightId i -> Bool
forall a. Eq a => a -> a -> Bool
== RightId i
ir' =
      Score s i -> Maybe (Score s i)
forall a. a -> Maybe a
Just (Score s i -> Maybe (Score s i)) -> Score s i -> Maybe (Score s i)
forall a b. (a -> b) -> a -> b
$! LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
forall s i.
LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
SBoth LeftId i
il ([(Holes s, Holes s)]
bs1 [(Holes s, Holes s)]
-> [(Holes s, Holes s)] -> [(Holes s, Holes s)]
forall a. Semigroup a => a -> a -> a
<> [(Holes s, Holes s)]
bs2) RightId i
ir
plus Score s i
_ Score s i
_ = Maybe (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
_ = String -> s
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 = Score s i -> Maybe (Score s i) -> Score s i
forall a. a -> Maybe a -> a
fromMaybe (String -> Score s i
forall a. HasCallStack => String -> a
error String
"illegal times") (Maybe (Score s i) -> Score s i) -> Maybe (Score s i) -> Score s i
forall a b. (a -> b) -> a -> b
$ Score s i -> Score s i -> Maybe (Score s i)
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 = Score s i -> Maybe (Score s i) -> Score s i
forall a. a -> Maybe a -> a
fromMaybe Score s i
forall {a}. a
err (Maybe (Score s i) -> Score s i) -> Maybe (Score s i) -> Score s i
forall a b. (a -> b) -> a -> b
$ Score s i -> Score s i -> Maybe (Score s i)
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 =
    String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
      String
"Attempting illegal unsplit: left="
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Score s i -> String
forall a. Show a => a -> String
show Score s i
left
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", right="
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Score s i -> String
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 -> s -> Score s i
forall s i. s -> Score s i
SVal (s
op s -> s -> s
forall a. Semiring a => a -> a -> a
R.* s
s)
    SLeft [Holes s]
ls RightId i
i -> [Holes s] -> RightId i -> Score s i
forall s i. [Holes s] -> RightId i -> Score s i
SLeft (s -> Holes s -> Holes s
forall s. Semiring s => s -> Holes s -> Holes s
prependLeft s
op (Holes s -> Holes s) -> [Holes s] -> [Holes s]
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 -> LeftId i -> [Holes s] -> Score s i
forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
i (s -> Holes s -> Holes s
forall s. Semiring s => s -> Holes s -> Holes s
prependLeft s
op (Holes s -> Holes s) -> [Holes s] -> [Holes s]
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 -> LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
forall s i.
LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
SBoth LeftId i
il ((Holes s -> Holes s) -> (Holes s, Holes s) -> (Holes s, Holes s)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (s -> Holes s -> Holes s
forall s. Semiring s => s -> Holes s -> Holes s
prependLeft s
op) ((Holes s, Holes s) -> (Holes s, Holes s))
-> [(Holes s, Holes s)] -> [(Holes s, Holes s)]
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 = Score s i -> Score s i
forall {s} {i}.
(Semiring s, Show i, Show s) =>
Score s i -> Score s i
wrap
 where
  newir :: RightId i
newir = i -> RightId i
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) = [Holes s] -> RightId i -> Score s i
forall s i. [Holes s] -> RightId i -> Score s i
SLeft [[s
forall a. Semiring a => a
R.one, s
v]] RightId i
newir
  wrap (SLeft [Holes s]
ls RightId i
_) = [Holes s] -> RightId i -> Score s i
forall s i. [Holes s] -> RightId i -> Score s i
SLeft (s -> Holes s -> Holes s
forall a. a -> [a] -> [a]
addHoleLeft s
forall a. Semiring a => a
R.one (Holes s -> Holes s) -> [Holes s] -> [Holes s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Holes s]
ls) RightId i
newir
  wrap Score s i
other = String -> Score s i
forall a. HasCallStack => String -> a
error (String -> Score s i) -> String -> Score s i
forall a b. (a -> b) -> a -> b
$ String
"Attempting illegal left-unspread on " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Score s i -> String
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 = Score s i -> Maybe (Score s i) -> Score s i
forall a. a -> Maybe a -> a
fromMaybe Score s i
forall {a}. a
err (Maybe (Score s i) -> Score s i) -> Maybe (Score s i) -> Score s i
forall a b. (a -> b) -> a -> b
$ do
  mr <- Score s i -> Score s i -> Maybe (Score s i)
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
  pure $ unwrap mr
 where
  err :: a
err =
    String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
      String
"Attempting illegal right-unspread: m="
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Score s i -> String
forall a. Show a => a -> String
show Score s i
m
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", r="
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Score s i -> String
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 = i -> LeftId i
forall i. i -> LeftId i
LeftId i
newid
  unwrap :: Score s i -> Score s i
unwrap (SVal s
s) = LeftId i -> [Holes s] -> Score s i
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) = LeftId i -> [Holes s] -> Score s i
forall s i. LeftId i -> [Holes s] -> Score s i
SRight LeftId i
newil (s -> Holes s -> Holes s
forall a. a -> [a] -> [a]
addHoleLeft s
op (Holes s -> Holes s) -> [Holes s] -> [Holes s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Holes s]
rs)
  unwrap (SLeft [Holes s]
ls RightId i
ir) = LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
forall s i.
LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
SBoth LeftId i
newil (([s
op, s
forall a. Semiring a => a
R.one],) (Holes s -> (Holes s, Holes s))
-> [Holes s] -> [(Holes s, Holes s)]
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) = LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
forall s i.
LeftId i -> [(Holes s, Holes s)] -> RightId i -> Score s i
SBoth LeftId i
newil ((Holes s -> Holes s) -> (Holes s, Holes s) -> (Holes s, Holes s)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (s -> Holes s -> Holes s
forall a. a -> [a] -> [a]
addHoleLeft s
op) ((Holes s, Holes s) -> (Holes s, Holes s))
-> [(Holes s, Holes s)] -> [(Holes s, Holes s)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Holes s, Holes s)]
bs) RightId i
ir