{-# 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'.
    IsPitch
  , protoVoiceEvaluator
  , protoVoiceEvaluatorNoRepSplit

    -- * Parsing Derivations
  , pvDerivUnrestricted
  , pvDerivRightBranch

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

    -- * Useful Helpers
  , pvThaw
  ) where

import Common
import PVGrammar

import Musicology.Pitch
  ( Diatonic
  , Interval (..)
  , Notation
  , SPitch
  , pc
  , pto
  )
import Musicology.Pitch.Spelled -- TODO: remove

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 Data.Traversable (for)
import GHC.Generics (Generic)
import Internal.MultiSet qualified as MS
import Musicology.Core
  ( HasPitch (..)
  , Pitch
  , Pitched (..)
  , isStep
  )

import Debug.Trace qualified as DT

-- 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
(EdgeEither a b -> EdgeEither a b -> Bool)
-> (EdgeEither a b -> EdgeEither a b -> Bool)
-> Eq (EdgeEither a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
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
/= :: EdgeEither a b -> EdgeEither a b -> Bool
Eq, Eq (EdgeEither a b)
Eq (EdgeEither a b) =>
(EdgeEither a b -> EdgeEither a b -> Ordering)
-> (EdgeEither a b -> EdgeEither a b -> Bool)
-> (EdgeEither a b -> EdgeEither a b -> Bool)
-> (EdgeEither a b -> EdgeEither a b -> Bool)
-> (EdgeEither a b -> EdgeEither a b -> Bool)
-> (EdgeEither a b -> EdgeEither a b -> EdgeEither a b)
-> (EdgeEither a b -> EdgeEither a b -> EdgeEither a b)
-> Ord (EdgeEither a b)
EdgeEither a b -> EdgeEither a b -> Bool
EdgeEither a b -> EdgeEither a b -> Ordering
EdgeEither a b -> EdgeEither a b -> EdgeEither a b
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
$ccompare :: forall a b.
(Ord a, Ord b) =>
EdgeEither a b -> EdgeEither a b -> Ordering
compare :: EdgeEither a b -> EdgeEither a b -> Ordering
$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
>= :: EdgeEither a b -> EdgeEither a b -> Bool
$cmax :: 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
$cmin :: 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
Ord, Int -> EdgeEither a b -> ShowS
[EdgeEither a b] -> ShowS
EdgeEither a b -> String
(Int -> EdgeEither a b -> ShowS)
-> (EdgeEither a b -> String)
-> ([EdgeEither a b] -> ShowS)
-> Show (EdgeEither a b)
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
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> EdgeEither a b -> ShowS
showsPrec :: Int -> EdgeEither a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => EdgeEither a b -> String
show :: EdgeEither a b -> String
$cshowList :: forall a b. (Show a, Show b) => [EdgeEither a b] -> ShowS
showList :: [EdgeEither a b] -> ShowS
Show, (forall x. EdgeEither a b -> Rep (EdgeEither a b) x)
-> (forall x. Rep (EdgeEither a b) x -> EdgeEither a b)
-> Generic (EdgeEither a b)
forall x. Rep (EdgeEither a b) x -> EdgeEither a b
forall x. EdgeEither a b -> Rep (EdgeEither a b) x
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
$cfrom :: forall a b x. EdgeEither a b -> Rep (EdgeEither a b) x
from :: forall x. EdgeEither a b -> Rep (EdgeEither a b) x
$cto :: forall a b x. Rep (EdgeEither a b) x -> EdgeEither a b
to :: forall x. Rep (EdgeEither a b) x -> EdgeEither a b
Generic, Eq (EdgeEither a b)
Eq (EdgeEither a b) =>
(Int -> EdgeEither a b -> Int)
-> (EdgeEither a b -> Int) -> Hashable (EdgeEither a b)
Int -> EdgeEither a b -> Int
EdgeEither a b -> Int
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
$chashWithSalt :: forall a b.
(Hashable a, Hashable b) =>
Int -> EdgeEither a b -> Int
hashWithSalt :: Int -> EdgeEither a b -> Int
$chash :: forall a b. (Hashable a, Hashable b) => EdgeEither a b -> Int
hash :: EdgeEither a b -> Int
Hashable, EdgeEither a b -> ()
(EdgeEither a b -> ()) -> NFData (EdgeEither a b)
forall a. (a -> ()) -> NFData a
forall a b. (NFData a, NFData b) => EdgeEither a b -> ()
$crnf :: forall a b. (NFData a, NFData b) => EdgeEither a b -> ()
rnf :: 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
(Elaboration a b c d -> Elaboration a b c d -> Bool)
-> (Elaboration a b c d -> Elaboration a b c d -> Bool)
-> Eq (Elaboration a b c d)
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
$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
/= :: Elaboration a b c d -> Elaboration a b c d -> Bool
Eq, Eq (Elaboration a b c d)
Eq (Elaboration a b c d) =>
(Elaboration a b c d -> Elaboration a b c d -> Ordering)
-> (Elaboration a b c d -> Elaboration a b c d -> Bool)
-> (Elaboration a b c d -> Elaboration a b c d -> Bool)
-> (Elaboration a b c d -> Elaboration a b c d -> Bool)
-> (Elaboration a b c d -> Elaboration a b c d -> Bool)
-> (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 -> Elaboration a b c d)
-> Ord (Elaboration a b c d)
Elaboration a b c d -> Elaboration a b c d -> Bool
Elaboration a b c d -> Elaboration a b c d -> Ordering
Elaboration a b c d -> Elaboration a b c d -> Elaboration a b c d
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
$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
compare :: Elaboration a b c d -> Elaboration a b c d -> Ordering
$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
>= :: Elaboration a b c d -> Elaboration a b c d -> Bool
$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
max :: 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
min :: Elaboration a b c d -> Elaboration a b c d -> Elaboration a b c d
Ord, Int -> Elaboration a b c d -> ShowS
[Elaboration a b c d] -> ShowS
Elaboration a b c d -> String
(Int -> Elaboration a b c d -> ShowS)
-> (Elaboration a b c d -> String)
-> ([Elaboration a b c d] -> ShowS)
-> Show (Elaboration a b c d)
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
$cshowsPrec :: forall a b c d.
(Show a, Show b, Show c, Show d) =>
Int -> Elaboration a b c d -> ShowS
showsPrec :: Int -> Elaboration a b c d -> ShowS
$cshow :: forall a b c d.
(Show a, Show b, Show c, Show d) =>
Elaboration a b c d -> String
show :: Elaboration a b c d -> String
$cshowList :: forall a b c d.
(Show a, Show b, Show c, Show d) =>
[Elaboration a b c d] -> ShowS
showList :: [Elaboration a b c d] -> ShowS
Show, (forall x. Elaboration a b c d -> Rep (Elaboration a b c d) x)
-> (forall x. Rep (Elaboration a b c d) x -> Elaboration a b c d)
-> Generic (Elaboration a b c d)
forall x. Rep (Elaboration a b c d) x -> Elaboration a b c d
forall x. Elaboration a b c d -> Rep (Elaboration a b c d) x
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
$cfrom :: forall a b c d x.
Elaboration a b c d -> Rep (Elaboration a b c d) x
from :: forall 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
to :: forall x. Rep (Elaboration a b c d) x -> Elaboration a b c d
Generic, Eq (Elaboration a b c d)
Eq (Elaboration a b c d) =>
(Int -> Elaboration a b c d -> Int)
-> (Elaboration a b c d -> Int) -> Hashable (Elaboration a b c d)
Int -> Elaboration a b c d -> Int
Elaboration a b c d -> Int
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
$chashWithSalt :: forall a b c d.
(Hashable a, Hashable b, Hashable c, Hashable d) =>
Int -> Elaboration a b c d -> Int
hashWithSalt :: Int -> 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
hash :: Elaboration a b c d -> Int
Hashable, Elaboration a b c d -> ()
(Elaboration a b c d -> ()) -> NFData (Elaboration a b c d)
forall a. (a -> ()) -> NFData a
forall a b c d.
(NFData a, NFData b, NFData c, NFData d) =>
Elaboration a b c d -> ()
$crnf :: forall a b c d.
(NFData a, NFData b, NFData c, NFData d) =>
Elaboration a b c d -> ()
rnf :: 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 = (([a], [b], [c], [d])
 -> Elaboration a b c d -> ([a], [b], [c], [d]))
-> ([a], [b], [c], [d])
-> t (Elaboration a b c d)
-> ([a], [b], [c], [d])
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([a], [b], [c], [d]) -> Elaboration a b c d -> ([a], [b], [c], [d])
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 a -> [a] -> [a]
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 a -> [a] -> [a]
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 a -> [a] -> [a]
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
d)

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

-- | A constraint alias for note types.
type IsPitch :: Type -> Constraint
type IsPitch n =
  (HasPitch n, Diatonic (ICOf (IntervalOf n)), Eq (ICOf (IntervalOf n)), Eq (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 Pitch i -> Pitch i -> Bool
forall a. Eq a => a -> a -> Bool
/= Pitch i
pm Bool -> Bool -> Bool
&& Pitch i
pm Pitch i -> Pitch i -> Bool
forall a. Eq a => a -> a -> Bool
/= Pitch i
pr Bool -> Bool -> Bool
&& Pitch i
pl Pitch i -> Pitch i -> Bool
forall a. Eq a => a -> a -> Bool
/= Pitch i
pr Bool -> Bool -> Bool
&& Ordering
dir1 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
odir Bool -> Bool -> Bool
&& Ordering
dir2 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
odir
 where
  odir :: Ordering
odir = i -> Ordering
forall i. Interval i => i -> Ordering
direction (i -> Ordering) -> i -> Ordering
forall a b. (a -> b) -> a -> b
$ Pitch i
pl Pitch i -> Pitch i -> i
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch i
pr
  dir1 :: Ordering
dir1 = i -> Ordering
forall i. Interval i => i -> Ordering
direction (i -> Ordering) -> i -> Ordering
forall a b. (a -> b) -> a -> b
$ Pitch i
pl Pitch i -> Pitch i -> i
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch i
pm
  dir2 :: Ordering
dir2 = i -> Ordering
forall i. Interval i => i -> Ordering
direction (i -> Ordering) -> i -> Ordering
forall a b. (a -> b) -> a -> b
$ Pitch i
pm Pitch i -> Pitch i -> i
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
  :: (IsPitch n)
  => StartStop (Note n)
  -> Note n
  -> StartStop (Note n)
  -> Maybe
      ( EdgeEither
          (DoubleOrnament, Edge n)
          (PassingOrnament, InnerEdge n)
      )
findOrnament :: forall n.
IsPitch n =>
StartStop (Note n)
-> Note n
-> StartStop (Note n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
findOrnament (Inner Note n
l) Note n
m (Inner Note n
r)
  | Pitch (ICOf (IntervalOf n))
pl Pitch (ICOf (IntervalOf n)) -> Pitch (ICOf (IntervalOf n)) -> Bool
forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pm Bool -> Bool -> Bool
&& Pitch (ICOf (IntervalOf n))
pm Pitch (ICOf (IntervalOf n)) -> Pitch (ICOf (IntervalOf n)) -> Bool
forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pr = EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a. a -> Maybe a
Just (EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
 -> Maybe
      (EdgeEither
         (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)))
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a b. (a -> b) -> a -> b
$ (DoubleOrnament, Edge n)
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
forall a b. a -> EdgeEither a b
Reg (DoubleOrnament
FullRepeat, (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
l, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
r))
  | Pitch (ICOf (IntervalOf n))
pl Pitch (ICOf (IntervalOf n)) -> Pitch (ICOf (IntervalOf n)) -> Bool
forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pm Bool -> Bool -> Bool
&& Bool
so = EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a. a -> Maybe a
Just (EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
 -> Maybe
      (EdgeEither
         (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)))
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a b. (a -> b) -> a -> b
$ (DoubleOrnament, Edge n)
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
forall a b. a -> EdgeEither a b
Reg (DoubleOrnament
RightRepeatOfLeft, (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
l, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
r))
  | Pitch (ICOf (IntervalOf n))
pm Pitch (ICOf (IntervalOf n)) -> Pitch (ICOf (IntervalOf n)) -> Bool
forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pr Bool -> Bool -> Bool
&& Bool
so = EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a. a -> Maybe a
Just (EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
 -> Maybe
      (EdgeEither
         (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)))
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a b. (a -> b) -> a -> b
$ (DoubleOrnament, Edge n)
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
forall a b. a -> EdgeEither a b
Reg (DoubleOrnament
LeftRepeatOfRight, (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
l, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
r))
  | Pitch (ICOf (IntervalOf n))
pl Pitch (ICOf (IntervalOf n)) -> Pitch (ICOf (IntervalOf n)) -> Bool
forall a. Eq a => a -> a -> Bool
== Pitch (ICOf (IntervalOf n))
pr Bool -> Bool -> Bool
&& Bool
s1 = EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a. a -> Maybe a
Just (EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
 -> Maybe
      (EdgeEither
         (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)))
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a b. (a -> b) -> a -> b
$ (DoubleOrnament, Edge n)
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
forall a b. a -> EdgeEither a b
Reg (DoubleOrnament
FullNeighbor, (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
l, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
r))
  | Bool
s1 Bool -> Bool -> Bool
&& Bool
s2 Bool -> Bool -> Bool
&& Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n))
-> 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 = EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a. a -> Maybe a
Just (EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
 -> Maybe
      (EdgeEither
         (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)))
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a b. (a -> b) -> a -> b
$ (PassingOrnament, InnerEdge n)
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
forall a b. b -> EdgeEither a b
Pass (PassingOrnament
PassingMid, (Note n
l, Note n
r))
 where
  pl :: Pitch (ICOf (IntervalOf n))
pl = Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n)))
-> Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall a b. (a -> b) -> a -> b
$ n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (n -> Pitch (IntervalOf n)) -> n -> Pitch (IntervalOf n)
forall a b. (a -> b) -> a -> b
$ Note n -> n
forall n. Note n -> n
notePitch Note n
l
  pm :: Pitch (ICOf (IntervalOf n))
pm = Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n)))
-> Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall a b. (a -> b) -> a -> b
$ n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (n -> Pitch (IntervalOf n)) -> n -> Pitch (IntervalOf n)
forall a b. (a -> b) -> a -> b
$ Note n -> n
forall n. Note n -> n
notePitch Note n
m
  pr :: Pitch (ICOf (IntervalOf n))
pr = Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n)))
-> Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall a b. (a -> b) -> a -> b
$ n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (n -> Pitch (IntervalOf n)) -> n -> Pitch (IntervalOf n)
forall a b. (a -> b) -> a -> b
$ Note n -> n
forall n. Note n -> n
notePitch Note n
r
  s1 :: Bool
s1 = ICOf (IntervalOf n) -> Bool
forall i. Diatonic i => i -> Bool
isStep (ICOf (IntervalOf n) -> Bool) -> ICOf (IntervalOf n) -> Bool
forall a b. (a -> b) -> a -> b
$ Pitch (ICOf (IntervalOf n))
pl Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n)) -> ICOf (IntervalOf n)
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pm
  s2 :: Bool
s2 = ICOf (IntervalOf n) -> Bool
forall i. Diatonic i => i -> Bool
isStep (ICOf (IntervalOf n) -> Bool) -> ICOf (IntervalOf n) -> Bool
forall a b. (a -> b) -> a -> b
$ Pitch (ICOf (IntervalOf n))
pm Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n)) -> ICOf (IntervalOf n)
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pr
  so :: Bool
so = ICOf (IntervalOf n) -> Bool
forall i. Diatonic i => i -> Bool
isStep (ICOf (IntervalOf n) -> Bool) -> ICOf (IntervalOf n) -> Bool
forall a b. (a -> b) -> a -> b
$ Pitch (ICOf (IntervalOf n))
pl Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n)) -> ICOf (IntervalOf n)
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pr
findOrnament StartStop (Note n)
Start Note n
_ StartStop (Note n)
Stop = EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a. a -> Maybe a
Just (EdgeEither (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
 -> Maybe
      (EdgeEither
         (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)))
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall a b. (a -> b) -> a -> b
$ (DoubleOrnament, Edge n)
-> EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n)
forall a b. a -> EdgeEither a b
Reg (DoubleOrnament
RootNote, (StartStop (Note n)
forall a. StartStop a
Start, StartStop (Note n)
forall a. StartStop a
Stop))
findOrnament StartStop (Note n)
_ Note n
_ StartStop (Note n)
_ = Maybe
  (EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
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
  :: (IsPitch n)
  => EdgeEither (StartStop (Note n)) (Note n)
  -> Note n
  -> EdgeEither (StartStop (Note n)) (Note n)
  -> Maybe (InnerEdge n, PassingOrnament)
findPassing :: forall n.
IsPitch n =>
EdgeEither (StartStop (Note n)) (Note n)
-> Note n
-> EdgeEither (StartStop (Note n)) (Note n)
-> Maybe (InnerEdge n, PassingOrnament)
findPassing (Reg (Inner Note n
l)) Note n
m (Pass Note n
r)
  | ICOf (IntervalOf n) -> Bool
forall i. Diatonic i => i -> Bool
isStep (Pitch (ICOf (IntervalOf n))
pl Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n)) -> ICOf (IntervalOf n)
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pm) Bool -> Bool -> Bool
&& Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n))
-> 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 =
      (InnerEdge n, PassingOrnament)
-> Maybe (InnerEdge n, PassingOrnament)
forall a. a -> Maybe a
Just ((Note n
l, Note n
r), PassingOrnament
PassingLeft)
 where
  pl :: Pitch (ICOf (IntervalOf n))
pl = Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n)))
-> Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall a b. (a -> b) -> a -> b
$ n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (n -> Pitch (IntervalOf n)) -> n -> Pitch (IntervalOf n)
forall a b. (a -> b) -> a -> b
$ Note n -> n
forall n. Note n -> n
notePitch Note n
l
  pm :: Pitch (ICOf (IntervalOf n))
pm = Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n)))
-> Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall a b. (a -> b) -> a -> b
$ n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (n -> Pitch (IntervalOf n)) -> n -> Pitch (IntervalOf n)
forall a b. (a -> b) -> a -> b
$ Note n -> n
forall n. Note n -> n
notePitch Note n
m
  pr :: Pitch (ICOf (IntervalOf n))
pr = Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n)))
-> Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall a b. (a -> b) -> a -> b
$ n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (n -> Pitch (IntervalOf n)) -> n -> Pitch (IntervalOf n)
forall a b. (a -> b) -> a -> b
$ Note n -> n
forall n. Note n -> n
notePitch Note n
r
findPassing (Pass Note n
l) Note n
m (Reg (Inner Note n
r))
  | ICOf (IntervalOf n) -> Bool
forall i. Diatonic i => i -> Bool
isStep (Pitch (ICOf (IntervalOf n))
pm Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n)) -> ICOf (IntervalOf n)
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` Pitch (ICOf (IntervalOf n))
pr) Bool -> Bool -> Bool
&& Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n))
-> Pitch (ICOf (IntervalOf n))
-> 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 =
      (InnerEdge n, PassingOrnament)
-> Maybe (InnerEdge n, PassingOrnament)
forall a. a -> Maybe a
Just ((Note n
l, Note n
r), PassingOrnament
PassingRight)
 where
  pl :: Pitch (ICOf (IntervalOf n))
pl = Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n)))
-> Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall a b. (a -> b) -> a -> b
$ n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (n -> Pitch (IntervalOf n)) -> n -> Pitch (IntervalOf n)
forall a b. (a -> b) -> a -> b
$ Note n -> n
forall n. Note n -> n
notePitch Note n
l
  pm :: Pitch (ICOf (IntervalOf n))
pm = Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n)))
-> Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall a b. (a -> b) -> a -> b
$ n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (n -> Pitch (IntervalOf n)) -> n -> Pitch (IntervalOf n)
forall a b. (a -> b) -> a -> b
$ Note n -> n
forall n. Note n -> n
notePitch Note n
m
  pr :: Pitch (ICOf (IntervalOf n))
pr = Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n)))
-> Pitch (IntervalOf n) -> Pitch (ICOf (IntervalOf n))
forall a b. (a -> b) -> a -> b
$ n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (n -> Pitch (IntervalOf n)) -> n -> Pitch (IntervalOf n)
forall a b. (a -> b) -> a -> b
$ Note n -> n
forall n. Note n -> n
notePitch Note n
r
findPassing EdgeEither (StartStop (Note n)) (Note n)
_ Note n
_ EdgeEither (StartStop (Note n)) (Note n)
_ = Maybe (InnerEdge n, PassingOrnament)
forall a. Maybe a
Nothing

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

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

{- | Checks a transition to see if can can in principle be reduced.
If a note is adjacent to several regular edges, it cannot be reduced by a split or spread.
Consequently, if both sides of the transition contain notes adjacent to several edges,
neither can be reduced and the transition is irreducible
-}
edgesAreReducible :: (Hashable n) => Edges n -> Bool
edgesAreReducible :: forall n. Hashable n => Edges n -> Bool
edgesAreReducible (Edges HashSet (Edge n)
reg MultiSet (InnerEdge n)
_pass) = [StartStop (Note n)] -> Bool
forall {a}. Hashable a => [StartStop a] -> Bool
isFree [StartStop (Note n)]
left Bool -> Bool -> Bool
|| [StartStop (Note n)] -> Bool
forall {a}. Hashable a => [StartStop a] -> Bool
isFree [StartStop (Note n)]
right
 where
  left :: [StartStop (Note n)]
left = Edge n -> StartStop (Note n)
forall a b. (a, b) -> a
fst (Edge n -> StartStop (Note n)) -> [Edge n] -> [StartStop (Note n)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashSet (Edge n) -> [Edge n]
forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
reg
  right :: [StartStop (Note n)]
right = Edge n -> StartStop (Note n)
forall a b. (a, b) -> b
snd (Edge n -> StartStop (Note n)) -> [Edge n] -> [StartStop (Note n)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashSet (Edge n) -> [Edge n]
forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
reg
  isFree :: [StartStop a] -> Bool
isFree [StartStop a]
notes = (MultiSet a -> Int
forall a. MultiSet a -> Int
MS.cardinality (MultiSet a -> Int) -> MultiSet a -> Int
forall a b. (a -> b) -> a -> b
$ [a] -> MultiSet a
forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList ([a] -> MultiSet a) -> [a] -> MultiSet a
forall a b. (a -> b) -> a -> b
$ (StartStop a -> Maybe a) -> [StartStop a] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe StartStop a -> Maybe a
forall a. StartStop a -> Maybe a
getInner [StartStop a]
notes) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2

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

{-# SPECIALIZE protoVoiceEvaluator ::
  (Foldable t, Foldable t2)
  => Eval
      (Edges SPitch)
      (t (Edge SPitch))
      (Notes SPitch)
      (t2 (Note SPitch))
      (Spread SPitch)
      (PVLeftmost SPitch)
  #-}

{- | 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, IsPitch n, Notation n, Hashable n)
  => Eval (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread n) (PVLeftmost n)
protoVoiceEvaluator :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (PVLeftmost n)
protoVoiceEvaluator =
  UnspreadMiddle (Edges n) (Notes n) (Spread n) (Spread n)
-> UnspreadLeft (Edges n) (Notes n) (Spread n)
-> UnspreadRight (Edges n) (Notes n) (Spread n)
-> (StartStop (Notes n)
    -> Edges n
    -> Notes n
    -> Edges n
    -> StartStop (Notes n)
    -> [(Edges n, Split n)])
-> (StartStop (Notes n)
    -> Maybe (t (Edge n))
    -> StartStop (Notes n)
    -> [(Edges n, Freeze n)])
-> (t2 (Note n) -> Notes n)
-> Eval
     (Edges n)
     (t (Edge n))
     (Notes n)
     (t2 (Note n))
     (Spread n)
     (Leftmost (Split n) (Freeze n) (Spread n))
forall tr tr' slc slc' s f h.
UnspreadMiddle tr slc h h
-> UnspreadLeft tr slc h
-> UnspreadRight tr slc h
-> (StartStop slc -> tr -> slc -> tr -> StartStop slc -> [(tr, s)])
-> (StartStop slc -> Maybe tr' -> StartStop slc -> [(tr, f)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' h (Leftmost s f h)
mkLeftmostEval
    UnspreadMiddle (Edges n) (Notes n) (Spread n) (Spread n)
forall n.
(Eq n, Ord n, Hashable n, IsPitch n, Notation n) =>
UnspreadMiddle (Edges n) (Notes n) (Spread n) (Spread n)
pvUnspreadMiddle
    UnspreadLeft (Edges n) (Notes n) (Spread n)
forall n. Hashable n => UnspreadLeft (Edges n) (Notes n) (Spread n)
pvUnspreadLeft
    UnspreadRight (Edges n) (Notes n) (Spread n)
forall n.
Hashable n =>
UnspreadRight (Edges n) (Notes n) (Spread n)
pvUnspreadRight
    StartStop (Notes n)
-> Edges n
-> Notes n
-> Edges n
-> StartStop (Notes n)
-> [(Edges n, Split n)]
forall n.
(IsPitch 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)
_ Maybe (t (Edge n))
t StartStop (Notes n)
_ -> let edges :: Edges n
edges = Maybe (t (Edge n)) -> Edges n
forall (t :: * -> *) n.
(Foldable t, Ord n, Hashable n) =>
Maybe (t (Edge n)) -> Edges n
pvThaw Maybe (t (Edge n))
t in [(Edges n
edges, HashSet (Edge n) -> Freeze n
forall n. HashSet (Edge n) -> Freeze n
FreezeOp (Edges n -> HashSet (Edge n)
forall n. Edges n -> HashSet (Edge n)
edgesReg Edges n
edges))])
    t2 (Note n) -> Notes n
forall (t :: * -> *) n.
(Foldable t, Eq n, Hashable n) =>
t (Note n) -> Notes n
pvSlice

{- | Computes the possible verticalizations (unspread) of a middle transition.
 The verticalization fails if the middle transition contains regular edges
 that are not repetitions.
 Otherwise, unspread matches notes connected by a repetition edge
 and then lists all possible /maximal matchings/
 between the non-paired notes in the left and right slice.
 The remaining unmatched notes are verticalized as "single children".
-}

-- implementation details: see note [Unspread]
pvUnspreadMiddle
  :: forall n
   . (Eq n, Ord n, Hashable n, IsPitch n, Notation n)
  => UnspreadMiddle (Edges n) (Notes n) (Spread n) (Spread n)
pvUnspreadMiddle :: forall n.
(Eq n, Ord n, Hashable n, IsPitch n, Notation n) =>
UnspreadMiddle (Edges n) (Notes n) (Spread n) (Spread n)
pvUnspreadMiddle (Notes HashSet (Note n)
notesl, edges :: Edges n
edges@(Edges HashSet (Edge n)
regular MultiSet (InnerEdge n)
passing), Notes HashSet (Note n)
notesr)
  | (Edge n -> Bool) -> HashSet (Edge n) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Edge n -> Bool) -> Edge n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge n -> Bool
forall {b} {b} {f :: * -> *}.
(ICOf (IntervalOf b) ~ ICOf (IntervalOf b),
 Eq (f (Pitch (ICOf (IntervalOf b)))), Functor f, HasPitch b,
 HasPitch b) =>
(f (Note b), f (Note b)) -> Bool
isRepetition) HashSet (Edge n)
regular = [] -- can't unspread non-repetition edges
  | Bool
otherwise = do
      -- List monad
      -- choose a matching for the unpaired notes
      matching <- [[InnerEdge n]]
unpairedMatchings
      -- add to the paired matching
      let pairs = (HashMap (Note n) (SpreadChildren n)
 -> InnerEdge n -> HashMap (Note n) (SpreadChildren n))
-> HashMap (Note n) (SpreadChildren n)
-> [InnerEdge n]
-> HashMap (Note n) (SpreadChildren n)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\HashMap (Note n) (SpreadChildren n)
m (Note n
l, Note n
r) -> Note n
-> Note n
-> HashMap (Note n) (SpreadChildren n)
-> HashMap (Note n) (SpreadChildren n)
forall {n}.
Hashable n =>
Note n
-> Note n
-> HashMap (Note n) (SpreadChildren n)
-> HashMap (Note n) (SpreadChildren n)
insertPair Note n
l Note n
r HashMap (Note n) (SpreadChildren n)
m) HashMap (Note n) (SpreadChildren n)
repPairs [InnerEdge n]
matching
          -- find pitches that have not been matched
          matchedl = [Note n] -> HashSet (Note n)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Note n] -> HashSet (Note n)) -> [Note n] -> HashSet (Note n)
forall a b. (a -> b) -> a -> b
$ (InnerEdge n -> Note n) -> [InnerEdge n] -> [Note n]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InnerEdge n -> Note n
forall a b. (a, b) -> a
fst [InnerEdge n]
matching
          matchedr = [Note n] -> HashSet (Note n)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Note n] -> HashSet (Note n)) -> [Note n] -> HashSet (Note n)
forall a b. (a -> b) -> a -> b
$ (InnerEdge n -> Note n) -> [InnerEdge n] -> [Note n]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InnerEdge n -> Note n
forall a b. (a, b) -> b
snd [InnerEdge n]
matching
          leftoverl = HashSet (Note n) -> [Note n]
forall a. HashSet a -> [a]
S.toList (HashSet (Note n) -> [Note n]) -> HashSet (Note n) -> [Note n]
forall a b. (a -> b) -> a -> b
$ HashSet (Note n)
unpairedl HashSet (Note n) -> HashSet (Note n) -> HashSet (Note n)
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`S.difference` HashSet (Note n)
matchedl
          leftoverr = HashSet (Note n) -> [Note n]
forall a. HashSet a -> [a]
S.toList (HashSet (Note n) -> [Note n]) -> HashSet (Note n) -> [Note n]
forall a b. (a -> b) -> a -> b
$ HashSet (Note n)
unpairedr HashSet (Note n) -> HashSet (Note n) -> HashSet (Note n)
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`S.difference` HashSet (Note n)
matchedr
          -- create single parents for the leftover notes
          singlel = (Note n -> (Note n, SpreadChildren n))
-> [Note n] -> [(Note n, SpreadChildren n)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Note n
l -> (Note n -> Note n
forall {n}. Note n -> Note n
mkParent1 Note n
l, Note n -> SpreadChildren n
forall n. Note n -> SpreadChildren n
SpreadLeftChild Note n
l)) [Note n]
leftoverl
          singler = (Note n -> (Note n, SpreadChildren n))
-> [Note n] -> [(Note n, SpreadChildren n)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Note n
r -> (Note n -> Note n
forall {n}. Note n -> Note n
mkParent1 Note n
r, Note n -> SpreadChildren n
forall n. Note n -> SpreadChildren n
SpreadRightChild Note n
r)) [Note n]
leftoverr
          -- combine all mappings
          mappings = HashMap (Note n) (SpreadChildren n)
-> HashMap (Note n) (SpreadChildren n)
-> HashMap (Note n) (SpreadChildren n)
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
HM.union HashMap (Note n) (SpreadChildren n)
pairs (HashMap (Note n) (SpreadChildren n)
 -> HashMap (Note n) (SpreadChildren n))
-> HashMap (Note n) (SpreadChildren n)
-> HashMap (Note n) (SpreadChildren n)
forall a b. (a -> b) -> a -> b
$ [(Note n, SpreadChildren n)] -> HashMap (Note n) (SpreadChildren n)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Note n, SpreadChildren n)]
singlel [(Note n, SpreadChildren n)]
-> [(Note n, SpreadChildren n)] -> [(Note n, SpreadChildren n)]
forall a. Semigroup a => a -> a -> a
<> [(Note n, SpreadChildren n)]
singler)
          top = HashSet (Note n) -> Notes n
forall n. HashSet (Note n) -> Notes n
Notes (HashSet (Note n) -> Notes n) -> HashSet (Note n) -> Notes n
forall a b. (a -> b) -> a -> b
$ HashMap (Note n) (SpreadChildren n) -> HashSet (Note n)
forall k a. HashMap k a -> HashSet k
HM.keysSet HashMap (Note n) (SpreadChildren n)
mappings
          op = HashMap (Note n) (SpreadChildren n) -> Edges n -> Spread n
forall n.
HashMap (Note n) (SpreadChildren n) -> Edges n -> Spread n
SpreadOp HashMap (Note n) (SpreadChildren n)
mappings Edges n
edges
      pure $ (top, op, op)
 where
  isRepetition :: (f (Note b), f (Note b)) -> Bool
isRepetition (f (Note b)
p1, f (Note b)
p2) = (Note b -> Pitch (ICOf (IntervalOf b)))
-> f (Note b) -> f (Pitch (ICOf (IntervalOf b)))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pitch (IntervalOf b) -> Pitch (ICOf (IntervalOf b))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf b) -> Pitch (ICOf (IntervalOf b)))
-> (Note b -> Pitch (IntervalOf b))
-> Note b
-> Pitch (ICOf (IntervalOf b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Pitch (IntervalOf b)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (b -> Pitch (IntervalOf b))
-> (Note b -> b) -> Note b -> Pitch (IntervalOf b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note b -> b
forall n. Note n -> n
notePitch) f (Note b)
p1 f (Pitch (ICOf (IntervalOf b)))
-> f (Pitch (ICOf (IntervalOf b))) -> Bool
forall a. Eq a => a -> a -> Bool
== (Note b -> Pitch (ICOf (IntervalOf b)))
-> f (Note b) -> f (Pitch (ICOf (IntervalOf b)))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pitch (IntervalOf b) -> Pitch (ICOf (IntervalOf b))
Pitch (IntervalOf b) -> Pitch (ICOf (IntervalOf b))
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Pitch (IntervalOf b) -> Pitch (ICOf (IntervalOf b)))
-> (Note b -> Pitch (IntervalOf b))
-> Note b
-> Pitch (ICOf (IntervalOf b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Pitch (IntervalOf b)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (b -> Pitch (IntervalOf b))
-> (Note b -> b) -> Note b -> Pitch (IntervalOf b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note b -> b
forall n. Note n -> n
notePitch) f (Note b)
p2
  mkParent2 :: Note n -> Note n -> Note n
mkParent2 (Note n
p1 String
i1) (Note n
p2 String
i2) = n -> String -> Note n
forall n. n -> String -> Note n
Note n
p1 (String
i1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"+" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
i2)
  mkParent1 :: Note n -> Note n
mkParent1 (Note n
p String
i) = n -> String -> Note n
forall n. n -> String -> Note n
Note n
p (String
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'")
  insertPair :: Note n
-> Note n
-> HashMap (Note n) (SpreadChildren n)
-> HashMap (Note n) (SpreadChildren n)
insertPair Note n
l Note n
r HashMap (Note n) (SpreadChildren n)
m = Note n
-> SpreadChildren n
-> HashMap (Note n) (SpreadChildren n)
-> HashMap (Note n) (SpreadChildren n)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (Note n -> Note n -> Note n
forall {n} {n}. Note n -> Note n -> Note n
mkParent2 Note n
l Note n
r) (Note n -> Note n -> SpreadChildren n
forall n. Note n -> Note n -> SpreadChildren n
SpreadBothChildren Note n
l Note n
r) HashMap (Note n) (SpreadChildren n)
m

  -- pairs notes at repetition edges and collects the unpaired notes
  pairRep :: (HashMap (Note n) (SpreadChildren n), HashSet (Note n),
 HashSet (Note n))
-> (StartStop (Note n), StartStop (Note n))
-> (HashMap (Note n) (SpreadChildren n), HashSet (Note n),
    HashSet (Note n))
pairRep (HashMap (Note n) (SpreadChildren n)
paired, HashSet (Note n)
nl, HashSet (Note n)
nr) edge :: (StartStop (Note n), StartStop (Note n))
edge@(StartStop (Note n)
ssl, StartStop (Note n)
ssr)
    | Inner Note n
l <- StartStop (Note n)
ssl
    , Inner Note n
r <- StartStop (Note n)
ssr
    , n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (Note n -> n
forall n. Note n -> n
notePitch Note n
l) Pitch (IntervalOf n) -> Pitch (IntervalOf n) -> Bool
forall a. Eq a => a -> a -> Bool
== n -> Pitch (IntervalOf n)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
pitch (Note n -> n
forall n. Note n -> n
notePitch Note n
r) =
        ( Note n
-> Note n
-> HashMap (Note n) (SpreadChildren n)
-> HashMap (Note n) (SpreadChildren n)
forall {n}.
Hashable n =>
Note n
-> Note n
-> HashMap (Note n) (SpreadChildren n)
-> HashMap (Note n) (SpreadChildren n)
insertPair Note n
l Note n
r HashMap (Note n) (SpreadChildren n)
paired
        , Note n -> HashSet (Note n) -> HashSet (Note n)
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.delete Note n
l HashSet (Note n)
nl
        , Note n -> HashSet (Note n) -> HashSet (Note n)
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.delete Note n
r HashSet (Note n)
nr
        )
    | Bool
otherwise = (HashMap (Note n) (SpreadChildren n)
paired, HashSet (Note n)
nl, HashSet (Note n)
nr)
  (HashMap (Note n) (SpreadChildren n)
repPairs, HashSet (Note n)
unpairedl, HashSet (Note n)
unpairedr) = ((HashMap (Note n) (SpreadChildren n), HashSet (Note n),
  HashSet (Note n))
 -> Edge n
 -> (HashMap (Note n) (SpreadChildren n), HashSet (Note n),
     HashSet (Note n)))
-> (HashMap (Note n) (SpreadChildren n), HashSet (Note n),
    HashSet (Note n))
-> HashSet (Edge n)
-> (HashMap (Note n) (SpreadChildren n), HashSet (Note n),
    HashSet (Note n))
forall b a. (b -> a -> b) -> b -> HashSet a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (HashMap (Note n) (SpreadChildren n), HashSet (Note n),
 HashSet (Note n))
-> Edge n
-> (HashMap (Note n) (SpreadChildren n), HashSet (Note n),
    HashSet (Note n))
forall {n}.
(HasPitch n, Hashable n, Eq (IntervalOf n)) =>
(HashMap (Note n) (SpreadChildren n), HashSet (Note n),
 HashSet (Note n))
-> (StartStop (Note n), StartStop (Note n))
-> (HashMap (Note n) (SpreadChildren n), HashSet (Note n),
    HashSet (Note n))
pairRep (HashMap (Note n) (SpreadChildren n)
forall k v. HashMap k v
HM.empty, HashSet (Note n)
notesl, HashSet (Note n)
notesr) (HashSet (Edge n)
 -> (HashMap (Note n) (SpreadChildren n), HashSet (Note n),
     HashSet (Note n)))
-> HashSet (Edge n)
-> (HashMap (Note n) (SpreadChildren n), HashSet (Note n),
    HashSet (Note n))
forall a b. (a -> b) -> a -> b
$ HashSet (Edge n)
regular

  -- collects the pitches of unpaired notes left and right
  unpairedPitches :: [n]
unpairedPitches = HashSet n -> [n]
forall a. HashSet a -> [a]
S.toList (HashSet n -> [n]) -> HashSet n -> [n]
forall a b. (a -> b) -> a -> b
$ (Note n -> n) -> HashSet (Note n) -> HashSet n
forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
S.map Note n -> n
forall n. Note n -> n
notePitch HashSet (Note n)
unpairedl
  unpairedlList :: [Note n]
unpairedlList = HashSet (Note n) -> [Note n]
forall a. HashSet a -> [a]
S.toList HashSet (Note n)
unpairedl
  unpairedrList :: [Note n]
unpairedrList = HashSet (Note n) -> [Note n]
forall a. HashSet a -> [a]
S.toList HashSet (Note n)
unpairedr

  -- splits the unpaired notes by pitch,
  -- then computes all possible matchings for each group.
  -- note that only pitches from one side need to be checked
  -- since pitches on the other side that are not included in a group
  -- cannot be matched in the first place
  pairingGroups :: [[[(Note n, Note n)]]]
  pairingGroups :: [[[InnerEdge n]]]
pairingGroups = ((n -> [[InnerEdge n]]) -> [n] -> [[[InnerEdge n]]])
-> [n] -> (n -> [[InnerEdge n]]) -> [[[InnerEdge n]]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (n -> [[InnerEdge n]]) -> [n] -> [[[InnerEdge n]]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [n]
unpairedPitches ((n -> [[InnerEdge n]]) -> [[[InnerEdge n]]])
-> (n -> [[InnerEdge n]]) -> [[[InnerEdge n]]]
forall a b. (a -> b) -> a -> b
$ \n
p ->
    let ls :: [Note n]
ls = (Note n -> Bool) -> [Note n] -> [Note n]
forall a. (a -> Bool) -> [a] -> [a]
filter ((n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
p) (n -> Bool) -> (Note n -> n) -> Note n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note n -> n
forall n. Note n -> n
notePitch) [Note n]
unpairedlList
        rs :: [Note n]
rs = (Note n -> Bool) -> [Note n] -> [Note n]
forall a. (a -> Bool) -> [a] -> [a]
filter ((n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
p) (n -> Bool) -> (Note n -> n) -> Note n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note n -> n
forall n. Note n -> n
notePitch) [Note n]
unpairedrList
     in [Note n] -> [Note n] -> [[InnerEdge n]]
matchGroup [Note n]
ls [Note n]
rs

  -- Computes all possible matchings within a pitch group,
  -- i.e. between two sets of notes with the same pitch
  matchGroup :: [Note n] -> [Note n] -> [[(Note n, Note n)]]
  matchGroup :: [Note n] -> [Note n] -> [[InnerEdge n]]
matchGroup [Note n]
ls [Note n]
rs =
    if [Note n] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Note n]
ls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Note n] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Note n]
rs
      then [Note n] -> [Note n] -> [[InnerEdge n]]
allMatches [Note n]
ls [Note n]
rs
      else ([InnerEdge n] -> [InnerEdge n])
-> [[InnerEdge n]] -> [[InnerEdge n]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InnerEdge n -> InnerEdge n) -> [InnerEdge n] -> [InnerEdge n]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InnerEdge n -> InnerEdge n) -> [InnerEdge n] -> [InnerEdge n])
-> (InnerEdge n -> InnerEdge n) -> [InnerEdge n] -> [InnerEdge n]
forall a b. (a -> b) -> a -> b
$ \(Note n
a, Note n
b) -> (Note n
b, Note n
a)) ([[InnerEdge n]] -> [[InnerEdge n]])
-> [[InnerEdge n]] -> [[InnerEdge n]]
forall a b. (a -> b) -> a -> b
$ [Note n] -> [Note n] -> [[InnerEdge n]]
allMatches [Note n]
rs [Note n]
ls
   where
    allMatches :: [Note n] -> [Note n] -> [[(Note n, Note n)]]
    allMatches :: [Note n] -> [Note n] -> [[InnerEdge n]]
allMatches [] [Note n]
_ = [InnerEdge n] -> [[InnerEdge n]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    allMatches (Note n
a : [Note n]
as) [Note n]
bs = do
      -- List monad
      b <- [Note n]
bs
      let bs' = (Note n -> Bool) -> [Note n] -> [Note n]
forall a. (a -> Bool) -> [a] -> [a]
filter (Note n -> Note n -> Bool
forall a. Eq a => a -> a -> Bool
/= Note n
b) [Note n]
bs
      rest <- allMatches as bs'
      pure $ (a, b) : rest

  -- A list of possible matchings of unpaired notes.
  -- Takes all combintations of matchings per pitch group
  -- and then concatenates the groups within each combination.
  unpairedMatchings :: [[(Note n, Note n)]]
  unpairedMatchings :: [[InnerEdge n]]
unpairedMatchings = ([[InnerEdge n]] -> [InnerEdge n])
-> [[[InnerEdge n]]] -> [[InnerEdge n]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[InnerEdge n]] -> [InnerEdge n]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[InnerEdge n]]] -> [[InnerEdge n]])
-> [[[InnerEdge n]]] -> [[InnerEdge n]]
forall a b. (a -> b) -> a -> b
$ [[[InnerEdge n]]] -> [[[InnerEdge n]]]
forall a. [[a]] -> [[a]]
cartProd [[[InnerEdge n]]]
pairingGroups

{-
Note [Unspread]
~~~~~~~~~~~~~~~

Unspread performs the following steps
1. Check if the transition contains non-repeating regular edges.
   If so, reject the unspread (return []).
2. Pair all notes that are connected by a repeating edge.
3. Compute all /maximal matchings/ for the remaining notes.
   This can be modelled as a matching problem in a bipartite graph
   where the notes from the left and right child slice are the two groups of vertices
   and pairs of notes with the same pitch are the candidate edges.
   However, because of this construction, we can make additional assumptions:
   - the graph can be decomposed into separated components (one for each pitch)
   - within each component, any note on the left can be matched with any note on the right
   Accordingly, the maximal matchings for the unpaired notes can be computed like this:
   1. Partition the graph into components, one per pitch.
      It is sufficient to do this using the pitches of one side
      since notes on the other side that are not included this way
      don't have a partner that they could be matched to anyways.
   2. Within each group, find the side with fewer pitches
      and compute all possible matchings with notes on the other side.
      This is implemented in the list monad by going through the notes on the smaller side,
      non-deterministically choosing a partner note from the other side,
      and removing that note from the pool.
      For each group, this results in a list of possiblem matchings.
   3. Find all combintations of group-level matchings across groups,
      i.e. the cartesian product of the matching lists for all groups.
      For each combination, combine the group-level matchings to one complete matching.
4. For each matching found in step 3 (together with the edge-paired notes),
   compute the corresponding verticalization.
   non-matched notes on either side are explained as "single children"
   with their own parent in the output slice.
-}

{- | 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 :: (Hashable n) => UnspreadLeft (Edges n) (Notes n) (Spread n)
pvUnspreadLeft :: forall n. Hashable n => UnspreadLeft (Edges n) (Notes n) (Spread n)
pvUnspreadLeft (Edges HashSet (StartStop (Note n), StartStop (Note n))
reg MultiSet (Note n, Note n)
pass, Notes n
_) Notes n
_ (SpreadOp HashMap (Note n) (SpreadChildren n)
mapping Edges n
_) = Maybe (Edges n) -> [Edges n]
forall a. Maybe a -> [a]
maybeToList Maybe (Edges n)
remapped
 where
  mappingList :: [(Note n, SpreadChildren n)]
mappingList = HashMap (Note n) (SpreadChildren n) -> [(Note n, SpreadChildren n)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap (Note n) (SpreadChildren n)
mapping
  inverseByLeft :: [(Note n, Note n)]
inverseByLeft = [Maybe (Note n, Note n)] -> [(Note n, Note n)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Note n, Note n)] -> [(Note n, Note n)])
-> [Maybe (Note n, Note n)] -> [(Note n, Note n)]
forall a b. (a -> b) -> a -> b
$ ((Note n, SpreadChildren n) -> Maybe (Note n, Note n))
-> [(Note n, SpreadChildren n)] -> [Maybe (Note n, Note n)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Note n
p, SpreadChildren n
s) -> (,Note n
p) (Note n -> (Note n, Note n))
-> Maybe (Note n) -> Maybe (Note n, Note n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpreadChildren n -> Maybe (Note n)
forall n. SpreadChildren n -> Maybe (Note n)
leftSpreadChild SpreadChildren n
s) [(Note n, SpreadChildren n)]
mappingList
  leftMapping :: HashMap (Note n) (Note n)
leftMapping = [(Note n, Note n)] -> HashMap (Note n) (Note n)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Note n, Note n)]
inverseByLeft
  remapped :: Maybe (Edges n)
remapped = do
    -- Maybe
    reg' <- (((StartStop (Note n), StartStop (Note n))
  -> Maybe (StartStop (Note n), StartStop (Note n)))
 -> HashSet (StartStop (Note n), StartStop (Note n))
 -> Maybe (HashSet (StartStop (Note n), StartStop (Note n))))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> ((StartStop (Note n), StartStop (Note n))
    -> Maybe (StartStop (Note n), StartStop (Note n)))
-> Maybe (HashSet (StartStop (Note n), StartStop (Note n)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((StartStop (Note n), StartStop (Note n))
 -> Maybe (StartStop (Note n), StartStop (Note n)))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> Maybe (HashSet (StartStop (Note n), StartStop (Note n)))
forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet HashSet (StartStop (Note n), StartStop (Note n))
reg (((StartStop (Note n), StartStop (Note n))
  -> Maybe (StartStop (Note n), StartStop (Note n)))
 -> Maybe (HashSet (StartStop (Note n), StartStop (Note n))))
-> ((StartStop (Note n), StartStop (Note n))
    -> Maybe (StartStop (Note n), StartStop (Note n)))
-> Maybe (HashSet (StartStop (Note n), StartStop (Note n)))
forall a b. (a -> b) -> a -> b
$ \(StartStop (Note n)
l, StartStop (Note n)
r) -> do
      rn <- StartStop (Note n) -> Maybe (Note n)
forall a. StartStop a -> Maybe a
getInner StartStop (Note n)
r
      rn' <- HM.lookup rn leftMapping
      pure (l, Inner rn')
    pass' <- flip MS.traverse pass $ \(Note n
ln, Note n
rn) -> do
      rn' <- Note n -> HashMap (Note n) (Note n) -> Maybe (Note n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Note n
rn HashMap (Note n) (Note n)
leftMapping
      pure (ln, rn')
    pure $ Edges reg' pass'

{- | 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 :: (Hashable n) => UnspreadRight (Edges n) (Notes n) (Spread n)
pvUnspreadRight :: forall n.
Hashable n =>
UnspreadRight (Edges n) (Notes n) (Spread n)
pvUnspreadRight (Notes n
_, Edges HashSet (StartStop (Note n), StartStop (Note n))
reg MultiSet (Note n, Note n)
pass) Notes n
_ (SpreadOp HashMap (Note n) (SpreadChildren n)
mapping Edges n
_) = Maybe (Edges n) -> [Edges n]
forall a. Maybe a -> [a]
maybeToList Maybe (Edges n)
remapped
 where
  mappingList :: [(Note n, SpreadChildren n)]
mappingList = HashMap (Note n) (SpreadChildren n) -> [(Note n, SpreadChildren n)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap (Note n) (SpreadChildren n)
mapping
  inverseByRight :: [(Note n, Note n)]
inverseByRight = [Maybe (Note n, Note n)] -> [(Note n, Note n)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Note n, Note n)] -> [(Note n, Note n)])
-> [Maybe (Note n, Note n)] -> [(Note n, Note n)]
forall a b. (a -> b) -> a -> b
$ ((Note n, SpreadChildren n) -> Maybe (Note n, Note n))
-> [(Note n, SpreadChildren n)] -> [Maybe (Note n, Note n)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Note n
p, SpreadChildren n
s) -> (,Note n
p) (Note n -> (Note n, Note n))
-> Maybe (Note n) -> Maybe (Note n, Note n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpreadChildren n -> Maybe (Note n)
forall n. SpreadChildren n -> Maybe (Note n)
rightSpreadChild SpreadChildren n
s) [(Note n, SpreadChildren n)]
mappingList
  rightMapping :: HashMap (Note n) (Note n)
rightMapping = [(Note n, Note n)] -> HashMap (Note n) (Note n)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Note n, Note n)]
inverseByRight
  remapped :: Maybe (Edges n)
remapped = do
    -- Maybe
    reg' <- (((StartStop (Note n), StartStop (Note n))
  -> Maybe (StartStop (Note n), StartStop (Note n)))
 -> HashSet (StartStop (Note n), StartStop (Note n))
 -> Maybe (HashSet (StartStop (Note n), StartStop (Note n))))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> ((StartStop (Note n), StartStop (Note n))
    -> Maybe (StartStop (Note n), StartStop (Note n)))
-> Maybe (HashSet (StartStop (Note n), StartStop (Note n)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((StartStop (Note n), StartStop (Note n))
 -> Maybe (StartStop (Note n), StartStop (Note n)))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> Maybe (HashSet (StartStop (Note n), StartStop (Note n)))
forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet HashSet (StartStop (Note n), StartStop (Note n))
reg (((StartStop (Note n), StartStop (Note n))
  -> Maybe (StartStop (Note n), StartStop (Note n)))
 -> Maybe (HashSet (StartStop (Note n), StartStop (Note n))))
-> ((StartStop (Note n), StartStop (Note n))
    -> Maybe (StartStop (Note n), StartStop (Note n)))
-> Maybe (HashSet (StartStop (Note n), StartStop (Note n)))
forall a b. (a -> b) -> a -> b
$ \(StartStop (Note n)
l, StartStop (Note n)
r) -> do
      ln <- StartStop (Note n) -> Maybe (Note n)
forall a. StartStop a -> Maybe a
getInner StartStop (Note n)
l
      ln' <- HM.lookup ln rightMapping
      pure (Inner ln', r)
    pass' <- flip MS.traverse pass $ \(Note n
ln, Note n
rn) -> do
      ln' <- Note n -> HashMap (Note n) (Note n) -> Maybe (Note n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Note n
ln HashMap (Note n) (Note n)
rightMapping
      pure (ln', rn)
    pure $ Edges reg' pass'

{- | 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
  :: forall n
   . (IsPitch 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.
(IsPitch 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 HashSet (Note n)
notesm) (Edges HashSet (Edge n)
rightRegs MultiSet (InnerEdge n)
rightPass) StartStop (Notes n)
notesr = do
  -- List
  -- pick one combination
  reduction <- [[Elaboration
    (Edge n, (Note n, DoubleOrnament))
    (InnerEdge n, (Note n, PassingOrnament))
    (Note n, (Note n, RightOrnament))
    (Note n, (Note n, LeftOrnament))]]
-> [[Elaboration
       (Edge n, (Note n, DoubleOrnament))
       (InnerEdge n, (Note n, PassingOrnament))
       (Note n, (Note n, RightOrnament))
       (Note n, (Note n, LeftOrnament))]]
forall a. [[a]] -> [[a]]
cartProd [[Elaboration
    (Edge n, (Note n, DoubleOrnament))
    (InnerEdge n, (Note n, PassingOrnament))
    (Note n, (Note n, RightOrnament))
    (Note n, (Note n, LeftOrnament))]]
reductions
  -- construct split from reduction
  mkTop $ partitionElaborations reduction
 where
  !innerL :: [StartStop (Note n)]
innerL = StartStop (Notes n) -> [StartStop (Note n)]
forall n. StartStop (Notes n) -> [StartStop (Note n)]
innerNotes StartStop (Notes n)
notesl
  !innerR :: [StartStop (Note n)]
innerR = StartStop (Notes n) -> [StartStop (Note n)]
forall n. StartStop (Notes n) -> [StartStop (Note n)]
innerNotes StartStop (Notes n)
notesr

  reductions
    :: [ [ Elaboration
            (Edge n, (Note n, DoubleOrnament))
            (InnerEdge n, (Note n, PassingOrnament))
            (Note n, (Note n, RightOrnament))
            (Note n, (Note n, LeftOrnament))
         ]
       ]
  reductions :: [[Elaboration
    (Edge n, (Note n, DoubleOrnament))
    (InnerEdge n, (Note n, PassingOrnament))
    (Note n, (Note n, RightOrnament))
    (Note n, (Note n, LeftOrnament))]]
reductions = Note n
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
findReductions (Note n
 -> [Elaboration
       (Edge n, (Note n, DoubleOrnament))
       (InnerEdge n, (Note n, PassingOrnament))
       (Note n, (Note n, RightOrnament))
       (Note n, (Note n, LeftOrnament))])
-> [Note n]
-> [[Elaboration
       (Edge n, (Note n, DoubleOrnament))
       (InnerEdge n, (Note n, PassingOrnament))
       (Note n, (Note n, RightOrnament))
       (Note n, (Note n, LeftOrnament))]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashSet (Note n) -> [Note n]
forall a. HashSet a -> [a]
S.toList HashSet (Note n)
notesm

  -- finds all possible reductions for a single middle note
  findReductions
    :: Note n
    -> [ Elaboration
          (Edge n, (Note n, DoubleOrnament))
          (InnerEdge n, (Note n, PassingOrnament))
          (Note n, (Note n, RightOrnament))
          (Note n, (Note n, LeftOrnament))
       ]
  findReductions :: Note n
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
findReductions Note n
note
    -- more than one mandatory edge left or right -> no reduction possible
    | [Edge n] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Edge n]
leftRegParent Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| [Edge n] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Edge n]
rightRegParent Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = []
    -- case 1: two mandatory parents: must use both
    | [(StartStop (Note n)
lparent, StartStop (Note n)
_)] <- [Edge n]
leftRegParent
    , [(StartStop (Note n)
_, StartStop (Note n)
rparent)] <- [Edge n]
rightRegParent =
        StartStop (Note n)
-> Note n
-> StartStop (Note n)
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall {n} {c} {d}.
(HasPitch n, Diatonic (ICOf (IntervalOf n)),
 Eq (ICOf (IntervalOf n)), Eq (IntervalOf n)) =>
StartStop (Note n)
-> Note n
-> StartStop (Note n)
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      c
      d]
helperDouble StartStop (Note n)
lparent Note n
note StartStop (Note n)
rparent
    -- case 2: mandatory parent left: choose right parent or none
    | [(StartStop (Note n)
lparent, StartStop (Note n)
_)] <- [Edge n]
leftRegParent =
        let double :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
double = do
              rparent <- [StartStop (Note n)]
innerR
              helperDouble lparent note rparent
            passing :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
passing = StartStop (Note n)
-> Note n
-> [InnerEdge n]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall {n} {a} {a} {c} {d}.
(HasPitch n, Diatonic (ICOf (IntervalOf n)),
 Eq (ICOf (IntervalOf n)), Eq (IntervalOf n)) =>
StartStop (Note n)
-> Note n
-> [(a, Note n)]
-> [Elaboration a (InnerEdge n, (Note n, PassingOrnament)) c d]
helperPassingRight StartStop (Note n)
lparent Note n
note [InnerEdge n]
rightPassParents
            single :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
single = StartStop (Note n)
-> Note n
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall {n} {a} {b} {d}.
(HasPitch n, Diatonic (ICOf (IntervalOf n)),
 Eq (ICOf (IntervalOf n)), Eq (IntervalOf n)) =>
StartStop (Note n)
-> Note n -> [Elaboration a b (Note n, (Note n, RightOrnament)) d]
helperSingleLeft StartStop (Note n)
lparent Note n
note
         in [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
double [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
passing [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
single
    -- case 3: mandatory parent right
    | [(StartStop (Note n)
_, StartStop (Note n)
rparent)] <- [Edge n]
rightRegParent =
        let double :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
double = do
              lparent <- [StartStop (Note n)]
innerL
              helperDouble lparent note rparent
            passing :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
passing = [InnerEdge n]
-> Note n
-> StartStop (Note n)
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall {n} {b} {a} {c} {d}.
(HasPitch n, Diatonic (ICOf (IntervalOf n)),
 Eq (ICOf (IntervalOf n)), Eq (IntervalOf n)) =>
[(Note n, b)]
-> Note n
-> StartStop (Note n)
-> [Elaboration a (InnerEdge n, (Note n, PassingOrnament)) c d]
helperPassingLeft [InnerEdge n]
leftPassParents Note n
note StartStop (Note n)
rparent
            single :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
single = Note n
-> StartStop (Note n)
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall {n} {a} {b} {c}.
(HasPitch n, Diatonic (ICOf (IntervalOf n)),
 Eq (ICOf (IntervalOf n)), Eq (IntervalOf n)) =>
Note n
-> StartStop (Note n)
-> [Elaboration a b c (Note n, (Note n, LeftOrnament))]
helperSingleRight Note n
note StartStop (Note n)
rparent
         in [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
double [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
passing [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
single
    -- case 4: no mandatory parents
    | Bool
otherwise =
        let double :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
double = do
              lparent <- [StartStop (Note n)]
innerL
              rparent <- innerR
              helperDouble lparent note rparent
            rightPassing :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
rightPassing = do
              lparent <- [StartStop (Note n)]
innerL
              helperPassingRight lparent note rightPassParents
            leftPassing :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
leftPassing = do
              rparent <- [StartStop (Note n)]
innerR
              helperPassingLeft leftPassParents note rparent
            leftSingle :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
leftSingle = do
              lparent <- [StartStop (Note n)]
innerL
              helperSingleLeft lparent note
            rightSingle :: [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
rightSingle = do
              rparent <- [StartStop (Note n)]
innerR
              helperSingleRight note rparent
         in [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
double [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
leftPassing [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
rightPassing [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
leftSingle [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      (Note n, (Note n, RightOrnament))
      (Note n, (Note n, LeftOrnament))]
forall a. Semigroup a => a -> a -> a
<> [Elaboration
   (Edge n, (Note n, DoubleOrnament))
   (InnerEdge n, (Note n, PassingOrnament))
   (Note n, (Note n, RightOrnament))
   (Note n, (Note n, LeftOrnament))]
rightSingle
   where
    -- mandatory edges left
    leftRegParent :: [Edge n]
leftRegParent = (Edge n -> Bool) -> [Edge n] -> [Edge n]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(StartStop (Note n)
_, StartStop (Note n)
r) -> StartStop (Note n)
r StartStop (Note n) -> StartStop (Note n) -> Bool
forall a. Eq a => a -> a -> Bool
== Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
note) ([Edge n] -> [Edge n]) -> [Edge n] -> [Edge n]
forall a b. (a -> b) -> a -> b
$ HashSet (Edge n) -> [Edge n]
forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
leftRegs
    -- mandatory edges right
    rightRegParent :: [Edge n]
rightRegParent = (Edge n -> Bool) -> [Edge n] -> [Edge n]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(StartStop (Note n)
l, StartStop (Note n)
_) -> StartStop (Note n)
l StartStop (Note n) -> StartStop (Note n) -> Bool
forall a. Eq a => a -> a -> Bool
== Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
note) ([Edge n] -> [Edge n]) -> [Edge n] -> [Edge n]
forall a b. (a -> b) -> a -> b
$ HashSet (Edge n) -> [Edge n]
forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
rightRegs
    -- passing edges left
    leftPassParents :: [InnerEdge n]
leftPassParents = (InnerEdge n -> Bool) -> [InnerEdge n] -> [InnerEdge n]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Note n
_, Note n
r) -> Note n
r Note n -> Note n -> Bool
forall a. Eq a => a -> a -> Bool
== Note n
note) ([InnerEdge n] -> [InnerEdge n]) -> [InnerEdge n] -> [InnerEdge n]
forall a b. (a -> b) -> a -> b
$ MultiSet (InnerEdge n) -> [InnerEdge n]
forall a. MultiSet a -> [a]
MS.toList MultiSet (InnerEdge n)
leftPass
    -- passing edges right
    rightPassParents :: [InnerEdge n]
rightPassParents = (InnerEdge n -> Bool) -> [InnerEdge n] -> [InnerEdge n]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Note n
l, Note n
_) -> Note n
l Note n -> Note n -> Bool
forall a. Eq a => a -> a -> Bool
== Note n
note) ([InnerEdge n] -> [InnerEdge n]) -> [InnerEdge n] -> [InnerEdge n]
forall a b. (a -> b) -> a -> b
$ MultiSet (InnerEdge n) -> [InnerEdge n]
forall a. MultiSet a -> [a]
MS.toList MultiSet (InnerEdge n)
rightPass

  -- helper functions: find specific reductions of a note to certain parents
  -- all of them return a list of reductions of the form (parent, (child, ornamentType))
  -- wrapped in the appropriate Elaboration constructor

  -- reduce with two regular parents
  helperDouble :: StartStop (Note n)
-> Note n
-> StartStop (Note n)
-> [Elaboration
      (Edge n, (Note n, DoubleOrnament))
      (InnerEdge n, (Note n, PassingOrnament))
      c
      d]
helperDouble StartStop (Note n)
lparent Note n
note StartStop (Note n)
rparent =
    case StartStop (Note n)
-> Note n
-> StartStop (Note n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
forall n.
IsPitch n =>
StartStop (Note n)
-> Note n
-> StartStop (Note n)
-> Maybe
     (EdgeEither
        (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
findOrnament StartStop (Note n)
lparent Note n
note StartStop (Note n)
rparent of
      Maybe
  (EdgeEither
     (DoubleOrnament, Edge n) (PassingOrnament, InnerEdge n))
Nothing -> []
      Just (Reg (DoubleOrnament
orn, Edge n
reg)) -> [(Edge n, (Note n, DoubleOrnament))
-> Elaboration
     (Edge n, (Note n, DoubleOrnament))
     (InnerEdge n, (Note n, PassingOrnament))
     c
     d
forall a b c d. a -> Elaboration a b c d
EReg (Edge n
reg, (Note n
note, DoubleOrnament
orn))]
      Just (Pass (PassingOrnament
orn, InnerEdge n
pass)) -> [(InnerEdge n, (Note n, PassingOrnament))
-> Elaboration
     (Edge n, (Note n, DoubleOrnament))
     (InnerEdge n, (Note n, PassingOrnament))
     c
     d
forall a b c d. b -> Elaboration a b c d
EPass (InnerEdge n
pass, (Note n
note, PassingOrnament
orn))]

  -- reduce with a passing edge on the right and a regular parent on the left
  helperPassingRight :: StartStop (Note n)
-> Note n
-> [(a, Note n)]
-> [Elaboration a (InnerEdge n, (Note n, PassingOrnament)) c d]
helperPassingRight StartStop (Note n)
lparent Note n
note [(a, Note n)]
rpassing = do
    (_, rparent) <- [(a, Note n)]
rpassing
    (pass, orn) <- maybeToList $ findPassing (Reg lparent) note (Pass rparent)
    pure $ EPass (pass, (note, orn))

  -- reduce with a passing edge on the left and a regular parent on the right
  helperPassingLeft :: [(Note n, b)]
-> Note n
-> StartStop (Note n)
-> [Elaboration a (InnerEdge n, (Note n, PassingOrnament)) c d]
helperPassingLeft [(Note n, b)]
lpassing Note n
note StartStop (Note n)
rparent = do
    (lparent, _) <- [(Note n, b)]
lpassing
    (pass, orn) <- maybeToList $ findPassing (Pass lparent) note (Reg rparent)
    pure $ EPass (pass, (note, orn))

  -- reduce with a single parent on the left
  helperSingleLeft :: StartStop (Note n)
-> Note n -> [Elaboration a b (Note n, (Note n, RightOrnament)) d]
helperSingleLeft StartStop (Note n)
lparent Note n
note = case StartStop (Note n)
lparent of
    Inner Note n
lp -> case Note n -> Note n -> Maybe RightOrnament
forall n. IsPitch n => Note n -> Note n -> Maybe RightOrnament
findRightOrnament Note n
lp Note n
note of
      Maybe RightOrnament
Nothing -> []
      Just RightOrnament
orn -> [(Note n, (Note n, RightOrnament))
-> Elaboration a b (Note n, (Note n, RightOrnament)) d
forall a b c d. c -> Elaboration a b c d
ER (Note n
lp, (Note n
note, RightOrnament
orn))]
    StartStop (Note n)
_ -> []

  -- reduce with a single parent on the right
  helperSingleRight :: Note n
-> StartStop (Note n)
-> [Elaboration a b c (Note n, (Note n, LeftOrnament))]
helperSingleRight Note n
note StartStop (Note n)
rparent = case StartStop (Note n)
rparent of
    Inner Note n
rp -> case Note n -> Note n -> Maybe LeftOrnament
forall n. IsPitch n => Note n -> Note n -> Maybe LeftOrnament
findLeftOrnament Note n
note Note n
rp of
      Maybe LeftOrnament
Nothing -> []
      Just LeftOrnament
orn -> [(Note n, (Note n, LeftOrnament))
-> Elaboration a b c (Note n, (Note n, LeftOrnament))
forall a b c d. d -> Elaboration a b c d
EL (Note n
rp, (Note n
note, LeftOrnament
orn))]
    StartStop (Note n)
_ -> []

  -- convert a combination into a derivation operation:
  -- turn the accumulated information into the format expected from the evaluator
  mkTop
    :: ( [(Edge n, (Note n, DoubleOrnament))]
       , [((Note n, Note n), (Note n, PassingOrnament))]
       , [(Note n, (Note n, RightOrnament))]
       , [(Note n, (Note n, LeftOrnament))]
       )
    -> [(Edges n, Split n)]
  mkTop :: ([(Edge n, (Note n, DoubleOrnament))],
 [(InnerEdge n, (Note n, PassingOrnament))],
 [(Note n, (Note n, RightOrnament))],
 [(Note n, (Note n, LeftOrnament))])
-> [(Edges n, Split n)]
mkTop ([(Edge n, (Note n, DoubleOrnament))]
regs, [(InnerEdge n, (Note n, PassingOrnament))]
pass, [(Note n, (Note n, RightOrnament))]
rs, [(Note n, (Note n, LeftOrnament))]
ls) =
    if Edges n -> Bool
forall n. Hashable n => Edges n -> Bool
edgesAreReducible Edges n
top
      then (Edges n, Split n) -> [(Edges n, Split n)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Edges n
top, Map (Edge n) [(Note n, DoubleOrnament)]
-> Map (InnerEdge n) [(Note n, PassingOrnament)]
-> Map (Note n) [(Note n, RightOrnament)]
-> Map (Note n) [(Note n, LeftOrnament)]
-> HashSet (Edge n)
-> HashSet (Edge n)
-> MultiSet (InnerEdge n)
-> MultiSet (InnerEdge n)
-> Split n
forall n.
Map (Edge n) [(Note n, DoubleOrnament)]
-> Map (InnerEdge n) [(Note n, PassingOrnament)]
-> Map (Note n) [(Note n, RightOrnament)]
-> Map (Note n) [(Note n, LeftOrnament)]
-> HashSet (Edge n)
-> HashSet (Edge n)
-> MultiSet (InnerEdge n)
-> MultiSet (InnerEdge n)
-> Split n
SplitOp Map (Edge n) [(Note n, DoubleOrnament)]
regmap Map (InnerEdge n) [(Note n, PassingOrnament)]
passmap Map (Note n) [(Note n, RightOrnament)]
rmap Map (Note n) [(Note n, LeftOrnament)]
lmap HashSet (Edge n)
leftRegs HashSet (Edge n)
rightRegs MultiSet (InnerEdge n)
passL MultiSet (InnerEdge n)
passR)
      else []
   where
    -- collect all operations
    mapify :: [(k, a)] -> Map k [a]
mapify [(k, a)]
xs = ([a] -> [a] -> [a]) -> [(k, [a])] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
(<>) ([(k, [a])] -> Map k [a]) -> [(k, [a])] -> Map k [a]
forall a b. (a -> b) -> a -> b
$ (a -> [a]) -> (k, a) -> (k, [a])
forall a b. (a -> b) -> (k, a) -> (k, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> [a] -> [a]
forall a. a -> [a] -> [a]
: []) ((k, a) -> (k, [a])) -> [(k, a)] -> [(k, [a])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, a)]
xs
    regmap :: Map (Edge n) [(Note n, DoubleOrnament)]
regmap = [(Edge n, (Note n, DoubleOrnament))]
-> Map (Edge n) [(Note n, DoubleOrnament)]
forall {k} {a}. Ord k => [(k, a)] -> Map k [a]
mapify [(Edge n, (Note n, DoubleOrnament))]
regs
    passmap :: Map (InnerEdge n) [(Note n, PassingOrnament)]
passmap = [(InnerEdge n, (Note n, PassingOrnament))]
-> Map (InnerEdge n) [(Note n, PassingOrnament)]
forall {k} {a}. Ord k => [(k, a)] -> Map k [a]
mapify [(InnerEdge n, (Note n, PassingOrnament))]
pass
    lmap :: Map (Note n) [(Note n, LeftOrnament)]
lmap = [(Note n, (Note n, LeftOrnament))]
-> Map (Note n) [(Note n, LeftOrnament)]
forall {k} {a}. Ord k => [(k, a)] -> Map k [a]
mapify [(Note n, (Note n, LeftOrnament))]
ls
    rmap :: Map (Note n) [(Note n, RightOrnament)]
rmap = [(Note n, (Note n, RightOrnament))]
-> Map (Note n) [(Note n, RightOrnament)]
forall {k} {a}. Ord k => [(k, a)] -> Map k [a]
mapify [(Note n, (Note n, RightOrnament))]
rs
    leftPassingChild :: ((a, b), (b, PassingOrnament)) -> Maybe (a, b)
leftPassingChild ((a
l, b
_r), (b
m, PassingOrnament
orn)) =
      if PassingOrnament
orn PassingOrnament -> PassingOrnament -> Bool
forall a. Eq a => a -> a -> Bool
== PassingOrnament
PassingRight then (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
l, b
m) else Maybe (a, b)
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 PassingOrnament -> PassingOrnament -> Bool
forall a. Eq a => a -> a -> Bool
== PassingOrnament
PassingLeft then (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
m, b
r) else Maybe (a, b)
forall a. Maybe a
Nothing
    passL :: MultiSet (InnerEdge n)
passL = (InnerEdge n -> MultiSet (InnerEdge n) -> MultiSet (InnerEdge n))
-> MultiSet (InnerEdge n)
-> [InnerEdge n]
-> MultiSet (InnerEdge n)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr InnerEdge n -> MultiSet (InnerEdge n) -> MultiSet (InnerEdge n)
forall a. (Eq a, Hashable a) => a -> MultiSet a -> MultiSet a
MS.delete MultiSet (InnerEdge n)
leftPass ([InnerEdge n] -> MultiSet (InnerEdge n))
-> [InnerEdge n] -> MultiSet (InnerEdge n)
forall a b. (a -> b) -> a -> b
$ ((InnerEdge n, (Note n, PassingOrnament)) -> Maybe (InnerEdge n))
-> [(InnerEdge n, (Note n, PassingOrnament))] -> [InnerEdge n]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (InnerEdge n, (Note n, PassingOrnament)) -> Maybe (InnerEdge n)
forall {a} {b} {b}. ((a, b), (b, PassingOrnament)) -> Maybe (a, b)
leftPassingChild [(InnerEdge n, (Note n, PassingOrnament))]
pass
    passR :: MultiSet (InnerEdge n)
passR = (InnerEdge n -> MultiSet (InnerEdge n) -> MultiSet (InnerEdge n))
-> MultiSet (InnerEdge n)
-> [InnerEdge n]
-> MultiSet (InnerEdge n)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr InnerEdge n -> MultiSet (InnerEdge n) -> MultiSet (InnerEdge n)
forall a. (Eq a, Hashable a) => a -> MultiSet a -> MultiSet a
MS.delete MultiSet (InnerEdge n)
rightPass ([InnerEdge n] -> MultiSet (InnerEdge n))
-> [InnerEdge n] -> MultiSet (InnerEdge n)
forall a b. (a -> b) -> a -> b
$ ((InnerEdge n, (Note n, PassingOrnament)) -> Maybe (InnerEdge n))
-> [(InnerEdge n, (Note n, PassingOrnament))] -> [InnerEdge n]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (InnerEdge n, (Note n, PassingOrnament)) -> Maybe (InnerEdge n)
forall {a} {b} {a}. ((a, b), (a, PassingOrnament)) -> Maybe (a, b)
rightPassingChild [(InnerEdge n, (Note n, PassingOrnament))]
pass
    top :: Edges n
top = HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges ([Edge n] -> HashSet (Edge n)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ((Edge n, (Note n, DoubleOrnament)) -> Edge n
forall a b. (a, b) -> a
fst ((Edge n, (Note n, DoubleOrnament)) -> Edge n)
-> [(Edge n, (Note n, DoubleOrnament))] -> [Edge n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Edge n, (Note n, DoubleOrnament))]
regs)) ([InnerEdge n] -> MultiSet (InnerEdge n)
forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList ((InnerEdge n, (Note n, PassingOrnament)) -> InnerEdge n
forall a b. (a, b) -> a
fst ((InnerEdge n, (Note n, PassingOrnament)) -> InnerEdge n)
-> [(InnerEdge n, (Note n, PassingOrnament))] -> [InnerEdge n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(InnerEdge n, (Note n, PassingOrnament))]
pass))

-- old pvUnsplit (no IDs, multisets)
-- pvUnsplit notesl (Edges leftRegs leftPass) (Notes notesm) (Edges rightRegs rightPass) notesr =
--   map mkTop combinations
--  where
--   -- preprocessing of the notes left and right of the unsplit
--   !innerL = Reg <$> innerNotes notesl
--   !innerR = Reg <$> innerNotes notesr

--   -- find all reduction options for every pitch
--   !options = noteOptions <$> MS.toOccurList notesm
--   noteOptions (note, nocc)
--     | nocc < MS.size mandatoryLeft || nocc < MS.size mandatoryRight =
--         []
--     | otherwise =
--         partitionElaborations
--           <$> enumerateOptions mandatoryLeft mandatoryRight nocc
--    where
--     -- compute the mandatory edges for the current pitch:
--     mleftRegs = S.map (Reg . fst) $ S.filter ((== Inner note) . snd) leftRegs
--     mleftPass = MS.map (Pass . fst) $ MS.filter ((== note) . snd) leftPass
--     mrightRegs = S.map (Reg . snd) $ S.filter ((== Inner note) . fst) rightRegs
--     mrightPass = MS.map (Pass . snd) $ MS.filter ((== note) . fst) rightPass
--     mandatoryLeft = MS.fromSet mleftRegs <> mleftPass
--     mandatoryRight = MS.fromSet mrightRegs <> mrightPass

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

--     -- stage 1: consume all mandatory edges on the left
--     enumerateOptions ml mr n = do
--       (mr', n', acc) <- MS.foldM goL (mr, n, []) ml
--       (n'', acc') <- MS.foldM goR (n', acc) mr'
--       goFree freeOptions n'' acc'
--     goL (_, 0, _) _ = []
--     goL (mr, n, acc) l = do
--       (new, mr') <- pickLeft n l mr
--       pure (mr', n - 1, new : acc)
--     -- combine a mandatory left with a mandatory right or free right edge
--     pickLeft n l mr
--       | n > MS.size mr = mand <> opt <> single
--       | otherwise = mand
--      where
--       mand = do
--         r <- MS.distinctElems mr
--         red <- maybeToList $ tryReduction True True l note r
--         pure (red, MS.delete r mr)
--       -- TODO: remove mr options here?
--       tryOpt r = tryReduction True (r `S.member` mrightRegs) l note r
--       opt = (,mr) <$> mapMaybe tryOpt innerR
--       single = fmap (,mr) $ maybeToList $ tryLeftReduction note l

--     -- stage 2: consume all remaining mandatory edges on the right
--     goR (0, _) _ = []
--     goR (n, acc) r = do
--       new <- pickRight r
--       pure (n - 1, new : acc)
--     -- combine mandatory right with free left edge
--     pickRight r = opt <> single
--      where
--       tryOpt l = tryReduction (l `S.member` mleftRegs) True l note r
--       opt = mapMaybe tryOpt innerL
--       single = maybeToList $ tryRightReduction note r

--     -- stage 3: explain all remaining notes through a combination of unknown edges
--     goFree _ 0 acc = pure acc
--     goFree [] _ _ = []
--     goFree [lastOpt] n acc = pure $ L.replicate n lastOpt <> acc
--     goFree (opt : opts) n acc = do
--       nopt <- [0 .. n]
--       goFree opts (n - nopt) (L.replicate nopt opt <> acc)
--     -- list all options for free reduction
--     freeOptions = pickFreeBoth <> pickFreeLeft <> pickFreeRight
--     -- combine two free edges
--     pickFreeBoth = do
--       l <- innerL
--       r <- innerR
--       maybeToList $
--         tryReduction (l `S.member` mleftRegs) (r `S.member` mrightRegs) l note r
--     -- reduce to left using free edge
--     pickFreeLeft = mapMaybe (tryLeftReduction note) innerL
--     -- reduce to right using free edge
--     pickFreeRight = mapMaybe (tryRightReduction note) innerR

--   -- at all stages: try out potential reductions:

--   -- two terminal edges: any ornament
--   tryReduction lIsUsed rIsUsed (Reg notel) notem (Reg noter) = do
--     reduction <- findOrnament notel (Inner notem) noter lIsUsed rIsUsed
--     pure $ case reduction of
--       (Reg (orn, parent)) -> EReg (parent, (notem, orn))
--       (Pass (pass, parent)) -> EPass (parent, (notem, pass))
--   -- a non-terminal edge left and a terminal edge right: passing note
--   tryReduction _ _ notel@(Pass _) notem noter@(Reg _) = do
--     (parent, pass) <- findPassing notel notem noter
--     pure $ EPass (parent, (notem, pass))
--   -- a terminal edge left and a non-terminal edge right: passing note
--   tryReduction _ _ notel@(Reg _) notem noter@(Pass _) = do
--     (parent, pass) <- findPassing notel notem noter
--     pure $ EPass (parent, (notem, pass))
--   -- all other combinations are forbidden
--   tryReduction _ _ _ _ _ = Nothing

--   -- single reduction to a left parent
--   tryLeftReduction notem (Reg (Inner notel)) = do
--     orn <- findRightOrnament notel notem
--     pure $ ER (notel, (notem, orn))
--   tryLeftReduction _ _ = Nothing

--   -- single reduction to a right parent
--   tryRightReduction notem (Reg (Inner noter)) = do
--     orn <- findLeftOrnament notem noter
--     pure $ EL (noter, (notem, orn))
--   tryRightReduction _ _ = Nothing

--   -- compute all possible combinations of reduction options
--   !combinations =
--     if any L.null options -- check if any note has no options
--       then [] -- if yes, then no reduction is possible at all
--       else foldM pickOption ([], [], [], []) options -- otherwise, compute all combinations
--       -- picks all different options for a single note in the list monad
--   pickOption (accReg, accPass, accL, accR) opts = do
--     (regs, pass, ls, rs) <- opts
--     pure (regs <> accReg, pass <> accPass, ls <> accL, rs <> accR)

--   -- convert a combination into a derivation operation:
--   -- turn the accumulated information into the format expected from the evaluator
--   mkTop (regs, pass, rs, ls) =
--     if True -- validate
--       then (top, SplitOp tmap ntmap rmap lmap leftRegs rightRegs passL passR)
--       else
--         error $
--           "invalid unsplit:\n  notesl="
--             <> show notesl
--             <> "\n  notesr="
--             <> show notesr
--             <> "\n  notesm="
--             <> show (Notes notesm)
--             <> "\n  left="
--             <> show (Edges leftRegs leftPass)
--             <> "\n  right="
--             <> show (Edges rightRegs rightPass)
--             <> "\n  top="
--             <> show 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 xs = M.fromListWith (<>) $ fmap (: []) <$> xs
--     tmap = mapify regs
--     ntmap = mapify pass
--     lmap = mapify ls
--     rmap = mapify rs
--     top = Edges (S.fromList (fst <$> regs)) (MS.fromList (fst <$> pass))
--     passL = foldr MS.delete leftPass $ mapMaybe leftPassingChild pass
--     passR = foldr MS.delete rightPass $ mapMaybe rightPassingChild pass
--     leftPassingChild ((l, _r), (m, orn)) =
--       if orn == PassingRight then Just (l, m) else Nothing
--     rightPassingChild ((_l, r), (m, orn)) =
--       if orn == PassingLeft then Just (m, r) else Nothing

-- | Unfreezes a single transition, which may be 'Nothing'.
pvThaw
  :: (Foldable t, Ord n, Hashable n)
  => Maybe (t (Edge n))
  -> Edges n
pvThaw :: forall (t :: * -> *) n.
(Foldable t, Ord n, Hashable n) =>
Maybe (t (Edge n)) -> Edges n
pvThaw Maybe (t (Edge n))
e = HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges ([Edge n] -> HashSet (Edge n)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Edge n] -> HashSet (Edge n)) -> [Edge n] -> HashSet (Edge n)
forall a b. (a -> b) -> a -> b
$ [Edge n]
-> (t (Edge n) -> [Edge n]) -> Maybe (t (Edge n)) -> [Edge n]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] t (Edge n) -> [Edge n]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (t (Edge n))
e) MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty

pvSlice :: (Foldable t, Eq n, Hashable n) => t (Note n) -> Notes n
pvSlice :: forall (t :: * -> *) n.
(Foldable t, Eq n, Hashable n) =>
t (Note n) -> Notes n
pvSlice = HashSet (Note n) -> Notes n
forall n. HashSet (Note n) -> Notes n
Notes (HashSet (Note n) -> Notes n)
-> (t (Note n) -> HashSet (Note n)) -> t (Note n) -> Notes n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Note n] -> HashSet (Note n)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Note n] -> HashSet (Note n))
-> (t (Note n) -> [Note n]) -> t (Note n) -> HashSet (Note n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (Note n) -> [Note n]
forall a. t a -> [a]
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, IsPitch n, Notation n, Hashable n)
  => Eval (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread n) (PVLeftmost n)
protoVoiceEvaluatorNoRepSplit :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (PVLeftmost n)
protoVoiceEvaluatorNoRepSplit = UnspreadMiddle (Edges n) (Notes n) (Spread n) (PVLeftmost n)
-> UnspreadLeft (Edges n) (Notes n) (Spread n)
-> UnspreadRight (Edges n) (Notes n) (Spread n)
-> Unsplit (Edges n) (Notes n) (PVLeftmost n)
-> (StartStop (Notes n)
    -> Maybe (t (Edge n))
    -> StartStop (Notes n)
    -> Bool
    -> [(Edges n, PVLeftmost n)])
-> (t2 (Note n) -> Notes n)
-> Eval
     (Edges n)
     (t (Edge n))
     (Notes n)
     (t2 (Note n))
     (Spread n)
     (PVLeftmost n)
forall tr tr' slc slc' h v.
UnspreadMiddle tr slc h v
-> UnspreadLeft tr slc h
-> UnspreadRight tr slc h
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' h v
Eval UnspreadMiddle (Edges n) (Notes n) (Spread n) (PVLeftmost n)
vm UnspreadLeft (Edges n) (Notes n) (Spread n)
vl UnspreadRight (Edges n) (Notes n) (Spread n)
vr Unsplit (Edges n) (Notes n) (PVLeftmost n)
filterSplit StartStop (Notes n)
-> Maybe (t (Edge n))
-> StartStop (Notes n)
-> Bool
-> [(Edges n, PVLeftmost n)]
t t2 (Note n) -> Notes n
s
 where
  (Eval UnspreadMiddle (Edges n) (Notes n) (Spread n) (PVLeftmost n)
vm UnspreadLeft (Edges n) (Notes n) (Spread n)
vl UnspreadRight (Edges n) (Notes n) (Spread n)
vr Unsplit (Edges n) (Notes n) (PVLeftmost n)
mg StartStop (Notes n)
-> Maybe (t (Edge n))
-> StartStop (Notes n)
-> Bool
-> [(Edges n, PVLeftmost n)]
t t2 (Note n) -> Notes n
s) = Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (PVLeftmost n)
forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (PVLeftmost n)
protoVoiceEvaluator
  filterSplit :: Unsplit (Edges n) (Notes n) (PVLeftmost n)
filterSplit StartStop (Notes n)
l Edges n
lt Notes n
mid Edges n
rt StartStop (Notes n)
r SplitType
typ = ((Edges n, PVLeftmost n) -> Bool)
-> [(Edges n, PVLeftmost n)] -> [(Edges n, PVLeftmost n)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Edges n, PVLeftmost n) -> Bool
forall {a} {n} {f} {h}. (a, Leftmost (Split n) f h) -> Bool
ok ([(Edges n, PVLeftmost n)] -> [(Edges n, PVLeftmost n)])
-> [(Edges n, PVLeftmost n)] -> [(Edges n, PVLeftmost n)]
forall a b. (a -> b) -> a -> b
$ Unsplit (Edges n) (Notes 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 n) f h) -> Bool
ok (a
_, LMSplitLeft Split n
op) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Split n -> Bool
forall {n}. Split n -> Bool
onlyRepeats Split n
op
  ok (a
_, LMSplitOnly Split n
op) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Split n -> Bool
forall {n}. Split n -> Bool
onlyRepeats Split n
op
  ok (a
_, LMSplitRight Split n
op) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Split n -> Bool
forall {n}. Split n -> Bool
onlyRepeats Split n
op
  ok (a, Leftmost (Split n) f h)
_ = Bool
False
  onlyRepeats :: Split n -> Bool
onlyRepeats (SplitOp Map (Edge n) [(Note n, DoubleOrnament)]
regs Map (InnerEdge n) [(Note n, PassingOrnament)]
pass Map (Note n) [(Note n, RightOrnament)]
rs Map (Note n) [(Note n, LeftOrnament)]
ls HashSet (Edge n)
_ HashSet (Edge n)
_ MultiSet (InnerEdge n)
_ MultiSet (InnerEdge n)
_) =
    Map (InnerEdge n) [(Note n, PassingOrnament)] -> Bool
forall k a. Map k a -> Bool
M.null Map (InnerEdge n) [(Note n, PassingOrnament)]
pass Bool -> Bool -> Bool
&& (Bool
allRepetitionsLeft Bool -> Bool -> Bool
|| Bool
allRepetitionsRight)
   where
    allSinglesRepeat :: Bool
allSinglesRepeat =
      ((Note n, [(Note n, RightOrnament)]) -> Bool)
-> [(Note n, [(Note n, RightOrnament)])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((RightOrnament -> Bool)
-> (Note n, [(Note n, RightOrnament)]) -> Bool
forall {t :: * -> *} {b} {a} {a}.
Foldable t =>
(b -> Bool) -> (a, t (a, b)) -> Bool
check (RightOrnament -> RightOrnament -> Bool
forall a. Eq a => a -> a -> Bool
== RightOrnament
RightRepeat)) (Map (Note n) [(Note n, RightOrnament)]
-> [(Note n, [(Note n, RightOrnament)])]
forall k a. Map k a -> [(k, a)]
M.toList Map (Note n) [(Note n, RightOrnament)]
rs)
        Bool -> Bool -> Bool
&& ((Note n, [(Note n, LeftOrnament)]) -> Bool)
-> [(Note n, [(Note n, LeftOrnament)])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((LeftOrnament -> Bool)
-> (Note n, [(Note n, LeftOrnament)]) -> Bool
forall {t :: * -> *} {b} {a} {a}.
Foldable t =>
(b -> Bool) -> (a, t (a, b)) -> Bool
check (LeftOrnament -> LeftOrnament -> Bool
forall a. Eq a => a -> a -> Bool
== LeftOrnament
LeftRepeat)) (Map (Note n) [(Note n, LeftOrnament)]
-> [(Note n, [(Note n, LeftOrnament)])]
forall k a. Map k a -> [(k, a)]
M.toList Map (Note n) [(Note n, LeftOrnament)]
ls)
    allRepetitionsLeft :: Bool
allRepetitionsLeft =
      ((Edge n, [(Note n, DoubleOrnament)]) -> Bool)
-> [(Edge n, [(Note n, DoubleOrnament)])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((DoubleOrnament -> Bool)
-> (Edge n, [(Note n, DoubleOrnament)]) -> Bool
forall {t :: * -> *} {b} {a} {a}.
Foldable t =>
(b -> Bool) -> (a, t (a, b)) -> Bool
check DoubleOrnament -> Bool
isRepetitionOnLeft) (Map (Edge n) [(Note n, DoubleOrnament)]
-> [(Edge n, [(Note n, DoubleOrnament)])]
forall k a. Map k a -> [(k, a)]
M.toList Map (Edge n) [(Note n, DoubleOrnament)]
regs) Bool -> Bool -> Bool
&& Bool
allSinglesRepeat
    allRepetitionsRight :: Bool
allRepetitionsRight =
      ((Edge n, [(Note n, DoubleOrnament)]) -> Bool)
-> [(Edge n, [(Note n, DoubleOrnament)])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((DoubleOrnament -> Bool)
-> (Edge n, [(Note n, DoubleOrnament)]) -> Bool
forall {t :: * -> *} {b} {a} {a}.
Foldable t =>
(b -> Bool) -> (a, t (a, b)) -> Bool
check DoubleOrnament -> Bool
isRepetitionOnRight) (Map (Edge n) [(Note n, DoubleOrnament)]
-> [(Edge n, [(Note n, DoubleOrnament)])]
forall k a. Map k a -> [(k, a)]
M.toList Map (Edge n) [(Note n, DoubleOrnament)]
regs) Bool -> Bool -> Bool
&& Bool
allSinglesRepeat
  check :: (b -> Bool) -> (a, t (a, b)) -> Bool
check b -> Bool
fpred (a
_, t (a, b)
os) = ((a, b) -> Bool) -> t (a, b) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (b -> Bool
fpred (b -> Bool) -> ((a, b) -> b) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> b
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, IsPitch n, Notation n, Hashable n)
  => Eval
      (Edges n)
      (t (Edge n))
      (Notes n)
      (t2 (Note n))
      (Spread n)
      (Derivations (PVLeftmost n))
pvDerivUnrestricted :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (Derivations (PVLeftmost n))
pvDerivUnrestricted = (PVLeftmost n -> Derivations (PVLeftmost n))
-> Eval
     (Edges n)
     (t (Edge n))
     (Notes n)
     (t2 (Note n))
     (Spread n)
     (PVLeftmost n)
-> Eval
     (Edges n)
     (t (Edge n))
     (Notes n)
     (t2 (Note n))
     (Spread n)
     (Derivations (PVLeftmost n))
forall v w tr tr' slc slc' h.
(v -> w) -> Eval tr tr' slc slc' h v -> Eval tr tr' slc slc' h w
mapEvalScore PVLeftmost n -> Derivations (PVLeftmost n)
forall a. a -> Derivations a
Do Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (PVLeftmost n)
forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread 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, IsPitch n, Notation n, Hashable n)
  => Eval
      (Merged, (RightBranchSpread, Edges n))
      (t (Edge n))
      ((), ((), Notes n))
      (t2 (Note n))
      ((), ((), (Spread n)))
      (Derivations (PVLeftmost n))
pvDerivRightBranch :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (Merged, (RightBranchSpread, Edges n))
  (t (Edge n))
  ((), ((), Notes n))
  (t2 (Note n))
  ((), ((), Spread n))
  (Derivations (PVLeftmost n))
pvDerivRightBranch =
  Eval
  (RightBranchSpread, Edges n)
  (t (Edge n))
  ((), Notes n)
  (t2 (Note n))
  ((), Spread n)
  (Derivations (PVLeftmost n))
-> Eval
     (Merged, (RightBranchSpread, Edges n))
     (t (Edge n))
     ((), ((), Notes n))
     (t2 (Note n))
     ((), ((), Spread n))
     (Derivations (PVLeftmost n))
forall tr tr' slc slc' h w.
Eval tr tr' slc slc' h w
-> Eval (Merged, tr) tr' ((), slc) slc' ((), h) w
splitFirst (Eval
   (RightBranchSpread, Edges n)
   (t (Edge n))
   ((), Notes n)
   (t2 (Note n))
   ((), Spread n)
   (Derivations (PVLeftmost n))
 -> Eval
      (Merged, (RightBranchSpread, Edges n))
      (t (Edge n))
      ((), ((), Notes n))
      (t2 (Note n))
      ((), ((), Spread n))
      (Derivations (PVLeftmost n)))
-> Eval
     (RightBranchSpread, Edges n)
     (t (Edge n))
     ((), Notes n)
     (t2 (Note n))
     ((), Spread n)
     (Derivations (PVLeftmost n))
-> Eval
     (Merged, (RightBranchSpread, Edges n))
     (t (Edge n))
     ((), ((), Notes n))
     (t2 (Note n))
     ((), ((), Spread n))
     (Derivations (PVLeftmost n))
forall a b. (a -> b) -> a -> b
$ Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (Derivations (PVLeftmost n))
-> Eval
     (RightBranchSpread, Edges n)
     (t (Edge n))
     ((), Notes n)
     (t2 (Note n))
     ((), Spread n)
     (Derivations (PVLeftmost n))
forall tr tr' slc slc' h w.
Eval tr tr' slc slc' h w
-> Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) w
rightBranchSpread (Eval
   (Edges n)
   (t (Edge n))
   (Notes n)
   (t2 (Note n))
   (Spread n)
   (Derivations (PVLeftmost n))
 -> Eval
      (RightBranchSpread, Edges n)
      (t (Edge n))
      ((), Notes n)
      (t2 (Note n))
      ((), Spread n)
      (Derivations (PVLeftmost n)))
-> Eval
     (Edges n)
     (t (Edge n))
     (Notes n)
     (t2 (Note n))
     (Spread n)
     (Derivations (PVLeftmost n))
-> Eval
     (RightBranchSpread, Edges n)
     (t (Edge n))
     ((), Notes n)
     (t2 (Note n))
     ((), Spread n)
     (Derivations (PVLeftmost n))
forall a b. (a -> b) -> a -> b
$ (PVLeftmost n -> Derivations (PVLeftmost n))
-> Eval
     (Edges n)
     (t (Edge n))
     (Notes n)
     (t2 (Note n))
     (Spread n)
     (PVLeftmost n)
-> Eval
     (Edges n)
     (t (Edge n))
     (Notes n)
     (t2 (Note n))
     (Spread n)
     (Derivations (PVLeftmost n))
forall v w tr tr' slc slc' h.
(v -> w) -> Eval tr tr' slc slc' h v -> Eval tr tr' slc slc' h w
mapEvalScore PVLeftmost n -> Derivations (PVLeftmost n)
forall a. a -> Derivations a
Do Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (PVLeftmost n)
forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (PVLeftmost n)
protoVoiceEvaluatorNoRepSplit

-- | An evaluator for protovoices that produces values in the counting semiring.
pvCountUnrestricted
  :: (Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n, Hashable n)
  => Eval (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread n) Int
pvCountUnrestricted :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread n) Int
pvCountUnrestricted = (PVLeftmost n -> Int)
-> Eval
     (Edges n)
     (t (Edge n))
     (Notes n)
     (t2 (Note n))
     (Spread n)
     (PVLeftmost n)
-> Eval
     (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread n) Int
forall v w tr tr' slc slc' h.
(v -> w) -> Eval tr tr' slc slc' h v -> Eval tr tr' slc slc' h w
mapEvalScore (Int -> PVLeftmost n -> Int
forall a b. a -> b -> a
const Int
1) Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (PVLeftmost n)
forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread 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, IsPitch n, Notation n, Hashable n)
  => Eval (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread n) Int
pvCountNoRepSplit :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread n) Int
pvCountNoRepSplit = (PVLeftmost n -> Int)
-> Eval
     (Edges n)
     (t (Edge n))
     (Notes n)
     (t2 (Note n))
     (Spread n)
     (PVLeftmost n)
-> Eval
     (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread n) Int
forall v w tr tr' slc slc' h.
(v -> w) -> Eval tr tr' slc slc' h v -> Eval tr tr' slc slc' h w
mapEvalScore (Int -> PVLeftmost n -> Int
forall a b. a -> b -> a
const Int
1) Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread n)
  (PVLeftmost n)
forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (Edges n)
  (t (Edge n))
  (Notes n)
  (t2 (Note n))
  (Spread 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, IsPitch n, Notation n, Hashable n)
  => Eval (RightBranchSpread, Edges n) (t (Edge n)) ((), Notes n) (t2 (Note n)) ((), Spread n) Int
pvCountNoRepSplitRightBranch :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (RightBranchSpread, Edges n)
  (t (Edge n))
  ((), Notes n)
  (t2 (Note n))
  ((), Spread n)
  Int
pvCountNoRepSplitRightBranch = Eval (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread n) Int
-> Eval
     (RightBranchSpread, Edges n)
     (t (Edge n))
     ((), Notes n)
     (t2 (Note n))
     ((), Spread n)
     Int
forall tr tr' slc slc' h w.
Eval tr tr' slc slc' h w
-> Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) w
rightBranchSpread Eval (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread n) Int
forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval (Edges n) (t (Edge n)) (Notes n) (t2 (Note n)) (Spread 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, IsPitch n, Notation n, Hashable n)
  => Eval
      (Merged, (RightBranchSpread, Edges n))
      (t (Edge n))
      ((), ((), Notes n))
      (t2 (Note n))
      ((), ((), Spread n))
      Int
pvCountNoRepSplitRightBranchSplitFirst :: forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (Merged, (RightBranchSpread, Edges n))
  (t (Edge n))
  ((), ((), Notes n))
  (t2 (Note n))
  ((), ((), Spread n))
  Int
pvCountNoRepSplitRightBranchSplitFirst = Eval
  (RightBranchSpread, Edges n)
  (t (Edge n))
  ((), Notes n)
  (t2 (Note n))
  ((), Spread n)
  Int
-> Eval
     (Merged, (RightBranchSpread, Edges n))
     (t (Edge n))
     ((), ((), Notes n))
     (t2 (Note n))
     ((), ((), Spread n))
     Int
forall tr tr' slc slc' h w.
Eval tr tr' slc slc' h w
-> Eval (Merged, tr) tr' ((), slc) slc' ((), h) w
splitFirst Eval
  (RightBranchSpread, Edges n)
  (t (Edge n))
  ((), Notes n)
  (t2 (Note n))
  ((), Spread n)
  Int
forall (t :: * -> *) (t2 :: * -> *) n.
(Foldable t, Foldable t2, Eq n, Ord n, IsPitch n, Notation n,
 Hashable n) =>
Eval
  (RightBranchSpread, Edges n)
  (t (Edge n))
  ((), Notes n)
  (t2 (Note n))
  ((), Spread n)
  Int
pvCountNoRepSplitRightBranch