{-# LANGUAGE TypeFamilies #-}

{- | This module contains functions for the generative aspects of protovoice derivations:

 - manually constructing protovoice operations (see "PVGrammar") using a monadic interface
 - applying ("replaying") these operations.
-}
module PVGrammar.Generate
  ( -- * Manually Constructing Derivations

    -- | The functions in this section can be used
    -- to manually construct individual derivation operations
    -- or in conjunction with the (indexed-)monadic functions in "Common" (see 'Common.buildDerivation')
    -- to manually construct complete derivations.
    -- Each outer-structure operation ('mkSplit', 'mkSpread', 'mkFreeze') enters a writer monad
    -- in which inner-structure operations can be chained to determine the details.
    --
    -- Note that the legality of the operations is not always checked, so be careful!

    -- * Freeze
    mkFreeze

    -- ** Split
  , mkSplit
  , splitRegular
  , splitPassing
  , addFromLeft
  , addFromRight
  , addPassingLeft
  , addPassingRight

    -- ** Spread
  , mkSpread
  , SpreadDir (..)
  , spreadNote
  , addPassing
  , addOctaveRepetition

    -- * Derivation Players

    -- | These players can be used with the replay functions in the "Display" module
    -- to obtain derivation graphs for protovoice derivations.
  , derivationPlayerPV
  , derivationPlayerPVAllEdges

    -- * Applying Operations

    -- | Apply operations to parent objects and get the resulting child objects.
  , applySplit
  , applySplitAllEdges
  , applyFreeze
  , applySpread
  , freezable

    -- * Utility Functions
  , debugPVAnalysis
  , checkDerivation
  ) where

import Common
import Display
import PVGrammar

import Musicology.Pitch (Notation (..))

import Control.Monad (foldM)
import Control.Monad.Writer.Strict qualified as MW
import Data.Bifunctor (bimap)
import Data.Foldable (toList)
import Data.HashMap.Strict qualified as HM
import Data.HashSet qualified as S
import Data.Hashable (Hashable)
import Data.List qualified as L
import Data.Map.Strict qualified as M
import Data.Maybe (catMaybes)
import Data.Monoid (Endo (..))
import Data.Traversable (for)
import Internal.MultiSet qualified as MS
import Lens.Micro qualified as Lens
import Lens.Micro.Extras qualified as Lens
import Musicology.Core qualified as MC
  ( HasPitch (pitch)
  , Pitched (IntervalOf)
  )

-- building operations
-- ===================

{- | Create a freeze operation.
 Can be used together with the 'Common.freeze' action within a monadic derivation.
-}
mkFreeze :: (Hashable n) => [InnerEdge n] -> Freeze n
mkFreeze :: forall n. Hashable n => [InnerEdge n] -> Freeze n
mkFreeze [InnerEdge n]
ties = HashSet (Edge n) -> Freeze n
forall n. HashSet (Edge n) -> Freeze n
FreezeOp (HashSet (Edge n) -> Freeze n) -> HashSet (Edge n) -> Freeze n
forall a b. (a -> b) -> a -> b
$ [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
$ (InnerEdge n -> Edge n) -> [InnerEdge n] -> [Edge 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
r) -> (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)) [InnerEdge n]
ties

{- | Create a split operation monadically

 > mkSplit $ do
 >   ... -- internal split actions

 Can be used together with the 'Common.split' action within a monadic derivation.
-}
mkSplit :: MW.Writer (Split n) a -> Split n
mkSplit :: forall n a. Writer (Split n) a -> Split n
mkSplit = Writer (Split n) a -> Split n
forall w a. Writer w a -> w
MW.execWriter

-- | During a split, split an existing regular edge between two notes.
splitRegular
  :: (Ord n, Hashable n)
  => StartStop (Note n)
  -- ^ left parent
  -> StartStop (Note n)
  -- ^ right parent
  -> Note n
  -- ^ the new child note
  -> DoubleOrnament
  -- ^ the ornament type of the child note
  -> Bool
  -- ^ keep the left child edge (left parent to child)?
  -> Bool
  -- ^ keep the right child edge (child to right parent)?
  -> MW.Writer (Split n) ()
splitRegular :: forall n.
(Ord n, Hashable n) =>
StartStop (Note n)
-> StartStop (Note n)
-> Note n
-> DoubleOrnament
-> Bool
-> Bool
-> Writer (Split n) ()
splitRegular StartStop (Note n)
l StartStop (Note n)
r Note n
c DoubleOrnament
o Bool
kl Bool
kr =
  Split n -> WriterT (Split n) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell (Split n -> WriterT (Split n) Identity ())
-> Split n -> WriterT (Split n) Identity ()
forall a b. (a -> b) -> a -> b
$
    Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
-> Map (InnerEdge n) [(Note n, PassingOrnament)]
-> Map (Note n) [(Note n, RightOrnament)]
-> Map (Note n) [(Note n, LeftOrnament)]
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note 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
      ((StartStop (Note n), StartStop (Note n))
-> [(Note n, DoubleOrnament)]
-> Map
     (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
forall k a. k -> a -> Map k a
M.singleton (StartStop (Note n)
l, StartStop (Note n)
r) [(Note n
c, DoubleOrnament
o)])
      Map (InnerEdge n) [(Note n, PassingOrnament)]
forall k a. Map k a
M.empty
      Map (Note n) [(Note n, RightOrnament)]
forall k a. Map k a
M.empty
      Map (Note n) [(Note n, LeftOrnament)]
forall k a. Map k a
M.empty
      HashSet (StartStop (Note n), StartStop (Note n))
kls
      HashSet (StartStop (Note n), StartStop (Note n))
krs
      MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty
      MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty
 where
  kls :: HashSet (StartStop (Note n), StartStop (Note n))
kls = if Bool
kl then (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Hashable a => a -> HashSet a
S.singleton (StartStop (Note n)
l, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
c) else HashSet (StartStop (Note n), StartStop (Note n))
forall a. HashSet a
S.empty
  krs :: HashSet (StartStop (Note n), StartStop (Note n))
krs = if Bool
kr then (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Hashable a => a -> HashSet a
S.singleton (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
c, StartStop (Note n)
r) else HashSet (StartStop (Note n), StartStop (Note n))
forall a. HashSet a
S.empty

-- | During a split, split an existing passing edge, introducing a new passing note.
splitPassing
  :: (Ord n, Hashable n)
  => Note n
  -- ^ left parent
  -> Note n
  -- ^ right parent
  -> Note n
  -- ^ the new child note
  -> PassingOrnament
  -- ^ the ornament type of the child note
  -> Bool
  -- ^ keep the left child edge (if step)
  -> Bool
  -- ^ keep the right child edge (if step)
  -> MW.Writer (Split n) ()
splitPassing :: forall n.
(Ord n, Hashable n) =>
Note n
-> Note n
-> Note n
-> PassingOrnament
-> Bool
-> Bool
-> Writer (Split n) ()
splitPassing Note n
l Note n
r Note n
c PassingOrnament
o Bool
kl Bool
kr =
  Split n -> WriterT (Split n) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell (Split n -> WriterT (Split n) Identity ())
-> Split n -> WriterT (Split n) Identity ()
forall a b. (a -> b) -> a -> b
$
    Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
-> Map (InnerEdge n) [(Note n, PassingOrnament)]
-> Map (Note n) [(Note n, RightOrnament)]
-> Map (Note n) [(Note n, LeftOrnament)]
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note 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
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
forall k a. Map k a
M.empty
      (InnerEdge n
-> [(Note n, PassingOrnament)]
-> Map (InnerEdge n) [(Note n, PassingOrnament)]
forall k a. k -> a -> Map k a
M.singleton (Note n
l, Note n
r) [(Note n
c, PassingOrnament
o)])
      Map (Note n) [(Note n, RightOrnament)]
forall k a. Map k a
M.empty
      Map (Note n) [(Note n, LeftOrnament)]
forall k a. Map k a
M.empty
      HashSet (StartStop (Note n), StartStop (Note n))
kls
      HashSet (StartStop (Note n), StartStop (Note n))
krs
      MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty
      MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty
 where
  kls :: HashSet (StartStop (Note n), StartStop (Note n))
kls =
    if PassingOrnament
o PassingOrnament -> PassingOrnament -> Bool
forall a. Eq a => a -> a -> Bool
/= PassingOrnament
PassingRight Bool -> Bool -> Bool
&& Bool
kl then (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Hashable a => a -> HashSet a
S.singleton (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
c) else HashSet (StartStop (Note n), StartStop (Note n))
forall a. HashSet a
S.empty
  krs :: HashSet (StartStop (Note n), StartStop (Note n))
krs =
    if PassingOrnament
o PassingOrnament -> PassingOrnament -> Bool
forall a. Eq a => a -> a -> Bool
/= PassingOrnament
PassingLeft Bool -> Bool -> Bool
&& Bool
kr then (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Hashable a => a -> HashSet a
S.singleton (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
c, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
r) else HashSet (StartStop (Note n), StartStop (Note n))
forall a. HashSet a
S.empty

-- | During a split, add a new single-sided ornament to a left parent note.
addFromLeft
  :: (Ord n, Hashable n)
  => Note n
  -- ^ parent (from the left slice)
  -> Note n
  -- ^ the new child note
  -> RightOrnament
  -- ^ the new child note's ornament type
  -> Bool
  -- ^ keep the new edge?
  -> MW.Writer (Split n) ()
addFromLeft :: forall n.
(Ord n, Hashable n) =>
Note n -> Note n -> RightOrnament -> Bool -> Writer (Split n) ()
addFromLeft Note n
parent Note n
child RightOrnament
op Bool
keep =
  Split n -> WriterT (Split n) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell (Split n -> WriterT (Split n) Identity ())
-> Split n -> WriterT (Split n) Identity ()
forall a b. (a -> b) -> a -> b
$
    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)]
forall k a. Map k a
M.empty
      Map (InnerEdge n) [(Note n, PassingOrnament)]
forall k a. Map k a
M.empty
      (Note n
-> [(Note n, RightOrnament)]
-> Map (Note n) [(Note n, RightOrnament)]
forall k a. k -> a -> Map k a
M.singleton Note n
parent [(Note n
child, RightOrnament
op)])
      Map (Note n) [(Note n, LeftOrnament)]
forall k a. Map k a
M.empty
      (if Bool
keep then Edge n -> HashSet (Edge n)
forall a. Hashable a => a -> HashSet a
S.singleton (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
parent, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
child) else HashSet (Edge n)
forall a. HashSet a
S.empty)
      HashSet (Edge n)
forall a. HashSet a
S.empty
      MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty
      MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty

-- | During a split, add a new single-sided ornament to a right parent note.
addFromRight
  :: (Ord n, Hashable n)
  => Note n
  -- ^ parent (from the right slice)
  -> Note n
  -- ^ the new child note
  -> LeftOrnament
  -- ^ the new child note's ornament type
  -> Bool
  -- ^ keep the new edge?
  -> MW.Writer (Split n) ()
addFromRight :: forall n.
(Ord n, Hashable n) =>
Note n -> Note n -> LeftOrnament -> Bool -> Writer (Split n) ()
addFromRight Note n
parent Note n
child LeftOrnament
op Bool
keep =
  Split n -> WriterT (Split n) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell (Split n -> WriterT (Split n) Identity ())
-> Split n -> WriterT (Split n) Identity ()
forall a b. (a -> b) -> a -> b
$
    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)]
forall k a. Map k a
M.empty
      Map (InnerEdge n) [(Note n, PassingOrnament)]
forall k a. Map k a
M.empty
      Map (Note n) [(Note n, RightOrnament)]
forall k a. Map k a
M.empty
      (Note n
-> [(Note n, LeftOrnament)]
-> Map (Note n) [(Note n, LeftOrnament)]
forall k a. k -> a -> Map k a
M.singleton Note n
parent [(Note n
child, LeftOrnament
op)])
      HashSet (Edge n)
forall a. HashSet a
S.empty
      (if Bool
keep then Edge n -> HashSet (Edge n)
forall a. Hashable a => a -> HashSet a
S.singleton (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
child, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
parent) else HashSet (Edge n)
forall a. HashSet a
S.empty)
      MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty
      MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty

-- | During a split, add a new passing edge between the left parent slice and the child slice.
addPassingLeft
  :: (Ord n, Hashable n)
  => Note n
  -- ^ note from the left parent slice
  -> Note n
  -- ^ note from the child slice
  -> MW.Writer (Split n) ()
addPassingLeft :: forall n.
(Ord n, Hashable n) =>
Note n -> Note n -> Writer (Split n) ()
addPassingLeft Note n
l Note n
m = Split n -> WriterT (Split n) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell (Split n -> WriterT (Split n) Identity ())
-> Split n -> WriterT (Split n) Identity ()
forall a b. (a -> b) -> a -> b
$ Split n
forall a. Monoid a => a
mempty{passLeft = MS.singleton (l, m)}

-- | During a split, add a new passing edge between the child slice and the right parent slice.
addPassingRight
  :: (Ord n, Hashable n)
  => Note n
  -- ^ note from the child slice
  -> Note n
  -- ^ note from the right parent slice
  -> MW.Writer (Split n) ()
addPassingRight :: forall n.
(Ord n, Hashable n) =>
Note n -> Note n -> Writer (Split n) ()
addPassingRight Note n
m Note n
r = Split n -> WriterT (Split n) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell (Split n -> WriterT (Split n) Identity ())
-> Split n -> WriterT (Split n) Identity ()
forall a b. (a -> b) -> a -> b
$ Split n
forall a. Monoid a => a
mempty{passRight = MS.singleton (m, r)}

{- | Create a spread operation monadically

 > mkSpread $ do
 >   ... -- internal spread actions

 Can be used together with the 'Common.spread' action within a monadic derivation.
-}
mkSpread :: MW.Writer (Endo (Spread n)) () -> Spread n
mkSpread :: forall n. Writer (Endo (Spread n)) () -> Spread n
mkSpread Writer (Endo (Spread n)) ()
actions = Endo (Spread n) -> Spread n -> Spread n
forall a. Endo a -> a -> a
appEndo (Writer (Endo (Spread n)) () -> Endo (Spread n)
forall w a. Writer w a -> w
MW.execWriter Writer (Endo (Spread n)) ()
actions) Spread n
forall {n}. Spread n
emptySpread
 where
  emptySpread :: Spread n
emptySpread = 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)
forall k v. HashMap k v
HM.empty (Edges n -> Spread n) -> Edges n -> Spread n
forall a b. (a -> b) -> a -> b
$ HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge n)
forall a. HashSet a
S.empty MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty

-- | A helper type to express the direction in which a note is spread + the child(ren)'s new IDs.
data SpreadDir = ToLeft String | ToRight String | ToBoth String String

-- | During a spread, distribute one of the parent notes to the child slices of a spread.
spreadNote
  :: (Ord n, Hashable n)
  => Note n
  -- ^ the parent note
  -> SpreadDir
  -- ^ the distribution of the note
  -> Bool
  -- ^ introduce a repetition edge (if possible)?
  -> MW.Writer (Endo (Spread n)) ()
spreadNote :: forall n.
(Ord n, Hashable n) =>
Note n -> SpreadDir -> Bool -> Writer (Endo (Spread n)) ()
spreadNote Note n
note SpreadDir
dir Bool
edge = Endo (Spread n) -> WriterT (Endo (Spread n)) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell (Endo (Spread n) -> WriterT (Endo (Spread n)) Identity ())
-> Endo (Spread n) -> WriterT (Endo (Spread n)) Identity ()
forall a b. (a -> b) -> a -> b
$ (Spread n -> Spread n) -> Endo (Spread n)
forall a. (a -> a) -> Endo a
Endo Spread n -> Spread n
h
 where
  h :: Spread n -> Spread n
h (SpreadOp HashMap (Note n) (SpreadChildren n)
dist (Edges HashSet (Edge n)
mRegs MultiSet (InnerEdge n)
mPassings)) = 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)
dist' (HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge n)
mRegs' MultiSet (InnerEdge n)
mPassings)
   where
    pitch :: n
pitch = Note n -> n
forall n. Note n -> n
notePitch Note n
note
    dir' :: SpreadChildren n
dir' = case SpreadDir
dir of
      ToLeft String
idl -> Note n -> SpreadChildren n
forall n. Note n -> SpreadChildren n
SpreadLeftChild (n -> String -> Note n
forall n. n -> String -> Note n
Note n
pitch String
idl)
      ToRight String
idr -> Note n -> SpreadChildren n
forall n. Note n -> SpreadChildren n
SpreadRightChild (n -> String -> Note n
forall n. n -> String -> Note n
Note n
pitch String
idr)
      ToBoth String
idl String
idr -> Note n -> Note n -> SpreadChildren n
forall n. Note n -> Note n -> SpreadChildren n
SpreadBothChildren (n -> String -> Note n
forall n. n -> String -> Note n
Note n
pitch String
idl) (n -> String -> Note n
forall n. n -> String -> Note n
Note n
pitch String
idr)
    dist' :: HashMap (Note n) (SpreadChildren n)
dist' = 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 SpreadChildren n
dir' HashMap (Note n) (SpreadChildren n)
dist
    mRegs' :: HashSet (Edge n)
mRegs' =
      HashSet (Edge n) -> HashSet (Edge n) -> HashSet (Edge n)
forall a. Eq a => HashSet a -> HashSet a -> HashSet a
S.union HashSet (Edge n)
mRegs (HashSet (Edge n) -> HashSet (Edge n))
-> HashSet (Edge n) -> HashSet (Edge n)
forall a b. (a -> b) -> a -> b
$ case (Bool
edge, SpreadDir
dir) of
        (Bool
True, ToBoth String
idl String
idr) -> Edge n -> HashSet (Edge n)
forall a. Hashable a => a -> HashSet a
S.singleton (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner (n -> String -> Note n
forall n. n -> String -> Note n
Note n
pitch String
idl), Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner (n -> String -> Note n
forall n. n -> String -> Note n
Note n
pitch String
idr))
        (Bool, SpreadDir)
_ -> HashSet (Edge n)
forall a. HashSet a
S.empty

-- | During a spread, add a new passing edge between the child slices of a spread.
addPassing
  :: (Ord n, Hashable n)
  => Note n
  -- ^ the left end of the edge
  -> Note n
  -- ^ the right end of the edge
  -> MW.Writer (Endo (Spread n)) ()
addPassing :: forall n.
(Ord n, Hashable n) =>
Note n -> Note n -> Writer (Endo (Spread n)) ()
addPassing Note n
l Note n
r = Endo (Spread n) -> WriterT (Endo (Spread n)) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell (Endo (Spread n) -> WriterT (Endo (Spread n)) Identity ())
-> Endo (Spread n) -> WriterT (Endo (Spread n)) Identity ()
forall a b. (a -> b) -> a -> b
$ (Spread n -> Spread n) -> Endo (Spread n)
forall a. (a -> a) -> Endo a
Endo Spread n -> Spread n
h
 where
  h :: Spread n -> Spread n
h (SpreadOp HashMap (Note n) (SpreadChildren n)
dist (Edges HashSet (Edge n)
mRegs MultiSet (Note n, Note n)
mPassings)) = 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)
dist (HashSet (Edge n) -> MultiSet (Note n, Note n) -> Edges n
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge n)
mRegs MultiSet (Note n, Note n)
mPassings')
   where
    mPassings' :: MultiSet (Note n, Note n)
mPassings' = (Note n, Note n)
-> MultiSet (Note n, Note n) -> MultiSet (Note n, Note n)
forall a. (Eq a, Hashable a) => a -> MultiSet a -> MultiSet a
MS.insert (Note n
l, Note n
r) MultiSet (Note n, Note n)
mPassings

{- | During a spread, add a new repetition edge
 between two notes of the same pitch class but from different octaves.
-}
addOctaveRepetition
  :: (Ord n, Hashable n)
  => Note n
  -- ^ the left end of the edge
  -> Note n
  -- ^ the right end of the edge
  -> MW.Writer (Endo (Spread n)) ()
addOctaveRepetition :: forall n.
(Ord n, Hashable n) =>
Note n -> Note n -> Writer (Endo (Spread n)) ()
addOctaveRepetition Note n
l Note n
r = Endo (Spread n) -> WriterT (Endo (Spread n)) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell (Endo (Spread n) -> WriterT (Endo (Spread n)) Identity ())
-> Endo (Spread n) -> WriterT (Endo (Spread n)) Identity ()
forall a b. (a -> b) -> a -> b
$ (Spread n -> Spread n) -> Endo (Spread n)
forall a. (a -> a) -> Endo a
Endo Spread n -> Spread n
h
 where
  h :: Spread n -> Spread n
h (SpreadOp HashMap (Note n) (SpreadChildren n)
dist (Edges HashSet (StartStop (Note n), StartStop (Note n))
mRegs MultiSet (InnerEdge n)
mPassings)) = 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)
dist (HashSet (StartStop (Note n), StartStop (Note n))
-> MultiSet (InnerEdge n) -> Edges n
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (StartStop (Note n), StartStop (Note n))
mRegs' MultiSet (InnerEdge n)
mPassings)
   where
    mRegs' :: HashSet (StartStop (Note n), StartStop (Note n))
mRegs' = (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert (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) HashSet (StartStop (Note n), StartStop (Note n))
mRegs

-- applying operations
-- ===================

-- | Tries to apply a split operation to the parent transition.
applySplit
  :: forall n
   . (Ord n, Notation n, Hashable n)
  => Split n
  -- ^ the split operation
  -> Edges n
  -- ^ the parent transition
  -> Either String (Edges n, Notes n, Edges n)
  -- ^ the resulting child transitions and slice (or an error message).
applySplit :: forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit inSplit :: Split n
inSplit@(SplitOp Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
splitRegs Map (Note n, Note n) [(Note n, PassingOrnament)]
splitPassings Map (Note n) [(Note n, RightOrnament)]
ls Map (Note n) [(Note n, LeftOrnament)]
rs HashSet (StartStop (Note n), StartStop (Note n))
keepl HashSet (StartStop (Note n), StartStop (Note n))
keepr MultiSet (Note n, Note n)
passl MultiSet (Note n, Note n)
passr) inTop :: Edges n
inTop@(Edges HashSet (StartStop (Note n), StartStop (Note n))
topRegs MultiSet (Note n, Note n)
topPassings) =
  do
    notesReg <- HashSet (StartStop (Note n), StartStop (Note n))
-> Map
     (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
-> Either String (HashSet (Note n))
applyRegs HashSet (StartStop (Note n), StartStop (Note n))
topRegs Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
splitRegs
    (notesPassing, leftPassings, rightPassings) <- applyPassings topPassings splitPassings
    let notesL = Map (Note n) [(Note n, RightOrnament)] -> HashSet (Note n)
forall {a} {a} {b}. Hashable a => Map a [(a, b)] -> HashSet a
collectNotes Map (Note n) [(Note n, RightOrnament)]
ls
        notesR = Map (Note n) [(Note n, LeftOrnament)] -> HashSet (Note n)
forall {a} {a} {b}. Hashable a => Map a [(a, b)] -> HashSet a
collectNotes Map (Note n) [(Note n, LeftOrnament)]
rs
        notes = [HashSet (Note n)] -> HashSet (Note n)
forall a. Eq a => [HashSet a] -> HashSet a
S.unions [HashSet (Note n)
notesReg, HashSet (Note n)
notesPassing, HashSet (Note n)
notesL, HashSet (Note n)
notesR]
    pure
      ( Edges keepl (MS.union leftPassings passl)
      , Notes notes
      , Edges keepr (MS.union rightPassings passr)
      )
 where
  allOps :: Map a [b] -> [(a, b)]
allOps Map a [b]
opset = do
    (parent, children) <- Map a [b] -> [(a, [b])]
forall k a. Map k a -> [(k, a)]
M.toList Map a [b]
opset
    child <- children
    pure (parent, child)

  showEdge :: (a, a) -> String
showEdge (a
p1, a
p2) = a -> String
forall a. Show a => a -> String
show a
p1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
p2
  showEdges :: t (a, a) -> String
showEdges t (a, a)
ts = String
"{" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," ((a, a) -> String
forall {a} {a}. (Show a, Show a) => (a, a) -> String
showEdge ((a, a) -> String) -> [(a, a)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (a, a) -> [(a, a)]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (a, a)
ts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"}"

  applyRegs :: HashSet (StartStop (Note n), StartStop (Note n))
-> Map
     (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
-> Either String (HashSet (Note n))
applyRegs HashSet (StartStop (Note n), StartStop (Note n))
top Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
ops = do
    (top', notes) <- ((HashSet (StartStop (Note n), StartStop (Note n)),
  HashSet (Note n))
 -> ((StartStop (Note n), StartStop (Note n)),
     (Note n, DoubleOrnament))
 -> Either
      String
      (HashSet (StartStop (Note n), StartStop (Note n)),
       HashSet (Note n)))
-> (HashSet (StartStop (Note n), StartStop (Note n)),
    HashSet (Note n))
-> [((StartStop (Note n), StartStop (Note n)),
     (Note n, DoubleOrnament))]
-> Either
     String
     (HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (Note n))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (HashSet (StartStop (Note n), StartStop (Note n))
-> (HashSet (StartStop (Note n), StartStop (Note n)),
    HashSet (Note n))
-> ((StartStop (Note n), StartStop (Note n)),
    (Note n, DoubleOrnament))
-> Either
     String
     (HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (Note n))
applyReg HashSet (StartStop (Note n), StartStop (Note n))
top) (HashSet (StartStop (Note n), StartStop (Note n))
top, HashSet (Note n)
forall a. HashSet a
S.empty) ([((StartStop (Note n), StartStop (Note n)),
   (Note n, DoubleOrnament))]
 -> Either
      String
      (HashSet (StartStop (Note n), StartStop (Note n)),
       HashSet (Note n)))
-> [((StartStop (Note n), StartStop (Note n)),
     (Note n, DoubleOrnament))]
-> Either
     String
     (HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (Note n))
forall a b. (a -> b) -> a -> b
$ Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
-> [((StartStop (Note n), StartStop (Note n)),
     (Note n, DoubleOrnament))]
forall {a} {b}. Map a [b] -> [(a, b)]
allOps Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
ops
    if S.null top'
      then Right notes
      else Left $ "did not use all terminal edges, remaining: " <> showEdges top'

  applyReg :: HashSet (StartStop (Note n), StartStop (Note n))
-> (HashSet (StartStop (Note n), StartStop (Note n)),
    HashSet (Note n))
-> ((StartStop (Note n), StartStop (Note n)),
    (Note n, DoubleOrnament))
-> Either
     String
     (HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (Note n))
applyReg HashSet (StartStop (Note n), StartStop (Note n))
topAll (HashSet (StartStop (Note n), StartStop (Note n))
top, HashSet (Note n)
notes) ((StartStop (Note n), StartStop (Note n))
parent, (Note n
note, DoubleOrnament
_))
    | (StartStop (Note n), StartStop (Note n))
parent (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n)) -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet (StartStop (Note n), StartStop (Note n))
topAll =
        (HashSet (StartStop (Note n), StartStop (Note n)),
 HashSet (Note n))
-> Either
     String
     (HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (Note n))
forall a b. b -> Either a b
Right (HashSet (StartStop (Note n), StartStop (Note n))
top', HashSet (Note n)
notes')
    | Bool
otherwise =
        String
-> Either
     String
     (HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (Note n))
forall a b. a -> Either a b
Left (String
 -> Either
      String
      (HashSet (StartStop (Note n), StartStop (Note n)),
       HashSet (Note n)))
-> String
-> Either
     String
     (HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (Note n))
forall a b. (a -> b) -> a -> b
$
          String
"used non-existing terminal edge\n  top="
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Edges n -> String
forall a. Show a => a -> String
show Edges n
inTop
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n  split="
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Split n -> String
forall a. Show a => a -> String
show Split n
inSplit
   where
    top' :: HashSet (StartStop (Note n), StartStop (Note n))
top' = (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.delete (StartStop (Note n), StartStop (Note n))
parent HashSet (StartStop (Note n), StartStop (Note n))
top
    notes' :: HashSet (Note n)
notes' = Note n -> HashSet (Note n) -> HashSet (Note n)
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert Note n
note HashSet (Note n)
notes

  applyPassings :: MultiSet (Note n, Note n)
-> Map (Note n, Note n) [(Note n, PassingOrnament)]
-> Either
     String
     (HashSet (Note n), MultiSet (Note n, Note n),
      MultiSet (Note n, Note n))
applyPassings MultiSet (Note n, Note n)
top Map (Note n, Note n) [(Note n, PassingOrnament)]
ops = do
    (top', notes, lPassings, rPassings) <-
      ((MultiSet (Note n, Note n), HashSet (Note n),
  MultiSet (Note n, Note n), MultiSet (Note n, Note n))
 -> ((Note n, Note n), (Note n, PassingOrnament))
 -> Either
      String
      (MultiSet (Note n, Note n), HashSet (Note n),
       MultiSet (Note n, Note n), MultiSet (Note n, Note n)))
-> (MultiSet (Note n, Note n), HashSet (Note n),
    MultiSet (Note n, Note n), MultiSet (Note n, Note n))
-> [((Note n, Note n), (Note n, PassingOrnament))]
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (MultiSet (Note n, Note n), HashSet (Note n),
 MultiSet (Note n, Note n), MultiSet (Note n, Note n))
-> ((Note n, Note n), (Note n, PassingOrnament))
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n))
applyPassing (MultiSet (Note n, Note n)
top, HashSet (Note n)
forall a. HashSet a
S.empty, MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty, MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty) ([((Note n, Note n), (Note n, PassingOrnament))]
 -> Either
      String
      (MultiSet (Note n, Note n), HashSet (Note n),
       MultiSet (Note n, Note n), MultiSet (Note n, Note n)))
-> [((Note n, Note n), (Note n, PassingOrnament))]
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n))
forall a b. (a -> b) -> a -> b
$ Map (Note n, Note n) [(Note n, PassingOrnament)]
-> [((Note n, Note n), (Note n, PassingOrnament))]
forall {a} {b}. Map a [b] -> [(a, b)]
allOps Map (Note n, Note n) [(Note n, PassingOrnament)]
ops
    if MS.null top'
      then Right (notes, lPassings, rPassings)
      else
        Left $
          "did not use all non-terminal edges, remaining: "
            <> showEdges
              (MS.toList top')

  applyPassing :: (MultiSet (Note n, Note n), HashSet (Note n),
 MultiSet (Note n, Note n), MultiSet (Note n, Note n))
-> ((Note n, Note n), (Note n, PassingOrnament))
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n))
applyPassing (MultiSet (Note n, Note n)
top, HashSet (Note n)
notes, MultiSet (Note n, Note n)
lPassings, MultiSet (Note n, Note n)
rPassings) (parent :: (Note n, Note n)
parent@(Note n
pl, Note n
pr), (Note n
note, PassingOrnament
pass))
    | (Note n, Note n)
parent (Note n, Note n) -> MultiSet (Note n, Note n) -> Bool
forall k. (Eq k, Hashable k) => k -> MultiSet k -> Bool
`MS.member` MultiSet (Note n, Note n)
top =
        (MultiSet (Note n, Note n), HashSet (Note n),
 MultiSet (Note n, Note n), MultiSet (Note n, Note n))
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n))
forall a b. b -> Either a b
Right (MultiSet (Note n, Note n)
top', HashSet (Note n)
notes', MultiSet (Note n, Note n)
lPassings', MultiSet (Note n, Note n)
rPassings')
    | Bool
otherwise =
        String
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n))
forall a b. a -> Either a b
Left (String
 -> Either
      String
      (MultiSet (Note n, Note n), HashSet (Note n),
       MultiSet (Note n, Note n), MultiSet (Note n, Note n)))
-> String
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n))
forall a b. (a -> b) -> a -> b
$
          String
"used non-existing non-terminal edge\n  top="
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Edges n -> String
forall a. Show a => a -> String
show Edges n
inTop
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n  split="
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Split n -> String
forall a. Show a => a -> String
show Split n
inSplit
   where
    top' :: MultiSet (Note n, Note n)
top' = (Note n, Note n)
-> MultiSet (Note n, Note n) -> MultiSet (Note n, Note n)
forall a. (Eq a, Hashable a) => a -> MultiSet a -> MultiSet a
MS.delete (Note n, Note n)
parent MultiSet (Note n, Note n)
top
    notes' :: HashSet (Note n)
notes' = Note n -> HashSet (Note n) -> HashSet (Note n)
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert Note n
note HashSet (Note n)
notes
    (MultiSet (Note n, Note n)
newl, MultiSet (Note n, Note n)
newr) = case PassingOrnament
pass of
      PassingOrnament
PassingMid -> (MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty, MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty)
      PassingOrnament
PassingLeft -> (MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty, (Note n, Note n) -> MultiSet (Note n, Note n)
forall a. Hashable a => a -> MultiSet a
MS.singleton (Note n
note, Note n
pr))
      PassingOrnament
PassingRight -> ((Note n, Note n) -> MultiSet (Note n, Note n)
forall a. Hashable a => a -> MultiSet a
MS.singleton (Note n
pl, Note n
note), MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty)
    lPassings' :: MultiSet (Note n, Note n)
lPassings' = MultiSet (Note n, Note n)
-> MultiSet (Note n, Note n) -> MultiSet (Note n, Note n)
forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.union MultiSet (Note n, Note n)
newl MultiSet (Note n, Note n)
lPassings
    rPassings' :: MultiSet (Note n, Note n)
rPassings' = MultiSet (Note n, Note n)
-> MultiSet (Note n, Note n) -> MultiSet (Note n, Note n)
forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.union MultiSet (Note n, Note n)
newr MultiSet (Note n, Note n)
rPassings

  singleChild :: (a, (a, b)) -> a
singleChild (a
_, (a
note, b
_)) = a
note
  collectNotes :: Map a [(a, b)] -> HashSet a
collectNotes Map a [(a, b)]
ops = [a] -> HashSet a
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([a] -> HashSet a) -> [a] -> HashSet a
forall a b. (a -> b) -> a -> b
$ (a, (a, b)) -> a
forall {a} {a} {b}. (a, (a, b)) -> a
singleChild ((a, (a, b)) -> a) -> [(a, (a, b))] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map a [(a, b)] -> [(a, (a, b))]
forall {a} {b}. Map a [b] -> [(a, b)]
allOps Map a [(a, b)]
ops

-- | Indicates whether a transition can be frozen (i.e., doesn't contain non-"tie" edges).
freezable :: (Eq (MC.IntervalOf n), MC.HasPitch n) => Edges n -> Bool
freezable :: forall n. (Eq (IntervalOf n), HasPitch n) => Edges n -> Bool
freezable (Edges HashSet (Edge n)
ts MultiSet (InnerEdge n)
nts) = MultiSet (InnerEdge n) -> Bool
forall k. MultiSet k -> Bool
MS.null MultiSet (InnerEdge n)
nts Bool -> Bool -> Bool
&& (Edge n -> Bool) -> HashSet (Edge n) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Edge n -> Bool
forall {b} {b} {f :: * -> *}.
(IntervalOf b ~ IntervalOf b, ReTypeInterval b (IntervalOf b) ~ b,
 Eq (f (Pitch (IntervalOf b))), Functor f, HasPitch b,
 HasPitch b) =>
(f (Note b), f (Note b)) -> Bool
isRep HashSet (Edge n)
ts
 where
  isRep :: (f (Note b), f (Note b)) -> Bool
isRep (f (Note b)
a, f (Note b)
b) = (Note b -> Pitch (IntervalOf b))
-> f (Note b) -> f (Pitch (IntervalOf b))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> Pitch (IntervalOf b)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
MC.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)
a f (Pitch (IntervalOf b)) -> f (Pitch (IntervalOf b)) -> Bool
forall a. Eq a => a -> a -> Bool
== (Note b -> Pitch (IntervalOf b))
-> f (Note b) -> f (Pitch (IntervalOf b))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> Pitch (IntervalOf b)
b -> Pitch (IntervalOf b)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
MC.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)
b

-- | Tries to apply a freeze operation to a transition.
applyFreeze
  :: (Eq (MC.IntervalOf n), MC.HasPitch n)
  => Freeze n
  -- ^ the freeze operation
  -> Edges n
  -- ^ the unfrozen edge
  -> Either String (Edges n)
  -- ^ the frozen transition
applyFreeze :: forall n.
(Eq (IntervalOf n), HasPitch n) =>
Freeze n -> Edges n -> Either String (Edges n)
applyFreeze (FreezeOp HashSet (Edge n)
_ties) e :: Edges n
e@(Edges HashSet (Edge n)
ts MultiSet (InnerEdge n)
nts)
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ MultiSet (InnerEdge n) -> Bool
forall k. MultiSet k -> Bool
MS.null MultiSet (InnerEdge n)
nts = String -> Either String (Edges n)
forall a b. a -> Either a b
Left String
"cannot freeze non-terminal edges"
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Edge n -> Bool) -> HashSet (Edge n) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Edge n -> Bool
forall {b} {b} {f :: * -> *}.
(IntervalOf b ~ IntervalOf b, ReTypeInterval b (IntervalOf b) ~ b,
 Eq (f (Pitch (IntervalOf b))), Functor f, HasPitch b,
 HasPitch b) =>
(f (Note b), f (Note b)) -> Bool
isRep HashSet (Edge n)
ts = String -> Either String (Edges n)
forall a b. a -> Either a b
Left String
"cannot freeze non-tie edges"
  | Bool
otherwise = Edges n -> Either String (Edges n)
forall a b. b -> Either a b
Right Edges n
e
 where
  isRep :: (f (Note b), f (Note b)) -> Bool
isRep (f (Note b)
a, f (Note b)
b) = (Note b -> Pitch (IntervalOf b))
-> f (Note b) -> f (Pitch (IntervalOf b))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> Pitch (IntervalOf b)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
MC.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)
a f (Pitch (IntervalOf b)) -> f (Pitch (IntervalOf b)) -> Bool
forall a. Eq a => a -> a -> Bool
== (Note b -> Pitch (IntervalOf b))
-> f (Note b) -> f (Pitch (IntervalOf b))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> Pitch (IntervalOf b)
b -> Pitch (IntervalOf b)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
MC.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)
b

-- | Tries to apply a spread operation to the parent transitions and slice.
applySpread
  :: forall n
   . (Ord n, Notation n, Hashable n)
  => Spread n
  -- ^ the spread operation
  -> Edges n
  -- ^ the left parent transition
  -> Notes n
  -- ^ the parent slice
  -> Edges n
  -- ^ the right parent transition
  -> Either String (Edges n, Notes n, Edges n, Notes n, Edges n)
  -- ^ the child transitions and slices (or an error message)
applySpread :: forall n.
(Ord n, Notation n, Hashable n) =>
Spread n
-> Edges n
-> Notes n
-> Edges n
-> Either String (Edges n, Notes n, Edges n, Notes n, Edges n)
applySpread (SpreadOp HashMap (Note n) (SpreadChildren n)
dist Edges n
childm) Edges n
pl (Notes HashSet (Note n)
notesm) Edges n
pr = do
  (notesl, notesr) <-
    ((HashMap (Note n) (Note n), HashMap (Note n) (Note n))
 -> Note n
 -> Either
      String (HashMap (Note n) (Note n), HashMap (Note n) (Note n)))
-> (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
-> [Note n]
-> Either
     String (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
-> Note n
-> Either
     String (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
applyDist (HashMap (Note n) (Note n)
forall k v. HashMap k v
HM.empty, HashMap (Note n) (Note n)
forall k v. HashMap k v
HM.empty) ([Note n]
 -> Either
      String (HashMap (Note n) (Note n), HashMap (Note n) (Note n)))
-> [Note n]
-> Either
     String (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
forall a b. (a -> b) -> a -> b
$
      HashSet (Note n) -> [Note n]
forall a. HashSet a -> [a]
S.toList HashSet (Note n)
notesm
  childl <- fixEdges Lens._2 pl notesl
  childr <- fixEdges Lens._1 pr notesr
  pure (childl, Notes (S.fromList $ HM.elems notesl), childm, Notes (S.fromList $ HM.elems notesr), childr)
 where
  -- apply spread of one parent note, collect children in accumulators
  applyDist :: (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
-> Note n
-> Either
     String (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
applyDist (HashMap (Note n) (Note n)
notesl, HashMap (Note n) (Note n)
notesr) Note n
note = do
    d <-
      Either String (SpreadChildren n)
-> (SpreadChildren n -> Either String (SpreadChildren n))
-> Maybe (SpreadChildren n)
-> Either String (SpreadChildren n)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String (SpreadChildren n)
forall a b. a -> Either a b
Left (String -> Either String (SpreadChildren n))
-> String -> Either String (SpreadChildren n)
forall a b. (a -> b) -> a -> b
$ Note n -> String
forall a. Show a => a -> String
show Note n
note String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not distributed") SpreadChildren n -> Either String (SpreadChildren n)
forall a b. b -> Either a b
Right (Maybe (SpreadChildren n) -> Either String (SpreadChildren n))
-> Maybe (SpreadChildren n) -> Either String (SpreadChildren n)
forall a b. (a -> b) -> a -> b
$
        Note n
-> HashMap (Note n) (SpreadChildren n) -> Maybe (SpreadChildren n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Note n
note HashMap (Note n) (SpreadChildren n)
dist
    case d of
      SpreadLeftChild Note n
n -> (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
-> Either
     String (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note n
-> Note n -> HashMap (Note n) (Note n) -> HashMap (Note n) (Note n)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Note n
note Note n
n HashMap (Note n) (Note n)
notesl, HashMap (Note n) (Note n)
notesr)
      SpreadRightChild Note n
n -> (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
-> Either
     String (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap (Note n) (Note n)
notesl, Note n
-> Note n -> HashMap (Note n) (Note n) -> HashMap (Note n) (Note n)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Note n
note Note n
n HashMap (Note n) (Note n)
notesr)
      SpreadBothChildren Note n
nl Note n
nr -> (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
-> Either
     String (HashMap (Note n) (Note n), HashMap (Note n) (Note n))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note n
-> Note n -> HashMap (Note n) (Note n) -> HashMap (Note n) (Note n)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Note n
note Note n
nl HashMap (Note n) (Note n)
notesl, Note n
-> Note n -> HashMap (Note n) (Note n) -> HashMap (Note n) (Note n)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Note n
note Note n
nr HashMap (Note n) (Note n)
notesr)

  -- replace notes in child edges or drop if the note was moved to the other side
  fixEdges
    :: (forall a. (Lens.Lens (a, a) (a, a) a a))
    -> Edges n
    -> HM.HashMap (Note n) (Note n)
    -> Either String (Edges n)
  fixEdges :: (forall a (f :: * -> *).
 Functor f =>
 (a -> f a) -> (a, a) -> f (a, a))
-> Edges n -> HashMap (Note n) (Note n) -> Either String (Edges n)
fixEdges forall a (f :: * -> *).
Functor f =>
(a -> f a) -> (a, a) -> f (a, a)
lens (Edges HashSet (Edge n)
reg MultiSet (InnerEdge n)
pass) HashMap (Note n) (Note n)
notemap = do
    -- passing edges: can't be dropped, throw error if moved:
    pass' <- [InnerEdge n]
-> (InnerEdge n -> Either String (InnerEdge n))
-> Either String [InnerEdge n]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (MultiSet (InnerEdge n) -> [InnerEdge n]
forall a. MultiSet a -> [a]
MS.toList MultiSet (InnerEdge n)
pass) ((InnerEdge n -> Either String (InnerEdge n))
 -> Either String [InnerEdge n])
-> (InnerEdge n -> Either String (InnerEdge n))
-> Either String [InnerEdge n]
forall a b. (a -> b) -> a -> b
$ \InnerEdge n
edge ->
      case 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 (Getting (Note n) (InnerEdge n) (Note n) -> InnerEdge n -> Note n
forall a s. Getting a s a -> s -> a
Lens.view Getting (Note n) (InnerEdge n) (Note n)
forall a (f :: * -> *).
Functor f =>
(a -> f a) -> (a, a) -> f (a, a)
lens InnerEdge n
edge) HashMap (Note n) (Note n)
notemap of
        Maybe (Note n)
Nothing -> String -> Either String (InnerEdge n)
forall a b. a -> Either a b
Left String
"dropping passing edge"
        Just Note n
n' -> InnerEdge n -> Either String (InnerEdge n)
forall a b. b -> Either a b
Right (InnerEdge n -> Either String (InnerEdge n))
-> InnerEdge n -> Either String (InnerEdge n)
forall a b. (a -> b) -> a -> b
$ ASetter (InnerEdge n) (InnerEdge n) (Note n) (Note n)
-> Note n -> InnerEdge n -> InnerEdge n
forall s t a b. ASetter s t a b -> b -> s -> t
Lens.set ASetter (InnerEdge n) (InnerEdge n) (Note n) (Note n)
forall a (f :: * -> *).
Functor f =>
(a -> f a) -> (a, a) -> f (a, a)
lens Note n
n' InnerEdge n
edge
    -- regular edges: just drop if note was moved
    reg' <- for (S.toList reg) $ \Edge n
edge ->
      case Getting (StartStop (Note n)) (Edge n) (StartStop (Note n))
-> Edge n -> StartStop (Note n)
forall a s. Getting a s a -> s -> a
Lens.view Getting (StartStop (Note n)) (Edge n) (StartStop (Note n))
forall a (f :: * -> *).
Functor f =>
(a -> f a) -> (a, a) -> f (a, a)
lens Edge n
edge of
        StartStop (Note n)
Start -> String -> Either String (Maybe (Edge n))
forall a b. a -> Either a b
Left String
"invalid edge containing ⋊ encountered during spread"
        StartStop (Note n)
Stop -> String -> Either String (Maybe (Edge n))
forall a b. a -> Either a b
Left String
"invalid edge containing ⋉ encountered during spread"
        Inner Note n
n -> Maybe (Edge n) -> Either String (Maybe (Edge n))
forall a b. b -> Either a b
Right (Maybe (Edge n) -> Either String (Maybe (Edge n)))
-> Maybe (Edge n) -> Either String (Maybe (Edge n))
forall a b. (a -> b) -> a -> b
$
          case 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
n HashMap (Note n) (Note n)
notemap of
            Maybe (Note n)
Nothing -> Maybe (Edge n)
forall a. Maybe a
Nothing
            Just Note n
n' -> Edge n -> Maybe (Edge n)
forall a. a -> Maybe a
Just (Edge n -> Maybe (Edge n)) -> Edge n -> Maybe (Edge n)
forall a b. (a -> b) -> a -> b
$ ASetter (Edge n) (Edge n) (StartStop (Note n)) (StartStop (Note n))
-> StartStop (Note n) -> Edge n -> Edge n
forall s t a b. ASetter s t a b -> b -> s -> t
Lens.set ASetter (Edge n) (Edge n) (StartStop (Note n)) (StartStop (Note n))
forall a (f :: * -> *).
Functor f =>
(a -> f a) -> (a, a) -> f (a, a)
lens (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
n') Edge n
edge
    pure $ Edges (S.fromList $ catMaybes reg') (MS.fromList pass')

{- | A variant of 'applySplit' that inserts all protovoice edges into the child transitions,
 even those that are not "kept" (used for further elaboration).
 This is useful when you want to see all relations between notes in the piece.
-}
applySplitAllEdges
  :: forall n
   . (Ord n, Notation n, Hashable n)
  => Split n
  -> Edges n
  -> Either String (Edges n, Notes n, Edges n)
applySplitAllEdges :: forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplitAllEdges inSplit :: Split n
inSplit@(SplitOp Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
splitRegs Map (Note n, Note n) [(Note n, PassingOrnament)]
splitPassings Map (Note n) [(Note n, RightOrnament)]
ls Map (Note n) [(Note n, LeftOrnament)]
rs HashSet (StartStop (Note n), StartStop (Note n))
_ HashSet (StartStop (Note n), StartStop (Note n))
_ MultiSet (Note n, Note n)
passl MultiSet (Note n, Note n)
passr) inTop :: Edges n
inTop@(Edges HashSet (StartStop (Note n), StartStop (Note n))
topRegs MultiSet (Note n, Note n)
topPassings) =
  do
    (notesReg, leftRegsReg, rightRegsReg) <- HashSet (StartStop (Note n), StartStop (Note n))
-> Map
     (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
-> Either
     String
     (HashSet (Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
applyRegs HashSet (StartStop (Note n), StartStop (Note n))
topRegs Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
splitRegs
    (notesPassing, leftPassings, rightPassings, leftRegsPass, rightRegsPass) <-
      applyPassings
        topPassings
        splitPassings
    let notesL = Map (Note n) [(Note n, RightOrnament)] -> HashSet (Note n)
forall {a} {a} {b}. Hashable a => Map a [(a, b)] -> HashSet a
collectNotes Map (Note n) [(Note n, RightOrnament)]
ls
        notesR = Map (Note n) [(Note n, LeftOrnament)] -> HashSet (Note n)
forall {a} {a} {b}. Hashable a => Map a [(a, b)] -> HashSet a
collectNotes Map (Note n) [(Note n, LeftOrnament)]
rs
        notes = [HashSet (Note n)] -> HashSet (Note n)
forall a. Eq a => [HashSet a] -> HashSet a
S.unions [HashSet (Note n)
notesReg, HashSet (Note n)
notesPassing, HashSet (Note n)
notesL, HashSet (Note n)
notesR]
        leftSingleEdges = (\(Note n
p, (Note n
c, RightOrnament
_)) -> (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
p, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
c)) ((Note n, (Note n, RightOrnament))
 -> (StartStop (Note n), StartStop (Note n)))
-> [(Note n, (Note n, RightOrnament))]
-> [(StartStop (Note n), StartStop (Note n))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Note n) [(Note n, RightOrnament)]
-> [(Note n, (Note n, RightOrnament))]
forall {a} {b}. Map a [b] -> [(a, b)]
allOps Map (Note n) [(Note n, RightOrnament)]
ls
        rightSingleEdges = (\(Note n
p, (Note n
c, LeftOrnament
_)) -> (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
c, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
p)) ((Note n, (Note n, LeftOrnament))
 -> (StartStop (Note n), StartStop (Note n)))
-> [(Note n, (Note n, LeftOrnament))]
-> [(StartStop (Note n), StartStop (Note n))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Note n) [(Note n, LeftOrnament)]
-> [(Note n, (Note n, LeftOrnament))]
forall {a} {b}. Map a [b] -> [(a, b)]
allOps Map (Note n) [(Note n, LeftOrnament)]
rs
        edgesl = HashSet (StartStop (Note n), StartStop (Note n))
leftRegsReg HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Semigroup a => a -> a -> a
<> HashSet (StartStop (Note n), StartStop (Note n))
leftRegsPass HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Semigroup a => a -> a -> a
<> [(StartStop (Note n), StartStop (Note n))]
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [(StartStop (Note n), StartStop (Note n))]
leftSingleEdges
        edgesr = HashSet (StartStop (Note n), StartStop (Note n))
rightRegsReg HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Semigroup a => a -> a -> a
<> HashSet (StartStop (Note n), StartStop (Note n))
rightRegsPass HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Semigroup a => a -> a -> a
<> [(StartStop (Note n), StartStop (Note n))]
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [(StartStop (Note n), StartStop (Note n))]
rightSingleEdges
    pure
      ( Edges edgesl (MS.union leftPassings passl)
      , Notes notes
      , Edges edgesr (MS.union rightPassings passr)
      )
 where
  allOps :: Map a [b] -> [(a, b)]
allOps Map a [b]
opset = do
    (parent, children) <- Map a [b] -> [(a, [b])]
forall k a. Map k a -> [(k, a)]
M.toList Map a [b]
opset
    child <- children
    pure (parent, child)

  showEdge :: (a, a) -> String
showEdge (a
p1, a
p2) = a -> String
forall a. Show a => a -> String
show a
p1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
p2
  showEdges :: t (a, a) -> String
showEdges t (a, a)
ts = String
"{" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," ((a, a) -> String
forall {a} {a}. (Show a, Show a) => (a, a) -> String
showEdge ((a, a) -> String) -> [(a, a)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (a, a) -> [(a, a)]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (a, a)
ts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"}"

  applyRegs :: HashSet (StartStop (Note n), StartStop (Note n))
-> Map
     (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
-> Either
     String
     (HashSet (Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
applyRegs HashSet (StartStop (Note n), StartStop (Note n))
top Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
ops = do
    (notes, edgesl, edgesr) <-
      ((HashSet (Note n),
  HashSet (StartStop (Note n), StartStop (Note n)),
  HashSet (StartStop (Note n), StartStop (Note n)))
 -> ((StartStop (Note n), StartStop (Note n)),
     (Note n, DoubleOrnament))
 -> Either
      String
      (HashSet (Note n),
       HashSet (StartStop (Note n), StartStop (Note n)),
       HashSet (StartStop (Note n), StartStop (Note n))))
-> (HashSet (Note n),
    HashSet (StartStop (Note n), StartStop (Note n)),
    HashSet (StartStop (Note n), StartStop (Note n)))
-> [((StartStop (Note n), StartStop (Note n)),
     (Note n, DoubleOrnament))]
-> Either
     String
     (HashSet (Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (HashSet (StartStop (Note n), StartStop (Note n))
-> (HashSet (Note n),
    HashSet (StartStop (Note n), StartStop (Note n)),
    HashSet (StartStop (Note n), StartStop (Note n)))
-> ((StartStop (Note n), StartStop (Note n)),
    (Note n, DoubleOrnament))
-> Either
     String
     (HashSet (Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
applyReg HashSet (StartStop (Note n), StartStop (Note n))
top) (HashSet (Note n)
forall a. HashSet a
S.empty, HashSet (StartStop (Note n), StartStop (Note n))
forall a. HashSet a
S.empty, HashSet (StartStop (Note n), StartStop (Note n))
forall a. HashSet a
S.empty) ([((StartStop (Note n), StartStop (Note n)),
   (Note n, DoubleOrnament))]
 -> Either
      String
      (HashSet (Note n),
       HashSet (StartStop (Note n), StartStop (Note n)),
       HashSet (StartStop (Note n), StartStop (Note n))))
-> [((StartStop (Note n), StartStop (Note n)),
     (Note n, DoubleOrnament))]
-> Either
     String
     (HashSet (Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
forall a b. (a -> b) -> a -> b
$
        Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
-> [((StartStop (Note n), StartStop (Note n)),
     (Note n, DoubleOrnament))]
forall {a} {b}. Map a [b] -> [(a, b)]
allOps Map
  (StartStop (Note n), StartStop (Note n)) [(Note n, DoubleOrnament)]
ops
    pure (notes, edgesl, edgesr)

  applyReg :: HashSet (StartStop (Note n), StartStop (Note n))
-> (HashSet (Note n),
    HashSet (StartStop (Note n), StartStop (Note n)),
    HashSet (StartStop (Note n), StartStop (Note n)))
-> ((StartStop (Note n), StartStop (Note n)),
    (Note n, DoubleOrnament))
-> Either
     String
     (HashSet (Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
applyReg HashSet (StartStop (Note n), StartStop (Note n))
topAll (HashSet (Note n)
notes, HashSet (StartStop (Note n), StartStop (Note n))
edgesl, HashSet (StartStop (Note n), StartStop (Note n))
edgesr) ((StartStop (Note n), StartStop (Note n))
parent, (Note n
note, DoubleOrnament
_))
    | (StartStop (Note n), StartStop (Note n))
parent (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n)) -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet (StartStop (Note n), StartStop (Note n))
topAll =
        (HashSet (Note n),
 HashSet (StartStop (Note n), StartStop (Note n)),
 HashSet (StartStop (Note n), StartStop (Note n)))
-> Either
     String
     (HashSet (Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
forall a b. b -> Either a b
Right (HashSet (Note n)
notes', HashSet (StartStop (Note n), StartStop (Note n))
edgesl', HashSet (StartStop (Note n), StartStop (Note n))
edgesr')
    | Bool
otherwise =
        String
-> Either
     String
     (HashSet (Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
forall a b. a -> Either a b
Left (String
 -> Either
      String
      (HashSet (Note n),
       HashSet (StartStop (Note n), StartStop (Note n)),
       HashSet (StartStop (Note n), StartStop (Note n))))
-> String
-> Either
     String
     (HashSet (Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
forall a b. (a -> b) -> a -> b
$
          String
"used non-existing terminal edge\n  top="
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Edges n -> String
forall a. Show a => a -> String
show Edges n
inTop
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n  split="
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Split n -> String
forall a. Show a => a -> String
show Split n
inSplit
   where
    notes' :: HashSet (Note n)
notes' = Note n -> HashSet (Note n) -> HashSet (Note n)
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert Note n
note HashSet (Note n)
notes
    edgesl' :: HashSet (StartStop (Note n), StartStop (Note n))
edgesl' = (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert ((StartStop (Note n), StartStop (Note n)) -> StartStop (Note n)
forall a b. (a, b) -> a
fst (StartStop (Note n), StartStop (Note n))
parent, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
note) HashSet (StartStop (Note n), StartStop (Note n))
edgesl
    edgesr' :: HashSet (StartStop (Note n), StartStop (Note n))
edgesr' = (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
note, (StartStop (Note n), StartStop (Note n)) -> StartStop (Note n)
forall a b. (a, b) -> b
snd (StartStop (Note n), StartStop (Note n))
parent) HashSet (StartStop (Note n), StartStop (Note n))
edgesr

  applyPassings :: MultiSet (Note n, Note n)
-> Map (Note n, Note n) [(Note n, PassingOrnament)]
-> Either
     String
     (HashSet (Note n), MultiSet (Note n, Note n),
      MultiSet (Note n, Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
applyPassings MultiSet (Note n, Note n)
top Map (Note n, Note n) [(Note n, PassingOrnament)]
ops = do
    (top', notes, lPassings, rPassings, lRegs, rRegs) <-
      ((MultiSet (Note n, Note n), HashSet (Note n),
  MultiSet (Note n, Note n), MultiSet (Note n, Note n),
  HashSet (StartStop (Note n), StartStop (Note n)),
  HashSet (StartStop (Note n), StartStop (Note n)))
 -> ((Note n, Note n), (Note n, PassingOrnament))
 -> Either
      String
      (MultiSet (Note n, Note n), HashSet (Note n),
       MultiSet (Note n, Note n), MultiSet (Note n, Note n),
       HashSet (StartStop (Note n), StartStop (Note n)),
       HashSet (StartStop (Note n), StartStop (Note n))))
-> (MultiSet (Note n, Note n), HashSet (Note n),
    MultiSet (Note n, Note n), MultiSet (Note n, Note n),
    HashSet (StartStop (Note n), StartStop (Note n)),
    HashSet (StartStop (Note n), StartStop (Note n)))
-> [((Note n, Note n), (Note n, PassingOrnament))]
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (MultiSet (Note n, Note n), HashSet (Note n),
 MultiSet (Note n, Note n), MultiSet (Note n, Note n),
 HashSet (StartStop (Note n), StartStop (Note n)),
 HashSet (StartStop (Note n), StartStop (Note n)))
-> ((Note n, Note n), (Note n, PassingOrnament))
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
applyPassing (MultiSet (Note n, Note n)
top, HashSet (Note n)
forall a. HashSet a
S.empty, MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty, MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty, HashSet (StartStop (Note n), StartStop (Note n))
forall a. HashSet a
S.empty, HashSet (StartStop (Note n), StartStop (Note n))
forall a. HashSet a
S.empty) ([((Note n, Note n), (Note n, PassingOrnament))]
 -> Either
      String
      (MultiSet (Note n, Note n), HashSet (Note n),
       MultiSet (Note n, Note n), MultiSet (Note n, Note n),
       HashSet (StartStop (Note n), StartStop (Note n)),
       HashSet (StartStop (Note n), StartStop (Note n))))
-> [((Note n, Note n), (Note n, PassingOrnament))]
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
forall a b. (a -> b) -> a -> b
$
        Map (Note n, Note n) [(Note n, PassingOrnament)]
-> [((Note n, Note n), (Note n, PassingOrnament))]
forall {a} {b}. Map a [b] -> [(a, b)]
allOps Map (Note n, Note n) [(Note n, PassingOrnament)]
ops
    if MS.null top'
      then Right (notes, lPassings, rPassings, lRegs, rRegs)
      else
        Left $
          "did not use all non-terminal edges, remaining: "
            <> showEdges
              (MS.toList top')

  applyPassing :: (MultiSet (Note n, Note n), HashSet (Note n),
 MultiSet (Note n, Note n), MultiSet (Note n, Note n),
 HashSet (StartStop (Note n), StartStop (Note n)),
 HashSet (StartStop (Note n), StartStop (Note n)))
-> ((Note n, Note n), (Note n, PassingOrnament))
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
applyPassing (MultiSet (Note n, Note n)
top, HashSet (Note n)
notes, MultiSet (Note n, Note n)
lPassings, MultiSet (Note n, Note n)
rPassings, HashSet (StartStop (Note n), StartStop (Note n))
lRegs, HashSet (StartStop (Note n), StartStop (Note n))
rRegs) (parent :: (Note n, Note n)
parent@(Note n
pl, Note n
pr), (Note n
note, PassingOrnament
pass))
    | (Note n, Note n)
parent (Note n, Note n) -> MultiSet (Note n, Note n) -> Bool
forall k. (Eq k, Hashable k) => k -> MultiSet k -> Bool
`MS.member` MultiSet (Note n, Note n)
top =
        (MultiSet (Note n, Note n), HashSet (Note n),
 MultiSet (Note n, Note n), MultiSet (Note n, Note n),
 HashSet (StartStop (Note n), StartStop (Note n)),
 HashSet (StartStop (Note n), StartStop (Note n)))
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
forall a b. b -> Either a b
Right (MultiSet (Note n, Note n)
top', HashSet (Note n)
notes', MultiSet (Note n, Note n)
lPassings', MultiSet (Note n, Note n)
rPassings', HashSet (StartStop (Note n), StartStop (Note n))
lRegs', HashSet (StartStop (Note n), StartStop (Note n))
rRegs')
    | Bool
otherwise =
        String
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
forall a b. a -> Either a b
Left (String
 -> Either
      String
      (MultiSet (Note n, Note n), HashSet (Note n),
       MultiSet (Note n, Note n), MultiSet (Note n, Note n),
       HashSet (StartStop (Note n), StartStop (Note n)),
       HashSet (StartStop (Note n), StartStop (Note n))))
-> String
-> Either
     String
     (MultiSet (Note n, Note n), HashSet (Note n),
      MultiSet (Note n, Note n), MultiSet (Note n, Note n),
      HashSet (StartStop (Note n), StartStop (Note n)),
      HashSet (StartStop (Note n), StartStop (Note n)))
forall a b. (a -> b) -> a -> b
$
          String
"used non-existing non-terminal edge\n  top="
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Edges n -> String
forall a. Show a => a -> String
show Edges n
inTop
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n  split="
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Split n -> String
forall a. Show a => a -> String
show Split n
inSplit
   where
    top' :: MultiSet (Note n, Note n)
top' = (Note n, Note n)
-> MultiSet (Note n, Note n) -> MultiSet (Note n, Note n)
forall a. (Eq a, Hashable a) => a -> MultiSet a -> MultiSet a
MS.delete (Note n, Note n)
parent MultiSet (Note n, Note n)
top
    notes' :: HashSet (Note n)
notes' = Note n -> HashSet (Note n) -> HashSet (Note n)
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert Note n
note HashSet (Note n)
notes
    (MultiSet (Note n, Note n)
newlPassing, MultiSet (Note n, Note n)
newrPassing, HashSet (StartStop (Note n), StartStop (Note n))
newlReg, HashSet (StartStop (Note n), StartStop (Note n))
newrReg) = case PassingOrnament
pass of
      PassingOrnament
PassingMid ->
        ( MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty
        , MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty
        , (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Hashable a => a -> HashSet a
S.singleton (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
pl, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
note)
        , (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Hashable a => a -> HashSet a
S.singleton (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
note, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
pr)
        )
      PassingOrnament
PassingLeft ->
        ( MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty
        , (Note n, Note n) -> MultiSet (Note n, Note n)
forall a. Hashable a => a -> MultiSet a
MS.singleton (Note n
note, Note n
pr)
        , (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Hashable a => a -> HashSet a
S.singleton (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
pl, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
note)
        , HashSet (StartStop (Note n), StartStop (Note n))
forall a. HashSet a
S.empty
        )
      PassingOrnament
PassingRight ->
        ( (Note n, Note n) -> MultiSet (Note n, Note n)
forall a. Hashable a => a -> MultiSet a
MS.singleton (Note n
pl, Note n
note)
        , MultiSet (Note n, Note n)
forall a. MultiSet a
MS.empty
        , HashSet (StartStop (Note n), StartStop (Note n))
forall a. HashSet a
S.empty
        , (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Hashable a => a -> HashSet a
S.singleton (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
note, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner Note n
pr)
        )
    lPassings' :: MultiSet (Note n, Note n)
lPassings' = MultiSet (Note n, Note n)
-> MultiSet (Note n, Note n) -> MultiSet (Note n, Note n)
forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.union MultiSet (Note n, Note n)
newlPassing MultiSet (Note n, Note n)
lPassings
    rPassings' :: MultiSet (Note n, Note n)
rPassings' = MultiSet (Note n, Note n)
-> MultiSet (Note n, Note n) -> MultiSet (Note n, Note n)
forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.union MultiSet (Note n, Note n)
newrPassing MultiSet (Note n, Note n)
rPassings
    lRegs' :: HashSet (StartStop (Note n), StartStop (Note n))
lRegs' = HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Eq a => HashSet a -> HashSet a -> HashSet a
S.union HashSet (StartStop (Note n), StartStop (Note n))
newlReg HashSet (StartStop (Note n), StartStop (Note n))
lRegs
    rRegs' :: HashSet (StartStop (Note n), StartStop (Note n))
rRegs' = HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
-> HashSet (StartStop (Note n), StartStop (Note n))
forall a. Eq a => HashSet a -> HashSet a -> HashSet a
S.union HashSet (StartStop (Note n), StartStop (Note n))
newrReg HashSet (StartStop (Note n), StartStop (Note n))
rRegs

  singleChild :: (a, (a, b)) -> a
singleChild (a
_, (a
note, b
_)) = a
note
  collectNotes :: Map a [(a, b)] -> HashSet a
collectNotes Map a [(a, b)]
ops = [a] -> HashSet a
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([a] -> HashSet a) -> [a] -> HashSet a
forall a b. (a -> b) -> a -> b
$ (a, (a, b)) -> a
forall {a} {a} {b}. (a, (a, b)) -> a
singleChild ((a, (a, b)) -> a) -> [(a, (a, b))] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map a [(a, b)] -> [(a, (a, b))]
forall {a} {b}. Map a [b] -> [(a, b)]
allOps Map a [(a, b)]
ops

{- | A variant of 'applyFreeze' that allows non-"tie" edges in the open transition.
 This is useful in conjunction with 'applySplitAllEdges'
 because the non-tie edges will not be dropped before freezing.
-}
applyFreezeAllEdges :: Freeze n -> Edges n -> Either String (Edges n)
applyFreezeAllEdges (FreezeOp HashSet (Edge n)
_) e :: Edges n
e@(Edges HashSet (Edge n)
_ts MultiSet (InnerEdge n)
nts)
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ MultiSet (InnerEdge n) -> Bool
forall k. MultiSet k -> Bool
MS.null MultiSet (InnerEdge n)
nts = String -> Either String (Edges n)
forall a b. a -> Either a b
Left String
"cannot freeze non-terminal edges"
  | Bool
otherwise = Edges n -> Either String (Edges n)
forall a b. b -> Either a b
Right Edges n
e

-- debugging analyses

{- | A specialized version of 'debugAnalysis' for protovoice derivations.
 Prints the steps and intermediate configurations of a derivation.
-}
debugPVAnalysis
  :: (Notation n, Ord n, Hashable n, MC.HasPitch n, Eq (MC.IntervalOf n))
  => PVAnalysis n
  -> IO (Either String ())
debugPVAnalysis :: forall n.
(Notation n, Ord n, Hashable n, HasPitch n, Eq (IntervalOf n)) =>
PVAnalysis n -> IO (Either String ())
debugPVAnalysis = (Split n -> Edges n -> Either String (Edges n, Notes n, Edges n))
-> (Freeze n -> Edges n -> Either String (Edges n))
-> (Spread n
    -> Edges n
    -> Notes n
    -> Edges n
    -> Either String (Edges n, Notes n, Edges n, Notes n, Edges n))
-> Analysis (Split n) (Freeze n) (Spread n) (Edges n) (Notes n)
-> IO (Either String ())
forall tr slc s f h.
(Show tr, Show slc, Show s, Show h) =>
(s -> tr -> Either String (tr, slc, tr))
-> (f -> tr -> Either String tr)
-> (h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr))
-> Analysis s f h tr slc
-> IO (Either String ())
debugAnalysis Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit Freeze n -> Edges n -> Either String (Edges n)
forall n.
(Eq (IntervalOf n), HasPitch n) =>
Freeze n -> Edges n -> Either String (Edges n)
applyFreeze Spread n
-> Edges n
-> Notes n
-> Edges n
-> Either String (Edges n, Notes n, Edges n, Notes n, Edges n)
forall n.
(Ord n, Notation n, Hashable n) =>
Spread n
-> Edges n
-> Notes n
-> Edges n
-> Either String (Edges n, Notes n, Edges n, Notes n, Edges n)
applySpread

-- derivation player
-- =================

{- | A derivation player for protovoices.
 The default version of the PV player drops all edges that are not used later on
 when generating child transitions.
 This behaviour matches the intermediate representation of the parsers,
 which only track edges that are necessary to explain the downstream notes.
 If you want to generate all edges (i.e., all functional relations between notes)
 use 'derivationPlayerPVAllEdges'.
-}
derivationPlayerPV
  :: (Eq n, Ord n, Notation n, Hashable n, Eq (MC.IntervalOf n), MC.HasPitch n)
  => DerivationPlayer (Split n) (Freeze n) (Spread n) (Notes n) (Edges n)
derivationPlayerPV :: forall n.
(Eq n, Ord n, Notation n, Hashable n, Eq (IntervalOf n),
 HasPitch n) =>
DerivationPlayer
  (Split n) (Freeze n) (Spread n) (Notes n) (Edges n)
derivationPlayerPV =
  Edges n
-> (Split n
    -> Edges n -> Either String (Edges n, Notes n, Edges n))
-> (Freeze n -> Edges n -> Either String (Edges n))
-> (Spread n
    -> Edges n
    -> Notes n
    -> Edges n
    -> Either String (Edges n, Notes n, Edges n, Notes n, Edges n))
-> DerivationPlayer
     (Split n) (Freeze n) (Spread n) (Notes n) (Edges n)
forall s f h slc tr.
tr
-> (s -> tr -> Either String (tr, slc, tr))
-> (f -> tr -> Either String tr)
-> (h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr))
-> DerivationPlayer s f h slc tr
DerivationPlayer
    Edges n
topTrans
    Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit
    Freeze n -> Edges n -> Either String (Edges n)
forall n.
(Eq (IntervalOf n), HasPitch n) =>
Freeze n -> Edges n -> Either String (Edges n)
applyFreeze
    Spread n
-> Edges n
-> Notes n
-> Edges n
-> Either String (Edges n, Notes n, Edges n, Notes n, Edges n)
forall n.
(Ord n, Notation n, Hashable n) =>
Spread n
-> Edges n
-> Notes n
-> Edges n
-> Either String (Edges n, Notes n, Edges n, Notes n, Edges n)
applySpread
 where
  topTrans :: Edges n
topTrans = 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. Hashable a => a -> HashSet a
S.singleton (StartStop (Note n)
forall a. StartStop a
Start, StartStop (Note n)
forall a. StartStop a
Stop)) MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty

{- | A derivation player for protovoices that produces all edges
 that express a functional relation between two notes.
 For a version that only produces "necessary" edges, use 'derivationPlayerPV'.
-}
derivationPlayerPVAllEdges
  :: (Eq n, Ord n, Notation n, Hashable n, Eq (MC.IntervalOf n), MC.HasPitch n)
  => DerivationPlayer (Split n) (Freeze n) (Spread n) (Notes n) (Edges n)
derivationPlayerPVAllEdges :: forall n.
(Eq n, Ord n, Notation n, Hashable n, Eq (IntervalOf n),
 HasPitch n) =>
DerivationPlayer
  (Split n) (Freeze n) (Spread n) (Notes n) (Edges n)
derivationPlayerPVAllEdges =
  Edges n
-> (Split n
    -> Edges n -> Either String (Edges n, Notes n, Edges n))
-> (Freeze n -> Edges n -> Either String (Edges n))
-> (Spread n
    -> Edges n
    -> Notes n
    -> Edges n
    -> Either String (Edges n, Notes n, Edges n, Notes n, Edges n))
-> DerivationPlayer
     (Split n) (Freeze n) (Spread n) (Notes n) (Edges n)
forall s f h slc tr.
tr
-> (s -> tr -> Either String (tr, slc, tr))
-> (f -> tr -> Either String tr)
-> (h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr))
-> DerivationPlayer s f h slc tr
DerivationPlayer
    Edges n
topTrans
    Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplitAllEdges
    Freeze n -> Edges n -> Either String (Edges n)
forall {n} {n}. Freeze n -> Edges n -> Either String (Edges n)
applyFreezeAllEdges
    Spread n
-> Edges n
-> Notes n
-> Edges n
-> Either String (Edges n, Notes n, Edges n, Notes n, Edges n)
forall n.
(Ord n, Notation n, Hashable n) =>
Spread n
-> Edges n
-> Notes n
-> Edges n
-> Either String (Edges n, Notes n, Edges n, Notes n, Edges n)
applySpread
 where
  topTrans :: Edges n
topTrans = 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. Hashable a => a -> HashSet a
S.singleton (StartStop (Note n)
forall a. StartStop a
Start, StartStop (Note n)
forall a. StartStop a
Stop)) MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty

{- | Compares the output of a derivation
 with the original piece (as provided to the parser).
 Returns 'True' if the output matches the original
 and 'False' if the output doesn't match or the derivation is invalid.
-}
checkDerivation
  :: ( Ord n
     , Notation n
     , Hashable n
     , Eq (MC.IntervalOf n)
     , MC.HasPitch n
     , Show n
     )
  => [Leftmost (Split n) (Freeze n) (Spread n)]
  -> Path [Note n] [Edge n]
  -> Bool
checkDerivation :: forall n.
(Ord n, Notation n, Hashable n, Eq (IntervalOf n), HasPitch n,
 Show n) =>
[Leftmost (Split n) (Freeze n) (Spread n)]
-> Path [Note n] [Edge n] -> Bool
checkDerivation [Leftmost (Split n) (Freeze n) (Spread n)]
deriv Path [Note n] [Edge n]
original =
  case DerivationPlayer
  (Split n) (Freeze n) (Spread n) (Notes n) (Edges n)
-> [Leftmost (Split n) (Freeze n) (Spread n)]
-> Either String (DerivationGraph (Notes n) (Edges n))
forall (t :: * -> *) slc tr s f h.
(Foldable t, Ord slc, Ord tr) =>
DerivationPlayer s f h slc tr
-> t (Leftmost s f h) -> Either String (DerivationGraph slc tr)
replayDerivation DerivationPlayer
  (Split n) (Freeze n) (Spread n) (Notes n) (Edges n)
forall n.
(Eq n, Ord n, Notation n, Hashable n, Eq (IntervalOf n),
 HasPitch n) =>
DerivationPlayer
  (Split n) (Freeze n) (Spread n) (Notes n) (Edges n)
derivationPlayerPV [Leftmost (Split n) (Freeze n) (Spread n)]
deriv of
    (Left String
_) -> Bool
False
    (Right DerivationGraph (Notes n) (Edges n)
g) -> do
      let path' :: Maybe (Path (Notes n) (Edges n), Edges n)
path' = case DerivationGraph (Notes n) (Edges n)
-> [DerivTrans (Notes n) (Edges n)]
forall slc tr. DerivationGraph slc tr -> [DerivTrans slc tr]
dgFrozen DerivationGraph (Notes n) (Edges n)
g of
            (DerivTrans (Notes n) (Edges n)
_ : (DerivSlice (Notes n)
_, Edges n
tlast, DerivSlice (Notes n)
slast) : [DerivTrans (Notes n) (Edges n)]
rst) -> do
              s <- StartStop (Notes n) -> Maybe (Notes n)
forall a. StartStop a -> Maybe a
getInner (StartStop (Notes n) -> Maybe (Notes n))
-> StartStop (Notes n) -> Maybe (Notes n)
forall a b. (a -> b) -> a -> b
$ DerivSlice (Notes n) -> StartStop (Notes n)
forall slc. DerivSlice slc -> StartStop slc
dslContent DerivSlice (Notes n)
slast
              foldM foldPath (PathEnd s, tlast) rst
            [DerivTrans (Notes n) (Edges n)]
_ -> Maybe (Path (Notes n) (Edges n), Edges n)
forall a. Maybe a
Nothing
          orig' :: Path (Notes n) (Edges n)
orig' =
            ([Note n] -> Notes n)
-> ([Edge n] -> Edges n)
-> Path [Note n] [Edge n]
-> Path (Notes n) (Edges n)
forall a b c d. (a -> b) -> (c -> d) -> Path a c -> Path b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
              (HashSet (Note n) -> Notes n
forall n. HashSet (Note n) -> Notes n
Notes (HashSet (Note n) -> Notes n)
-> ([Note n] -> HashSet (Note n)) -> [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)
              (\[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]
e) MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty)
              Path [Note n] [Edge n]
original
      case Maybe (Path (Notes n) (Edges n), Edges n)
path' of
        Maybe (Path (Notes n) (Edges n), Edges n)
Nothing -> Bool
False
        Just (Path (Notes n) (Edges n)
result, Edges n
_) -> Path (Notes n) (Edges n)
result Path (Notes n) (Edges n) -> Path (Notes n) (Edges n) -> Bool
forall a. Eq a => a -> a -> Bool
== Path (Notes n) (Edges n)
orig'
 where
  foldPath :: (Path around between, between)
-> (a, b, DerivSlice around) -> Maybe (Path around between, b)
foldPath (Path around between
pacc, between
tacc) (a
_, b
tnew, DerivSlice around
snew) = do
    s <- StartStop around -> Maybe around
forall a. StartStop a -> Maybe a
getInner (StartStop around -> Maybe around)
-> StartStop around -> Maybe around
forall a b. (a -> b) -> a -> b
$ DerivSlice around -> StartStop around
forall slc. DerivSlice slc -> StartStop slc
dslContent DerivSlice around
snew
    pure (Path s tacc pacc, tnew)