{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeFamilies #-}

{- | This module contains code that is specific to parsing the protovoice grammar.
 It implements a number of evaluators ('Eval') that can be used with the various parsers.
-}
module PVGrammar.Parse
  ( -- * Generic Parsing

    -- | Evaluators that directly return protovoice operations.
    -- They can be embedded into a semiring using 'mapEvalScore'.
    IsNote
  , protoVoiceEvaluator
  , protoVoiceEvaluatorNoRepSplit

    -- * Parsing Derivations
  , pvDerivUnrestricted
  , pvDerivRightBranch

    -- * Counting Parses
  , pvCountUnrestricted
  , pvCountNoRepSplit
  , pvCountNoRepSplitRightBranch
  , pvCountNoRepSplitRightBranchSplitFirst
  ) where

import Common
import PVGrammar

import Musicology.Pitch
  ( Diatonic
  , Interval (..)
  , Notation
  , pc
  , pto
  )

import Control.DeepSeq (NFData)
import Control.Monad (foldM)
import Data.Foldable
  ( foldl'
  , toList
  )
import Data.HashMap.Strict qualified as HM
import Data.HashSet qualified as S
import Data.Hashable (Hashable)
import Data.Kind (Constraint, Type)
import Data.List qualified as L
import Data.Map.Strict qualified as M
import Data.Maybe
  ( catMaybes
  , mapMaybe
  , maybeToList
  )
import GHC.Generics (Generic)
import Internal.MultiSet qualified as MS
import Musicology.Core
  ( HasPitch (..)
  , Pitch
  , Pitched (..)
  , isStep
  )

-- helper type: Either for terminal and non-terminal edges
-- -------------------------------------------------------

{- | A tag that distinguishes between objects related to terminal and non-terminal edges.
 Like 'Either', but with semantic constructor names to avoid confusion.
-}
data EdgeEither a b
  = -- | marks an terminal edge (or some related object)
    Reg !a
  | -- | marks a non-terminal edge (or some related object)
    Pass !b
  deriving (EdgeEither a b -> EdgeEither a b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
EdgeEither a b -> EdgeEither a b -> Bool
/= :: EdgeEither a b -> EdgeEither a b -> Bool
$c/= :: forall a b.
(Eq a, Eq b) =>
EdgeEither a b -> EdgeEither a b -> Bool
== :: EdgeEither a b -> EdgeEither a b -> Bool
$c== :: forall a b.
(Eq a, Eq b) =>
EdgeEither a b -> EdgeEither a b -> Bool
Eq, EdgeEither a b -> EdgeEither a b -> Bool
EdgeEither a b -> EdgeEither a b -> 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 {a} {b}. (Ord a, Ord b) => Eq (EdgeEither a b)
forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> Bool
forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> Ordering
forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> EdgeEither a b
min :: EdgeEither a b -> EdgeEither a b -> EdgeEither a b
$cmin :: forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> EdgeEither a b
max :: EdgeEither a b -> EdgeEither a b -> EdgeEither a b
$cmax :: forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> EdgeEither a b
>= :: EdgeEither a b -> EdgeEither a b -> Bool
$c>= :: forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> Bool
> :: EdgeEither a b -> EdgeEither a b -> Bool
$c> :: forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> Bool
<= :: EdgeEither a b -> EdgeEither a b -> Bool
$c<= :: forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> Bool
< :: EdgeEither a b -> EdgeEither a b -> Bool
$c< :: forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> Bool
compare :: EdgeEither a b -> EdgeEither a b -> Ordering
$ccompare :: forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> Ordering
Ord, Int -> EdgeEither a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> EdgeEither a b -> ShowS
forall a b. (Show a, Show b) => [EdgeEither a b] -> ShowS
forall a b. (Show a, Show b) => EdgeEither a b -> String
showList :: [EdgeEither a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [EdgeEither a b] -> ShowS
show :: EdgeEither a b -> String
$cshow :: forall a b. (Show a, Show b) => EdgeEither a b -> String
showsPrec :: Int -> EdgeEither a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> EdgeEither a b -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (EdgeEither a b) x -> EdgeEither a b
forall a b x. EdgeEither a b -> Rep (EdgeEither a b) x
$cto :: forall a b x. Rep (EdgeEither a b) x -> EdgeEither a b
$cfrom :: forall a b x. EdgeEither a b -> Rep (EdgeEither a b) x
Generic, forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {a} {b}. (Hashable a, Hashable b) => Eq (EdgeEither a b)
forall a b.
(Hashable a, Hashable b) =>
Int -> EdgeEither a b -> Int
forall a b. (Hashable a, Hashable b) => EdgeEither a b -> Int
hash :: EdgeEither a b -> Int
$chash :: forall a b. (Hashable a, Hashable b) => EdgeEither a b -> Int
hashWithSalt :: Int -> EdgeEither a b -> Int
$chashWithSalt :: forall a b.
(Hashable a, Hashable b) =>
Int -> EdgeEither a b -> Int
Hashable, forall a. (a -> ()) -> NFData a
forall a b. (NFData a, NFData b) => EdgeEither a b -> ()
rnf :: EdgeEither a b -> ()
$crnf :: forall a b. (NFData a, NFData b) => EdgeEither a b -> ()
NFData)

-- helper type: enum for possible operations
-- -----------------------------------------

{- | A tag that distinguishes four different types of operations:
  regular split, passing split, left ornament, and right ornament
-}
data Elaboration a b c d
  = -- | marks a terminal split
    EReg !a
  | -- | marks a non-terminal split
    EPass !b
  | -- | marks a right ornament
    ER !c
  | -- | marks a left ornament
    EL !d
  deriving (Elaboration a b c d -> Elaboration a b c d -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b c d.
(Eq a, Eq b, Eq c, Eq d) =>
Elaboration a b c d -> Elaboration a b c d -> Bool
/= :: Elaboration a b c d -> Elaboration a b c d -> Bool
$c/= :: forall a b c d.
(Eq a, Eq b, Eq c, Eq d) =>
Elaboration a b c d -> Elaboration a b c d -> Bool
== :: Elaboration a b c d -> Elaboration a b c d -> Bool
$c== :: forall a b c d.
(Eq a, Eq b, Eq c, Eq d) =>
Elaboration a b c d -> Elaboration a b c d -> Bool
Eq, Elaboration a b c d -> Elaboration a b c d -> 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 {a} {b} {c} {d}.
(Ord a, Ord b, Ord c, Ord d) =>
Eq (Elaboration a b c d)
forall a b c d.
(Ord a, Ord b, Ord c, Ord d) =>
Elaboration a b c d -> Elaboration a b c d -> Bool
forall a b c d.
(Ord a, Ord b, Ord c, Ord d) =>
Elaboration a b c d -> Elaboration a b c d -> Ordering
forall a b c d.
(Ord a, Ord b, Ord c, Ord d) =>
Elaboration a b c d -> Elaboration a b c d -> Elaboration a b c d
min :: Elaboration a b c d -> Elaboration a b c d -> Elaboration a b c d
$cmin :: forall a b c d.
(Ord a, Ord b, Ord c, Ord d) =>
Elaboration a b c d -> Elaboration a b c d -> Elaboration a b c d
max :: Elaboration a b c d -> Elaboration a b c d -> Elaboration a b c d
$cmax :: forall a b c d.
(Ord a, Ord b, Ord c, Ord d) =>
Elaboration a b c d -> Elaboration a b c d -> Elaboration a b c d
>= :: Elaboration a b c d -> Elaboration a b c d -> Bool
$c>= :: forall a b c d.
(Ord a, Ord b, Ord c, Ord d) =>
Elaboration a b c d -> Elaboration a b c d -> Bool
> :: Elaboration a b c d -> Elaboration a b c d -> Bool
$c> :: forall a b c d.
(Ord a, Ord b, Ord c, Ord d) =>
Elaboration a b c d -> Elaboration a b c d -> Bool
<= :: Elaboration a b c d -> Elaboration a b c d -> Bool
$c<= :: forall a b c d.
(Ord a, Ord b, Ord c, Ord d) =>
Elaboration a b c d -> Elaboration a b c d -> Bool
< :: Elaboration a b c d -> Elaboration a b c d -> Bool
$c< :: forall a b c d.
(Ord a, Ord b, Ord c, Ord d) =>
Elaboration a b c d -> Elaboration a b c d -> Bool
compare :: Elaboration a b c d -> Elaboration a b c d -> Ordering
$ccompare :: forall a b c d.
(Ord a, Ord b, Ord c, Ord d) =>
Elaboration a b c d -> Elaboration a b c d -> Ordering
Ord, Int -> Elaboration a b c d -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b c d.
(Show a, Show b, Show c, Show d) =>
Int -> Elaboration a b c d -> ShowS
forall a b c d.
(Show a, Show b, Show c, Show d) =>
[Elaboration a b c d] -> ShowS
forall a b c d.
(Show a, Show b, Show c, Show d) =>
Elaboration a b c d -> String
showList :: [Elaboration a b c d] -> ShowS
$cshowList :: forall a b c d.
(Show a, Show b, Show c, Show d) =>
[Elaboration a b c d] -> ShowS
show :: Elaboration a b c d -> String
$cshow :: forall a b c d.
(Show a, Show b, Show c, Show d) =>
Elaboration a b c d -> String
showsPrec :: Int -> Elaboration a b c d -> ShowS
$cshowsPrec :: forall a b c d.
(Show a, Show b, Show c, Show d) =>
Int -> Elaboration a b c d -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b c d x.
Rep (Elaboration a b c d) x -> Elaboration a b c d
forall a b c d x.
Elaboration a b c d -> Rep (Elaboration a b c d) x
$cto :: forall a b c d x.
Rep (Elaboration a b c d) x -> Elaboration a b c d
$cfrom :: forall a b c d x.
Elaboration a b c d -> Rep (Elaboration a b c d) x
Generic, forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {a} {b} {c} {d}.
(Hashable a, Hashable b, Hashable c, Hashable d) =>
Eq (Elaboration a b c d)
forall a b c d.
(Hashable a, Hashable b, Hashable c, Hashable d) =>
Int -> Elaboration a b c d -> Int
forall a b c d.
(Hashable a, Hashable b, Hashable c, Hashable d) =>
Elaboration a b c d -> Int
hash :: Elaboration a b c d -> Int
$chash :: forall a b c d.
(Hashable a, Hashable b, Hashable c, Hashable d) =>
Elaboration a b c d -> Int
hashWithSalt :: Int -> Elaboration a b c d -> Int
$chashWithSalt :: forall a b c d.
(Hashable a, Hashable b, Hashable c, Hashable d) =>
Int -> Elaboration a b c d -> Int
Hashable, forall a. (a -> ()) -> NFData a
forall a b c d.
(NFData a, NFData b, NFData c, NFData d) =>
Elaboration a b c d -> ()
rnf :: Elaboration a b c d -> ()
$crnf :: forall a b c d.
(NFData a, NFData b, NFData c, NFData d) =>
Elaboration a b c d -> ()
NFData)

{- | Takes a collection of 'Elaboration'
 and splits it into lists for each elaboration type.
-}
partitionElaborations
  :: Foldable t => t (Elaboration a b c d) -> ([a], [b], [c], [d])
partitionElaborations :: forall (t :: * -> *) a b c d.
Foldable t =>
t (Elaboration a b c d) -> ([a], [b], [c], [d])
partitionElaborations = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a} {a} {a} {a}.
([a], [a], [a], [a]) -> Elaboration a a a a -> ([a], [a], [a], [a])
select ([], [], [], [])
 where
  select :: ([a], [a], [a], [a]) -> Elaboration a a a a -> ([a], [a], [a], [a])
select ([a]
a, [a]
b, [a]
c, [a]
d) (EReg a
t) = (a
t forall a. a -> [a] -> [a]
: [a]
a, [a]
b, [a]
c, [a]
d)
  select ([a]
a, [a]
b, [a]
c, [a]
d) (EPass a
n) = ([a]
a, a
n forall a. a -> [a] -> [a]
: [a]
b, [a]
c, [a]
d)
  select ([a]
a, [a]
b, [a]
c, [a]
d) (ER a
l) = ([a]
a, [a]
b, a
l forall a. a -> [a] -> [a]
: [a]
c, [a]
d)
  select ([a]
a, [a]
b, [a]
c, [a]
d) (EL a
r) = ([a]
a, [a]
b, [a]
c, a
r forall a. a -> [a] -> [a]
: [a]
d)

-- parsing Ornamentations
-- ======================

-- | A constraint alias for note types.
type IsNote :: Type -> Constraint
type IsNote n =
  (HasPitch n, Diatonic (ICOf (IntervalOf n)), Eq (ICOf (IntervalOf n)))

-- | Checks if the middle pitch is between the left and the right pitch.
between
  :: (Eq i, Interval i)
  => Pitch i
  -- ^ left pitch
  -> Pitch i
  -- ^ middle pitch
  -> Pitch i
  -- ^ right pitch
  -> Bool
between :: forall i.
(Eq i, Interval i) =>
Pitch i -> Pitch i -> Pitch i -> Bool
between Pitch i
pl Pitch i
pm Pitch i
pr =
  Pitch i
pl forall a. Eq a => a -> a -> Bool
/= Pitch i
pm Bool -> Bool -> Bool
&& Pitch i
pm forall a. Eq a => a -> a -> Bool
/= Pitch i
pr Bool -> Bool -> Bool
&& Pitch i
pl forall a. Eq a => a -> a -> Bool
/= Pitch i
pr Bool -> Bool -> Bool
&& Ordering
dir1 forall a. Eq a => a -> a -> Bool
== Ordering
odir Bool -> Bool -> Bool
&& Ordering
dir2 forall a. Eq a => a -> a -> Bool
== Ordering
odir
 where
  odir :: Ordering
odir = forall i. Interval i => i -> Ordering
direction forall a b. (a -> b) -> a -> b
$ Pitch i
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch i
pr
  dir1 :: Ordering
dir1 = forall i. Interval i => i -> Ordering
direction forall a b. (a -> b) -> a -> b
$ Pitch i
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch i
pm
  dir2 :: Ordering
dir2 = forall i. Interval i => i -> Ordering
direction forall a b. (a -> b) -> a -> b
$ Pitch i
pm forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch i
pr

{- | Attempts to reduce three nodes using an ornamentation operation.
 If succesfull, returns the ornament type and the parent edge,
 which is either a non-terminal edge for passing notes,
 or a terminal edge for all other operations.
-}
findOrnament
  :: (IsNote n)
  => StartStop n
  -> StartStop n
  -> StartStop n
  -> Bool
  -> Bool
  -> Maybe
      ( EdgeEither
          (DoubleOrnament, Edge n)
          (PassingOrnament, InnerEdge n)
      )
findOrnament :: forall n.
IsNote n =>
StartStop n
-> StartStop n
-> StartStop n
-> Bool
-> Bool
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
findOrnament (Inner n
l) (Inner n
m) (Inner n
r) Bool
True Bool
True
  | Pitch (ICOf (IntervalOf n))
pl forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pm Bool -> Bool -> Bool
&& Pitch (ICOf (IntervalOf n))
pm forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pr = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> EdgeEither a b
Reg (DoubleOrnament
FullRepeat, (forall a. a -> StartStop a
Inner n
l, forall a. a -> StartStop a
Inner n
r))
  | Pitch (ICOf (IntervalOf n))
pl forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pm Bool -> Bool -> Bool
&& Bool
so = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> EdgeEither a b
Reg (DoubleOrnament
RightRepeatOfLeft, (forall a. a -> StartStop a
Inner n
l, forall a. a -> StartStop a
Inner n
r))
  | Pitch (ICOf (IntervalOf n))
pm forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pr Bool -> Bool -> Bool
&& Bool
so = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> EdgeEither a b
Reg (DoubleOrnament
LeftRepeatOfRight, (forall a. a -> StartStop a
Inner n
l, forall a. a -> StartStop a
Inner n
r))
 where
  pl :: Pitch (ICOf (IntervalOf n))
pl = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
l
  pm :: Pitch (ICOf (IntervalOf n))
pm = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
m
  pr :: Pitch (ICOf (IntervalOf n))
pr = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
r
  so :: Bool
so = forall i. Diatonic i => i -> Bool
isStep forall a b. (a -> b) -> a -> b
$ Pitch (ICOf (IntervalOf n))
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pr
findOrnament (Inner n
l) (Inner n
m) (Inner n
r) Bool
_ Bool
_
  | Pitch (ICOf (IntervalOf n))
pl forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pr Bool -> Bool -> Bool
&& Bool
s1 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> EdgeEither a b
Reg (DoubleOrnament
FullNeighbor, (forall a. a -> StartStop a
Inner n
l, forall a. a -> StartStop a
Inner n
r))
  | Bool
s1 Bool -> Bool -> Bool
&& Bool
s2 Bool -> Bool -> Bool
&& forall i.
(Eq i, Interval i) =>
Pitch i -> Pitch i -> Pitch i -> Bool
between Pitch (ICOf (IntervalOf n))
pl Pitch (ICOf (IntervalOf n))
pm Pitch (ICOf (IntervalOf n))
pr = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> EdgeEither a b
Pass (PassingOrnament
PassingMid, (n
l, n
r))
 where
  pl :: Pitch (ICOf (IntervalOf n))
pl = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
l
  pm :: Pitch (ICOf (IntervalOf n))
pm = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
m
  pr :: Pitch (ICOf (IntervalOf n))
pr = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
r
  s1 :: Bool
s1 = forall i. Diatonic i => i -> Bool
isStep forall a b. (a -> b) -> a -> b
$ Pitch (ICOf (IntervalOf n))
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pm
  s2 :: Bool
s2 = forall i. Diatonic i => i -> Bool
isStep forall a b. (a -> b) -> a -> b
$ Pitch (ICOf (IntervalOf n))
pm forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pr
findOrnament StartStop n
Start (Inner n
_) StartStop n
Stop Bool
_ Bool
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> EdgeEither a b
Reg (DoubleOrnament
RootNote, (forall a. StartStop a
Start, forall a. StartStop a
Stop))
findOrnament StartStop n
_ StartStop n
_ StartStop n
_ Bool
_ Bool
_ = forall a. Maybe a
Nothing

{- | Attempts to reduce three notes as a passing motion
 where one of the child edges is a non-terminal edge.

 Since one of the edges is a terminal edge,
 the corresponding outer note could be start/stop symbol, in which case the reduction fails.
 The side with the terminal edge is thus a @StartStop Pitch i@ within a 'Reg',
 while the non-terminal side is a @Pitch i@ within an 'Pass'.
 Exactly one side must be a 'Reg' and the other an 'Pass', otherwise the reduction fails.
-}
findPassing
  :: (IsNote n)
  => EdgeEither (StartStop n) n
  -> n
  -> EdgeEither (StartStop n) n
  -> Maybe (InnerEdge n, PassingOrnament)
findPassing :: forall n.
IsNote n =>
EdgeEither (StartStop n) n
-> n
-> EdgeEither (StartStop n) n
-> Maybe (InnerEdge n, PassingOrnament)
findPassing (Reg (Inner n
l)) n
m (Pass n
r)
  | forall i. Diatonic i => i -> Bool
isStep (Pitch (ICOf (IntervalOf n))
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pm) Bool -> Bool -> Bool
&& forall i.
(Eq i, Interval i) =>
Pitch i -> Pitch i -> Pitch i -> Bool
between Pitch (ICOf (IntervalOf n))
pl Pitch (ICOf (IntervalOf n))
pm Pitch (ICOf (IntervalOf n))
pr =
      forall a. a -> Maybe a
Just ((n
l, n
r), PassingOrnament
PassingLeft)
 where
  pl :: Pitch (ICOf (IntervalOf n))
pl = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
l
  pm :: Pitch (ICOf (IntervalOf n))
pm = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
m
  pr :: Pitch (ICOf (IntervalOf n))
pr = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
r
findPassing (Pass n
l) n
m (Reg (Inner n
r))
  | forall i. Diatonic i => i -> Bool
isStep (Pitch (ICOf (IntervalOf n))
pm forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pr) Bool -> Bool -> Bool
&& forall i.
(Eq i, Interval i) =>
Pitch i -> Pitch i -> Pitch i -> Bool
between Pitch (ICOf (IntervalOf n))
pl Pitch (ICOf (IntervalOf n))
pm Pitch (ICOf (IntervalOf n))
pr =
      forall a. a -> Maybe a
Just ((n
l, n
r), PassingOrnament
PassingRight)
 where
  pl :: Pitch (ICOf (IntervalOf n))
pl = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
l
  pm :: Pitch (ICOf (IntervalOf n))
pm = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
m
  pr :: Pitch (ICOf (IntervalOf n))
pr = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
r
findPassing EdgeEither (StartStop n) n
_ n
_ EdgeEither (StartStop n) n
_ = forall a. Maybe a
Nothing

findRightOrnament :: (IsNote n) => n -> n -> Maybe RightOrnament
findRightOrnament :: forall n. IsNote n => n -> n -> Maybe RightOrnament
findRightOrnament n
l n
m
  | Pitch (ICOf (IntervalOf n))
pl forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pm = forall a. a -> Maybe a
Just RightOrnament
RightRepeat
  | forall i. Diatonic i => i -> Bool
isStep (Pitch (ICOf (IntervalOf n))
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pm) = forall a. a -> Maybe a
Just RightOrnament
RightNeighbor
  | Bool
otherwise = forall a. Maybe a
Nothing
 where
  pl :: Pitch (ICOf (IntervalOf n))
pl = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
l
  pm :: Pitch (ICOf (IntervalOf n))
pm = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
m

findLeftOrnament :: (IsNote n) => n -> n -> Maybe LeftOrnament
findLeftOrnament :: forall n. IsNote n => n -> n -> Maybe LeftOrnament
findLeftOrnament n
m n
r
  | Pitch (ICOf (IntervalOf n))
pm forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pr = forall a. a -> Maybe a
Just LeftOrnament
LeftRepeat
  | forall i. Diatonic i => i -> Bool
isStep (Pitch (ICOf (IntervalOf n))
pm forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pr) = forall a. a -> Maybe a
Just LeftOrnament
LeftNeighbor
  | Bool
otherwise = forall a. Maybe a
Nothing
 where
  pm :: Pitch (ICOf (IntervalOf n))
pm = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
m
  pr :: Pitch (ICOf (IntervalOf n))
pr = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall a b. (a -> b) -> a -> b
$ forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch n
r

-- evaluator interface
-- ===================

{- | The evaluator that represents the proto-voice grammar.
 As scores it returns a representation of each operation.
 These scores do not form a semiring,
 but can be embedded into different semirings using 'mapEvalScore'.
-}
protoVoiceEvaluator
  :: (Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n, Hashable n)
  => Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) (PVLeftmost n)
protoVoiceEvaluator :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) (PVLeftmost n)
protoVoiceEvaluator =
  forall tr slc h s tr' f slc'.
UnspreadMiddle tr slc h
-> UnspreadLeft tr slc
-> UnspreadRight tr slc
-> (StartStop slc -> tr -> slc -> tr -> StartStop slc -> [(tr, s)])
-> (StartStop slc -> Maybe tr' -> StartStop slc -> [(tr, f)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' (Leftmost s f h)
mkLeftmostEval
    forall n.
(Eq n, Ord n, Hashable n, IsNote n) =>
UnspreadMiddle (Edges n) (Notes n) (Spread n)
pvUnspreadMiddle
    forall n. UnspreadLeft (Edges n) (Notes n)
pvUnspreadLeft
    forall n. UnspreadRight (Edges n) (Notes n)
pvUnspreadRight
    forall n.
(IsNote n, Notation n, Ord n, Hashable n) =>
StartStop (Notes n)
-> Edges n
-> Notes n
-> Edges n
-> StartStop (Notes n)
-> [(Edges n, Split n)]
pvUnsplit
    forall (t :: * -> *) n.
(Foldable t, Ord n, Hashable n) =>
StartStop (Notes n)
-> Maybe (t (Edge n)) -> StartStop (Notes n) -> [(Edges n, Freeze)]
pvThaw
    forall (t :: * -> *) n.
(Foldable t, Eq n, Hashable n) =>
t n -> Notes n
pvSlice

{- | Computes the verticalization (unspread) of a middle transition.
 If the verticalization is admitted, returns the corresponding operation.
-}
pvUnspreadMiddle
  :: (Eq n, Ord n, Hashable n, IsNote n)
  => UnspreadMiddle (Edges n) (Notes n) (Spread n)
pvUnspreadMiddle :: forall n.
(Eq n, Ord n, Hashable n, IsNote n) =>
UnspreadMiddle (Edges n) (Notes n) (Spread n)
pvUnspreadMiddle (Notes MultiSet n
nl, Edges n
edges, Notes MultiSet n
nr)
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {a} {a} {f :: * -> *}.
(ICOf (IntervalOf a) ~ ICOf (IntervalOf a),
 Eq (f (Pitch (ICOf (IntervalOf a)))), Functor f, HasPitch a,
 HasPitch a) =>
(f a, f a) -> Bool
notARepetition (forall n. Edges n -> HashSet (Edge n)
edgesReg Edges n
edges) = forall a. Maybe a
Nothing
  | Bool
otherwise = forall a. a -> Maybe a
Just (forall n. MultiSet n -> Notes n
Notes MultiSet n
top, Spread n
op)
 where
  notARepetition :: (f a, f a) -> Bool
notARepetition (f a
p1, f a
p2) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch) f a
p1 forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch) f a
p2
  top :: MultiSet n
top = forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.maxUnion MultiSet n
nl MultiSet n
nr
  leftMS :: MultiSet n
leftMS = MultiSet n
nl forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.\\ MultiSet n
nr
  left :: HashMap n SpreadDirection
left = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> SpreadDirection
ToLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet n
leftMS
  rightMS :: MultiSet n
rightMS = MultiSet n
nr forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.\\ MultiSet n
nl
  right :: HashMap n SpreadDirection
right = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> SpreadDirection
ToRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet n
rightMS
  bothSet :: HashSet n
bothSet =
    forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.intersection (forall k. MultiSet k -> HashSet k
MS.toSet MultiSet n
nl) (forall k. MultiSet k -> HashSet k
MS.toSet MultiSet n
nr)
      forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`S.difference` (forall k. MultiSet k -> HashSet k
MS.toSet MultiSet n
leftMS forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`S.union` forall k. MultiSet k -> HashSet k
MS.toSet MultiSet n
rightMS)
  both :: HashMap n SpreadDirection
both = forall a b. (a -> b -> a) -> a -> HashSet b -> a
S.foldl' (\HashMap n SpreadDirection
m n
k -> forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert n
k SpreadDirection
ToBoth HashMap n SpreadDirection
m) forall k v. HashMap k v
HM.empty HashSet n
bothSet
  op :: Spread n
op = forall n. HashMap n SpreadDirection -> Edges n -> Spread n
SpreadOp (HashMap n SpreadDirection
left forall a. Semigroup a => a -> a -> a
<> HashMap n SpreadDirection
right forall a. Semigroup a => a -> a -> a
<> HashMap n SpreadDirection
both) Edges n
edges

{- | Computes all left parent transitions for a verticalization and a left child transition.
 Here, this operation is always admitted and unique,
 so the edges from the child transition are just passed through.
-}
pvUnspreadLeft :: UnspreadLeft (Edges n) (Notes n)
pvUnspreadLeft :: forall n. UnspreadLeft (Edges n) (Notes n)
pvUnspreadLeft (Edges n
el, Notes n
_) Notes n
_ = [Edges n
el]

{- | Computes all right parent transition for a verticalization and a right child transition.
 Here, this operation is always admitted and unique,
 so the edges from the child transition are just passed through.
-}
pvUnspreadRight :: UnspreadRight (Edges n) (Notes n)
pvUnspreadRight :: forall n. UnspreadRight (Edges n) (Notes n)
pvUnspreadRight (Notes n
_, Edges n
er) Notes n
_ = [Edges n
er]

{- | Computes all possible unsplits of two child transitions.
 Since transitions here only represent the certain edges,
 'pvUnsplit' must also take into account unelaborated edges,
 which are not present in the child transitions.
-}
pvUnsplit
  :: (IsNote n, Notation n, Ord n, Hashable n)
  => StartStop (Notes n)
  -> Edges n
  -> Notes n
  -> Edges n
  -> StartStop (Notes n)
  -> [(Edges n, Split n)]
pvUnsplit :: forall n.
(IsNote n, Notation n, Ord n, Hashable n) =>
StartStop (Notes n)
-> Edges n
-> Notes n
-> Edges n
-> StartStop (Notes n)
-> [(Edges n, Split n)]
pvUnsplit StartStop (Notes n)
notesl (Edges HashSet (Edge n)
leftRegs MultiSet (InnerEdge n)
leftPass) (Notes MultiSet n
notesm) (Edges HashSet (Edge n)
rightRegs MultiSet (InnerEdge n)
rightPass) StartStop (Notes n)
notesr =
  forall a b. (a -> b) -> [a] -> [b]
map ([(Edge n, (n, DoubleOrnament))],
 [(InnerEdge n, (n, PassingOrnament))], [(n, (n, RightOrnament))],
 [(n, (n, LeftOrnament))])
-> (Edges n, Split n)
mkTop [([(Edge n, (n, DoubleOrnament))],
  [(InnerEdge n, (n, PassingOrnament))], [(n, (n, RightOrnament))],
  [(n, (n, LeftOrnament))])]
combinations
 where
  -- preprocessing of the notes left and right of the unsplit
  !innerL :: [EdgeEither (StartStop n) n]
innerL = forall a b. a -> EdgeEither a b
Reg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n. StartStop (Notes n) -> [StartStop n]
innerNotes StartStop (Notes n)
notesl
  !innerR :: [EdgeEither (StartStop n) n]
innerR = forall a b. a -> EdgeEither a b
Reg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n. StartStop (Notes n) -> [StartStop n]
innerNotes StartStop (Notes n)
notesr

  -- find all reduction options for every pitch
  !options :: [[([(Edge n, (n, DoubleOrnament))],
   [(InnerEdge n, (n, PassingOrnament))], [(n, (n, RightOrnament))],
   [(n, (n, LeftOrnament))])]]
options = (n, Int)
-> [([(Edge n, (n, DoubleOrnament))],
     [(InnerEdge n, (n, PassingOrnament))], [(n, (n, RightOrnament))],
     [(n, (n, LeftOrnament))])]
noteOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet n
notesm
  noteOptions :: (n, Int)
-> [([(Edge n, (n, DoubleOrnament))],
     [(InnerEdge n, (n, PassingOrnament))], [(n, (n, RightOrnament))],
     [(n, (n, LeftOrnament))])]
noteOptions (n
note, Int
nocc)
    | Int
nocc forall a. Ord a => a -> a -> Bool
< forall a. MultiSet a -> Int
MS.size MultiSet (EdgeEither (StartStop n) n)
mandatoryLeft Bool -> Bool -> Bool
|| Int
nocc forall a. Ord a => a -> a -> Bool
< forall a. MultiSet a -> Int
MS.size MultiSet (EdgeEither (StartStop n) n)
mandatoryRight =
        []
    | Bool
otherwise =
        forall (t :: * -> *) a b c d.
Foldable t =>
t (Elaboration a b c d) -> ([a], [b], [c], [d])
partitionElaborations
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MultiSet (EdgeEither (StartStop n) n)
-> MultiSet (EdgeEither (StartStop n) n)
-> Int
-> [[Elaboration
       (Edge n, (n, DoubleOrnament))
       (InnerEdge n, (n, PassingOrnament))
       (n, (n, RightOrnament))
       (n, (n, LeftOrnament))]]
enumerateOptions MultiSet (EdgeEither (StartStop n) n)
mandatoryLeft MultiSet (EdgeEither (StartStop n) n)
mandatoryRight Int
nocc
   where
    -- compute the mandatory edges for the current pitch:
    mleftRegs :: HashSet (EdgeEither (StartStop n) n)
mleftRegs = forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
S.map (forall a b. a -> EdgeEither a b
Reg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter ((forall a. Eq a => a -> a -> Bool
== forall a. a -> StartStop a
Inner n
note) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) HashSet (Edge n)
leftRegs
    mleftPass :: MultiSet (EdgeEither (StartStop n) n)
mleftPass = forall b a.
(Eq b, Hashable b) =>
(a -> b) -> MultiSet a -> MultiSet b
MS.map (forall a b. b -> EdgeEither a b
Pass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> MultiSet a -> MultiSet a
MS.filter ((forall a. Eq a => a -> a -> Bool
== n
note) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) MultiSet (InnerEdge n)
leftPass
    mrightRegs :: HashSet (EdgeEither (StartStop n) n)
mrightRegs = forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
S.map (forall a b. a -> EdgeEither a b
Reg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter ((forall a. Eq a => a -> a -> Bool
== forall a. a -> StartStop a
Inner n
note) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) HashSet (Edge n)
rightRegs
    mrightPass :: MultiSet (EdgeEither (StartStop n) n)
mrightPass = forall b a.
(Eq b, Hashable b) =>
(a -> b) -> MultiSet a -> MultiSet b
MS.map (forall a b. b -> EdgeEither a b
Pass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> MultiSet a -> MultiSet a
MS.filter ((forall a. Eq a => a -> a -> Bool
== n
note) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) MultiSet (InnerEdge n)
rightPass
    mandatoryLeft :: MultiSet (EdgeEither (StartStop n) n)
mandatoryLeft = forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromSet HashSet (EdgeEither (StartStop n) n)
mleftRegs forall a. Semigroup a => a -> a -> a
<> MultiSet (EdgeEither (StartStop n) n)
mleftPass
    mandatoryRight :: MultiSet (EdgeEither (StartStop n) n)
mandatoryRight = forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromSet HashSet (EdgeEither (StartStop n) n)
mrightRegs forall a. Semigroup a => a -> a -> a
<> MultiSet (EdgeEither (StartStop n) n)
mrightPass

    -- the possible reductions of a (multiple) pitch are enumerated in three stages:

    -- stage 1: consume all mandatory edges on the left
    enumerateOptions :: MultiSet (EdgeEither (StartStop n) n)
-> MultiSet (EdgeEither (StartStop n) n)
-> Int
-> [[Elaboration
       (Edge n, (n, DoubleOrnament))
       (InnerEdge n, (n, PassingOrnament))
       (n, (n, RightOrnament))
       (n, (n, LeftOrnament))]]
enumerateOptions MultiSet (EdgeEither (StartStop n) n)
ml MultiSet (EdgeEither (StartStop n) n)
mr Int
n = do
      (MultiSet (EdgeEither (StartStop n) n)
mr', Int
n', [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
acc) <- forall (m :: * -> *) b a.
Monad m =>
(b -> a -> m b) -> b -> MultiSet a -> m b
MS.foldM (MultiSet (EdgeEither (StartStop n) n), Int,
 [Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament))])
-> EdgeEither (StartStop n) n
-> [(MultiSet (EdgeEither (StartStop n) n), Int,
     [Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        (n, (n, RightOrnament))
        (n, (n, LeftOrnament))])]
goL (MultiSet (EdgeEither (StartStop n) n)
mr, Int
n, []) MultiSet (EdgeEither (StartStop n) n)
ml
      (Int
n'', [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
acc') <- forall (m :: * -> *) b a.
Monad m =>
(b -> a -> m b) -> b -> MultiSet a -> m b
MS.foldM (Int,
 [Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament))])
-> EdgeEither (StartStop n) n
-> [(Int,
     [Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        (n, (n, RightOrnament))
        (n, (n, LeftOrnament))])]
goR (Int
n', [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
acc) MultiSet (EdgeEither (StartStop n) n)
mr'
      forall {a}. [a] -> Int -> [a] -> [[a]]
goFree [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
freeOptions Int
n'' [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
acc'
    goL :: (MultiSet (EdgeEither (StartStop n) n), Int,
 [Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament))])
-> EdgeEither (StartStop n) n
-> [(MultiSet (EdgeEither (StartStop n) n), Int,
     [Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        (n, (n, RightOrnament))
        (n, (n, LeftOrnament))])]
goL (MultiSet (EdgeEither (StartStop n) n)
_, Int
0, [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
_) EdgeEither (StartStop n) n
_ = []
    goL (MultiSet (EdgeEither (StartStop n) n)
mr, Int
n, [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
acc) EdgeEither (StartStop n) n
l = do
      (Elaboration
  (Edge n, (n, DoubleOrnament))
  (InnerEdge n, (n, PassingOrnament))
  (n, (n, RightOrnament))
  (n, (n, LeftOrnament))
new, MultiSet (EdgeEither (StartStop n) n)
mr') <- Int
-> EdgeEither (StartStop n) n
-> MultiSet (EdgeEither (StartStop n) n)
-> [(Elaboration
       (Edge n, (n, DoubleOrnament))
       (InnerEdge n, (n, PassingOrnament))
       (n, (n, RightOrnament))
       (n, (n, LeftOrnament)),
     MultiSet (EdgeEither (StartStop n) n))]
pickLeft Int
n EdgeEither (StartStop n) n
l MultiSet (EdgeEither (StartStop n) n)
mr
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (MultiSet (EdgeEither (StartStop n) n)
mr', Int
n forall a. Num a => a -> a -> a
- Int
1, Elaboration
  (Edge n, (n, DoubleOrnament))
  (InnerEdge n, (n, PassingOrnament))
  (n, (n, RightOrnament))
  (n, (n, LeftOrnament))
new forall a. a -> [a] -> [a]
: [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
acc)
    -- combine a mandatory left with a mandatory right or free right edge
    pickLeft :: Int
-> EdgeEither (StartStop n) n
-> MultiSet (EdgeEither (StartStop n) n)
-> [(Elaboration
       (Edge n, (n, DoubleOrnament))
       (InnerEdge n, (n, PassingOrnament))
       (n, (n, RightOrnament))
       (n, (n, LeftOrnament)),
     MultiSet (EdgeEither (StartStop n) n))]
pickLeft Int
n EdgeEither (StartStop n) n
l MultiSet (EdgeEither (StartStop n) n)
mr
      | Int
n forall a. Ord a => a -> a -> Bool
> forall a. MultiSet a -> Int
MS.size MultiSet (EdgeEither (StartStop n) n)
mr = [(Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament)),
  MultiSet (EdgeEither (StartStop n) n))]
mand forall a. Semigroup a => a -> a -> a
<> [(Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament)),
  MultiSet (EdgeEither (StartStop n) n))]
opt forall a. Semigroup a => a -> a -> a
<> [(Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament)),
  MultiSet (EdgeEither (StartStop n) n))]
single
      | Bool
otherwise = [(Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament)),
  MultiSet (EdgeEither (StartStop n) n))]
mand
     where
      mand :: [(Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament)),
  MultiSet (EdgeEither (StartStop n) n))]
mand = do
        EdgeEither (StartStop n) n
r <- forall k. MultiSet k -> [k]
MS.distinctElems MultiSet (EdgeEither (StartStop n) n)
mr
        Elaboration
  (Edge n, (n, DoubleOrnament))
  (InnerEdge n, (n, PassingOrnament))
  (n, (n, RightOrnament))
  (n, (n, LeftOrnament))
red <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall {n} {c} {d}.
(HasPitch n, Diatonic (ICOf (IntervalOf n)),
 Eq (ICOf (IntervalOf n))) =>
Bool
-> Bool
-> EdgeEither (StartStop n) n
-> n
-> EdgeEither (StartStop n) n
-> Maybe
     (Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        c
        d)
tryReduction Bool
True Bool
True EdgeEither (StartStop n) n
l n
note EdgeEither (StartStop n) n
r
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Elaboration
  (Edge n, (n, DoubleOrnament))
  (InnerEdge n, (n, PassingOrnament))
  (n, (n, RightOrnament))
  (n, (n, LeftOrnament))
red, forall a. (Eq a, Hashable a) => a -> MultiSet a -> MultiSet a
MS.delete EdgeEither (StartStop n) n
r MultiSet (EdgeEither (StartStop n) n)
mr)
      -- TODO: remove mr options here?
      tryOpt :: EdgeEither (StartStop n) n
-> Maybe
     (Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        (n, (n, RightOrnament))
        (n, (n, LeftOrnament)))
tryOpt EdgeEither (StartStop n) n
r = forall {n} {c} {d}.
(HasPitch n, Diatonic (ICOf (IntervalOf n)),
 Eq (ICOf (IntervalOf n))) =>
Bool
-> Bool
-> EdgeEither (StartStop n) n
-> n
-> EdgeEither (StartStop n) n
-> Maybe
     (Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        c
        d)
tryReduction Bool
True (EdgeEither (StartStop n) n
r forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet (EdgeEither (StartStop n) n)
mrightRegs) EdgeEither (StartStop n) n
l n
note EdgeEither (StartStop n) n
r
      opt :: [(Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament)),
  MultiSet (EdgeEither (StartStop n) n))]
opt = (,MultiSet (EdgeEither (StartStop n) n)
mr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe EdgeEither (StartStop n) n
-> Maybe
     (Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        (n, (n, RightOrnament))
        (n, (n, LeftOrnament)))
tryOpt [EdgeEither (StartStop n) n]
innerR
      single :: [(Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament)),
  MultiSet (EdgeEither (StartStop n) n))]
single = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,MultiSet (EdgeEither (StartStop n) n)
mr) forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall {a} {b} {a} {b} {d}.
(HasPitch a, Diatonic (ICOf (IntervalOf a)),
 Eq (ICOf (IntervalOf a))) =>
a
-> EdgeEither (StartStop a) b
-> Maybe (Elaboration a b (a, (a, RightOrnament)) d)
tryLeftReduction n
note EdgeEither (StartStop n) n
l

    -- stage 2: consume all remaining mandatory edges on the right
    goR :: (Int,
 [Elaboration
    (Edge n, (n, DoubleOrnament))
    (InnerEdge n, (n, PassingOrnament))
    (n, (n, RightOrnament))
    (n, (n, LeftOrnament))])
-> EdgeEither (StartStop n) n
-> [(Int,
     [Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        (n, (n, RightOrnament))
        (n, (n, LeftOrnament))])]
goR (Int
0, [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
_) EdgeEither (StartStop n) n
_ = []
    goR (Int
n, [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
acc) EdgeEither (StartStop n) n
r = do
      Elaboration
  (Edge n, (n, DoubleOrnament))
  (InnerEdge n, (n, PassingOrnament))
  (n, (n, RightOrnament))
  (n, (n, LeftOrnament))
new <- EdgeEither (StartStop n) n
-> [Elaboration
      (Edge n, (n, DoubleOrnament))
      (InnerEdge n, (n, PassingOrnament))
      (n, (n, RightOrnament))
      (n, (n, LeftOrnament))]
pickRight EdgeEither (StartStop n) n
r
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n forall a. Num a => a -> a -> a
- Int
1, Elaboration
  (Edge n, (n, DoubleOrnament))
  (InnerEdge n, (n, PassingOrnament))
  (n, (n, RightOrnament))
  (n, (n, LeftOrnament))
new forall a. a -> [a] -> [a]
: [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
acc)
    -- combine mandatory right with free left edge
    pickRight :: EdgeEither (StartStop n) n
-> [Elaboration
      (Edge n, (n, DoubleOrnament))
      (InnerEdge n, (n, PassingOrnament))
      (n, (n, RightOrnament))
      (n, (n, LeftOrnament))]
pickRight EdgeEither (StartStop n) n
r = [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
opt forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
single
     where
      tryOpt :: EdgeEither (StartStop n) n
-> Maybe
     (Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        (n, (n, RightOrnament))
        (n, (n, LeftOrnament)))
tryOpt EdgeEither (StartStop n) n
l = forall {n} {c} {d}.
(HasPitch n, Diatonic (ICOf (IntervalOf n)),
 Eq (ICOf (IntervalOf n))) =>
Bool
-> Bool
-> EdgeEither (StartStop n) n
-> n
-> EdgeEither (StartStop n) n
-> Maybe
     (Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        c
        d)
tryReduction (EdgeEither (StartStop n) n
l forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet (EdgeEither (StartStop n) n)
mleftRegs) Bool
True EdgeEither (StartStop n) n
l n
note EdgeEither (StartStop n) n
r
      opt :: [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
opt = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe EdgeEither (StartStop n) n
-> Maybe
     (Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        (n, (n, RightOrnament))
        (n, (n, LeftOrnament)))
tryOpt [EdgeEither (StartStop n) n]
innerL
      single :: [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
single = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall {a} {b} {a} {b} {c}.
(HasPitch a, Diatonic (ICOf (IntervalOf a)),
 Eq (ICOf (IntervalOf a))) =>
a
-> EdgeEither (StartStop a) b
-> Maybe (Elaboration a b c (a, (a, LeftOrnament)))
tryRightReduction n
note EdgeEither (StartStop n) n
r

    -- stage 3: explain all remaining notes through a combination of unknown edges
    goFree :: [a] -> Int -> [a] -> [[a]]
goFree [a]
_ Int
0 [a]
acc = forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
acc
    goFree [] Int
_ [a]
_ = []
    goFree [a
lastOpt] Int
n [a]
acc = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
L.replicate Int
n a
lastOpt forall a. Semigroup a => a -> a -> a
<> [a]
acc
    goFree (a
opt : [a]
opts) Int
n [a]
acc = do
      Int
nopt <- [Int
0 .. Int
n]
      [a] -> Int -> [a] -> [[a]]
goFree [a]
opts (Int
n forall a. Num a => a -> a -> a
- Int
nopt) (forall a. Int -> a -> [a]
L.replicate Int
nopt a
opt forall a. Semigroup a => a -> a -> a
<> [a]
acc)
    -- list all options for free reduction
    freeOptions :: [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
freeOptions = [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
pickFreeBoth forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
pickFreeLeft forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
pickFreeRight
    -- combine two free edges
    pickFreeBoth :: [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
pickFreeBoth = do
      EdgeEither (StartStop n) n
l <- [EdgeEither (StartStop n) n]
innerL
      EdgeEither (StartStop n) n
r <- [EdgeEither (StartStop n) n]
innerR
      forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$
        forall {n} {c} {d}.
(HasPitch n, Diatonic (ICOf (IntervalOf n)),
 Eq (ICOf (IntervalOf n))) =>
Bool
-> Bool
-> EdgeEither (StartStop n) n
-> n
-> EdgeEither (StartStop n) n
-> Maybe
     (Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        c
        d)
tryReduction (EdgeEither (StartStop n) n
l forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet (EdgeEither (StartStop n) n)
mleftRegs) (EdgeEither (StartStop n) n
r forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet (EdgeEither (StartStop n) n)
mrightRegs) EdgeEither (StartStop n) n
l n
note EdgeEither (StartStop n) n
r
    -- reduce to left using free edge
    pickFreeLeft :: [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
pickFreeLeft = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {a} {b} {a} {b} {d}.
(HasPitch a, Diatonic (ICOf (IntervalOf a)),
 Eq (ICOf (IntervalOf a))) =>
a
-> EdgeEither (StartStop a) b
-> Maybe (Elaboration a b (a, (a, RightOrnament)) d)
tryLeftReduction n
note) [EdgeEither (StartStop n) n]
innerL
    -- reduce to right using free edge
    pickFreeRight :: [Elaboration
   (Edge n, (n, DoubleOrnament))
   (InnerEdge n, (n, PassingOrnament))
   (n, (n, RightOrnament))
   (n, (n, LeftOrnament))]
pickFreeRight = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {a} {b} {a} {b} {c}.
(HasPitch a, Diatonic (ICOf (IntervalOf a)),
 Eq (ICOf (IntervalOf a))) =>
a
-> EdgeEither (StartStop a) b
-> Maybe (Elaboration a b c (a, (a, LeftOrnament)))
tryRightReduction n
note) [EdgeEither (StartStop n) n]
innerR

  -- at all stages: try out potential reductions:

  -- two terminal edges: any ornament
  tryReduction :: Bool
-> Bool
-> EdgeEither (StartStop n) n
-> n
-> EdgeEither (StartStop n) n
-> Maybe
     (Elaboration
        (Edge n, (n, DoubleOrnament))
        (InnerEdge n, (n, PassingOrnament))
        c
        d)
tryReduction Bool
lIsUsed Bool
rIsUsed (Reg StartStop n
notel) n
notem (Reg StartStop n
noter) = do
    EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
reduction <- forall n.
IsNote n =>
StartStop n
-> StartStop n
-> StartStop n
-> Bool
-> Bool
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
findOrnament StartStop n
notel (forall a. a -> StartStop a
Inner n
notem) StartStop n
noter Bool
lIsUsed Bool
rIsUsed
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
reduction of
      (Reg (DoubleOrnament
orn, Edge n
parent)) -> forall a b c d. a -> Elaboration a b c d
EReg (Edge n
parent, (n
notem, DoubleOrnament
orn))
      (Pass (PassingOrnament
pass, InnerEdge n
parent)) -> forall a b c d. b -> Elaboration a b c d
EPass (InnerEdge n
parent, (n
notem, PassingOrnament
pass))
  -- a non-terminal edge left and a terminal edge right: passing note
  tryReduction Bool
_ Bool
_ notel :: EdgeEither (StartStop n) n
notel@(Pass n
_) n
notem noter :: EdgeEither (StartStop n) n
noter@(Reg StartStop n
_) = do
    (InnerEdge n
parent, PassingOrnament
pass) <- forall n.
IsNote n =>
EdgeEither (StartStop n) n
-> n
-> EdgeEither (StartStop n) n
-> Maybe (InnerEdge n, PassingOrnament)
findPassing EdgeEither (StartStop n) n
notel n
notem EdgeEither (StartStop n) n
noter
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c d. b -> Elaboration a b c d
EPass (InnerEdge n
parent, (n
notem, PassingOrnament
pass))
  -- a terminal edge left and a non-terminal edge right: passing note
  tryReduction Bool
_ Bool
_ notel :: EdgeEither (StartStop n) n
notel@(Reg StartStop n
_) n
notem noter :: EdgeEither (StartStop n) n
noter@(Pass n
_) = do
    (InnerEdge n
parent, PassingOrnament
pass) <- forall n.
IsNote n =>
EdgeEither (StartStop n) n
-> n
-> EdgeEither (StartStop n) n
-> Maybe (InnerEdge n, PassingOrnament)
findPassing EdgeEither (StartStop n) n
notel n
notem EdgeEither (StartStop n) n
noter
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c d. b -> Elaboration a b c d
EPass (InnerEdge n
parent, (n
notem, PassingOrnament
pass))
  -- all other combinations are forbidden
  tryReduction Bool
_ Bool
_ EdgeEither (StartStop n) n
_ n
_ EdgeEither (StartStop n) n
_ = forall a. Maybe a
Nothing

  -- single reduction to a left parent
  tryLeftReduction :: a
-> EdgeEither (StartStop a) b
-> Maybe (Elaboration a b (a, (a, RightOrnament)) d)
tryLeftReduction a
notem (Reg (Inner a
notel)) = do
    RightOrnament
orn <- forall n. IsNote n => n -> n -> Maybe RightOrnament
findRightOrnament a
notel a
notem
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c d. c -> Elaboration a b c d
ER (a
notel, (a
notem, RightOrnament
orn))
  tryLeftReduction a
_ EdgeEither (StartStop a) b
_ = forall a. Maybe a
Nothing

  -- single reduction to a right parent
  tryRightReduction :: a
-> EdgeEither (StartStop a) b
-> Maybe (Elaboration a b c (a, (a, LeftOrnament)))
tryRightReduction a
notem (Reg (Inner a
noter)) = do
    LeftOrnament
orn <- forall n. IsNote n => n -> n -> Maybe LeftOrnament
findLeftOrnament a
notem a
noter
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c d. d -> Elaboration a b c d
EL (a
noter, (a
notem, LeftOrnament
orn))
  tryRightReduction a
_ EdgeEither (StartStop a) b
_ = forall a. Maybe a
Nothing

  -- compute all possible combinations of reduction options
  !combinations :: [([(Edge n, (n, DoubleOrnament))],
  [(InnerEdge n, (n, PassingOrnament))], [(n, (n, RightOrnament))],
  [(n, (n, LeftOrnament))])]
combinations =
    if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [[([(Edge n, (n, DoubleOrnament))],
   [(InnerEdge n, (n, PassingOrnament))], [(n, (n, RightOrnament))],
   [(n, (n, LeftOrnament))])]]
options -- check if any note has no options
      then [] -- if yes, then no reduction is possible at all
      else forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {m :: * -> *} {a} {b} {c} {d}.
(Monad m, Semigroup a, Semigroup b, Semigroup c, Semigroup d) =>
(a, b, c, d) -> m (a, b, c, d) -> m (a, b, c, d)
pickOption ([], [], [], []) [[([(Edge n, (n, DoubleOrnament))],
   [(InnerEdge n, (n, PassingOrnament))], [(n, (n, RightOrnament))],
   [(n, (n, LeftOrnament))])]]
options -- otherwise, compute all combinations
      -- picks all different options for a single note in the list monad
  pickOption :: (a, b, c, d) -> m (a, b, c, d) -> m (a, b, c, d)
pickOption (a
accReg, b
accPass, c
accL, d
accR) m (a, b, c, d)
opts = do
    (a
regs, b
pass, c
ls, d
rs) <- m (a, b, c, d)
opts
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
regs forall a. Semigroup a => a -> a -> a
<> a
accReg, b
pass forall a. Semigroup a => a -> a -> a
<> b
accPass, c
ls forall a. Semigroup a => a -> a -> a
<> c
accL, d
rs forall a. Semigroup a => a -> a -> a
<> d
accR)

  -- convert a combination into a derivation operation:
  -- turn the accumulated information into the format expected from the evaluator
  mkTop :: ([(Edge n, (n, DoubleOrnament))],
 [(InnerEdge n, (n, PassingOrnament))], [(n, (n, RightOrnament))],
 [(n, (n, LeftOrnament))])
-> (Edges n, Split n)
mkTop ([(Edge n, (n, DoubleOrnament))]
regs, [(InnerEdge n, (n, PassingOrnament))]
pass, [(n, (n, RightOrnament))]
rs, [(n, (n, LeftOrnament))]
ls) =
    if Bool
True -- validate
      then (Edges n
top, forall n.
Map (Edge n) [(n, DoubleOrnament)]
-> Map (InnerEdge n) [(n, PassingOrnament)]
-> Map n [(n, RightOrnament)]
-> Map n [(n, LeftOrnament)]
-> HashSet (Edge n)
-> HashSet (Edge n)
-> MultiSet (InnerEdge n)
-> MultiSet (InnerEdge n)
-> Split n
SplitOp Map (Edge n) [(n, DoubleOrnament)]
tmap Map (InnerEdge n) [(n, PassingOrnament)]
ntmap Map n [(n, RightOrnament)]
rmap Map n [(n, LeftOrnament)]
lmap HashSet (Edge n)
leftRegs HashSet (Edge n)
rightRegs MultiSet (InnerEdge n)
passL MultiSet (InnerEdge n)
passR)
      else
        forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
          String
"invalid unsplit:\n  notesl="
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show StartStop (Notes n)
notesl
            forall a. Semigroup a => a -> a -> a
<> String
"\n  notesr="
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show StartStop (Notes n)
notesr
            forall a. Semigroup a => a -> a -> a
<> String
"\n  notesm="
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall n. MultiSet n -> Notes n
Notes MultiSet n
notesm)
            forall a. Semigroup a => a -> a -> a
<> String
"\n  left="
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge n)
leftRegs MultiSet (InnerEdge n)
leftPass)
            forall a. Semigroup a => a -> a -> a
<> String
"\n  right="
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge n)
rightRegs MultiSet (InnerEdge n)
rightPass)
            forall a. Semigroup a => a -> a -> a
<> String
"\n  top="
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Edges n
top
   where
    -- validate =
    --   all ((`L.elem` innerNotes notesl) . fst . fst) regs
    --     && all ((`L.elem` innerNotes notesr) . snd . fst)   regs
    --     && all ((`L.elem` innerNotes notesl) . Inner . fst) rs
    --     && all ((`L.elem` innerNotes notesr) . Inner . fst) ls

    -- collect all operations
    mapify :: [(k, a)] -> Map k [a]
mapify [(k, a)]
xs = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Semigroup a => a -> a -> a
(<>) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
: []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, a)]
xs
    tmap :: Map (Edge n) [(n, DoubleOrnament)]
tmap = forall {k} {a}. Ord k => [(k, a)] -> Map k [a]
mapify [(Edge n, (n, DoubleOrnament))]
regs
    ntmap :: Map (InnerEdge n) [(n, PassingOrnament)]
ntmap = forall {k} {a}. Ord k => [(k, a)] -> Map k [a]
mapify [(InnerEdge n, (n, PassingOrnament))]
pass
    lmap :: Map n [(n, LeftOrnament)]
lmap = forall {k} {a}. Ord k => [(k, a)] -> Map k [a]
mapify [(n, (n, LeftOrnament))]
ls
    rmap :: Map n [(n, RightOrnament)]
rmap = forall {k} {a}. Ord k => [(k, a)] -> Map k [a]
mapify [(n, (n, RightOrnament))]
rs
    top :: Edges n
top = forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges (forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Edge n, (n, DoubleOrnament))]
regs)) (forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(InnerEdge n, (n, PassingOrnament))]
pass))
    passL :: MultiSet (InnerEdge n)
passL = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. (Eq a, Hashable a) => a -> MultiSet a -> MultiSet a
MS.delete MultiSet (InnerEdge n)
leftPass forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {b} {b}. ((a, b), (b, PassingOrnament)) -> Maybe (a, b)
leftPassingChild [(InnerEdge n, (n, PassingOrnament))]
pass
    passR :: MultiSet (InnerEdge n)
passR = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. (Eq a, Hashable a) => a -> MultiSet a -> MultiSet a
MS.delete MultiSet (InnerEdge n)
rightPass forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {b} {a}. ((a, b), (a, PassingOrnament)) -> Maybe (a, b)
rightPassingChild [(InnerEdge n, (n, PassingOrnament))]
pass
    leftPassingChild :: ((a, b), (b, PassingOrnament)) -> Maybe (a, b)
leftPassingChild ((a
l, b
_r), (b
m, PassingOrnament
orn)) =
      if PassingOrnament
orn forall a. Eq a => a -> a -> Bool
== PassingOrnament
PassingRight then forall a. a -> Maybe a
Just (a
l, b
m) else forall a. Maybe a
Nothing
    rightPassingChild :: ((a, b), (a, PassingOrnament)) -> Maybe (a, b)
rightPassingChild ((a
_l, b
r), (a
m, PassingOrnament
orn)) =
      if PassingOrnament
orn forall a. Eq a => a -> a -> Bool
== PassingOrnament
PassingLeft then forall a. a -> Maybe a
Just (a
m, b
r) else forall a. Maybe a
Nothing

{- | Computes all potential ways a surface transition could have been frozen.
 In this grammar, this operation is unique and just turns ties into edges.
-}
pvThaw
  :: (Foldable t, Ord n, Hashable n)
  => StartStop (Notes n)
  -> Maybe (t (Edge n))
  -> StartStop (Notes n)
  -> [(Edges n, Freeze)]
pvThaw :: forall (t :: * -> *) n.
(Foldable t, Ord n, Hashable n) =>
StartStop (Notes n)
-> Maybe (t (Edge n)) -> StartStop (Notes n) -> [(Edges n, Freeze)]
pvThaw StartStop (Notes n)
_ Maybe (t (Edge n))
e StartStop (Notes n)
_ = [(forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges (forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (t (Edge n))
e) forall a. MultiSet a
MS.empty, Freeze
FreezeOp)]

pvSlice :: (Foldable t, Eq n, Hashable n) => t n -> Notes n
pvSlice :: forall (t :: * -> *) n.
(Foldable t, Eq n, Hashable n) =>
t n -> Notes n
pvSlice = forall n. MultiSet n -> Notes n
Notes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- evaluators in specific semirings
-- ================================

{- | A restricted version of the PV evaluator
 that prohibits split operations in which one of the parent slices is repeated entirely.
-}
protoVoiceEvaluatorNoRepSplit
  :: (Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n, Hashable n)
  => Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) (PVLeftmost n)
protoVoiceEvaluatorNoRepSplit :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) (PVLeftmost n)
protoVoiceEvaluatorNoRepSplit = forall tr tr' slc slc' v.
UnspreadMiddle tr slc v
-> UnspreadLeft tr slc
-> UnspreadRight tr slc
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' v
Eval UnspreadMiddle (Edges n) (Notes n) (PVLeftmost n)
vm UnspreadLeft (Edges n) (Notes n)
vl UnspreadRight (Edges n) (Notes n)
vr StartStop (Notes n)
-> Edges n
-> Notes n
-> Edges n
-> StartStop (Notes n)
-> SplitType
-> [(Edges n, PVLeftmost n)]
filterSplit StartStop (Notes n)
-> Maybe (t (Edge n))
-> StartStop (Notes n)
-> Bool
-> [(Edges n, PVLeftmost n)]
t t2 n -> Notes n
s
 where
  (Eval UnspreadMiddle (Edges n) (Notes n) (PVLeftmost n)
vm UnspreadLeft (Edges n) (Notes n)
vl UnspreadRight (Edges n) (Notes n)
vr StartStop (Notes n)
-> Edges n
-> Notes n
-> Edges n
-> StartStop (Notes n)
-> SplitType
-> [(Edges n, PVLeftmost n)]
mg StartStop (Notes n)
-> Maybe (t (Edge n))
-> StartStop (Notes n)
-> Bool
-> [(Edges n, PVLeftmost n)]
t t2 n -> Notes n
s) = forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) (PVLeftmost n)
protoVoiceEvaluator
  filterSplit :: StartStop (Notes n)
-> Edges n
-> Notes n
-> Edges n
-> StartStop (Notes n)
-> SplitType
-> [(Edges n, PVLeftmost n)]
filterSplit StartStop (Notes n)
l Edges n
lt Notes n
mid Edges n
rt StartStop (Notes n)
r SplitType
typ = forall a. (a -> Bool) -> [a] -> [a]
filter forall {a} {a} {f} {h}. (a, Leftmost (Split a) f h) -> Bool
ok forall a b. (a -> b) -> a -> b
$ StartStop (Notes n)
-> Edges n
-> Notes n
-> Edges n
-> StartStop (Notes n)
-> SplitType
-> [(Edges n, PVLeftmost n)]
mg StartStop (Notes n)
l Edges n
lt Notes n
mid Edges n
rt StartStop (Notes n)
r SplitType
typ
  ok :: (a, Leftmost (Split a) f h) -> Bool
ok (a
_, LMSplitLeft Split a
op) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall {a}. Split a -> Bool
onlyRepeats Split a
op
  ok (a
_, LMSplitOnly Split a
op) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall {a}. Split a -> Bool
onlyRepeats Split a
op
  ok (a
_, LMSplitRight Split a
op) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall {a}. Split a -> Bool
onlyRepeats Split a
op
  ok (a, Leftmost (Split a) f h)
_ = Bool
False
  onlyRepeats :: Split a -> Bool
onlyRepeats (SplitOp Map (Edge a) [(a, DoubleOrnament)]
regs Map (InnerEdge a) [(a, PassingOrnament)]
pass Map a [(a, RightOrnament)]
rs Map a [(a, LeftOrnament)]
ls HashSet (Edge a)
_ HashSet (Edge a)
_ MultiSet (InnerEdge a)
_ MultiSet (InnerEdge a)
_) =
    forall k a. Map k a -> Bool
M.null Map (InnerEdge a) [(a, PassingOrnament)]
pass Bool -> Bool -> Bool
&& (Bool
allRepetitionsLeft Bool -> Bool -> Bool
|| Bool
allRepetitionsRight)
   where
    allSinglesRepeat :: Bool
allSinglesRepeat =
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall {t :: * -> *} {b} {a} {a}.
Foldable t =>
(b -> Bool) -> (a, t (a, b)) -> Bool
check (forall a. Eq a => a -> a -> Bool
== RightOrnament
RightRepeat)) (forall k a. Map k a -> [(k, a)]
M.toList Map a [(a, RightOrnament)]
rs)
        Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall {t :: * -> *} {b} {a} {a}.
Foldable t =>
(b -> Bool) -> (a, t (a, b)) -> Bool
check (forall a. Eq a => a -> a -> Bool
== LeftOrnament
LeftRepeat)) (forall k a. Map k a -> [(k, a)]
M.toList Map a [(a, LeftOrnament)]
ls)
    allRepetitionsLeft :: Bool
allRepetitionsLeft =
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall {t :: * -> *} {b} {a} {a}.
Foldable t =>
(b -> Bool) -> (a, t (a, b)) -> Bool
check DoubleOrnament -> Bool
isRepetitionOnLeft) (forall k a. Map k a -> [(k, a)]
M.toList Map (Edge a) [(a, DoubleOrnament)]
regs) Bool -> Bool -> Bool
&& Bool
allSinglesRepeat
    allRepetitionsRight :: Bool
allRepetitionsRight =
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall {t :: * -> *} {b} {a} {a}.
Foldable t =>
(b -> Bool) -> (a, t (a, b)) -> Bool
check DoubleOrnament -> Bool
isRepetitionOnRight) (forall k a. Map k a -> [(k, a)]
M.toList Map (Edge a) [(a, DoubleOrnament)]
regs) Bool -> Bool -> Bool
&& Bool
allSinglesRepeat
  check :: (b -> Bool) -> (a, t (a, b)) -> Bool
check b -> Bool
fpred (a
_, t (a, b)
os) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (b -> Bool
fpred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) t (a, b)
os

-- | An evaluator for protovoices that produces values in the 'Derivations' semiring.
pvDerivUnrestricted
  :: (Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n, Hashable n)
  => Eval
      (Edges n)
      (t (Edge n))
      (Notes n)
      (t2 n)
      (Derivations (PVLeftmost n))
pvDerivUnrestricted :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 n)
  (Derivations (PVLeftmost n))
pvDerivUnrestricted = forall v w tr tr' slc slc'.
(v -> w) -> Eval tr tr' slc slc' v -> Eval tr tr' slc slc' w
mapEvalScore forall a. a -> Derivations a
Do forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) (PVLeftmost n)
protoVoiceEvaluator

{- | An evaluator for protovoices that produces values in the 'Derivations' semiring.

 - Enforces right-branching spreads (see 'rightBranchSpread').
-}
pvDerivRightBranch
  :: (Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n, Hashable n)
  => Eval
      (Merged, (RightBranchSpread, Edges n))
      (t (Edge n))
      ((), ((), Notes n))
      (t2 n)
      (Derivations (PVLeftmost n))
pvDerivRightBranch :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval
  (Merged, (RightBranchSpread, Edges n))
  (t (Edge n))
  ((), ((), Notes n))
  (t2 n)
  (Derivations (PVLeftmost n))
pvDerivRightBranch =
  forall tr tr' slc slc' w.
Eval tr tr' slc slc' w -> Eval (Merged, tr) tr' ((), slc) slc' w
splitFirst forall a b. (a -> b) -> a -> b
$ forall tr tr' slc slc' w.
Eval tr tr' slc slc' w
-> Eval (RightBranchSpread, tr) tr' ((), slc) slc' w
rightBranchSpread forall a b. (a -> b) -> a -> b
$ forall v w tr tr' slc slc'.
(v -> w) -> Eval tr tr' slc slc' v -> Eval tr tr' slc slc' w
mapEvalScore forall a. a -> Derivations a
Do forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) (PVLeftmost n)
protoVoiceEvaluatorNoRepSplit

-- | An evaluator for protovoices that produces values in the counting semiring.
pvCountUnrestricted
  :: (Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n, Hashable n)
  => Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) Int
pvCountUnrestricted :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) Int
pvCountUnrestricted = forall v w tr tr' slc slc'.
(v -> w) -> Eval tr tr' slc slc' v -> Eval tr tr' slc slc' w
mapEvalScore (forall a b. a -> b -> a
const Int
1) forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) (PVLeftmost n)
protoVoiceEvaluator

{- | An evaluator for protovoices that produces values in the counting semiring.

 - Prohibits split operations in which one of the parent slices is repeated entirely (see 'protoVoiceEvaluatorNoRepSplit').
-}
pvCountNoRepSplit
  :: (Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n, Hashable n)
  => Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) Int
pvCountNoRepSplit :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) Int
pvCountNoRepSplit = forall v w tr tr' slc slc'.
(v -> w) -> Eval tr tr' slc slc' v -> Eval tr tr' slc slc' w
mapEvalScore (forall a b. a -> b -> a
const Int
1) forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) (PVLeftmost n)
protoVoiceEvaluatorNoRepSplit

{- | An evaluator for protovoices that produces values in the counting semiring.

 - Prohibits split operations in which one of the parent slices is repeated entirely (see 'protoVoiceEvaluatorNoRepSplit').
 - Enforces right-branching spreads (see 'rightBranchSpread').
-}
pvCountNoRepSplitRightBranch
  :: (Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n, Hashable n)
  => Eval (RightBranchSpread, Edges n) (t (Edge n)) ((), Notes n) (t2 n) Int
pvCountNoRepSplitRightBranch :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval
  (RightBranchSpread, Edges n) (t (Edge n)) ((), Notes n) (t2 n) Int
pvCountNoRepSplitRightBranch = forall tr tr' slc slc' w.
Eval tr tr' slc slc' w
-> Eval (RightBranchSpread, tr) tr' ((), slc) slc' w
rightBranchSpread forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 n) Int
pvCountNoRepSplit

{- | An evaluator for protovoices that produces values in the counting semiring.

 - Prohibits split operations in which one of the parent slices is repeated entirely (see 'protoVoiceEvaluatorNoRepSplit').
 - Enforces right-branching spreads (see 'rightBranchSpread').
 - Normalizes the order of adjacent split and spread operations to split-before-spread (see 'splitFirst').
-}
pvCountNoRepSplitRightBranchSplitFirst
  :: (Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n, Hashable n)
  => Eval
      (Merged, (RightBranchSpread, Edges n))
      (t (Edge n))
      ((), ((), Notes n))
      (t2 n)
      Int
pvCountNoRepSplitRightBranchSplitFirst :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval
  (Merged, (RightBranchSpread, Edges n))
  (t (Edge n))
  ((), ((), Notes n))
  (t2 n)
  Int
pvCountNoRepSplitRightBranchSplitFirst = forall tr tr' slc slc' w.
Eval tr tr' slc slc' w -> Eval (Merged, tr) tr' ((), slc) slc' w
splitFirst forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsNote n, Notation n,
 Hashable n) =>
Eval
  (RightBranchSpread, Edges n) (t (Edge n)) ((), Notes n) (t2 n) Int
pvCountNoRepSplitRightBranch