{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}

{- | This module contains common datatypes and functions specific to the protovoice grammar.
 In a protovoice derivations, slices are multisets of notes
 while transitions contain connections between these notes.

 Code that is specific to parsing can be found in "PVGrammar.Parse",
 while generative code is located in "PVGrammar.Generate".
-}
module PVGrammar
  ( -- * Inner Structure Types

    -- ** Slices: Notes
    Notes (..)
  , innerNotes

    -- ** Transitions: Sets of Obligatory Edges

    -- | Transitions contain two kinds of edges, regular edges and passing edges.
  , Edges (..)
  , topEdges
  , Edge
  , InnerEdge

    -- * Generative Operations

    -- ** Freeze
  , Freeze (..)

    -- ** Split
  , Split (..)
  , DoubleOrnament (..)
  , isRepetitionOnLeft
  , isRepetitionOnRight
  , PassingOrnament (..)
  , LeftOrnament (..)
  , RightOrnament (..)

    -- ** Spread
  , Spread (..)
  , SpreadDirection (..)

    -- * Derivations
  , PVLeftmost
  , PVAnalysis
  , analysisTraversePitch
  , analysisMapPitch

    -- * Loading Files
  , loadAnalysis
  , loadAnalysis'
  , slicesFromFile
  , slicesToPath
  , loadSurface
  , loadSurface'
  ) where

import Common

import Musicology.Pitch
  ( Interval
  , Notation (..)
  , Pitch
  , SInterval
  , SPC
  , SPitch
  , pc
  )

import Control.DeepSeq (NFData)
import Control.Monad.Identity (runIdentity)
import Data.Aeson
  ( FromJSON
  , ToJSON
  , (.:)
  )
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
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 (mapMaybe)
import Data.Text.Lazy.IO qualified as TL
import Data.Traversable (for)
import GHC.Generics (Generic)
import Internal.MultiSet qualified as MS
import Musicology.Core qualified as Music
import Musicology.Core.Slicing qualified as Music
import Musicology.MusicXML qualified as MusicXML

-- * Inner Structure Types

-- ** Slice Type: Sets of Notes

-- Slices contain a multiset of notes.

{- | The content type of slices in the protovoice model.
 Contains a multiset of pitches, representing the notes in a slice.
-}
newtype Notes n = Notes (MS.MultiSet n)
  deriving (Notes n -> Notes n -> Bool
forall n. Eq n => Notes n -> Notes n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Notes n -> Notes n -> Bool
$c/= :: forall n. Eq n => Notes n -> Notes n -> Bool
== :: Notes n -> Notes n -> Bool
$c== :: forall n. Eq n => Notes n -> Notes n -> Bool
Eq, Notes n -> Notes n -> Bool
Notes n -> Notes n -> Ordering
Notes n -> Notes n -> Notes n
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {n}. Ord n => Eq (Notes n)
forall n. Ord n => Notes n -> Notes n -> Bool
forall n. Ord n => Notes n -> Notes n -> Ordering
forall n. Ord n => Notes n -> Notes n -> Notes n
min :: Notes n -> Notes n -> Notes n
$cmin :: forall n. Ord n => Notes n -> Notes n -> Notes n
max :: Notes n -> Notes n -> Notes n
$cmax :: forall n. Ord n => Notes n -> Notes n -> Notes n
>= :: Notes n -> Notes n -> Bool
$c>= :: forall n. Ord n => Notes n -> Notes n -> Bool
> :: Notes n -> Notes n -> Bool
$c> :: forall n. Ord n => Notes n -> Notes n -> Bool
<= :: Notes n -> Notes n -> Bool
$c<= :: forall n. Ord n => Notes n -> Notes n -> Bool
< :: Notes n -> Notes n -> Bool
$c< :: forall n. Ord n => Notes n -> Notes n -> Bool
compare :: Notes n -> Notes n -> Ordering
$ccompare :: forall n. Ord n => Notes n -> Notes n -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall n x. Rep (Notes n) x -> Notes n
forall n x. Notes n -> Rep (Notes n) x
$cto :: forall n x. Rep (Notes n) x -> Notes n
$cfrom :: forall n x. Notes n -> Rep (Notes n) x
Generic)
  deriving anyclass (forall n. NFData n => Notes n -> ()
forall a. (a -> ()) -> NFData a
rnf :: Notes n -> ()
$crnf :: forall n. NFData n => Notes n -> ()
NFData, forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {n}. Hashable n => Eq (Notes n)
forall n. Hashable n => Int -> Notes n -> Int
forall n. Hashable n => Notes n -> Int
hash :: Notes n -> Int
$chash :: forall n. Hashable n => Notes n -> Int
hashWithSalt :: Int -> Notes n -> Int
$chashWithSalt :: forall n. Hashable n => Int -> Notes n -> Int
Hashable)

instance (Notation n) => Show (Notes n) where
  show :: Notes n -> String
show (Notes MultiSet n
ns) =
    String
"{" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," (forall {i} {b}.
(Notation i, Eq b, Num b, Show b) =>
(i, b) -> String
showNote forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet n
ns) forall a. Semigroup a => a -> a -> a
<> String
"}"
   where
    showNote :: (i, b) -> String
showNote (i
p, b
n) = forall i. Notation i => i -> String
showNotation i
p forall a. Semigroup a => a -> a -> a
<> String
mult
     where
      mult :: String
mult = if b
n forall a. Eq a => a -> a -> Bool
/= b
1 then String
"×" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show b
n else String
""

instance (Notation n, Eq n, Hashable n) => FromJSON (Notes n) where
  parseJSON :: Value -> Parser (Notes n)
parseJSON = forall a. String -> (Array -> Parser a) -> Value -> Parser a
Aeson.withArray String
"List of Notes" forall a b. (a -> b) -> a -> b
$ \Array
notes -> do
    Vector n
pitches <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n. Notation n => Value -> Parser n
parseJSONNote Array
notes
    pure $ forall n. MultiSet n -> Notes n
Notes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList Vector n
pitches

{- | Return the notes or start/stop symbols inside a slice.
 This is useful to get all objects that an 'Edge' can connect to.
-}
innerNotes :: StartStop (Notes n) -> [StartStop n]
innerNotes :: forall n. StartStop (Notes n) -> [StartStop n]
innerNotes (Inner (Notes MultiSet n
n)) = forall a. a -> StartStop a
Inner forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k. MultiSet k -> [k]
MS.distinctElems MultiSet n
n
innerNotes StartStop (Notes n)
Start = [forall a. StartStop a
Start]
innerNotes StartStop (Notes n)
Stop = [forall a. StartStop a
Stop]

-- TODO: could this be improved to forbid start/stop symbols on the wrong side?

-- | A proto-voice edge between two nodes (i.e. notes or start/stop symbols).
type Edge n = (StartStop n, StartStop n)

-- | A proto-voice edge between two notes (excluding start/stop symbols).
type InnerEdge n = (n, n)

{- | The content type of transitions in the protovoice model.
 Contains a multiset of regular edges and a multiset of passing edges.
 The represented edges are those that are definitely used later on.
 Edges that are not used are dropped before creating a child transition.
 A transition that contains passing edges cannot be frozen.
-}
data Edges n = Edges
  { forall n. Edges n -> HashSet (Edge n)
edgesReg :: !(S.HashSet (Edge n))
  -- ^ regular edges
  , forall n. Edges n -> MultiSet (InnerEdge n)
edgesPass :: !(MS.MultiSet (InnerEdge n))
  -- ^ passing edges
  }
  deriving (Edges n -> Edges n -> Bool
forall n. Eq n => Edges n -> Edges n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Edges n -> Edges n -> Bool
$c/= :: forall n. Eq n => Edges n -> Edges n -> Bool
== :: Edges n -> Edges n -> Bool
$c== :: forall n. Eq n => Edges n -> Edges n -> Bool
Eq, Edges n -> Edges n -> Bool
Edges n -> Edges n -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {n}. Ord n => Eq (Edges n)
forall n. Ord n => Edges n -> Edges n -> Bool
forall n. Ord n => Edges n -> Edges n -> Ordering
forall n. Ord n => Edges n -> Edges n -> Edges n
min :: Edges n -> Edges n -> Edges n
$cmin :: forall n. Ord n => Edges n -> Edges n -> Edges n
max :: Edges n -> Edges n -> Edges n
$cmax :: forall n. Ord n => Edges n -> Edges n -> Edges n
>= :: Edges n -> Edges n -> Bool
$c>= :: forall n. Ord n => Edges n -> Edges n -> Bool
> :: Edges n -> Edges n -> Bool
$c> :: forall n. Ord n => Edges n -> Edges n -> Bool
<= :: Edges n -> Edges n -> Bool
$c<= :: forall n. Ord n => Edges n -> Edges n -> Bool
< :: Edges n -> Edges n -> Bool
$c< :: forall n. Ord n => Edges n -> Edges n -> Bool
compare :: Edges n -> Edges n -> Ordering
$ccompare :: forall n. Ord n => Edges n -> Edges n -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall n x. Rep (Edges n) x -> Edges n
forall n x. Edges n -> Rep (Edges n) x
$cto :: forall n x. Rep (Edges n) x -> Edges n
$cfrom :: forall n x. Edges n -> Rep (Edges n) x
Generic, forall n. NFData n => Edges n -> ()
forall a. (a -> ()) -> NFData a
rnf :: Edges n -> ()
$crnf :: forall n. NFData n => Edges n -> ()
NFData, forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {n}. Hashable n => Eq (Edges n)
forall n. Hashable n => Int -> Edges n -> Int
forall n. Hashable n => Edges n -> Int
hash :: Edges n -> Int
$chash :: forall n. Hashable n => Edges n -> Int
hashWithSalt :: Int -> Edges n -> Int
$chashWithSalt :: forall n. Hashable n => Int -> Edges n -> Int
Hashable)

instance (Hashable n, Eq n) => Semigroup (Edges n) where
  (Edges HashSet (Edge n)
aT MultiSet (InnerEdge n)
aPass) <> :: Edges n -> Edges n -> Edges n
<> (Edges HashSet (Edge n)
bT MultiSet (InnerEdge n)
bPass) = forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges (HashSet (Edge n)
aT forall a. Semigroup a => a -> a -> a
<> HashSet (Edge n)
bT) (MultiSet (InnerEdge n)
aPass forall a. Semigroup a => a -> a -> a
<> MultiSet (InnerEdge n)
bPass)

instance (Hashable n, Eq n) => Monoid (Edges n) where
  mempty :: Edges n
mempty = forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges forall a. Monoid a => a
mempty forall a. MultiSet a
MS.empty

instance (Notation n) => Show (Edges n) where
  show :: Edges n -> String
show (Edges HashSet (Edge n)
reg MultiSet (InnerEdge n)
pass) = String
"{" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," ([String]
tReg forall a. Semigroup a => a -> a -> a
<> [String]
tPass) forall a. Semigroup a => a -> a -> a
<> String
"}"
   where
    tReg :: [String]
tReg = forall {i} {i}. (Notation i, Notation i) => (i, i) -> String
showReg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
reg
    tPass :: [String]
tPass = forall {i} {i} {a}.
(Notation i, Notation i, Show a) =>
((i, i), a) -> String
showPass forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet (InnerEdge n)
pass
    showReg :: (i, i) -> String
showReg (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
    showPass :: ((i, i), a) -> String
showPass ((i
p1, i
p2), a
n) =
      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 forall a. Semigroup a => a -> a -> a
<> String
"×" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
n

instance (Eq n, Hashable n, Notation n) => FromJSON (Edges n) where
  parseJSON :: Value -> Parser (Edges n)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Edges" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    [Edge n]
regular <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"regular" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n. Notation n => Value -> Parser (StartStop n, StartStop n)
parseEdge
    [InnerEdge n]
passing <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"passing" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n. Notation n => Value -> Parser (n, n)
parseInnerEdge
    pure $
      forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges
        (forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Edge n]
regular :: [Edge n]))
        (forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList ([InnerEdge n]
passing :: [InnerEdge n]))

-- | The starting transition of a derivation (@⋊——⋉@).
topEdges :: (Hashable n) => Edges n
topEdges :: forall n. Hashable n => Edges n
topEdges = 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

-- * Derivation Operations

-- | Two-sided ornament types (two parents).
data DoubleOrnament
  = -- | a full neighbor note
    FullNeighbor
  | -- | a repetition of both parents (which have the same pitch)
    FullRepeat
  | -- | a repetition of the right parent
    LeftRepeatOfRight
  | -- | a repetitions of the left parent
    RightRepeatOfLeft
  | -- | a note inserted at the top of the piece (between ⋊ and ⋉)
    RootNote
  deriving (DoubleOrnament -> DoubleOrnament -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DoubleOrnament -> DoubleOrnament -> Bool
$c/= :: DoubleOrnament -> DoubleOrnament -> Bool
== :: DoubleOrnament -> DoubleOrnament -> Bool
$c== :: DoubleOrnament -> DoubleOrnament -> Bool
Eq, Eq DoubleOrnament
DoubleOrnament -> DoubleOrnament -> Bool
DoubleOrnament -> DoubleOrnament -> Ordering
DoubleOrnament -> DoubleOrnament -> DoubleOrnament
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DoubleOrnament -> DoubleOrnament -> DoubleOrnament
$cmin :: DoubleOrnament -> DoubleOrnament -> DoubleOrnament
max :: DoubleOrnament -> DoubleOrnament -> DoubleOrnament
$cmax :: DoubleOrnament -> DoubleOrnament -> DoubleOrnament
>= :: DoubleOrnament -> DoubleOrnament -> Bool
$c>= :: DoubleOrnament -> DoubleOrnament -> Bool
> :: DoubleOrnament -> DoubleOrnament -> Bool
$c> :: DoubleOrnament -> DoubleOrnament -> Bool
<= :: DoubleOrnament -> DoubleOrnament -> Bool
$c<= :: DoubleOrnament -> DoubleOrnament -> Bool
< :: DoubleOrnament -> DoubleOrnament -> Bool
$c< :: DoubleOrnament -> DoubleOrnament -> Bool
compare :: DoubleOrnament -> DoubleOrnament -> Ordering
$ccompare :: DoubleOrnament -> DoubleOrnament -> Ordering
Ord, Int -> DoubleOrnament -> ShowS
[DoubleOrnament] -> ShowS
DoubleOrnament -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DoubleOrnament] -> ShowS
$cshowList :: [DoubleOrnament] -> ShowS
show :: DoubleOrnament -> String
$cshow :: DoubleOrnament -> String
showsPrec :: Int -> DoubleOrnament -> ShowS
$cshowsPrec :: Int -> DoubleOrnament -> ShowS
Show, forall x. Rep DoubleOrnament x -> DoubleOrnament
forall x. DoubleOrnament -> Rep DoubleOrnament x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DoubleOrnament x -> DoubleOrnament
$cfrom :: forall x. DoubleOrnament -> Rep DoubleOrnament x
Generic, [DoubleOrnament] -> Encoding
[DoubleOrnament] -> Value
DoubleOrnament -> Encoding
DoubleOrnament -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [DoubleOrnament] -> Encoding
$ctoEncodingList :: [DoubleOrnament] -> Encoding
toJSONList :: [DoubleOrnament] -> Value
$ctoJSONList :: [DoubleOrnament] -> Value
toEncoding :: DoubleOrnament -> Encoding
$ctoEncoding :: DoubleOrnament -> Encoding
toJSON :: DoubleOrnament -> Value
$ctoJSON :: DoubleOrnament -> Value
ToJSON, Value -> Parser [DoubleOrnament]
Value -> Parser DoubleOrnament
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [DoubleOrnament]
$cparseJSONList :: Value -> Parser [DoubleOrnament]
parseJSON :: Value -> Parser DoubleOrnament
$cparseJSON :: Value -> Parser DoubleOrnament
FromJSON, DoubleOrnament -> ()
forall a. (a -> ()) -> NFData a
rnf :: DoubleOrnament -> ()
$crnf :: DoubleOrnament -> ()
NFData)

-- | Types of passing notes (two parents).
data PassingOrnament
  = -- | a connecting passing note (step to both parents)
    PassingMid
  | -- | a step from the left parent
    PassingLeft
  | -- | a step from the right parent
    PassingRight
  deriving (PassingOrnament -> PassingOrnament -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PassingOrnament -> PassingOrnament -> Bool
$c/= :: PassingOrnament -> PassingOrnament -> Bool
== :: PassingOrnament -> PassingOrnament -> Bool
$c== :: PassingOrnament -> PassingOrnament -> Bool
Eq, Eq PassingOrnament
PassingOrnament -> PassingOrnament -> Bool
PassingOrnament -> PassingOrnament -> Ordering
PassingOrnament -> PassingOrnament -> PassingOrnament
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PassingOrnament -> PassingOrnament -> PassingOrnament
$cmin :: PassingOrnament -> PassingOrnament -> PassingOrnament
max :: PassingOrnament -> PassingOrnament -> PassingOrnament
$cmax :: PassingOrnament -> PassingOrnament -> PassingOrnament
>= :: PassingOrnament -> PassingOrnament -> Bool
$c>= :: PassingOrnament -> PassingOrnament -> Bool
> :: PassingOrnament -> PassingOrnament -> Bool
$c> :: PassingOrnament -> PassingOrnament -> Bool
<= :: PassingOrnament -> PassingOrnament -> Bool
$c<= :: PassingOrnament -> PassingOrnament -> Bool
< :: PassingOrnament -> PassingOrnament -> Bool
$c< :: PassingOrnament -> PassingOrnament -> Bool
compare :: PassingOrnament -> PassingOrnament -> Ordering
$ccompare :: PassingOrnament -> PassingOrnament -> Ordering
Ord, Int -> PassingOrnament -> ShowS
[PassingOrnament] -> ShowS
PassingOrnament -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PassingOrnament] -> ShowS
$cshowList :: [PassingOrnament] -> ShowS
show :: PassingOrnament -> String
$cshow :: PassingOrnament -> String
showsPrec :: Int -> PassingOrnament -> ShowS
$cshowsPrec :: Int -> PassingOrnament -> ShowS
Show, forall x. Rep PassingOrnament x -> PassingOrnament
forall x. PassingOrnament -> Rep PassingOrnament x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PassingOrnament x -> PassingOrnament
$cfrom :: forall x. PassingOrnament -> Rep PassingOrnament x
Generic, [PassingOrnament] -> Encoding
[PassingOrnament] -> Value
PassingOrnament -> Encoding
PassingOrnament -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [PassingOrnament] -> Encoding
$ctoEncodingList :: [PassingOrnament] -> Encoding
toJSONList :: [PassingOrnament] -> Value
$ctoJSONList :: [PassingOrnament] -> Value
toEncoding :: PassingOrnament -> Encoding
$ctoEncoding :: PassingOrnament -> Encoding
toJSON :: PassingOrnament -> Value
$ctoJSON :: PassingOrnament -> Value
ToJSON, Value -> Parser [PassingOrnament]
Value -> Parser PassingOrnament
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PassingOrnament]
$cparseJSONList :: Value -> Parser [PassingOrnament]
parseJSON :: Value -> Parser PassingOrnament
$cparseJSON :: Value -> Parser PassingOrnament
FromJSON, PassingOrnament -> ()
forall a. (a -> ()) -> NFData a
rnf :: PassingOrnament -> ()
$crnf :: PassingOrnament -> ()
NFData)

{- | Types of single-sided ornaments left of the parent (@child-parent@)

 > [ ] [p]
 >     /
 >   [c]
-}
data LeftOrnament
  = -- | an incomplete left neighbor
    LeftNeighbor
  | -- | an incomplete left repetition
    LeftRepeat
  deriving (LeftOrnament -> LeftOrnament -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LeftOrnament -> LeftOrnament -> Bool
$c/= :: LeftOrnament -> LeftOrnament -> Bool
== :: LeftOrnament -> LeftOrnament -> Bool
$c== :: LeftOrnament -> LeftOrnament -> Bool
Eq, Eq LeftOrnament
LeftOrnament -> LeftOrnament -> Bool
LeftOrnament -> LeftOrnament -> Ordering
LeftOrnament -> LeftOrnament -> LeftOrnament
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LeftOrnament -> LeftOrnament -> LeftOrnament
$cmin :: LeftOrnament -> LeftOrnament -> LeftOrnament
max :: LeftOrnament -> LeftOrnament -> LeftOrnament
$cmax :: LeftOrnament -> LeftOrnament -> LeftOrnament
>= :: LeftOrnament -> LeftOrnament -> Bool
$c>= :: LeftOrnament -> LeftOrnament -> Bool
> :: LeftOrnament -> LeftOrnament -> Bool
$c> :: LeftOrnament -> LeftOrnament -> Bool
<= :: LeftOrnament -> LeftOrnament -> Bool
$c<= :: LeftOrnament -> LeftOrnament -> Bool
< :: LeftOrnament -> LeftOrnament -> Bool
$c< :: LeftOrnament -> LeftOrnament -> Bool
compare :: LeftOrnament -> LeftOrnament -> Ordering
$ccompare :: LeftOrnament -> LeftOrnament -> Ordering
Ord, Int -> LeftOrnament -> ShowS
[LeftOrnament] -> ShowS
LeftOrnament -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LeftOrnament] -> ShowS
$cshowList :: [LeftOrnament] -> ShowS
show :: LeftOrnament -> String
$cshow :: LeftOrnament -> String
showsPrec :: Int -> LeftOrnament -> ShowS
$cshowsPrec :: Int -> LeftOrnament -> ShowS
Show, forall x. Rep LeftOrnament x -> LeftOrnament
forall x. LeftOrnament -> Rep LeftOrnament x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LeftOrnament x -> LeftOrnament
$cfrom :: forall x. LeftOrnament -> Rep LeftOrnament x
Generic, [LeftOrnament] -> Encoding
[LeftOrnament] -> Value
LeftOrnament -> Encoding
LeftOrnament -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [LeftOrnament] -> Encoding
$ctoEncodingList :: [LeftOrnament] -> Encoding
toJSONList :: [LeftOrnament] -> Value
$ctoJSONList :: [LeftOrnament] -> Value
toEncoding :: LeftOrnament -> Encoding
$ctoEncoding :: LeftOrnament -> Encoding
toJSON :: LeftOrnament -> Value
$ctoJSON :: LeftOrnament -> Value
ToJSON, Value -> Parser [LeftOrnament]
Value -> Parser LeftOrnament
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [LeftOrnament]
$cparseJSONList :: Value -> Parser [LeftOrnament]
parseJSON :: Value -> Parser LeftOrnament
$cparseJSON :: Value -> Parser LeftOrnament
FromJSON, LeftOrnament -> ()
forall a. (a -> ()) -> NFData a
rnf :: LeftOrnament -> ()
$crnf :: LeftOrnament -> ()
NFData)

{- | Types of single-sided ornaments right of the parent (@parent--child@).

 > [p] [ ]
 >   \
 >   [c]
-}
data RightOrnament
  = -- | an incomplete right neighbor
    RightNeighbor
  | -- | an incomplete right repetition
    RightRepeat
  deriving (RightOrnament -> RightOrnament -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RightOrnament -> RightOrnament -> Bool
$c/= :: RightOrnament -> RightOrnament -> Bool
== :: RightOrnament -> RightOrnament -> Bool
$c== :: RightOrnament -> RightOrnament -> Bool
Eq, Eq RightOrnament
RightOrnament -> RightOrnament -> Bool
RightOrnament -> RightOrnament -> Ordering
RightOrnament -> RightOrnament -> RightOrnament
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RightOrnament -> RightOrnament -> RightOrnament
$cmin :: RightOrnament -> RightOrnament -> RightOrnament
max :: RightOrnament -> RightOrnament -> RightOrnament
$cmax :: RightOrnament -> RightOrnament -> RightOrnament
>= :: RightOrnament -> RightOrnament -> Bool
$c>= :: RightOrnament -> RightOrnament -> Bool
> :: RightOrnament -> RightOrnament -> Bool
$c> :: RightOrnament -> RightOrnament -> Bool
<= :: RightOrnament -> RightOrnament -> Bool
$c<= :: RightOrnament -> RightOrnament -> Bool
< :: RightOrnament -> RightOrnament -> Bool
$c< :: RightOrnament -> RightOrnament -> Bool
compare :: RightOrnament -> RightOrnament -> Ordering
$ccompare :: RightOrnament -> RightOrnament -> Ordering
Ord, Int -> RightOrnament -> ShowS
[RightOrnament] -> ShowS
RightOrnament -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RightOrnament] -> ShowS
$cshowList :: [RightOrnament] -> ShowS
show :: RightOrnament -> String
$cshow :: RightOrnament -> String
showsPrec :: Int -> RightOrnament -> ShowS
$cshowsPrec :: Int -> RightOrnament -> ShowS
Show, forall x. Rep RightOrnament x -> RightOrnament
forall x. RightOrnament -> Rep RightOrnament x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RightOrnament x -> RightOrnament
$cfrom :: forall x. RightOrnament -> Rep RightOrnament x
Generic, [RightOrnament] -> Encoding
[RightOrnament] -> Value
RightOrnament -> Encoding
RightOrnament -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RightOrnament] -> Encoding
$ctoEncodingList :: [RightOrnament] -> Encoding
toJSONList :: [RightOrnament] -> Value
$ctoJSONList :: [RightOrnament] -> Value
toEncoding :: RightOrnament -> Encoding
$ctoEncoding :: RightOrnament -> Encoding
toJSON :: RightOrnament -> Value
$ctoJSON :: RightOrnament -> Value
ToJSON, Value -> Parser [RightOrnament]
Value -> Parser RightOrnament
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RightOrnament]
$cparseJSONList :: Value -> Parser [RightOrnament]
parseJSON :: Value -> Parser RightOrnament
$cparseJSON :: Value -> Parser RightOrnament
FromJSON, RightOrnament -> ()
forall a. (a -> ()) -> NFData a
rnf :: RightOrnament -> ()
$crnf :: RightOrnament -> ()
NFData)

-- | Returns 'True' if the child repeats the left parent
isRepetitionOnLeft :: DoubleOrnament -> Bool
isRepetitionOnLeft :: DoubleOrnament -> Bool
isRepetitionOnLeft DoubleOrnament
FullRepeat = Bool
True
isRepetitionOnLeft DoubleOrnament
RightRepeatOfLeft = Bool
True
isRepetitionOnLeft DoubleOrnament
_ = Bool
False

-- | Returns 'True' if the child repeats the right parent
isRepetitionOnRight :: DoubleOrnament -> Bool
isRepetitionOnRight :: DoubleOrnament -> Bool
isRepetitionOnRight DoubleOrnament
FullRepeat = Bool
True
isRepetitionOnRight DoubleOrnament
LeftRepeatOfRight = Bool
True
isRepetitionOnRight DoubleOrnament
_ = Bool
False

{- | Encodes the decisions made in a split operation.
 Contains a list of elaborations for every parent edge and note.
 Each elaboration contains the child pitch, and the corresponding ornament.
 For every produced edge, a decisions is made whether to keep it or not.
-}
data Split n = SplitOp
  { forall n. Split n -> Map (Edge n) [(n, DoubleOrnament)]
splitReg :: !(M.Map (Edge n) [(n, DoubleOrnament)])
  -- ^ Maps every regular edge to a list of ornamentations.
  , forall n. Split n -> Map (InnerEdge n) [(n, PassingOrnament)]
splitPass :: !(M.Map (InnerEdge n) [(n, PassingOrnament)])
  -- ^ Maps every passing edge to a passing tone.
  -- Since every passing edge is elaborated exactly once
  -- but there can be several instances of the same edge in a transition,
  -- the "same" edge can be elaborated with several passing notes,
  -- one for each instance of the edge.
  , forall n. Split n -> Map n [(n, RightOrnament)]
fromLeft :: !(M.Map n [(n, RightOrnament)])
  -- ^ Maps notes from the left parent slice to lists of ornamentations.
  , forall n. Split n -> Map n [(n, LeftOrnament)]
fromRight :: !(M.Map n [(n, LeftOrnament)])
  -- ^ Maps notes from the right parent slice to lists of ornamentations.
  , forall n. Split n -> HashSet (Edge n)
keepLeft :: !(S.HashSet (Edge n))
  -- ^ The set of regular edges to keep in the left child transition.
  , forall n. Split n -> HashSet (Edge n)
keepRight :: !(S.HashSet (Edge n))
  -- ^ The set of regular edges to keep in the right child transition.
  , forall n. Split n -> MultiSet (InnerEdge n)
passLeft :: !(MS.MultiSet (InnerEdge n))
  -- ^ Contains the new passing edges introduced in the left child transition
  -- (excluding those passed down from the parent transition).
  , forall n. Split n -> MultiSet (InnerEdge n)
passRight :: !(MS.MultiSet (InnerEdge n))
  -- ^ Contains the new passing edges introduced in the right child transition
  -- (excluding those passed down from the parent transition).
  }
  deriving (Split n -> Split n -> Bool
forall n. Eq n => Split n -> Split n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Split n -> Split n -> Bool
$c/= :: forall n. Eq n => Split n -> Split n -> Bool
== :: Split n -> Split n -> Bool
$c== :: forall n. Eq n => Split n -> Split n -> Bool
Eq, Split n -> Split n -> Bool
Split n -> Split n -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {n}. Ord n => Eq (Split n)
forall n. Ord n => Split n -> Split n -> Bool
forall n. Ord n => Split n -> Split n -> Ordering
forall n. Ord n => Split n -> Split n -> Split n
min :: Split n -> Split n -> Split n
$cmin :: forall n. Ord n => Split n -> Split n -> Split n
max :: Split n -> Split n -> Split n
$cmax :: forall n. Ord n => Split n -> Split n -> Split n
>= :: Split n -> Split n -> Bool
$c>= :: forall n. Ord n => Split n -> Split n -> Bool
> :: Split n -> Split n -> Bool
$c> :: forall n. Ord n => Split n -> Split n -> Bool
<= :: Split n -> Split n -> Bool
$c<= :: forall n. Ord n => Split n -> Split n -> Bool
< :: Split n -> Split n -> Bool
$c< :: forall n. Ord n => Split n -> Split n -> Bool
compare :: Split n -> Split n -> Ordering
$ccompare :: forall n. Ord n => Split n -> Split n -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall n x. Rep (Split n) x -> Split n
forall n x. Split n -> Rep (Split n) x
$cto :: forall n x. Rep (Split n) x -> Split n
$cfrom :: forall n x. Split n -> Rep (Split n) x
Generic, forall n. NFData n => Split n -> ()
forall a. (a -> ()) -> NFData a
rnf :: Split n -> ()
$crnf :: forall n. NFData n => Split n -> ()
NFData)

instance (Notation n) => Show (Split n) where
  show :: Split n -> String
show (SplitOp Map (Edge n) [(n, DoubleOrnament)]
reg Map (InnerEdge n) [(n, PassingOrnament)]
pass Map n [(n, RightOrnament)]
ls Map n [(n, LeftOrnament)]
rs HashSet (Edge n)
kl HashSet (Edge n)
kr MultiSet (InnerEdge n)
pl MultiSet (InnerEdge n)
pr) =
    String
"regular:"
      forall a. Semigroup a => a -> a -> a
<> [String] -> String
showOps [String]
opReg
      forall a. Semigroup a => a -> a -> a
<> String
", passing:"
      forall a. Semigroup a => a -> a -> a
<> [String] -> String
showOps [String]
opPass
      forall a. Semigroup a => a -> a -> a
<> String
", ls:"
      forall a. Semigroup a => a -> a -> a
<> [String] -> String
showOps [String]
opLs
      forall a. Semigroup a => a -> a -> a
<> String
", rs:"
      forall a. Semigroup a => a -> a -> a
<> [String] -> String
showOps [String]
opRs
      forall a. Semigroup a => a -> a -> a
<> String
", kl:"
      forall a. Semigroup a => a -> a -> a
<> [String] -> String
showOps [String]
keepLs
      forall a. Semigroup a => a -> a -> a
<> String
", kr:"
      forall a. Semigroup a => a -> a -> a
<> [String] -> String
showOps [String]
keepRs
      forall a. Semigroup a => a -> a -> a
<> String
", pl:"
      forall a. Semigroup a => a -> a -> a
<> [String] -> String
showOps [String]
passLs
      forall a. Semigroup a => a -> a -> a
<> String
", pr:"
      forall a. Semigroup a => a -> a -> a
<> [String] -> String
showOps [String]
passRs
   where
    showOps :: [String] -> String
showOps [String]
ops = String
"{" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," [String]
ops forall a. Semigroup a => a -> a -> a
<> String
"}"
    showEdge :: (i, i) -> String
showEdge (i
n1, i
n2) = forall i. Notation i => i -> String
showNotation i
n1 forall a. Semigroup a => a -> a -> a
<> String
"-" forall a. Semigroup a => a -> a -> a
<> forall i. Notation i => i -> String
showNotation i
n2
    showChild :: (i, a) -> String
showChild (i
p, a
o) = forall i. Notation i => i -> String
showNotation i
p forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
o
    showChildren :: [(i, a)] -> String
showChildren [(i, a)]
cs = String
"[" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," (forall {i} {a}. (Notation i, Show a) => (i, a) -> String
showChild forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(i, a)]
cs) forall a. Semigroup a => a -> a -> a
<> String
"]"

    showSplit :: ((i, i), [(i, a)]) -> String
showSplit ((i, i)
e, [(i, a)]
cs) = forall {i} {i}. (Notation i, Notation i) => (i, i) -> String
showEdge (i, i)
e forall a. Semigroup a => a -> a -> a
<> String
"=>" forall a. Semigroup a => a -> a -> a
<> forall {i} {a}. (Notation i, Show a) => [(i, a)] -> String
showChildren [(i, a)]
cs
    showL :: (i, [(i, a)]) -> String
showL (i
p, [(i, a)]
lchilds) = forall i. Notation i => i -> String
showNotation i
p forall a. Semigroup a => a -> a -> a
<> String
"=>" forall a. Semigroup a => a -> a -> a
<> forall {i} {a}. (Notation i, Show a) => [(i, a)] -> String
showChildren [(i, a)]
lchilds
    showR :: (i, [(i, a)]) -> String
showR (i
p, [(i, a)]
rchilds) = forall {i} {a}. (Notation i, Show a) => [(i, a)] -> String
showChildren [(i, a)]
rchilds forall a. Semigroup a => a -> a -> a
<> String
"<=" forall a. Semigroup a => a -> a -> a
<> forall i. Notation i => i -> String
showNotation i
p

    opReg :: [String]
opReg = forall {i} {i} {i} {a}.
(Notation i, Notation i, Notation i, Show a) =>
((i, i), [(i, a)]) -> String
showSplit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList Map (Edge n) [(n, DoubleOrnament)]
reg
    opPass :: [String]
opPass = forall {i} {i} {i} {a}.
(Notation i, Notation i, Notation i, Show a) =>
((i, i), [(i, a)]) -> String
showSplit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList Map (InnerEdge n) [(n, PassingOrnament)]
pass
    opLs :: [String]
opLs = forall {i} {i} {a}.
(Notation i, Notation i, Show a) =>
(i, [(i, a)]) -> String
showL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList Map n [(n, RightOrnament)]
ls
    opRs :: [String]
opRs = forall {a} {i} {i}.
(Show a, Notation i, Notation i) =>
(i, [(i, a)]) -> String
showR forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList Map n [(n, LeftOrnament)]
rs
    keepLs :: [String]
keepLs = forall {i} {i}. (Notation i, Notation i) => (i, i) -> String
showEdge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
kl
    keepRs :: [String]
keepRs = forall {i} {i}. (Notation i, Notation i) => (i, i) -> String
showEdge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
kr
    passLs :: [String]
passLs = forall {i} {i}. (Notation i, Notation i) => (i, i) -> String
showEdge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k. MultiSet k -> [k]
MS.toList MultiSet (InnerEdge n)
pl
    passRs :: [String]
passRs = forall {i} {i}. (Notation i, Notation i) => (i, i) -> String
showEdge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k. MultiSet k -> [k]
MS.toList MultiSet (InnerEdge n)
pr

instance (Ord n, Hashable n) => Semigroup (Split n) where
  (SplitOp Map (Edge n) [(n, DoubleOrnament)]
rega Map (InnerEdge n) [(n, PassingOrnament)]
passa Map n [(n, RightOrnament)]
la Map n [(n, LeftOrnament)]
ra HashSet (Edge n)
kla HashSet (Edge n)
kra MultiSet (InnerEdge n)
pla MultiSet (InnerEdge n)
pra) <> :: Split n -> Split n -> Split n
<> (SplitOp Map (Edge n) [(n, DoubleOrnament)]
regb Map (InnerEdge n) [(n, PassingOrnament)]
passb Map n [(n, RightOrnament)]
lb Map n [(n, LeftOrnament)]
rb HashSet (Edge n)
klb HashSet (Edge n)
krb MultiSet (InnerEdge n)
plb MultiSet (InnerEdge n)
prb) =
    forall n.
Map (Edge n) [(n, DoubleOrnament)]
-> Map (InnerEdge n) [(n, PassingOrnament)]
-> Map n [(n, RightOrnament)]
-> Map n [(n, LeftOrnament)]
-> HashSet (Edge n)
-> HashSet (Edge n)
-> MultiSet (InnerEdge n)
-> MultiSet (InnerEdge n)
-> Split n
SplitOp
      (Map (Edge n) [(n, DoubleOrnament)]
rega forall k a. (Ord k, Semigroup a) => Map k a -> Map k a -> Map k a
<+> Map (Edge n) [(n, DoubleOrnament)]
regb)
      (Map (InnerEdge n) [(n, PassingOrnament)]
passa forall k a. (Ord k, Semigroup a) => Map k a -> Map k a -> Map k a
<+> Map (InnerEdge n) [(n, PassingOrnament)]
passb)
      (Map n [(n, RightOrnament)]
la forall k a. (Ord k, Semigroup a) => Map k a -> Map k a -> Map k a
<+> Map n [(n, RightOrnament)]
lb)
      (Map n [(n, LeftOrnament)]
ra forall k a. (Ord k, Semigroup a) => Map k a -> Map k a -> Map k a
<+> Map n [(n, LeftOrnament)]
rb)
      (forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.union HashSet (Edge n)
kla HashSet (Edge n)
klb)
      (forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.union HashSet (Edge n)
kra HashSet (Edge n)
krb)
      (forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.union MultiSet (InnerEdge n)
pla MultiSet (InnerEdge n)
plb)
      (forall a.
(Eq a, Hashable a) =>
MultiSet a -> MultiSet a -> MultiSet a
MS.union MultiSet (InnerEdge n)
pra MultiSet (InnerEdge n)
prb)
   where
    (<+>) :: (Ord k, Semigroup a) => M.Map k a -> M.Map k a -> M.Map k a
    <+> :: forall k a. (Ord k, Semigroup a) => Map k a -> Map k a -> Map k a
(<+>) = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Semigroup a => a -> a -> a
(<>)

instance (Ord n, Hashable n) => Monoid (Split n) where
  mempty :: Split n
mempty =
    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. Map k a
M.empty forall a. HashSet a
S.empty forall a. HashSet a
S.empty forall a. MultiSet a
MS.empty forall a. MultiSet a
MS.empty

instance (Notation n, Ord n, Hashable n) => FromJSON (Split n) where
  parseJSON :: Value -> Parser (Split n)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Split" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    [(Edge n, [(n, DoubleOrnament)])]
regular <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"regular" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall o p.
(Notation n, FromJSON o) =>
(Value -> Parser p) -> Value -> Parser (p, [(n, o)])
parseElaboration forall n. Notation n => Value -> Parser (StartStop n, StartStop n)
parseEdge)
    [(InnerEdge n, [(n, PassingOrnament)])]
passing <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"passing" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall o p.
(Notation n, FromJSON o) =>
(Value -> Parser p) -> Value -> Parser (p, [(n, o)])
parseElaboration forall n. Notation n => Value -> Parser (n, n)
parseInnerEdge)
    [(n, [(n, RightOrnament)])]
fromL <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"fromLeft" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall o p.
(Notation n, FromJSON o) =>
(Value -> Parser p) -> Value -> Parser (p, [(n, o)])
parseElaboration forall n. Notation n => Value -> Parser n
parseJSONNote)
    [(n, [(n, LeftOrnament)])]
fromR <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"fromRight" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall o p.
(Notation n, FromJSON o) =>
(Value -> Parser p) -> Value -> Parser (p, [(n, o)])
parseElaboration forall n. Notation n => Value -> Parser n
parseJSONNote)
    [Edge n]
keepL <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"keepLeft" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n. Notation n => Value -> Parser (StartStop n, StartStop n)
parseEdge
    [Edge n]
keepR <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"keepRight" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n. Notation n => Value -> Parser (StartStop n, StartStop n)
parseEdge
    [InnerEdge n]
passL <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"passLeft" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n. Notation n => Value -> Parser (n, n)
parseInnerEdge
    [InnerEdge n]
passR <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"passRight" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n. Notation n => Value -> Parser (n, n)
parseInnerEdge
    pure $
      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. Ord k => [(k, a)] -> Map k a
M.fromList [(Edge n, [(n, DoubleOrnament)])]
regular)
        (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(InnerEdge n, [(n, PassingOrnament)])]
passing)
        (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(n, [(n, RightOrnament)])]
fromL)
        (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(n, [(n, LeftOrnament)])]
fromR)
        (forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Edge n]
keepL)
        (forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Edge n]
keepR)
        (forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList ([InnerEdge n]
passL :: [InnerEdge n]))
        (forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList ([InnerEdge n]
passR :: [InnerEdge n]))
   where
    parseElaboration
      :: (Notation n, FromJSON o)
      => (Aeson.Value -> Aeson.Parser p)
      -> Aeson.Value
      -> Aeson.Parser (p, [(n, o)])
    parseElaboration :: forall o p.
(Notation n, FromJSON o) =>
(Value -> Parser p) -> Value -> Parser (p, [(n, o)])
parseElaboration Value -> Parser p
parseParent = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Elaboration" forall a b. (a -> b) -> a -> b
$ \Object
reg -> do
      p
parent <- Object
reg forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"parent" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser p
parseParent
      [(n, o)]
children <- Object
reg forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"children" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall o. (Notation n, FromJSON o) => Value -> Parser (n, o)
parseChild
      pure (p
parent, [(n, o)]
children)
    parseChild
      :: (Notation n, FromJSON o) => Aeson.Value -> Aeson.Parser (n, o)
    parseChild :: forall o. (Notation n, FromJSON o) => Value -> Parser (n, o)
parseChild = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Child" forall a b. (a -> b) -> a -> b
$ \Object
cld -> do
      n
child <- Object
cld forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"child" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall n. Notation n => Value -> Parser n
parseJSONNote
      o
orn <- Object
cld forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"orn"
      pure (n
child, o
orn)

{- | Represents a freeze operation.
 Since this just ties all remaining edges
 (which must all be repetitions)
 no decisions have to be encoded.
-}
data Freeze = FreezeOp
  deriving (Freeze -> Freeze -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Freeze -> Freeze -> Bool
$c/= :: Freeze -> Freeze -> Bool
== :: Freeze -> Freeze -> Bool
$c== :: Freeze -> Freeze -> Bool
Eq, Eq Freeze
Freeze -> Freeze -> Bool
Freeze -> Freeze -> Ordering
Freeze -> Freeze -> Freeze
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Freeze -> Freeze -> Freeze
$cmin :: Freeze -> Freeze -> Freeze
max :: Freeze -> Freeze -> Freeze
$cmax :: Freeze -> Freeze -> Freeze
>= :: Freeze -> Freeze -> Bool
$c>= :: Freeze -> Freeze -> Bool
> :: Freeze -> Freeze -> Bool
$c> :: Freeze -> Freeze -> Bool
<= :: Freeze -> Freeze -> Bool
$c<= :: Freeze -> Freeze -> Bool
< :: Freeze -> Freeze -> Bool
$c< :: Freeze -> Freeze -> Bool
compare :: Freeze -> Freeze -> Ordering
$ccompare :: Freeze -> Freeze -> Ordering
Ord, forall x. Rep Freeze x -> Freeze
forall x. Freeze -> Rep Freeze x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Freeze x -> Freeze
$cfrom :: forall x. Freeze -> Rep Freeze x
Generic, Freeze -> ()
forall a. (a -> ()) -> NFData a
rnf :: Freeze -> ()
$crnf :: Freeze -> ()
NFData)

instance Show Freeze where
  show :: Freeze -> String
show Freeze
_ = String
"()"

instance FromJSON Freeze where
  parseJSON :: Value -> Parser Freeze
parseJSON Value
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Freeze
FreezeOp

{- | Encodes the distribution of a pitch in a spread.

 All instances of a pitch must be either moved completely to the left or the right (or both).
 In addition, some instances may be repeated on the other side.
 The difference is indicated by the field of the 'ToLeft' and 'ToRight' constructors.
 For example, @ToLeft 3@ indicates that out of @n@ instances,
 all @n@ are moved to the left and @n-3@ are replicated on the right.
-}
data SpreadDirection
  = -- | all to the left, n fewer to the right
    ToLeft !Int
  | -- | all to the right, n fewer to the left
    ToRight !Int
  | -- | all to both
    ToBoth
  deriving (SpreadDirection -> SpreadDirection -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpreadDirection -> SpreadDirection -> Bool
$c/= :: SpreadDirection -> SpreadDirection -> Bool
== :: SpreadDirection -> SpreadDirection -> Bool
$c== :: SpreadDirection -> SpreadDirection -> Bool
Eq, Eq SpreadDirection
SpreadDirection -> SpreadDirection -> Bool
SpreadDirection -> SpreadDirection -> Ordering
SpreadDirection -> SpreadDirection -> SpreadDirection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SpreadDirection -> SpreadDirection -> SpreadDirection
$cmin :: SpreadDirection -> SpreadDirection -> SpreadDirection
max :: SpreadDirection -> SpreadDirection -> SpreadDirection
$cmax :: SpreadDirection -> SpreadDirection -> SpreadDirection
>= :: SpreadDirection -> SpreadDirection -> Bool
$c>= :: SpreadDirection -> SpreadDirection -> Bool
> :: SpreadDirection -> SpreadDirection -> Bool
$c> :: SpreadDirection -> SpreadDirection -> Bool
<= :: SpreadDirection -> SpreadDirection -> Bool
$c<= :: SpreadDirection -> SpreadDirection -> Bool
< :: SpreadDirection -> SpreadDirection -> Bool
$c< :: SpreadDirection -> SpreadDirection -> Bool
compare :: SpreadDirection -> SpreadDirection -> Ordering
$ccompare :: SpreadDirection -> SpreadDirection -> Ordering
Ord, Int -> SpreadDirection -> ShowS
[SpreadDirection] -> ShowS
SpreadDirection -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpreadDirection] -> ShowS
$cshowList :: [SpreadDirection] -> ShowS
show :: SpreadDirection -> String
$cshow :: SpreadDirection -> String
showsPrec :: Int -> SpreadDirection -> ShowS
$cshowsPrec :: Int -> SpreadDirection -> ShowS
Show, forall x. Rep SpreadDirection x -> SpreadDirection
forall x. SpreadDirection -> Rep SpreadDirection x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SpreadDirection x -> SpreadDirection
$cfrom :: forall x. SpreadDirection -> Rep SpreadDirection x
Generic, SpreadDirection -> ()
forall a. (a -> ()) -> NFData a
rnf :: SpreadDirection -> ()
$crnf :: SpreadDirection -> ()
NFData)

instance Semigroup SpreadDirection where
  ToLeft Int
l1 <> :: SpreadDirection -> SpreadDirection -> SpreadDirection
<> ToLeft Int
l2 = Int -> SpreadDirection
ToLeft (Int
l1 forall a. Num a => a -> a -> a
+ Int
l2)
  ToRight Int
l1 <> ToRight Int
l2 = Int -> SpreadDirection
ToLeft (Int
l1 forall a. Num a => a -> a -> a
+ Int
l2)
  ToLeft Int
l <> ToRight Int
r
    | Int
l forall a. Eq a => a -> a -> Bool
== Int
r = SpreadDirection
ToBoth
    | Int
l forall a. Ord a => a -> a -> Bool
< Int
r = Int -> SpreadDirection
ToRight (Int
r forall a. Num a => a -> a -> a
- Int
l)
    | Bool
otherwise = Int -> SpreadDirection
ToLeft (Int
l forall a. Num a => a -> a -> a
- Int
r)
  SpreadDirection
ToBoth <> SpreadDirection
other = SpreadDirection
other
  SpreadDirection
a <> SpreadDirection
b = SpreadDirection
b forall a. Semigroup a => a -> a -> a
<> SpreadDirection
a

instance Monoid SpreadDirection where
  mempty :: SpreadDirection
mempty = SpreadDirection
ToBoth

{- | Represents a spread operation.
 Records for every pitch how it is distributed (see 'SpreadDirection').
 The resulting edges (repetitions and passing edges) are represented in a child transition.
-}
data Spread n = SpreadOp !(HM.HashMap n SpreadDirection) !(Edges n)
  deriving (Spread n -> Spread n -> Bool
forall n. Eq n => Spread n -> Spread n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Spread n -> Spread n -> Bool
$c/= :: forall n. Eq n => Spread n -> Spread n -> Bool
== :: Spread n -> Spread n -> Bool
$c== :: forall n. Eq n => Spread n -> Spread n -> Bool
Eq, Spread n -> Spread n -> Bool
Spread n -> Spread n -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {n}. Ord n => Eq (Spread n)
forall n. Ord n => Spread n -> Spread n -> Bool
forall n. Ord n => Spread n -> Spread n -> Ordering
forall n. Ord n => Spread n -> Spread n -> Spread n
min :: Spread n -> Spread n -> Spread n
$cmin :: forall n. Ord n => Spread n -> Spread n -> Spread n
max :: Spread n -> Spread n -> Spread n
$cmax :: forall n. Ord n => Spread n -> Spread n -> Spread n
>= :: Spread n -> Spread n -> Bool
$c>= :: forall n. Ord n => Spread n -> Spread n -> Bool
> :: Spread n -> Spread n -> Bool
$c> :: forall n. Ord n => Spread n -> Spread n -> Bool
<= :: Spread n -> Spread n -> Bool
$c<= :: forall n. Ord n => Spread n -> Spread n -> Bool
< :: Spread n -> Spread n -> Bool
$c< :: forall n. Ord n => Spread n -> Spread n -> Bool
compare :: Spread n -> Spread n -> Ordering
$ccompare :: forall n. Ord n => Spread n -> Spread n -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall n x. Rep (Spread n) x -> Spread n
forall n x. Spread n -> Rep (Spread n) x
$cto :: forall n x. Rep (Spread n) x -> Spread n
$cfrom :: forall n x. Spread n -> Rep (Spread n) x
Generic, forall n. NFData n => Spread n -> ()
forall a. (a -> ()) -> NFData a
rnf :: Spread n -> ()
$crnf :: forall n. NFData n => Spread n -> ()
NFData)

instance (Notation n) => Show (Spread n) where
  show :: Spread n -> String
show (SpreadOp HashMap n SpreadDirection
dist Edges n
m) = String
"{" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," [String]
dists forall a. Semigroup a => a -> a -> a
<> String
"} => " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Edges n
m
   where
    dists :: [String]
dists = forall {i} {a}. (Notation i, Show a) => (i, a) -> String
showDist forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap n SpreadDirection
dist
    showDist :: (i, a) -> String
showDist (i
p, a
to) = forall i. Notation i => i -> String
showNotation i
p forall a. Semigroup a => a -> a -> a
<> String
"=>" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
to

instance (Notation n, Eq n, Hashable n) => FromJSON (Spread n) where
  parseJSON :: Value -> Parser (Spread n)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Spread" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    [(n, SpreadDirection)]
dists <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"children" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Parser (n, SpreadDirection)
parseDist
    Edges n
edges <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"midEdges"
    pure $ forall n. HashMap n SpreadDirection -> Edges n -> Spread n
SpreadOp (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HM.fromListWith forall a. Semigroup a => a -> a -> a
(<>) [(n, SpreadDirection)]
dists) Edges n
edges
   where
    parseDist :: Value -> Parser (n, SpreadDirection)
parseDist = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"SpreadDist" forall a b. (a -> b) -> a -> b
$ \Object
dst -> do
      n
parent <- Object
dst forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"parent" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall n. Notation n => Value -> Parser n
parseJSONNote
      SpreadDirection
child <- Object
dst forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"child" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser SpreadDirection
parseChild
      pure (n
parent, SpreadDirection
child)
    parseChild :: Value -> Parser SpreadDirection
parseChild = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"SpreadChild" forall a b. (a -> b) -> a -> b
$ \Object
cld -> do
      Value
typ <- Object
cld forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
      case Value
typ of
        Value
"leftChild" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> SpreadDirection
ToLeft Int
1
        Value
"rightChild" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> SpreadDirection
ToRight Int
1
        Value
"bothChildren" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SpreadDirection
ToBoth
        Value
_ -> forall a. Value -> Parser a
Aeson.unexpected Value
typ

-- | 'Leftmost' specialized to the split, freeze, and spread operations of the grammar.
type PVLeftmost n = Leftmost (Split n) Freeze (Spread n)

-- helpers
-- =======

-- | Helper: parses a note's pitch from JSON.
parseJSONNote :: Notation n => Aeson.Value -> Aeson.Parser n
parseJSONNote :: forall n. Notation n => Value -> Parser n
parseJSONNote = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Note" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
  String
pitch <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pitch"
  case forall i. Notation i => String -> Maybe i
readNotation String
pitch of
    Just n
p -> forall (f :: * -> *) a. Applicative f => a -> f a
pure n
p
    Maybe n
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Could not parse pitch " forall a. Semigroup a => a -> a -> a
<> String
pitch

-- | Helper: parses an edge from JSON.
parseEdge
  :: Notation n => Aeson.Value -> Aeson.Parser (StartStop n, StartStop n)
parseEdge :: forall n. Notation n => Value -> Parser (StartStop n, StartStop n)
parseEdge = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Edge" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
  StartStop n
l <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"left" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n. Notation n => Value -> Parser n
parseJSONNote -- TODO: this might be broken wrt. StartStop
  StartStop n
r <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"right" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n. Notation n => Value -> Parser n
parseJSONNote
  pure (StartStop n
l, StartStop n
r)

-- | Helper: parses an inner edge from JSON
parseInnerEdge :: Notation n => Aeson.Value -> Aeson.Parser (n, n)
parseInnerEdge :: forall n. Notation n => Value -> Parser (n, n)
parseInnerEdge = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"InnerEdge" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
  StartStop Value
l <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"left"
  StartStop Value
r <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"right"
  case (StartStop Value
l, StartStop Value
r) of
    (Inner Value
il, Inner Value
ir) -> do
      n
pl <- forall n. Notation n => Value -> Parser n
parseJSONNote Value
il
      n
pr <- forall n. Notation n => Value -> Parser n
parseJSONNote Value
ir
      pure (n
pl, n
pr)
    (StartStop Value, StartStop Value)
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Edge is not an inner edge"

-- | An 'Analysis' specialized to PV types.
type PVAnalysis n = Analysis (Split n) Freeze (Spread n) (Edges n) (Notes n)

{- | Loads an analysis from a JSON file
 (as exported by the annotation tool).
-}
loadAnalysis :: FilePath -> IO (Either String (PVAnalysis SPitch))
loadAnalysis :: String -> IO (Either String (PVAnalysis SPitch))
loadAnalysis = forall a. FromJSON a => String -> IO (Either String a)
Aeson.eitherDecodeFileStrict

{- | Loads an analysis from a JSON file
 (as exported by the annotation tool).
 Converts all pitches to pitch classes.
-}
loadAnalysis' :: FilePath -> IO (Either String (PVAnalysis SPC))
loadAnalysis' :: String -> IO (Either String (PVAnalysis SPC))
loadAnalysis' String
fn = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall n' n.
(Eq n', Hashable n', Ord n') =>
(n -> n') -> PVAnalysis n -> PVAnalysis n'
analysisMapPitch (forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc @SInterval)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either String (PVAnalysis SPitch))
loadAnalysis String
fn

{- | Loads a MusicXML file and returns a list of salami slices.
 Each note is expressed as a pitch and a flag that indicates
 whether the note continues in the next slice.
-}
slicesFromFile :: FilePath -> IO [[(SPitch, Music.RightTied)]]
slicesFromFile :: String -> IO [[(SPitch, RightTied)]]
slicesFromFile String
file = do
  Text
txt <- String -> IO Text
TL.readFile String
file
  case Text -> Maybe Document
MusicXML.parseWithoutIds Text
txt of
    Maybe Document
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just Document
doc -> do
      let ([XmlNote]
xmlNotes, [[(Ratio Int, TimeSignature)]]
_) = Document -> ([XmlNote], [[(Ratio Int, TimeSignature)]])
MusicXML.parseScore Document
doc
          notes :: [Note SInterval (Ratio Int)]
notes = XmlNote -> Note SInterval (Ratio Int)
MusicXML.asNoteHeard forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [XmlNote]
xmlNotes
          slices :: [[(Note SInterval (Ratio Int), Tied)]]
slices = forall (f :: * -> *) n st s.
(Foldable f, HasTime n) =>
Slicer n (TimeOf n) st s -> f n -> [s]
Music.slicePiece forall a t. Eq a => Slicer a t ([a], [a]) [(a, Tied)]
Music.tiedSlicer [Note SInterval (Ratio Int)]
notes
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *} {a}.
(Functor f, HasPitch a) =>
f (a, Tied) -> f (Pitch (IntervalOf a), RightTied)
mkSlice forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[(Note SInterval (Ratio Int), Tied)]]
slices
 where
  mkSlice :: f (a, Tied) -> f (Pitch (IntervalOf a), RightTied)
mkSlice f (a, Tied)
notes = forall {a}.
HasPitch a =>
(a, Tied) -> (Pitch (IntervalOf a), RightTied)
mkNote forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, Tied)
notes
  mkNote :: (a, Tied) -> (Pitch (IntervalOf a), RightTied)
mkNote (a
note, Tied
tie) = (forall a. HasPitch a => a -> Pitch (IntervalOf a)
Music.pitch a
note, Tied -> RightTied
Music.rightTie Tied
tie)

-- | Converts salami slices (as returned by 'slicesFromFile') to a path as expected by parsers.
slicesToPath
  :: (Interval i, Ord i, Eq i)
  => [[(Pitch i, Music.RightTied)]]
  -> Path [Pitch i] [Edge (Pitch i)]
slicesToPath :: forall i.
(Interval i, Ord i, Eq i) =>
[[(Pitch i, RightTied)]] -> Path [Pitch i] [Edge (Pitch i)]
slicesToPath = forall {a}.
[[(a, RightTied)]] -> Path [a] [(StartStop a, StartStop a)]
go
 where
  -- normalizeTies (s : next : rest) = (fixTie <$> s)
  --   : normalizeTies (next : rest)
  --  where
  --   nextNotes = fst <$> next
  --   fixTie (p, t) = if p `L.elem` nextNotes then (p, t) else (p, Ends)
  -- normalizeTies [s] = [map (fmap $ const Ends) s]
  -- normalizeTies []  = []
  mkSlice :: [(b, b)] -> [b]
mkSlice = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst
  mkEdges :: [(a, RightTied)] -> [(StartStop a, StartStop a)]
mkEdges = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. (a, RightTied) -> Maybe (StartStop a, StartStop a)
mkEdge
   where
    mkEdge :: (a, RightTied) -> Maybe (StartStop a, StartStop a)
mkEdge (a
_, RightTied
Music.Ends) = forall a. Maybe a
Nothing
    mkEdge (a
p, RightTied
Music.Holds) = forall a. a -> Maybe a
Just (forall a. a -> StartStop a
Inner a
p, forall a. a -> StartStop a
Inner a
p)
  go :: [[(a, RightTied)]] -> Path [a] [(StartStop a, StartStop a)]
go [] = forall a. HasCallStack => String -> a
error String
"cannot construct path from empty list"
  go [[(a, RightTied)]
notes] = forall around between. around -> Path around between
PathEnd (forall {b} {b}. [(b, b)] -> [b]
mkSlice [(a, RightTied)]
notes)
  go ([(a, RightTied)]
notes : [[(a, RightTied)]]
rest) = forall around between.
around -> between -> Path around between -> Path around between
Path (forall {b} {b}. [(b, b)] -> [b]
mkSlice [(a, RightTied)]
notes) (forall {a}. [(a, RightTied)] -> [(StartStop a, StartStop a)]
mkEdges [(a, RightTied)]
notes) forall a b. (a -> b) -> a -> b
$ [[(a, RightTied)]] -> Path [a] [(StartStop a, StartStop a)]
go [[(a, RightTied)]]
rest

{- | Loads a MusicXML File and returns a surface path
 as input to parsers.
-}
loadSurface :: FilePath -> IO (Path [Pitch SInterval] [Edge (Pitch SInterval)])
loadSurface :: String -> IO (Path [SPitch] [Edge SPitch])
loadSurface = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall i.
(Interval i, Ord i, Eq i) =>
[[(Pitch i, RightTied)]] -> Path [Pitch i] [Edge (Pitch i)]
slicesToPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO [[(SPitch, RightTied)]]
slicesFromFile

{- | Loads a MusicXML File
 and returns a surface path of the given range of slices.
-}
loadSurface'
  :: FilePath
  -- ^ path to a MusicXML file
  -> Int
  -- ^ the first slice to include (starting at 0)
  -> Int
  -- ^ the last slice to include
  -> IO (Path [Pitch SInterval] [Edge (Pitch SInterval)])
loadSurface' :: String -> Int -> Int -> IO (Path [SPitch] [Edge SPitch])
loadSurface' String
fn Int
from Int
to =
  forall i.
(Interval i, Ord i, Eq i) =>
[[(Pitch i, RightTied)]] -> Path [Pitch i] [Edge (Pitch i)]
slicesToPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
from forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take (Int
to forall a. Num a => a -> a -> a
- Int
from forall a. Num a => a -> a -> a
+ Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [[(SPitch, RightTied)]]
slicesFromFile String
fn

-- | Apply an applicative action to all pitches in an analysis.
analysisTraversePitch
  :: (Applicative f, Eq n', Hashable n', Ord n')
  => (n -> f n')
  -> PVAnalysis n
  -> f (PVAnalysis n')
analysisTraversePitch :: forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n', Ord n') =>
(n -> f n') -> PVAnalysis n -> f (PVAnalysis n')
analysisTraversePitch n -> f n'
f (Analysis [Leftmost (Split n) Freeze (Spread n)]
deriv Path (Edges n) (Notes n)
top) = do
  [Leftmost (Split n') Freeze (Spread n')]
deriv' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n', Ord n') =>
(n -> f n')
-> Leftmost (Split n) Freeze (Spread n)
-> f (Leftmost (Split n') Freeze (Spread n'))
leftmostTraversePitch n -> f n'
f) [Leftmost (Split n) Freeze (Spread n)]
deriv
  Path (Edges n') (Notes n')
top' <- forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n')
-> Path (Edges n) (Notes n) -> f (Path (Edges n') (Notes n'))
pathTraversePitch n -> f n'
f Path (Edges n) (Notes n)
top
  pure $ forall s f h tr slc.
[Leftmost s f h] -> Path tr slc -> Analysis s f h tr slc
Analysis [Leftmost (Split n') Freeze (Spread n')]
deriv' Path (Edges n') (Notes n')
top'

-- | Map a function over all pitches in an analysis.
analysisMapPitch
  :: (Eq n', Hashable n', Ord n') => (n -> n') -> PVAnalysis n -> PVAnalysis n'
analysisMapPitch :: forall n' n.
(Eq n', Hashable n', Ord n') =>
(n -> n') -> PVAnalysis n -> PVAnalysis n'
analysisMapPitch n -> n'
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n', Ord n') =>
(n -> f n') -> PVAnalysis n -> f (PVAnalysis n')
analysisTraversePitch (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> n'
f)

pathTraversePitch
  :: (Applicative f, Eq n', Hashable n')
  => (n -> f n')
  -> Path (Edges n) (Notes n)
  -> f (Path (Edges n') (Notes n'))
pathTraversePitch :: forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n')
-> Path (Edges n) (Notes n) -> f (Path (Edges n') (Notes n'))
pathTraversePitch n -> f n'
f (Path Edges n
e Notes n
a Path (Edges n) (Notes n)
rest) = do
  Edges n'
e' <- forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> Edges n -> f (Edges n')
edgesTraversePitch n -> f n'
f Edges n
e
  Notes n'
a' <- forall n (f :: * -> *) a.
(Eq n, Hashable n, Applicative f) =>
(a -> f n) -> Notes a -> f (Notes n)
notesTraversePitch n -> f n'
f Notes n
a
  Path (Edges n') (Notes n')
rest' <- forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n')
-> Path (Edges n) (Notes n) -> f (Path (Edges n') (Notes n'))
pathTraversePitch n -> f n'
f Path (Edges n) (Notes n)
rest
  pure $ forall around between.
around -> between -> Path around between -> Path around between
Path Edges n'
e' Notes n'
a' Path (Edges n') (Notes n')
rest'
pathTraversePitch n -> f n'
f (PathEnd Edges n
e) = forall around between. around -> Path around between
PathEnd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> Edges n -> f (Edges n')
edgesTraversePitch n -> f n'
f Edges n
e

traverseEdge :: Applicative f => (n -> f n') -> (n, n) -> f (n', n')
traverseEdge :: forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge n -> f n'
f (n
n1, n
n2) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> n -> f n'
f n
n1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> n -> f n'
f n
n2

traverseSet
  :: (Applicative f, Eq n', Hashable n')
  => (n -> f n')
  -> S.HashSet n
  -> f (S.HashSet n')
traverseSet :: forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet n -> f n'
f HashSet n
set = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse n -> f n'
f (forall a. HashSet a -> [a]
S.toList HashSet n
set)

notesTraversePitch
  :: (Eq n, Hashable n, Applicative f) => (a -> f n) -> Notes a -> f (Notes n)
notesTraversePitch :: forall n (f :: * -> *) a.
(Eq n, Hashable n, Applicative f) =>
(a -> f n) -> Notes a -> f (Notes n)
notesTraversePitch a -> f n
f (Notes MultiSet a
notes) = forall n. MultiSet n -> Notes n
Notes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b (f :: * -> *) a.
(Eq b, Hashable b, Applicative f) =>
(a -> f b) -> MultiSet a -> f (MultiSet b)
MS.traverse a -> f n
f MultiSet a
notes

edgesTraversePitch
  :: (Applicative f, Eq n', Hashable n')
  => (n -> f n')
  -> Edges n
  -> f (Edges n')
edgesTraversePitch :: forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> Edges n -> f (Edges n')
edgesTraversePitch n -> f n'
f (Edges HashSet (Edge n)
reg MultiSet (InnerEdge n)
pass) = do
  HashSet (StartStop n', StartStop n')
reg' <- forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet (forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse n -> f n'
f)) HashSet (Edge n)
reg
  MultiSet (n', n')
pass' <- forall b (f :: * -> *) a.
(Eq b, Hashable b, Applicative f) =>
(a -> f b) -> MultiSet a -> f (MultiSet b)
MS.traverse (forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge n -> f n'
f) MultiSet (InnerEdge n)
pass
  pure $ forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (StartStop n', StartStop n')
reg' MultiSet (n', n')
pass'

leftmostTraversePitch
  :: (Applicative f, Eq n', Hashable n', Ord n')
  => (n -> f n')
  -> Leftmost (Split n) Freeze (Spread n)
  -> f (Leftmost (Split n') Freeze (Spread n'))
leftmostTraversePitch :: forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n', Ord n') =>
(n -> f n')
-> Leftmost (Split n) Freeze (Spread n)
-> f (Leftmost (Split n') Freeze (Spread n'))
leftmostTraversePitch n -> f n'
f Leftmost (Split n) Freeze (Spread n)
lm = case Leftmost (Split n) Freeze (Spread n)
lm of
  LMSplitLeft Split n
s -> forall s f h. s -> Leftmost s f h
LMSplitLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) n n'.
(Applicative f, Ord n', Hashable n') =>
(n -> f n') -> Split n -> f (Split n')
splitTraversePitch n -> f n'
f Split n
s
  LMSplitRight Split n
s -> forall s f h. s -> Leftmost s f h
LMSplitRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) n n'.
(Applicative f, Ord n', Hashable n') =>
(n -> f n') -> Split n -> f (Split n')
splitTraversePitch n -> f n'
f Split n
s
  LMSplitOnly Split n
s -> forall s f h. s -> Leftmost s f h
LMSplitOnly forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) n n'.
(Applicative f, Ord n', Hashable n') =>
(n -> f n') -> Split n -> f (Split n')
splitTraversePitch n -> f n'
f Split n
s
  LMFreezeLeft Freeze
fr -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall f s h. f -> Leftmost s f h
LMFreezeLeft Freeze
fr
  LMFreezeOnly Freeze
fr -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall f s h. f -> Leftmost s f h
LMFreezeOnly Freeze
fr
  LMSpread Spread n
h -> forall h s f. h -> Leftmost s f h
LMSpread forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> Spread n -> f (Spread n')
spreadTraversePitch n -> f n'
f Spread n
h

splitTraversePitch
  :: forall f n n'
   . (Applicative f, Ord n', Hashable n')
  => (n -> f n')
  -> Split n
  -> f (Split n')
splitTraversePitch :: forall (f :: * -> *) n n'.
(Applicative f, Ord n', Hashable n') =>
(n -> f n') -> Split n -> f (Split n')
splitTraversePitch n -> f n'
f (SplitOp Map (Edge n) [(n, DoubleOrnament)]
reg Map (InnerEdge n) [(n, PassingOrnament)]
pass Map n [(n, RightOrnament)]
ls Map n [(n, LeftOrnament)]
rs HashSet (Edge n)
kl HashSet (Edge n)
kr MultiSet (InnerEdge n)
pl MultiSet (InnerEdge n)
pr) = do
  Map (StartStop n', StartStop n') [(n', DoubleOrnament)]
reg' <- forall p p' o.
Ord p' =>
(p -> f p') -> Map p [(n, o)] -> f (Map p' [(n', o)])
traverseElabo (forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse n -> f n'
f)) Map (Edge n) [(n, DoubleOrnament)]
reg
  Map (n', n') [(n', PassingOrnament)]
pass' <- forall p p' o.
Ord p' =>
(p -> f p') -> Map p [(n, o)] -> f (Map p' [(n', o)])
traverseElabo (forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge n -> f n'
f) Map (InnerEdge n) [(n, PassingOrnament)]
pass
  Map n' [(n', RightOrnament)]
ls' <- forall p p' o.
Ord p' =>
(p -> f p') -> Map p [(n, o)] -> f (Map p' [(n', o)])
traverseElabo n -> f n'
f Map n [(n, RightOrnament)]
ls
  Map n' [(n', LeftOrnament)]
rs' <- forall p p' o.
Ord p' =>
(p -> f p') -> Map p [(n, o)] -> f (Map p' [(n', o)])
traverseElabo n -> f n'
f Map n [(n, LeftOrnament)]
rs
  HashSet (StartStop n', StartStop n')
kl' <- forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet (forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse n -> f n'
f)) HashSet (Edge n)
kl
  HashSet (StartStop n', StartStop n')
kr' <- forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet (forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse n -> f n'
f)) HashSet (Edge n)
kr
  MultiSet (n', n')
pl' <- forall b (f :: * -> *) a.
(Eq b, Hashable b, Applicative f) =>
(a -> f b) -> MultiSet a -> f (MultiSet b)
MS.traverse (forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge n -> f n'
f) MultiSet (InnerEdge n)
pl
  MultiSet (n', n')
pr' <- forall b (f :: * -> *) a.
(Eq b, Hashable b, Applicative f) =>
(a -> f b) -> MultiSet a -> f (MultiSet b)
MS.traverse (forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge n -> f n'
f) MultiSet (InnerEdge n)
pr
  pure $ forall n.
Map (Edge n) [(n, DoubleOrnament)]
-> Map (InnerEdge n) [(n, PassingOrnament)]
-> Map n [(n, RightOrnament)]
-> Map n [(n, LeftOrnament)]
-> HashSet (Edge n)
-> HashSet (Edge n)
-> MultiSet (InnerEdge n)
-> MultiSet (InnerEdge n)
-> Split n
SplitOp Map (StartStop n', StartStop n') [(n', DoubleOrnament)]
reg' Map (n', n') [(n', PassingOrnament)]
pass' Map n' [(n', RightOrnament)]
ls' Map n' [(n', LeftOrnament)]
rs' HashSet (StartStop n', StartStop n')
kl' HashSet (StartStop n', StartStop n')
kr' MultiSet (n', n')
pl' MultiSet (n', n')
pr'
 where
  traverseElabo
    :: forall p p' o
     . (Ord p')
    => (p -> f p')
    -> M.Map p [(n, o)]
    -> f (M.Map p' [(n', o)])
  traverseElabo :: forall p p' o.
Ord p' =>
(p -> f p') -> Map p [(n, o)] -> f (Map p' [(n', o)])
traverseElabo p -> f p'
fparent Map p [(n, o)]
mp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall k a. Map k a -> [(k, a)]
M.toList Map p [(n, o)]
mp) forall a b. (a -> b) -> a -> b
$ \(p
e, [(n, o)]
cs) ->
    do
      p'
e' <- p -> f p'
fparent p
e
      [(n', o)]
cs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(n
n, o
o) -> (,o
o) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> n -> f n'
f n
n) [(n, o)]
cs
      pure (p'
e', [(n', o)]
cs')

spreadTraversePitch
  :: (Applicative f, Eq n', Hashable n')
  => (n -> f n')
  -> Spread n
  -> f (Spread n')
spreadTraversePitch :: forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> Spread n -> f (Spread n')
spreadTraversePitch n -> f n'
f (SpreadOp HashMap n SpreadDirection
dist Edges n
edges) = do
  [(n', SpreadDirection)]
dist' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(n
k, SpreadDirection
v) -> (,SpreadDirection
v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> n -> f n'
f n
k) forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap n SpreadDirection
dist
  Edges n'
edges' <- forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> Edges n -> f (Edges n')
edgesTraversePitch n -> f n'
f Edges n
edges
  pure $ forall n. HashMap n SpreadDirection -> Edges n -> Spread n
SpreadOp (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HM.fromListWith forall a. Semigroup a => a -> a -> a
(<>) [(n', SpreadDirection)]
dist') Edges n'
edges'