{-# 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
  , addToLeft
  , addToRight
  , addPassingLeft
  , addPassingRight

    -- ** Spread
  , mkSpread
  , 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.Monoid (Endo (..))
import Internal.MultiSet qualified as MS
import Musicology.Core qualified as MC
  ( HasPitch (pitch)
  , Pitched (IntervalOf)
  )

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

{- | Create a freeze operation (alias for 'FreezeOp').
 Can be used together with the 'Common.freeze' action within a monadic derivation.
-}
mkFreeze :: Freeze
mkFreeze :: Freeze
mkFreeze = Freeze
FreezeOp

{- | 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 = 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 n
  -- ^ left parent
  -> StartStop n
  -- ^ right parent
  -> 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 n
-> StartStop n
-> n
-> DoubleOrnament
-> Bool
-> Bool
-> Writer (Split n) ()
splitRegular StartStop n
l StartStop n
r n
c DoubleOrnament
o Bool
kl Bool
kr =
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell forall a b. (a -> b) -> a -> b
$
    forall n.
Map (Edge n) [(n, DoubleOrnament)]
-> Map (InnerEdge n) [(n, PassingOrnament)]
-> Map n [(n, RightOrnament)]
-> Map n [(n, LeftOrnament)]
-> HashSet (Edge n)
-> HashSet (Edge n)
-> MultiSet (InnerEdge n)
-> MultiSet (InnerEdge n)
-> Split n
SplitOp
      (forall k a. k -> a -> Map k a
M.singleton (StartStop n
l, StartStop n
r) [(n
c, DoubleOrnament
o)])
      forall k a. Map k a
M.empty
      forall k a. Map k a
M.empty
      forall k a. Map k a
M.empty
      HashSet (StartStop n, StartStop n)
kls
      HashSet (StartStop n, StartStop n)
krs
      forall a. MultiSet a
MS.empty
      forall a. MultiSet a
MS.empty
 where
  kls :: HashSet (StartStop n, StartStop n)
kls = if Bool
kl then forall a. Hashable a => a -> HashSet a
S.singleton (StartStop n
l, forall a. a -> StartStop a
Inner n
c) else forall a. HashSet a
S.empty
  krs :: HashSet (StartStop n, StartStop n)
krs = if Bool
kr then forall a. Hashable a => a -> HashSet a
S.singleton (forall a. a -> StartStop a
Inner n
c, StartStop n
r) else forall a. HashSet a
S.empty

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

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

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

-- | During a split, add a new passing edge between the child slice and the right parent slice.
addPassingRight
  :: (Ord n, Hashable n)
  => n
  -- ^ note from the child slice
  -> n
  -- ^ note from the right parent slice
  -> MW.Writer (Split n) ()
addPassingRight :: forall n. (Ord n, Hashable n) => n -> n -> Writer (Split n) ()
addPassingRight n
m n
r = forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty{passRight :: MultiSet (InnerEdge n)
passRight = forall a. Hashable a => a -> MultiSet a
MS.singleton (n
m, n
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 = forall a. Endo a -> a -> a
appEndo (forall w a. Writer w a -> w
MW.execWriter Writer (Endo (Spread n)) ()
actions) forall {n}. Spread n
emptySpread
 where
  emptySpread :: Spread n
emptySpread = forall n. HashMap n SpreadDirection -> Edges n -> Spread n
SpreadOp forall k v. HashMap k v
HM.empty forall a b. (a -> b) -> a -> b
$ forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges forall a. HashSet a
S.empty forall a. MultiSet a
MS.empty

-- | During a spread, distribute one of the parent notes to the child slices of a spread.
spreadNote
  :: (Ord n, Hashable n)
  => n
  -- ^ the parent note
  -> SpreadDirection
  -- ^ the distribution of the note
  -> Bool
  -- ^ introduce a repetition edge (if possible)?
  -> MW.Writer (Endo (Spread n)) ()
spreadNote :: forall n.
(Ord n, Hashable n) =>
n -> SpreadDirection -> Bool -> Writer (Endo (Spread n)) ()
spreadNote n
pitch SpreadDirection
dir Bool
edge = forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Endo a
Endo Spread n -> Spread n
h
 where
  h :: Spread n -> Spread n
h (SpreadOp HashMap n SpreadDirection
dist (Edges HashSet (Edge n)
mRegs MultiSet (InnerEdge n)
mPassings)) = forall n. HashMap n SpreadDirection -> Edges n -> Spread n
SpreadOp HashMap n SpreadDirection
dist' (forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge n)
mRegs' MultiSet (InnerEdge n)
mPassings)
   where
    dist' :: HashMap n SpreadDirection
dist' = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert n
pitch SpreadDirection
dir HashMap n SpreadDirection
dist
    mRegs' :: HashSet (Edge n)
mRegs' =
      forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.union HashSet (Edge n)
mRegs forall a b. (a -> b) -> a -> b
$
        if Bool
edge then forall a. Hashable a => a -> HashSet a
S.singleton (forall a. a -> StartStop a
Inner n
pitch, forall a. a -> StartStop a
Inner n
pitch) else 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)
  => n
  -- ^ the left end of the edge
  -> n
  -- ^ the right end of the edge
  -> MW.Writer (Endo (Spread n)) ()
addPassing :: forall n.
(Ord n, Hashable n) =>
n -> n -> Writer (Endo (Spread n)) ()
addPassing n
l n
r = forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Endo a
Endo Spread n -> Spread n
h
 where
  h :: Spread n -> Spread n
h (SpreadOp HashMap n SpreadDirection
dist (Edges HashSet (Edge n)
mRegs MultiSet (n, n)
mPassings)) = forall n. HashMap n SpreadDirection -> Edges n -> Spread n
SpreadOp HashMap n SpreadDirection
dist (forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge n)
mRegs MultiSet (n, n)
mPassings')
   where
    mPassings' :: MultiSet (n, n)
mPassings' = forall a. (Eq a, Hashable a) => a -> MultiSet a -> MultiSet a
MS.insert (n
l, n
r) MultiSet (n, 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)
  => n
  -- ^ the left end of the edge
  -> n
  -- ^ the right end of the edge
  -> MW.Writer (Endo (Spread n)) ()
addOctaveRepetition :: forall n.
(Ord n, Hashable n) =>
n -> n -> Writer (Endo (Spread n)) ()
addOctaveRepetition n
l n
r = forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Endo a
Endo Spread n -> Spread n
h
 where
  h :: Spread n -> Spread n
h (SpreadOp HashMap n SpreadDirection
dist (Edges HashSet (StartStop n, StartStop n)
mRegs MultiSet (InnerEdge n)
mPassings)) = forall n. HashMap n SpreadDirection -> Edges n -> Spread n
SpreadOp HashMap n SpreadDirection
dist (forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (StartStop n, StartStop n)
mRegs' MultiSet (InnerEdge n)
mPassings)
   where
    mRegs' :: HashSet (StartStop n, StartStop n)
mRegs' = forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert (forall a. a -> StartStop a
Inner n
l, forall a. a -> StartStop a
Inner n
r) HashSet (StartStop n, StartStop 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 n, StartStop n) [(n, DoubleOrnament)]
splitRegs Map (n, n) [(n, PassingOrnament)]
splitPassings Map n [(n, RightOrnament)]
ls Map n [(n, LeftOrnament)]
rs HashSet (StartStop n, StartStop n)
keepl HashSet (StartStop n, StartStop n)
keepr MultiSet (n, n)
passl MultiSet (n, n)
passr) inTop :: Edges n
inTop@(Edges HashSet (StartStop n, StartStop n)
topRegs MultiSet (n, n)
topPassings) =
  do
    MultiSet n
notesReg <- HashSet (StartStop n, StartStop n)
-> Map (StartStop n, StartStop n) [(n, DoubleOrnament)]
-> Either String (MultiSet n)
applyRegs HashSet (StartStop n, StartStop n)
topRegs Map (StartStop n, StartStop n) [(n, DoubleOrnament)]
splitRegs
    (MultiSet n
notesPassing, MultiSet (n, n)
leftPassings, MultiSet (n, n)
rightPassings) <- MultiSet (n, n)
-> Map (n, n) [(n, PassingOrnament)]
-> Either String (MultiSet n, MultiSet (n, n), MultiSet (n, n))
applyPassings MultiSet (n, n)
topPassings Map (n, n) [(n, PassingOrnament)]
splitPassings
    let notesL :: MultiSet n
notesL = forall {a} {a} {b}. Hashable a => Map a [(a, b)] -> MultiSet a
collectNotes Map n [(n, RightOrnament)]
ls
        notesR :: MultiSet n
notesR = forall {a} {a} {b}. Hashable a => Map a [(a, b)] -> MultiSet a
collectNotes Map n [(n, LeftOrnament)]
rs
        notes :: MultiSet n
notes = forall (t :: * -> *) a0.
(Foldable t, Eq a0, Hashable a0) =>
t (MultiSet a0) -> MultiSet a0
MS.unions [MultiSet n
notesReg, MultiSet n
notesPassing, MultiSet n
notesL, MultiSet n
notesR]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (StartStop n, StartStop n)
keepl (forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.union MultiSet (n, n)
leftPassings MultiSet (n, n)
passl)
      , forall n. MultiSet n -> Notes n
Notes MultiSet n
notes
      , forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (StartStop n, StartStop n)
keepr (forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.union MultiSet (n, n)
rightPassings MultiSet (n, n)
passr)
      )
 where
  allOps :: Map a [b] -> [(a, b)]
allOps Map a [b]
opset = do
    (a
parent, [b]
children) <- forall k a. Map k a -> [(k, a)]
M.toList Map a [b]
opset
    b
child <- [b]
children
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
parent, b
child)

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

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

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

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

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

  singleChild :: (a, (a, b)) -> a
singleChild (a
_, (a
note, b
_)) = a
note
  collectNotes :: Map a [(a, b)] -> MultiSet a
collectNotes Map a [(a, b)]
ops = forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList forall a b. (a -> b) -> a -> b
$ forall {a} {a} {b}. (a, (a, b)) -> a
singleChild forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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) = forall k. MultiSet k -> Bool
MS.null MultiSet (InnerEdge n)
nts Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {a} {a} {f :: * -> *}.
(IntervalOf a ~ IntervalOf a, Eq (f (Pitch (IntervalOf a))),
 Functor f, HasPitch a, HasPitch a) =>
(f a, f a) -> Bool
isRep HashSet (Edge n)
ts
 where
  isRep :: (f a, f a) -> Bool
isRep (f a
a, f a
b) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasPitch a => a -> Pitch (IntervalOf a)
MC.pitch f a
a forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasPitch a => a -> Pitch (IntervalOf a)
MC.pitch f a
b

-- | Tries to apply a freeze operation to a transition.
applyFreeze
  :: (Eq (MC.IntervalOf n), MC.HasPitch n)
  => Freeze
  -- ^ the freeze operation
  -> Edges n
  -- ^ the unfrozen edge
  -> Either String (Edges n)
  -- ^ the frozen transition
applyFreeze :: forall n.
(Eq (IntervalOf n), HasPitch n) =>
Freeze -> Edges n -> Either String (Edges n)
applyFreeze Freeze
FreezeOp e :: Edges n
e@(Edges HashSet (Edge n)
ts MultiSet (InnerEdge n)
nts)
  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall k. MultiSet k -> Bool
MS.null MultiSet (InnerEdge n)
nts = forall a b. a -> Either a b
Left String
"cannot freeze non-terminal edges"
  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {a} {a} {f :: * -> *}.
(IntervalOf a ~ IntervalOf a, Eq (f (Pitch (IntervalOf a))),
 Functor f, HasPitch a, HasPitch a) =>
(f a, f a) -> Bool
isRep HashSet (Edge n)
ts = forall a b. a -> Either a b
Left String
"cannot freeze non-tie edges"
  | Bool
otherwise = forall a b. b -> Either a b
Right Edges n
e
 where
  isRep :: (f a, f a) -> Bool
isRep (f a
a, f a
b) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasPitch a => a -> Pitch (IntervalOf a)
MC.pitch f a
a forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasPitch a => a -> Pitch (IntervalOf a)
MC.pitch f a
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 n SpreadDirection
dist Edges n
childm) Edges n
pl (Notes MultiSet n
notesm) Edges n
pr = do
  (MultiSet n
notesl, MultiSet n
notesr) <-
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (MultiSet n, MultiSet n)
-> (n, Int) -> Either String (MultiSet n, MultiSet n)
applyDist (forall a. MultiSet a
MS.empty, forall a. MultiSet a
MS.empty) forall a b. (a -> b) -> a -> b
$
      forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet n
notesm
  Edges n
childl <- (forall a. (a, a) -> a)
-> Edges n -> MultiSet n -> Either String (Edges n)
fixEdges forall a b. (a, b) -> b
snd Edges n
pl MultiSet n
notesl
  Edges n
childr <- (forall a. (a, a) -> a)
-> Edges n -> MultiSet n -> Either String (Edges n)
fixEdges forall a b. (a, b) -> a
fst Edges n
pr MultiSet n
notesr
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Edges n
childl, forall n. MultiSet n -> Notes n
Notes MultiSet n
notesl, Edges n
childm, forall n. MultiSet n -> Notes n
Notes MultiSet n
notesr, Edges n
childr)
 where
  applyDist :: (MultiSet n, MultiSet n)
-> (n, Int) -> Either String (MultiSet n, MultiSet n)
applyDist (MultiSet n
notesl, MultiSet n
notesr) (n
note, Int
n) = do
    SpreadDirection
d <-
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall i. Notation i => i -> String
showNotation n
note forall a. Semigroup a => a -> a -> a
<> String
" is not distributed") forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup n
note HashMap n SpreadDirection
dist
    case SpreadDirection
d of
      SpreadDirection
ToBoth -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
(Eq a, Hashable a) =>
a -> Int -> MultiSet a -> MultiSet a
MS.insertMany n
note Int
n MultiSet n
notesl, forall a.
(Eq a, Hashable a) =>
a -> Int -> MultiSet a -> MultiSet a
MS.insertMany n
note Int
n MultiSet n
notesr)
      ToLeft Int
i ->
        if Int
i forall a. Ord a => a -> a -> Bool
> Int
n Bool -> Bool -> Bool
|| Int
i forall a. Ord a => a -> a -> Bool
<= Int
0
          then forall a b. a -> Either a b
Left String
"moving more notes than allowed to the right"
          else
            forall (f :: * -> *) a. Applicative f => a -> f a
pure
              (forall a.
(Eq a, Hashable a) =>
a -> Int -> MultiSet a -> MultiSet a
MS.insertMany n
note Int
n MultiSet n
notesl, forall a.
(Eq a, Hashable a) =>
a -> Int -> MultiSet a -> MultiSet a
MS.insertMany n
note (Int
n forall a. Num a => a -> a -> a
- Int
i) MultiSet n
notesr)
      ToRight Int
i ->
        if Int
i forall a. Ord a => a -> a -> Bool
> Int
n Bool -> Bool -> Bool
|| Int
i forall a. Ord a => a -> a -> Bool
<= Int
0
          then forall a b. a -> Either a b
Left String
"moving more notes than allowed to the left"
          else
            forall (f :: * -> *) a. Applicative f => a -> f a
pure
              (forall a.
(Eq a, Hashable a) =>
a -> Int -> MultiSet a -> MultiSet a
MS.insertMany n
note (Int
n forall a. Num a => a -> a -> a
- Int
i) MultiSet n
notesl, forall a.
(Eq a, Hashable a) =>
a -> Int -> MultiSet a -> MultiSet a
MS.insertMany n
note Int
n MultiSet n
notesr)
  fixEdges
    :: (forall a. (a, a) -> a)
    -> Edges n
    -> MS.MultiSet n
    -> Either String (Edges n)
  fixEdges :: (forall a. (a, a) -> a)
-> Edges n -> MultiSet n -> Either String (Edges n)
fixEdges forall a. (a, a) -> a
accessor (Edges HashSet (Edge n)
ts MultiSet (InnerEdge n)
nts) MultiSet n
notesms
    | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> MultiSet a -> Bool
MS.all ((forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet n
notes) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a, a) -> a
accessor) MultiSet (InnerEdge n)
nts =
        forall a b. a -> Either a b
Left
          String
"dropping non-terminal edge in spread"
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge n)
ts' MultiSet (InnerEdge n)
nts
   where
    notes :: HashSet n
notes = forall k. MultiSet k -> HashSet k
MS.toSet MultiSet n
notesms
    notesi :: HashSet (StartStop n)
notesi = forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
S.map forall a. a -> StartStop a
Inner HashSet n
notes
    ts' :: HashSet (Edge n)
ts' = forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter ((forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet (StartStop n)
notesi) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a, a) -> a
accessor) HashSet (Edge n)
ts

{- | 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 n, StartStop n) [(n, DoubleOrnament)]
splitRegs Map (n, n) [(n, PassingOrnament)]
splitPassings Map n [(n, RightOrnament)]
ls Map n [(n, LeftOrnament)]
rs HashSet (StartStop n, StartStop n)
_ HashSet (StartStop n, StartStop n)
_ MultiSet (n, n)
passl MultiSet (n, n)
passr) inTop :: Edges n
inTop@(Edges HashSet (StartStop n, StartStop n)
topRegs MultiSet (n, n)
topPassings) =
  do
    (MultiSet n
notesReg, HashSet (StartStop n, StartStop n)
leftRegsReg, HashSet (StartStop n, StartStop n)
rightRegsReg) <- HashSet (StartStop n, StartStop n)
-> Map (StartStop n, StartStop n) [(n, DoubleOrnament)]
-> Either
     String
     (MultiSet n, HashSet (StartStop n, StartStop n),
      HashSet (StartStop n, StartStop n))
applyRegs HashSet (StartStop n, StartStop n)
topRegs Map (StartStop n, StartStop n) [(n, DoubleOrnament)]
splitRegs
    (MultiSet n
notesPassing, MultiSet (n, n)
leftPassings, MultiSet (n, n)
rightPassings, HashSet (StartStop n, StartStop n)
leftRegsPass, HashSet (StartStop n, StartStop n)
rightRegsPass) <-
      MultiSet (n, n)
-> Map (n, n) [(n, PassingOrnament)]
-> Either
     String
     (MultiSet n, MultiSet (n, n), MultiSet (n, n),
      HashSet (StartStop n, StartStop n),
      HashSet (StartStop n, StartStop n))
applyPassings
        MultiSet (n, n)
topPassings
        Map (n, n) [(n, PassingOrnament)]
splitPassings
    let notesL :: MultiSet n
notesL = forall {a} {a} {b}. Hashable a => Map a [(a, b)] -> MultiSet a
collectNotes Map n [(n, RightOrnament)]
ls
        notesR :: MultiSet n
notesR = forall {a} {a} {b}. Hashable a => Map a [(a, b)] -> MultiSet a
collectNotes Map n [(n, LeftOrnament)]
rs
        notes :: MultiSet n
notes = forall (t :: * -> *) a0.
(Foldable t, Eq a0, Hashable a0) =>
t (MultiSet a0) -> MultiSet a0
MS.unions [MultiSet n
notesReg, MultiSet n
notesPassing, MultiSet n
notesL, MultiSet n
notesR]
        leftSingleEdges :: [(StartStop n, StartStop n)]
leftSingleEdges = (\(n
p, (n
c, RightOrnament
_)) -> (forall a. a -> StartStop a
Inner n
p, forall a. a -> StartStop a
Inner n
c)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}. Map a [b] -> [(a, b)]
allOps Map n [(n, RightOrnament)]
ls
        rightSingleEdges :: [(StartStop n, StartStop n)]
rightSingleEdges = (\(n
p, (n
c, LeftOrnament
_)) -> (forall a. a -> StartStop a
Inner n
c, forall a. a -> StartStop a
Inner n
p)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}. Map a [b] -> [(a, b)]
allOps Map n [(n, LeftOrnament)]
rs
        edgesl :: HashSet (StartStop n, StartStop n)
edgesl = HashSet (StartStop n, StartStop n)
leftRegsReg forall a. Semigroup a => a -> a -> a
<> HashSet (StartStop n, StartStop n)
leftRegsPass forall a. Semigroup a => a -> a -> a
<> forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [(StartStop n, StartStop n)]
leftSingleEdges
        edgesr :: HashSet (StartStop n, StartStop n)
edgesr = HashSet (StartStop n, StartStop n)
rightRegsReg forall a. Semigroup a => a -> a -> a
<> HashSet (StartStop n, StartStop n)
rightRegsPass forall a. Semigroup a => a -> a -> a
<> forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [(StartStop n, StartStop n)]
rightSingleEdges
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (StartStop n, StartStop n)
edgesl (forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.union MultiSet (n, n)
leftPassings MultiSet (n, n)
passl)
      , forall n. MultiSet n -> Notes n
Notes MultiSet n
notes
      , forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (StartStop n, StartStop n)
edgesr (forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.union MultiSet (n, n)
rightPassings MultiSet (n, n)
passr)
      )
 where
  allOps :: Map a [b] -> [(a, b)]
allOps Map a [b]
opset = do
    (a
parent, [b]
children) <- forall k a. Map k a -> [(k, a)]
M.toList Map a [b]
opset
    b
child <- [b]
children
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
parent, b
child)

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

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

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

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

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

  singleChild :: (a, (a, b)) -> a
singleChild (a
_, (a
note, b
_)) = a
note
  collectNotes :: Map a [(a, b)] -> MultiSet a
collectNotes Map a [(a, b)]
ops = forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList forall a b. (a -> b) -> a -> b
$ forall {a} {a} {b}. (a, (a, b)) -> a
singleChild forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 -> Edges n -> Either String (Edges n)
applyFreezeAllEdges Freeze
FreezeOp e :: Edges n
e@(Edges HashSet (Edge n)
ts MultiSet (InnerEdge n)
nts)
  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall k. MultiSet k -> Bool
MS.null MultiSet (InnerEdge n)
nts = forall a b. a -> Either a b
Left String
"cannot freeze non-terminal edges"
  | Bool
otherwise = 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 = 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 forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit forall n.
(Eq (IntervalOf n), HasPitch n) =>
Freeze -> Edges n -> Either String (Edges n)
applyFreeze 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 (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 (Spread n) (Notes n) (Edges n)
derivationPlayerPV =
  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
    forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit
    forall n.
(Eq (IntervalOf n), HasPitch n) =>
Freeze -> Edges n -> Either String (Edges n)
applyFreeze
    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 = forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges (forall a. Hashable a => a -> HashSet a
S.singleton (forall a. StartStop a
Start, forall a. StartStop a
Stop)) 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 (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 (Spread n) (Notes n) (Edges n)
derivationPlayerPVAllEdges =
  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
    forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplitAllEdges
    forall {n}. Freeze -> Edges n -> Either String (Edges n)
applyFreezeAllEdges
    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 = forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges (forall a. Hashable a => a -> HashSet a
S.singleton (forall a. StartStop a
Start, forall a. StartStop a
Stop)) 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 (Spread n)]
  -> Path [n] [Edge n]
  -> Bool
checkDerivation :: forall n.
(Ord n, Notation n, Hashable n, Eq (IntervalOf n), HasPitch n,
 Show n) =>
[Leftmost (Split n) Freeze (Spread n)] -> Path [n] [Edge n] -> Bool
checkDerivation [Leftmost (Split n) Freeze (Spread n)]
deriv Path [n] [Edge n]
original =
  case 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 forall n.
(Eq n, Ord n, Notation n, Hashable n, Eq (IntervalOf n),
 HasPitch n) =>
DerivationPlayer (Split n) Freeze (Spread n) (Notes n) (Edges n)
derivationPlayerPV [Leftmost (Split n) Freeze (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 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
              Notes n
s <- forall a. StartStop a -> Maybe a
getInner forall a b. (a -> b) -> a -> b
$ forall slc. DerivSlice slc -> StartStop slc
dslContent DerivSlice (Notes n)
slast
              forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {around} {between} {a} {b}.
(Path around between, between)
-> (a, b, DerivSlice around) -> Maybe (Path around between, b)
foldPath (forall around between. around -> Path around between
PathEnd Notes n
s, Edges n
tlast) [DerivTrans (Notes n) (Edges n)]
rst
            [DerivTrans (Notes n) (Edges n)]
_ -> forall a. Maybe a
Nothing
          orig' :: Path (Notes n) (Edges n)
orig' =
            forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
              (forall n. MultiSet n -> Notes n
Notes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList)
              (\[Edge n]
e -> forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges (forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Edge n]
e) forall a. MultiSet a
MS.empty)
              Path [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 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
    around
s <- forall a. StartStop a -> Maybe a
getInner forall a b. (a -> b) -> a -> b
$ forall slc. DerivSlice slc -> StartStop slc
dslContent DerivSlice around
snew
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall around between.
around -> between -> Path around between -> Path around between
Path around
s between
tacc Path around between
pacc, b
tnew)