{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# 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

    -- ** Note: a pitch with an ID.
    Note (..)

    -- ** 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 (..)
  , SpreadChildren (..)
  , leftSpreadChild
  , rightSpreadChild

    -- * 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.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.List.Extra qualified as L
import Data.Map.Strict qualified as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String (IsString (..))
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

-- ** Note type: pitch + ID

-- | A note with a pitch and an ID.
data Note n = Note {forall n. Note n -> n
notePitch :: n, forall n. Note n -> String
noteId :: String}
  deriving (Note n -> Note n -> Bool
(Note n -> Note n -> Bool)
-> (Note n -> Note n -> Bool) -> Eq (Note n)
forall n. Eq n => Note n -> Note n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall n. Eq n => Note n -> Note n -> Bool
== :: Note n -> Note n -> Bool
$c/= :: forall n. Eq n => Note n -> Note n -> Bool
/= :: Note n -> Note n -> Bool
Eq, Eq (Note n)
Eq (Note n) =>
(Note n -> Note n -> Ordering)
-> (Note n -> Note n -> Bool)
-> (Note n -> Note n -> Bool)
-> (Note n -> Note n -> Bool)
-> (Note n -> Note n -> Bool)
-> (Note n -> Note n -> Note n)
-> (Note n -> Note n -> Note n)
-> Ord (Note n)
Note n -> Note n -> Bool
Note n -> Note n -> Ordering
Note n -> Note n -> Note 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 (Note n)
forall n. Ord n => Note n -> Note n -> Bool
forall n. Ord n => Note n -> Note n -> Ordering
forall n. Ord n => Note n -> Note n -> Note n
$ccompare :: forall n. Ord n => Note n -> Note n -> Ordering
compare :: Note n -> Note n -> Ordering
$c< :: forall n. Ord n => Note n -> Note n -> Bool
< :: Note n -> Note n -> Bool
$c<= :: forall n. Ord n => Note n -> Note n -> Bool
<= :: Note n -> Note n -> Bool
$c> :: forall n. Ord n => Note n -> Note n -> Bool
> :: Note n -> Note n -> Bool
$c>= :: forall n. Ord n => Note n -> Note n -> Bool
>= :: Note n -> Note n -> Bool
$cmax :: forall n. Ord n => Note n -> Note n -> Note n
max :: Note n -> Note n -> Note n
$cmin :: forall n. Ord n => Note n -> Note n -> Note n
min :: Note n -> Note n -> Note n
Ord, (forall a b. (a -> b) -> Note a -> Note b)
-> (forall a b. a -> Note b -> Note a) -> Functor Note
forall a b. a -> Note b -> Note a
forall a b. (a -> b) -> Note a -> Note b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Note a -> Note b
fmap :: forall a b. (a -> b) -> Note a -> Note b
$c<$ :: forall a b. a -> Note b -> Note a
<$ :: forall a b. a -> Note b -> Note a
Functor, (forall m. Monoid m => Note m -> m)
-> (forall m a. Monoid m => (a -> m) -> Note a -> m)
-> (forall m a. Monoid m => (a -> m) -> Note a -> m)
-> (forall a b. (a -> b -> b) -> b -> Note a -> b)
-> (forall a b. (a -> b -> b) -> b -> Note a -> b)
-> (forall b a. (b -> a -> b) -> b -> Note a -> b)
-> (forall b a. (b -> a -> b) -> b -> Note a -> b)
-> (forall a. (a -> a -> a) -> Note a -> a)
-> (forall a. (a -> a -> a) -> Note a -> a)
-> (forall a. Note a -> [a])
-> (forall a. Note a -> Bool)
-> (forall a. Note a -> Int)
-> (forall a. Eq a => a -> Note a -> Bool)
-> (forall a. Ord a => Note a -> a)
-> (forall a. Ord a => Note a -> a)
-> (forall a. Num a => Note a -> a)
-> (forall a. Num a => Note a -> a)
-> Foldable Note
forall a. Eq a => a -> Note a -> Bool
forall a. Num a => Note a -> a
forall a. Ord a => Note a -> a
forall m. Monoid m => Note m -> m
forall a. Note a -> Bool
forall a. Note a -> Int
forall a. Note a -> [a]
forall a. (a -> a -> a) -> Note a -> a
forall m a. Monoid m => (a -> m) -> Note a -> m
forall b a. (b -> a -> b) -> b -> Note a -> b
forall a b. (a -> b -> b) -> b -> Note a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Note m -> m
fold :: forall m. Monoid m => Note m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Note a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Note a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Note a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Note a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Note a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Note a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Note a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Note a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Note a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Note a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Note a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Note a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Note a -> a
foldr1 :: forall a. (a -> a -> a) -> Note a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Note a -> a
foldl1 :: forall a. (a -> a -> a) -> Note a -> a
$ctoList :: forall a. Note a -> [a]
toList :: forall a. Note a -> [a]
$cnull :: forall a. Note a -> Bool
null :: forall a. Note a -> Bool
$clength :: forall a. Note a -> Int
length :: forall a. Note a -> Int
$celem :: forall a. Eq a => a -> Note a -> Bool
elem :: forall a. Eq a => a -> Note a -> Bool
$cmaximum :: forall a. Ord a => Note a -> a
maximum :: forall a. Ord a => Note a -> a
$cminimum :: forall a. Ord a => Note a -> a
minimum :: forall a. Ord a => Note a -> a
$csum :: forall a. Num a => Note a -> a
sum :: forall a. Num a => Note a -> a
$cproduct :: forall a. Num a => Note a -> a
product :: forall a. Num a => Note a -> a
Foldable, Functor Note
Foldable Note
(Functor Note, Foldable Note) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Note a -> f (Note b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Note (f a) -> f (Note a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Note a -> m (Note b))
-> (forall (m :: * -> *) a. Monad m => Note (m a) -> m (Note a))
-> Traversable Note
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Note (m a) -> m (Note a)
forall (f :: * -> *) a. Applicative f => Note (f a) -> f (Note a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Note a -> m (Note b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Note (f a) -> f (Note a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Note (f a) -> f (Note a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Note a -> m (Note b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Note a -> m (Note b)
$csequence :: forall (m :: * -> *) a. Monad m => Note (m a) -> m (Note a)
sequence :: forall (m :: * -> *) a. Monad m => Note (m a) -> m (Note a)
Traversable, (forall x. Note n -> Rep (Note n) x)
-> (forall x. Rep (Note n) x -> Note n) -> Generic (Note n)
forall x. Rep (Note n) x -> Note n
forall x. Note n -> Rep (Note n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall n x. Rep (Note n) x -> Note n
forall n x. Note n -> Rep (Note n) x
$cfrom :: forall n x. Note n -> Rep (Note n) x
from :: forall x. Note n -> Rep (Note n) x
$cto :: forall n x. Rep (Note n) x -> Note n
to :: forall x. Rep (Note n) x -> Note n
Generic)
  deriving anyclass (Note n -> ()
(Note n -> ()) -> NFData (Note n)
forall n. NFData n => Note n -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall n. NFData n => Note n -> ()
rnf :: Note n -> ()
NFData, Eq (Note n)
Eq (Note n) =>
(Int -> Note n -> Int) -> (Note n -> Int) -> Hashable (Note n)
Int -> Note n -> Int
Note n -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall n. Hashable n => Eq (Note n)
forall n. Hashable n => Int -> Note n -> Int
forall n. Hashable n => Note n -> Int
$chashWithSalt :: forall n. Hashable n => Int -> Note n -> Int
hashWithSalt :: Int -> Note n -> Int
$chash :: forall n. Hashable n => Note n -> Int
hash :: Note n -> Int
Hashable)

instance (Notation n) => Show (Note n) where
  show :: Note n -> String
show (Note n
p String
i) = n -> String
forall i. Notation i => i -> String
showNotation n
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
i

instance (Notation n) => FromJSON (Note n) where
  parseJSON :: Value -> Parser (Note n)
parseJSON = String -> (Object -> Parser (Note n)) -> Value -> Parser (Note n)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Note" ((Object -> Parser (Note n)) -> Value -> Parser (Note n))
-> (Object -> Parser (Note n)) -> Value -> Parser (Note n)
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    String
pitch <- Object
v Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pitch"
    String
i <- Object
v Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id"
    case String -> Maybe n
forall i. Notation i => String -> Maybe i
readNotation String
pitch of
      Just n
p -> Note n -> Parser (Note n)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note n -> Parser (Note n)) -> Note n -> Parser (Note n)
forall a b. (a -> b) -> a -> b
$ n -> String -> Note n
forall n. n -> String -> Note n
Note n
p String
i
      Maybe n
Nothing -> String -> Parser (Note n)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Note n)) -> String -> Parser (Note n)
forall a b. (a -> b) -> a -> b
$ String
"Could not parse pitch " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
pitch

instance (Notation n) => ToJSON (Note n) where
  toJSON :: Note n -> Value
toJSON (Note n
p String
i) = [Pair] -> Value
Aeson.object [Key
"pitch" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= n -> String
forall i. Notation i => i -> String
showNotation n
p, Key
"id" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
i]
  toEncoding :: Note n -> Encoding
toEncoding (Note n
p String
i) = Series -> Encoding
Aeson.pairs (Key
"pitch" Key -> String -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= n -> String
forall i. Notation i => i -> String
showNotation n
p Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"id" Key -> String -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
i)

{- | Lets you write a Note as a string literal with OverloadedStrings.
Pitch and ID are separate by a @.@ (the ID may contain more @.@s).
-}
instance (Notation n) => IsString (Note n) where
  fromString :: String -> Note n
fromString String
str = Note n -> Maybe (Note n) -> Note n
forall a. a -> Maybe a -> a
fromMaybe (String -> Note n
forall a. HasCallStack => String -> a
error (String -> Note n) -> String -> Note n
forall a b. (a -> b) -> a -> b
$ String
"cannot parse note literal " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
str) (Maybe (Note n) -> Note n) -> Maybe (Note n) -> Note n
forall a b. (a -> b) -> a -> b
$ do
    (String
pstr, [String]
idParts) <- [String] -> Maybe (String, [String])
forall a. [a] -> Maybe (a, [a])
L.uncons ([String] -> Maybe (String, [String]))
-> [String] -> Maybe (String, [String])
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
forall a. (HasCallStack, Eq a) => [a] -> [a] -> [[a]]
L.splitOn String
"." String
str
    n
pitch <- String -> Maybe n
forall i. Notation i => String -> Maybe i
readNotation String
pstr
    pure $ n -> String -> Note n
forall n. n -> String -> Note n
Note n
pitch (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"." [String]
idParts)

-- ** Slice Type: Sets of Notes

-- Slices contain a set of notes.

{- | The content type of slices in the protovoice model.
  Contains a set of notes (pitch x id), representing the notes in a slice.
-}
newtype Notes n = Notes (S.HashSet (Note n))
  deriving (Notes n -> Notes n -> Bool
(Notes n -> Notes n -> Bool)
-> (Notes n -> Notes n -> Bool) -> Eq (Notes n)
forall n. Eq n => Notes n -> Notes n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Notes n -> Notes n -> Bool
Eq, Eq (Notes n)
Eq (Notes n) =>
(Notes n -> Notes n -> Ordering)
-> (Notes n -> Notes n -> Bool)
-> (Notes n -> Notes n -> Bool)
-> (Notes n -> Notes n -> Bool)
-> (Notes n -> Notes n -> Bool)
-> (Notes n -> Notes n -> Notes n)
-> (Notes n -> Notes n -> Notes n)
-> Ord (Notes n)
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
$ccompare :: forall n. Ord n => Notes n -> Notes n -> Ordering
compare :: Notes n -> Notes n -> Ordering
$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
>= :: Notes n -> Notes n -> Bool
$cmax :: forall n. Ord n => Notes n -> Notes n -> Notes n
max :: Notes n -> Notes n -> Notes n
$cmin :: forall n. Ord n => Notes n -> Notes n -> Notes n
min :: Notes n -> Notes n -> Notes n
Ord, (forall x. Notes n -> Rep (Notes n) x)
-> (forall x. Rep (Notes n) x -> Notes n) -> Generic (Notes n)
forall x. Rep (Notes n) x -> Notes n
forall x. Notes n -> Rep (Notes n) x
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
$cfrom :: forall n x. Notes n -> Rep (Notes n) x
from :: forall x. Notes n -> Rep (Notes n) x
$cto :: forall n x. Rep (Notes n) x -> Notes n
to :: forall x. Rep (Notes n) x -> Notes n
Generic)
  deriving anyclass (Notes n -> ()
(Notes n -> ()) -> NFData (Notes n)
forall n. NFData n => Notes n -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall n. NFData n => Notes n -> ()
rnf :: Notes n -> ()
NFData, Eq (Notes n)
Eq (Notes n) =>
(Int -> Notes n -> Int) -> (Notes n -> Int) -> Hashable (Notes n)
Int -> Notes n -> Int
Notes n -> Int
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
$chashWithSalt :: forall n. Hashable n => Int -> Notes n -> Int
hashWithSalt :: Int -> Notes n -> Int
$chash :: forall n. Hashable n => Notes n -> Int
hash :: Notes n -> Int
Hashable, [Notes n] -> Value
[Notes n] -> Encoding
Notes n -> Bool
Notes n -> Value
Notes n -> Encoding
(Notes n -> Value)
-> (Notes n -> Encoding)
-> ([Notes n] -> Value)
-> ([Notes n] -> Encoding)
-> (Notes n -> Bool)
-> ToJSON (Notes n)
forall n. Notation n => [Notes n] -> Value
forall n. Notation n => [Notes n] -> Encoding
forall n. Notation n => Notes n -> Bool
forall n. Notation n => Notes n -> Value
forall n. Notation n => Notes n -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall n. Notation n => Notes n -> Value
toJSON :: Notes n -> Value
$ctoEncoding :: forall n. Notation n => Notes n -> Encoding
toEncoding :: Notes n -> Encoding
$ctoJSONList :: forall n. Notation n => [Notes n] -> Value
toJSONList :: [Notes n] -> Value
$ctoEncodingList :: forall n. Notation n => [Notes n] -> Encoding
toEncodingList :: [Notes n] -> Encoding
$comitField :: forall n. Notation n => Notes n -> Bool
omitField :: Notes n -> Bool
ToJSON)

instance (Notation n) => Show (Notes n) where
  show :: Notes n -> String
show (Notes HashSet (Note n)
ns) =
    String
"{" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," ((n -> String
forall i. Notation i => i -> String
showNotation (n -> String) -> (Note n -> n) -> Note n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note n -> n
forall n. Note n -> n
notePitch) (Note n -> String) -> [Note n] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashSet (Note n) -> [Note n]
forall a. HashSet a -> [a]
S.toList HashSet (Note n)
ns) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"}"

instance (Notation n, Eq n, Hashable n) => FromJSON (Notes n) where
  parseJSON :: Value -> Parser (Notes n)
parseJSON = String -> (Array -> Parser (Notes n)) -> Value -> Parser (Notes n)
forall a. String -> (Array -> Parser a) -> Value -> Parser a
Aeson.withArray String
"List of Notes" ((Array -> Parser (Notes n)) -> Value -> Parser (Notes n))
-> (Array -> Parser (Notes n)) -> Value -> Parser (Notes n)
forall a b. (a -> b) -> a -> b
$ \Array
notes -> do
    Vector (Note n)
pitches <- (Value -> Parser (Note n)) -> Array -> Parser (Vector (Note n))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
mapM Value -> Parser (Note n)
forall a. FromJSON a => Value -> Parser a
parseJSON Array
notes
    pure $ HashSet (Note n) -> Notes n
forall n. HashSet (Note n) -> Notes n
Notes (HashSet (Note n) -> Notes n) -> HashSet (Note n) -> Notes n
forall a b. (a -> b) -> a -> b
$ [Note n] -> HashSet (Note n)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Note n] -> HashSet (Note n)) -> [Note n] -> HashSet (Note n)
forall a b. (a -> b) -> a -> b
$ Vector (Note n) -> [Note n]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector (Note 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 (Note n)]
innerNotes :: forall n. StartStop (Notes n) -> [StartStop (Note n)]
innerNotes (Inner (Notes HashSet (Note n)
n)) = Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner (Note n -> StartStop (Note n)) -> [Note n] -> [StartStop (Note n)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashSet (Note n) -> [Note n]
forall a. HashSet a -> [a]
S.toList HashSet (Note n)
n
innerNotes StartStop (Notes n)
Start = [StartStop (Note n)
forall a. StartStop a
Start]
innerNotes StartStop (Notes n)
Stop = [StartStop (Note n)
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 (Note n), StartStop (Note n))

-- | A proto-voice edge between two notes (excluding start/stop symbols).
type InnerEdge n = (Note n, Note 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
(Edges n -> Edges n -> Bool)
-> (Edges n -> Edges n -> Bool) -> Eq (Edges n)
forall n. Eq n => Edges n -> Edges n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Edges n -> Edges n -> Bool
Eq, Eq (Edges n)
Eq (Edges n) =>
(Edges n -> Edges n -> Ordering)
-> (Edges n -> Edges n -> Bool)
-> (Edges n -> Edges n -> Bool)
-> (Edges n -> Edges n -> Bool)
-> (Edges n -> Edges n -> Bool)
-> (Edges n -> Edges n -> Edges n)
-> (Edges n -> Edges n -> Edges n)
-> Ord (Edges n)
Edges n -> Edges n -> Bool
Edges n -> Edges n -> Ordering
Edges n -> Edges n -> Edges 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 (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
$ccompare :: forall n. Ord n => Edges n -> Edges n -> Ordering
compare :: Edges n -> Edges n -> Ordering
$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
>= :: Edges n -> Edges n -> Bool
$cmax :: forall n. Ord n => Edges n -> Edges n -> Edges n
max :: Edges n -> Edges n -> Edges n
$cmin :: forall n. Ord n => Edges n -> Edges n -> Edges n
min :: Edges n -> Edges n -> Edges n
Ord, (forall x. Edges n -> Rep (Edges n) x)
-> (forall x. Rep (Edges n) x -> Edges n) -> Generic (Edges n)
forall x. Rep (Edges n) x -> Edges n
forall x. Edges n -> Rep (Edges n) x
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
$cfrom :: forall n x. Edges n -> Rep (Edges n) x
from :: forall x. Edges n -> Rep (Edges n) x
$cto :: forall n x. Rep (Edges n) x -> Edges n
to :: forall x. Rep (Edges n) x -> Edges n
Generic, Edges n -> ()
(Edges n -> ()) -> NFData (Edges n)
forall n. NFData n => Edges n -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall n. NFData n => Edges n -> ()
rnf :: Edges n -> ()
NFData, Eq (Edges n)
Eq (Edges n) =>
(Int -> Edges n -> Int) -> (Edges n -> Int) -> Hashable (Edges n)
Int -> Edges n -> Int
Edges n -> Int
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
$chashWithSalt :: forall n. Hashable n => Int -> Edges n -> Int
hashWithSalt :: Int -> Edges n -> Int
$chash :: forall n. Hashable n => Edges n -> Int
hash :: 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) = HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges (HashSet (Edge n)
aT HashSet (Edge n) -> HashSet (Edge n) -> HashSet (Edge n)
forall a. Semigroup a => a -> a -> a
<> HashSet (Edge n)
bT) (MultiSet (InnerEdge n)
aPass MultiSet (InnerEdge n)
-> MultiSet (InnerEdge n) -> MultiSet (InnerEdge n)
forall a. Semigroup a => a -> a -> a
<> MultiSet (InnerEdge n)
bPass)

instance (Hashable n, Eq n) => Monoid (Edges n) where
  mempty :: Edges n
mempty = HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge n)
forall a. Monoid a => a
mempty MultiSet (InnerEdge n)
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
"{" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," ([String]
tReg [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
tPass) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"}"
   where
    tReg :: [String]
tReg = Edge n -> String
forall {a} {a}. (Show a, Show a) => (a, a) -> String
showReg (Edge n -> String) -> [Edge n] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashSet (Edge n) -> [Edge n]
forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
reg
    tPass :: [String]
tPass = (InnerEdge n, Int) -> String
forall {a} {a} {a}.
(Show a, Show a, Show a) =>
((a, a), a) -> String
showPass ((InnerEdge n, Int) -> String) -> [(InnerEdge n, Int)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MultiSet (InnerEdge n) -> [(InnerEdge n, Int)]
forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet (InnerEdge n)
pass
    showReg :: (a, a) -> String
showReg (a
p1, a
p2) = a -> String
forall a. Show a => a -> String
show a
p1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
p2
    showPass :: ((a, a), a) -> String
showPass ((a
p1, a
p2), a
n) =
      a -> String
forall a. Show a => a -> String
show a
p1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
">" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
p2 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"×" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
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 = String -> (Object -> Parser (Edges n)) -> Value -> Parser (Edges n)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Edges" ((Object -> Parser (Edges n)) -> Value -> Parser (Edges n))
-> (Object -> Parser (Edges n)) -> Value -> Parser (Edges n)
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    [Edge n]
regular <- Object
v Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"regular" Parser [Value] -> ([Value] -> Parser [Edge n]) -> Parser [Edge n]
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Parser (Edge n)) -> [Value] -> Parser [Edge n]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Parser (Edge n)
forall n.
Notation n =>
Value -> Parser (StartStop (Note n), StartStop (Note n))
parseEdge
    [InnerEdge n]
passing <- Object
v Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"passing" Parser [Value]
-> ([Value] -> Parser [InnerEdge n]) -> Parser [InnerEdge n]
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Parser (InnerEdge n)) -> [Value] -> Parser [InnerEdge n]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Parser (InnerEdge n)
forall n. Notation n => Value -> Parser (Note n, Note n)
parseInnerEdge
    pure $
      HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges
        ([Edge n] -> HashSet (Edge n)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Edge n]
regular :: [Edge n]))
        ([InnerEdge n] -> MultiSet (InnerEdge n)
forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList ([InnerEdge n]
passing :: [InnerEdge n]))

instance (Notation n) => ToJSON (Edges n) where
  toJSON :: Edges n -> Value
toJSON (Edges HashSet (Edge n)
reg MultiSet (InnerEdge n)
pass) =
    [Pair] -> Value
Aeson.object
      [ Key
"regular" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Edge n -> Value) -> [Edge n] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Edge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON (HashSet (Edge n) -> [Edge n]
forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
reg)
      , Key
"passing" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (InnerEdge n -> Value) -> [InnerEdge n] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InnerEdge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON (MultiSet (InnerEdge n) -> [InnerEdge n]
forall a. MultiSet a -> [a]
MS.toList MultiSet (InnerEdge n)
pass)
      ]
  toEncoding :: Edges n -> Encoding
toEncoding (Edges HashSet (Edge n)
reg MultiSet (InnerEdge n)
pass) =
    Series -> Encoding
Aeson.pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
      Key
"regular" Key -> [Value] -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Edge n -> Value) -> [Edge n] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Edge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON (HashSet (Edge n) -> [Edge n]
forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
reg)
        Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"passing" Key -> [Value] -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (InnerEdge n -> Value) -> [InnerEdge n] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InnerEdge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON (MultiSet (InnerEdge n) -> [InnerEdge n]
forall a. MultiSet a -> [a]
MS.toList MultiSet (InnerEdge n)
pass)

-- | The starting transition of a derivation (@⋊——⋉@).
topEdges :: (Hashable n) => Edges n
topEdges :: forall n. Hashable n => Edges n
topEdges = HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges (Edge n -> HashSet (Edge n)
forall a. Hashable a => a -> HashSet a
S.singleton (StartStop (Note n)
forall a. StartStop a
Start, StartStop (Note n)
forall a. StartStop a
Stop)) MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty

-- * 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
(DoubleOrnament -> DoubleOrnament -> Bool)
-> (DoubleOrnament -> DoubleOrnament -> Bool) -> Eq DoubleOrnament
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DoubleOrnament -> DoubleOrnament -> Bool
== :: DoubleOrnament -> DoubleOrnament -> Bool
$c/= :: DoubleOrnament -> DoubleOrnament -> Bool
/= :: DoubleOrnament -> DoubleOrnament -> Bool
Eq, Eq DoubleOrnament
Eq DoubleOrnament =>
(DoubleOrnament -> DoubleOrnament -> Ordering)
-> (DoubleOrnament -> DoubleOrnament -> Bool)
-> (DoubleOrnament -> DoubleOrnament -> Bool)
-> (DoubleOrnament -> DoubleOrnament -> Bool)
-> (DoubleOrnament -> DoubleOrnament -> Bool)
-> (DoubleOrnament -> DoubleOrnament -> DoubleOrnament)
-> (DoubleOrnament -> DoubleOrnament -> DoubleOrnament)
-> Ord 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
$ccompare :: DoubleOrnament -> DoubleOrnament -> Ordering
compare :: DoubleOrnament -> DoubleOrnament -> Ordering
$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
>= :: DoubleOrnament -> DoubleOrnament -> Bool
$cmax :: DoubleOrnament -> DoubleOrnament -> DoubleOrnament
max :: DoubleOrnament -> DoubleOrnament -> DoubleOrnament
$cmin :: DoubleOrnament -> DoubleOrnament -> DoubleOrnament
min :: DoubleOrnament -> DoubleOrnament -> DoubleOrnament
Ord, Int -> DoubleOrnament -> ShowS
[DoubleOrnament] -> ShowS
DoubleOrnament -> String
(Int -> DoubleOrnament -> ShowS)
-> (DoubleOrnament -> String)
-> ([DoubleOrnament] -> ShowS)
-> Show DoubleOrnament
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DoubleOrnament -> ShowS
showsPrec :: Int -> DoubleOrnament -> ShowS
$cshow :: DoubleOrnament -> String
show :: DoubleOrnament -> String
$cshowList :: [DoubleOrnament] -> ShowS
showList :: [DoubleOrnament] -> ShowS
Show, (forall x. DoubleOrnament -> Rep DoubleOrnament x)
-> (forall x. Rep DoubleOrnament x -> DoubleOrnament)
-> Generic DoubleOrnament
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
$cfrom :: forall x. DoubleOrnament -> Rep DoubleOrnament x
from :: forall x. DoubleOrnament -> Rep DoubleOrnament x
$cto :: forall x. Rep DoubleOrnament x -> DoubleOrnament
to :: forall x. Rep DoubleOrnament x -> DoubleOrnament
Generic, [DoubleOrnament] -> Value
[DoubleOrnament] -> Encoding
DoubleOrnament -> Bool
DoubleOrnament -> Value
DoubleOrnament -> Encoding
(DoubleOrnament -> Value)
-> (DoubleOrnament -> Encoding)
-> ([DoubleOrnament] -> Value)
-> ([DoubleOrnament] -> Encoding)
-> (DoubleOrnament -> Bool)
-> ToJSON DoubleOrnament
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: DoubleOrnament -> Value
toJSON :: DoubleOrnament -> Value
$ctoEncoding :: DoubleOrnament -> Encoding
toEncoding :: DoubleOrnament -> Encoding
$ctoJSONList :: [DoubleOrnament] -> Value
toJSONList :: [DoubleOrnament] -> Value
$ctoEncodingList :: [DoubleOrnament] -> Encoding
toEncodingList :: [DoubleOrnament] -> Encoding
$comitField :: DoubleOrnament -> Bool
omitField :: DoubleOrnament -> Bool
ToJSON, Maybe DoubleOrnament
Value -> Parser [DoubleOrnament]
Value -> Parser DoubleOrnament
(Value -> Parser DoubleOrnament)
-> (Value -> Parser [DoubleOrnament])
-> Maybe DoubleOrnament
-> FromJSON DoubleOrnament
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser DoubleOrnament
parseJSON :: Value -> Parser DoubleOrnament
$cparseJSONList :: Value -> Parser [DoubleOrnament]
parseJSONList :: Value -> Parser [DoubleOrnament]
$comittedField :: Maybe DoubleOrnament
omittedField :: Maybe DoubleOrnament
FromJSON, DoubleOrnament -> ()
(DoubleOrnament -> ()) -> NFData DoubleOrnament
forall a. (a -> ()) -> NFData a
$crnf :: DoubleOrnament -> ()
rnf :: 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
(PassingOrnament -> PassingOrnament -> Bool)
-> (PassingOrnament -> PassingOrnament -> Bool)
-> Eq PassingOrnament
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PassingOrnament -> PassingOrnament -> Bool
== :: PassingOrnament -> PassingOrnament -> Bool
$c/= :: PassingOrnament -> PassingOrnament -> Bool
/= :: PassingOrnament -> PassingOrnament -> Bool
Eq, Eq PassingOrnament
Eq PassingOrnament =>
(PassingOrnament -> PassingOrnament -> Ordering)
-> (PassingOrnament -> PassingOrnament -> Bool)
-> (PassingOrnament -> PassingOrnament -> Bool)
-> (PassingOrnament -> PassingOrnament -> Bool)
-> (PassingOrnament -> PassingOrnament -> Bool)
-> (PassingOrnament -> PassingOrnament -> PassingOrnament)
-> (PassingOrnament -> PassingOrnament -> PassingOrnament)
-> Ord 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
$ccompare :: PassingOrnament -> PassingOrnament -> Ordering
compare :: PassingOrnament -> PassingOrnament -> Ordering
$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
>= :: PassingOrnament -> PassingOrnament -> Bool
$cmax :: PassingOrnament -> PassingOrnament -> PassingOrnament
max :: PassingOrnament -> PassingOrnament -> PassingOrnament
$cmin :: PassingOrnament -> PassingOrnament -> PassingOrnament
min :: PassingOrnament -> PassingOrnament -> PassingOrnament
Ord, Int -> PassingOrnament -> ShowS
[PassingOrnament] -> ShowS
PassingOrnament -> String
(Int -> PassingOrnament -> ShowS)
-> (PassingOrnament -> String)
-> ([PassingOrnament] -> ShowS)
-> Show PassingOrnament
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PassingOrnament -> ShowS
showsPrec :: Int -> PassingOrnament -> ShowS
$cshow :: PassingOrnament -> String
show :: PassingOrnament -> String
$cshowList :: [PassingOrnament] -> ShowS
showList :: [PassingOrnament] -> ShowS
Show, (forall x. PassingOrnament -> Rep PassingOrnament x)
-> (forall x. Rep PassingOrnament x -> PassingOrnament)
-> Generic PassingOrnament
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
$cfrom :: forall x. PassingOrnament -> Rep PassingOrnament x
from :: forall x. PassingOrnament -> Rep PassingOrnament x
$cto :: forall x. Rep PassingOrnament x -> PassingOrnament
to :: forall x. Rep PassingOrnament x -> PassingOrnament
Generic, [PassingOrnament] -> Value
[PassingOrnament] -> Encoding
PassingOrnament -> Bool
PassingOrnament -> Value
PassingOrnament -> Encoding
(PassingOrnament -> Value)
-> (PassingOrnament -> Encoding)
-> ([PassingOrnament] -> Value)
-> ([PassingOrnament] -> Encoding)
-> (PassingOrnament -> Bool)
-> ToJSON PassingOrnament
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: PassingOrnament -> Value
toJSON :: PassingOrnament -> Value
$ctoEncoding :: PassingOrnament -> Encoding
toEncoding :: PassingOrnament -> Encoding
$ctoJSONList :: [PassingOrnament] -> Value
toJSONList :: [PassingOrnament] -> Value
$ctoEncodingList :: [PassingOrnament] -> Encoding
toEncodingList :: [PassingOrnament] -> Encoding
$comitField :: PassingOrnament -> Bool
omitField :: PassingOrnament -> Bool
ToJSON, Maybe PassingOrnament
Value -> Parser [PassingOrnament]
Value -> Parser PassingOrnament
(Value -> Parser PassingOrnament)
-> (Value -> Parser [PassingOrnament])
-> Maybe PassingOrnament
-> FromJSON PassingOrnament
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser PassingOrnament
parseJSON :: Value -> Parser PassingOrnament
$cparseJSONList :: Value -> Parser [PassingOrnament]
parseJSONList :: Value -> Parser [PassingOrnament]
$comittedField :: Maybe PassingOrnament
omittedField :: Maybe PassingOrnament
FromJSON, PassingOrnament -> ()
(PassingOrnament -> ()) -> NFData PassingOrnament
forall a. (a -> ()) -> NFData a
$crnf :: PassingOrnament -> ()
rnf :: 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
(LeftOrnament -> LeftOrnament -> Bool)
-> (LeftOrnament -> LeftOrnament -> Bool) -> Eq LeftOrnament
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeftOrnament -> LeftOrnament -> Bool
== :: LeftOrnament -> LeftOrnament -> Bool
$c/= :: LeftOrnament -> LeftOrnament -> Bool
/= :: LeftOrnament -> LeftOrnament -> Bool
Eq, Eq LeftOrnament
Eq LeftOrnament =>
(LeftOrnament -> LeftOrnament -> Ordering)
-> (LeftOrnament -> LeftOrnament -> Bool)
-> (LeftOrnament -> LeftOrnament -> Bool)
-> (LeftOrnament -> LeftOrnament -> Bool)
-> (LeftOrnament -> LeftOrnament -> Bool)
-> (LeftOrnament -> LeftOrnament -> LeftOrnament)
-> (LeftOrnament -> LeftOrnament -> LeftOrnament)
-> Ord 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
$ccompare :: LeftOrnament -> LeftOrnament -> Ordering
compare :: LeftOrnament -> LeftOrnament -> Ordering
$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
>= :: LeftOrnament -> LeftOrnament -> Bool
$cmax :: LeftOrnament -> LeftOrnament -> LeftOrnament
max :: LeftOrnament -> LeftOrnament -> LeftOrnament
$cmin :: LeftOrnament -> LeftOrnament -> LeftOrnament
min :: LeftOrnament -> LeftOrnament -> LeftOrnament
Ord, Int -> LeftOrnament -> ShowS
[LeftOrnament] -> ShowS
LeftOrnament -> String
(Int -> LeftOrnament -> ShowS)
-> (LeftOrnament -> String)
-> ([LeftOrnament] -> ShowS)
-> Show LeftOrnament
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeftOrnament -> ShowS
showsPrec :: Int -> LeftOrnament -> ShowS
$cshow :: LeftOrnament -> String
show :: LeftOrnament -> String
$cshowList :: [LeftOrnament] -> ShowS
showList :: [LeftOrnament] -> ShowS
Show, (forall x. LeftOrnament -> Rep LeftOrnament x)
-> (forall x. Rep LeftOrnament x -> LeftOrnament)
-> Generic LeftOrnament
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
$cfrom :: forall x. LeftOrnament -> Rep LeftOrnament x
from :: forall x. LeftOrnament -> Rep LeftOrnament x
$cto :: forall x. Rep LeftOrnament x -> LeftOrnament
to :: forall x. Rep LeftOrnament x -> LeftOrnament
Generic, [LeftOrnament] -> Value
[LeftOrnament] -> Encoding
LeftOrnament -> Bool
LeftOrnament -> Value
LeftOrnament -> Encoding
(LeftOrnament -> Value)
-> (LeftOrnament -> Encoding)
-> ([LeftOrnament] -> Value)
-> ([LeftOrnament] -> Encoding)
-> (LeftOrnament -> Bool)
-> ToJSON LeftOrnament
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: LeftOrnament -> Value
toJSON :: LeftOrnament -> Value
$ctoEncoding :: LeftOrnament -> Encoding
toEncoding :: LeftOrnament -> Encoding
$ctoJSONList :: [LeftOrnament] -> Value
toJSONList :: [LeftOrnament] -> Value
$ctoEncodingList :: [LeftOrnament] -> Encoding
toEncodingList :: [LeftOrnament] -> Encoding
$comitField :: LeftOrnament -> Bool
omitField :: LeftOrnament -> Bool
ToJSON, Maybe LeftOrnament
Value -> Parser [LeftOrnament]
Value -> Parser LeftOrnament
(Value -> Parser LeftOrnament)
-> (Value -> Parser [LeftOrnament])
-> Maybe LeftOrnament
-> FromJSON LeftOrnament
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser LeftOrnament
parseJSON :: Value -> Parser LeftOrnament
$cparseJSONList :: Value -> Parser [LeftOrnament]
parseJSONList :: Value -> Parser [LeftOrnament]
$comittedField :: Maybe LeftOrnament
omittedField :: Maybe LeftOrnament
FromJSON, LeftOrnament -> ()
(LeftOrnament -> ()) -> NFData LeftOrnament
forall a. (a -> ()) -> NFData a
$crnf :: LeftOrnament -> ()
rnf :: 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
(RightOrnament -> RightOrnament -> Bool)
-> (RightOrnament -> RightOrnament -> Bool) -> Eq RightOrnament
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RightOrnament -> RightOrnament -> Bool
== :: RightOrnament -> RightOrnament -> Bool
$c/= :: RightOrnament -> RightOrnament -> Bool
/= :: RightOrnament -> RightOrnament -> Bool
Eq, Eq RightOrnament
Eq RightOrnament =>
(RightOrnament -> RightOrnament -> Ordering)
-> (RightOrnament -> RightOrnament -> Bool)
-> (RightOrnament -> RightOrnament -> Bool)
-> (RightOrnament -> RightOrnament -> Bool)
-> (RightOrnament -> RightOrnament -> Bool)
-> (RightOrnament -> RightOrnament -> RightOrnament)
-> (RightOrnament -> RightOrnament -> RightOrnament)
-> Ord 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
$ccompare :: RightOrnament -> RightOrnament -> Ordering
compare :: RightOrnament -> RightOrnament -> Ordering
$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
>= :: RightOrnament -> RightOrnament -> Bool
$cmax :: RightOrnament -> RightOrnament -> RightOrnament
max :: RightOrnament -> RightOrnament -> RightOrnament
$cmin :: RightOrnament -> RightOrnament -> RightOrnament
min :: RightOrnament -> RightOrnament -> RightOrnament
Ord, Int -> RightOrnament -> ShowS
[RightOrnament] -> ShowS
RightOrnament -> String
(Int -> RightOrnament -> ShowS)
-> (RightOrnament -> String)
-> ([RightOrnament] -> ShowS)
-> Show RightOrnament
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RightOrnament -> ShowS
showsPrec :: Int -> RightOrnament -> ShowS
$cshow :: RightOrnament -> String
show :: RightOrnament -> String
$cshowList :: [RightOrnament] -> ShowS
showList :: [RightOrnament] -> ShowS
Show, (forall x. RightOrnament -> Rep RightOrnament x)
-> (forall x. Rep RightOrnament x -> RightOrnament)
-> Generic RightOrnament
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
$cfrom :: forall x. RightOrnament -> Rep RightOrnament x
from :: forall x. RightOrnament -> Rep RightOrnament x
$cto :: forall x. Rep RightOrnament x -> RightOrnament
to :: forall x. Rep RightOrnament x -> RightOrnament
Generic, [RightOrnament] -> Value
[RightOrnament] -> Encoding
RightOrnament -> Bool
RightOrnament -> Value
RightOrnament -> Encoding
(RightOrnament -> Value)
-> (RightOrnament -> Encoding)
-> ([RightOrnament] -> Value)
-> ([RightOrnament] -> Encoding)
-> (RightOrnament -> Bool)
-> ToJSON RightOrnament
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: RightOrnament -> Value
toJSON :: RightOrnament -> Value
$ctoEncoding :: RightOrnament -> Encoding
toEncoding :: RightOrnament -> Encoding
$ctoJSONList :: [RightOrnament] -> Value
toJSONList :: [RightOrnament] -> Value
$ctoEncodingList :: [RightOrnament] -> Encoding
toEncodingList :: [RightOrnament] -> Encoding
$comitField :: RightOrnament -> Bool
omitField :: RightOrnament -> Bool
ToJSON, Maybe RightOrnament
Value -> Parser [RightOrnament]
Value -> Parser RightOrnament
(Value -> Parser RightOrnament)
-> (Value -> Parser [RightOrnament])
-> Maybe RightOrnament
-> FromJSON RightOrnament
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser RightOrnament
parseJSON :: Value -> Parser RightOrnament
$cparseJSONList :: Value -> Parser [RightOrnament]
parseJSONList :: Value -> Parser [RightOrnament]
$comittedField :: Maybe RightOrnament
omittedField :: Maybe RightOrnament
FromJSON, RightOrnament -> ()
(RightOrnament -> ()) -> NFData RightOrnament
forall a. (a -> ()) -> NFData a
$crnf :: RightOrnament -> ()
rnf :: 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) [(Note n, DoubleOrnament)]
splitReg :: !(M.Map (Edge n) [(Note n, DoubleOrnament)])
  -- ^ Maps every regular edge to a list of ornamentations.
  , forall n. Split n -> Map (InnerEdge n) [(Note n, PassingOrnament)]
splitPass :: !(M.Map (InnerEdge n) [(Note 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 (Note n) [(Note n, RightOrnament)]
fromLeft :: !(M.Map (Note n) [(Note n, RightOrnament)])
  -- ^ Maps notes from the left parent slice to lists of ornamentations.
  , forall n. Split n -> Map (Note n) [(Note n, LeftOrnament)]
fromRight :: !(M.Map (Note n) [(Note 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
(Split n -> Split n -> Bool)
-> (Split n -> Split n -> Bool) -> Eq (Split n)
forall n. Eq n => Split n -> Split n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Split n -> Split n -> Bool
Eq, Eq (Split n)
Eq (Split n) =>
(Split n -> Split n -> Ordering)
-> (Split n -> Split n -> Bool)
-> (Split n -> Split n -> Bool)
-> (Split n -> Split n -> Bool)
-> (Split n -> Split n -> Bool)
-> (Split n -> Split n -> Split n)
-> (Split n -> Split n -> Split n)
-> Ord (Split n)
Split n -> Split n -> Bool
Split n -> Split n -> Ordering
Split n -> Split n -> Split 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 (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
$ccompare :: forall n. Ord n => Split n -> Split n -> Ordering
compare :: Split n -> Split n -> Ordering
$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
>= :: Split n -> Split n -> Bool
$cmax :: forall n. Ord n => Split n -> Split n -> Split n
max :: Split n -> Split n -> Split n
$cmin :: forall n. Ord n => Split n -> Split n -> Split n
min :: Split n -> Split n -> Split n
Ord, (forall x. Split n -> Rep (Split n) x)
-> (forall x. Rep (Split n) x -> Split n) -> Generic (Split n)
forall x. Rep (Split n) x -> Split n
forall x. Split n -> Rep (Split n) x
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
$cfrom :: forall n x. Split n -> Rep (Split n) x
from :: forall x. Split n -> Rep (Split n) x
$cto :: forall n x. Rep (Split n) x -> Split n
to :: forall x. Rep (Split n) x -> Split n
Generic, Split n -> ()
(Split n -> ()) -> NFData (Split n)
forall n. NFData n => Split n -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall n. NFData n => Split n -> ()
rnf :: Split n -> ()
NFData)

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

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

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

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

instance (Ord n, Hashable n) => Monoid (Split n) where
  mempty :: Split n
mempty =
    Map (Edge n) [(Note n, DoubleOrnament)]
-> Map (InnerEdge n) [(Note n, PassingOrnament)]
-> Map (Note n) [(Note n, RightOrnament)]
-> Map (Note n) [(Note n, LeftOrnament)]
-> HashSet (Edge n)
-> HashSet (Edge n)
-> MultiSet (InnerEdge n)
-> MultiSet (InnerEdge n)
-> Split n
forall n.
Map (Edge n) [(Note n, DoubleOrnament)]
-> Map (InnerEdge n) [(Note n, PassingOrnament)]
-> Map (Note n) [(Note n, RightOrnament)]
-> Map (Note n) [(Note n, LeftOrnament)]
-> HashSet (Edge n)
-> HashSet (Edge n)
-> MultiSet (InnerEdge n)
-> MultiSet (InnerEdge n)
-> Split n
SplitOp Map (Edge n) [(Note n, DoubleOrnament)]
forall k a. Map k a
M.empty Map (InnerEdge n) [(Note n, PassingOrnament)]
forall k a. Map k a
M.empty Map (Note n) [(Note n, RightOrnament)]
forall k a. Map k a
M.empty Map (Note n) [(Note n, LeftOrnament)]
forall k a. Map k a
M.empty HashSet (Edge n)
forall a. HashSet a
S.empty HashSet (Edge n)
forall a. HashSet a
S.empty MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty MultiSet (InnerEdge n)
forall a. MultiSet a
MS.empty

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

instance (Notation n) => ToJSON (Split n) where
  toJSON :: Split n -> Value
toJSON (SplitOp Map (Edge n) [(Note n, DoubleOrnament)]
reg Map (InnerEdge n) [(Note n, PassingOrnament)]
pass Map (Note n) [(Note n, RightOrnament)]
fromL Map (Note n) [(Note n, LeftOrnament)]
fromR HashSet (Edge n)
keepL HashSet (Edge n)
keepR MultiSet (InnerEdge n)
passL MultiSet (InnerEdge n)
passR) =
    [Pair] -> Value
Aeson.object
      [ Key
"regular" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ((Edge n, [(Note n, DoubleOrnament)]) -> Value)
-> [(Edge n, [(Note n, DoubleOrnament)])] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Edge n -> Value) -> (Edge n, [(Note n, DoubleOrnament)]) -> Value
forall o p. ToJSON o => (p -> Value) -> (p, [(Note n, o)]) -> Value
elaboToJSON Edge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON) (Map (Edge n) [(Note n, DoubleOrnament)]
-> [(Edge n, [(Note n, DoubleOrnament)])]
forall k a. Map k a -> [(k, a)]
M.toList Map (Edge n) [(Note n, DoubleOrnament)]
reg)
      , Key
"passing" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ((InnerEdge n, [(Note n, PassingOrnament)]) -> Value)
-> [(InnerEdge n, [(Note n, PassingOrnament)])] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InnerEdge n -> Value)
-> (InnerEdge n, [(Note n, PassingOrnament)]) -> Value
forall o p. ToJSON o => (p -> Value) -> (p, [(Note n, o)]) -> Value
elaboToJSON InnerEdge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON) (Map (InnerEdge n) [(Note n, PassingOrnament)]
-> [(InnerEdge n, [(Note n, PassingOrnament)])]
forall k a. Map k a -> [(k, a)]
M.toList Map (InnerEdge n) [(Note n, PassingOrnament)]
pass)
      , Key
"fromLeft" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ((Note n, [(Note n, RightOrnament)]) -> Value)
-> [(Note n, [(Note n, RightOrnament)])] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Note n -> Value) -> (Note n, [(Note n, RightOrnament)]) -> Value
forall o p. ToJSON o => (p -> Value) -> (p, [(Note n, o)]) -> Value
elaboToJSON Note n -> Value
forall a. ToJSON a => a -> Value
toJSON) (Map (Note n) [(Note n, RightOrnament)]
-> [(Note n, [(Note n, RightOrnament)])]
forall k a. Map k a -> [(k, a)]
M.toList Map (Note n) [(Note n, RightOrnament)]
fromL)
      , Key
"fromRight" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ((Note n, [(Note n, LeftOrnament)]) -> Value)
-> [(Note n, [(Note n, LeftOrnament)])] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Note n -> Value) -> (Note n, [(Note n, LeftOrnament)]) -> Value
forall o p. ToJSON o => (p -> Value) -> (p, [(Note n, o)]) -> Value
elaboToJSON Note n -> Value
forall a. ToJSON a => a -> Value
toJSON) (Map (Note n) [(Note n, LeftOrnament)]
-> [(Note n, [(Note n, LeftOrnament)])]
forall k a. Map k a -> [(k, a)]
M.toList Map (Note n) [(Note n, LeftOrnament)]
fromR)
      , Key
"keepLeft" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Edge n -> Value) -> [Edge n] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Edge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON (HashSet (Edge n) -> [Edge n]
forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
keepL)
      , Key
"keepRight" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Edge n -> Value) -> [Edge n] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Edge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON (HashSet (Edge n) -> [Edge n]
forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
keepR)
      , Key
"passLeft" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (InnerEdge n -> Value) -> [InnerEdge n] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InnerEdge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON (MultiSet (InnerEdge n) -> [InnerEdge n]
forall a. MultiSet a -> [a]
MS.toList MultiSet (InnerEdge n)
passL)
      , Key
"passRight" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (InnerEdge n -> Value) -> [InnerEdge n] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InnerEdge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON (MultiSet (InnerEdge n) -> [InnerEdge n]
forall a. MultiSet a -> [a]
MS.toList MultiSet (InnerEdge n)
passR)
      ]
   where
    elaboToJSON :: (ToJSON o) => (p -> Aeson.Value) -> (p, [(Note n, o)]) -> Aeson.Value
    elaboToJSON :: forall o p. ToJSON o => (p -> Value) -> (p, [(Note n, o)]) -> Value
elaboToJSON p -> Value
fParent (p
parent, [(Note n, o)]
children) =
      [Pair] -> Value
Aeson.object
        [ Key
"parent" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= p -> Value
fParent p
parent
        , Key
"children" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ((Note n, o) -> Value) -> [(Note n, o)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Note n, o) -> Value
forall {v} {v}. (ToJSON v, ToJSON v) => (v, v) -> Value
childToJSON [(Note n, o)]
children
        ]
    childToJSON :: (v, v) -> Value
childToJSON (v
n, v
o) = [Pair] -> Value
Aeson.object [Key
"child" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
n, Key
"orn" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
o]

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

instance (Notation n) => Show (Freeze n) where
  show :: Freeze n -> String
show (FreezeOp HashSet (Edge n)
ties) = HashSet (Edge n) -> String
forall a. Show a => a -> String
show HashSet (Edge n)
ties

instance (Notation n, Hashable n) => FromJSON (Freeze n) where
  parseJSON :: Value -> Parser (Freeze n)
parseJSON = String
-> (Object -> Parser (Freeze n)) -> Value -> Parser (Freeze n)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Freeze" ((Object -> Parser (Freeze n)) -> Value -> Parser (Freeze n))
-> (Object -> Parser (Freeze n)) -> Value -> Parser (Freeze n)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    [Edge n]
ties <- Object
obj Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ties" Parser [Value] -> ([Value] -> Parser [Edge n]) -> Parser [Edge n]
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Parser (Edge n)) -> [Value] -> Parser [Edge n]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Parser (Edge n)
forall n.
Notation n =>
Value -> Parser (StartStop (Note n), StartStop (Note n))
parseEdge
    pure $ HashSet (Edge n) -> Freeze n
forall n. HashSet (Edge n) -> Freeze n
FreezeOp ([Edge n] -> HashSet (Edge n)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Edge n]
ties)

instance (Notation n) => ToJSON (Freeze n) where
  toJSON :: Freeze n -> Value
toJSON (FreezeOp HashSet (Edge n)
ties) = [Pair] -> Value
Aeson.object [Key
"ties" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Edge n -> Value) -> [Edge n] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Edge n -> Value
forall a. ToJSON a => (a, a) -> Value
edgeToJSON (HashSet (Edge n) -> [Edge n]
forall a. HashSet a -> [a]
S.toList HashSet (Edge n)
ties)] -- TODO: add empty prevTime?

-- {- | 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 (Eq, Ord, Show, Generic, NFData)

-- instance Semigroup SpreadDirection where
--   ToLeft l1 <> ToLeft l2 = ToLeft (l1 + l2)
--   ToRight l1 <> ToRight l2 = ToLeft (l1 + l2)
--   ToLeft l <> ToRight r
--     | l == r = ToBoth
--     | l < r = ToRight (r - l)
--     | otherwise = ToLeft (l - r)
--   ToBoth <> other = other
--   a <> b = b <> a

-- instance Monoid SpreadDirection where
--   mempty = ToBoth

{- | Represents the children of a note that is spread out.

A note can be distributed to either or both sub-slice.
-}
data SpreadChildren n
  = -- | a single child in the left slice
    SpreadLeftChild !(Note n)
  | -- | a single child in the right slice
    SpreadRightChild !(Note n)
  | -- | two children, on in each slice
    SpreadBothChildren !(Note n) !(Note n)
  deriving (SpreadChildren n -> SpreadChildren n -> Bool
(SpreadChildren n -> SpreadChildren n -> Bool)
-> (SpreadChildren n -> SpreadChildren n -> Bool)
-> Eq (SpreadChildren n)
forall n. Eq n => SpreadChildren n -> SpreadChildren n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall n. Eq n => SpreadChildren n -> SpreadChildren n -> Bool
== :: SpreadChildren n -> SpreadChildren n -> Bool
$c/= :: forall n. Eq n => SpreadChildren n -> SpreadChildren n -> Bool
/= :: SpreadChildren n -> SpreadChildren n -> Bool
Eq, Eq (SpreadChildren n)
Eq (SpreadChildren n) =>
(SpreadChildren n -> SpreadChildren n -> Ordering)
-> (SpreadChildren n -> SpreadChildren n -> Bool)
-> (SpreadChildren n -> SpreadChildren n -> Bool)
-> (SpreadChildren n -> SpreadChildren n -> Bool)
-> (SpreadChildren n -> SpreadChildren n -> Bool)
-> (SpreadChildren n -> SpreadChildren n -> SpreadChildren n)
-> (SpreadChildren n -> SpreadChildren n -> SpreadChildren n)
-> Ord (SpreadChildren n)
SpreadChildren n -> SpreadChildren n -> Bool
SpreadChildren n -> SpreadChildren n -> Ordering
SpreadChildren n -> SpreadChildren n -> SpreadChildren 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 (SpreadChildren n)
forall n. Ord n => SpreadChildren n -> SpreadChildren n -> Bool
forall n. Ord n => SpreadChildren n -> SpreadChildren n -> Ordering
forall n.
Ord n =>
SpreadChildren n -> SpreadChildren n -> SpreadChildren n
$ccompare :: forall n. Ord n => SpreadChildren n -> SpreadChildren n -> Ordering
compare :: SpreadChildren n -> SpreadChildren n -> Ordering
$c< :: forall n. Ord n => SpreadChildren n -> SpreadChildren n -> Bool
< :: SpreadChildren n -> SpreadChildren n -> Bool
$c<= :: forall n. Ord n => SpreadChildren n -> SpreadChildren n -> Bool
<= :: SpreadChildren n -> SpreadChildren n -> Bool
$c> :: forall n. Ord n => SpreadChildren n -> SpreadChildren n -> Bool
> :: SpreadChildren n -> SpreadChildren n -> Bool
$c>= :: forall n. Ord n => SpreadChildren n -> SpreadChildren n -> Bool
>= :: SpreadChildren n -> SpreadChildren n -> Bool
$cmax :: forall n.
Ord n =>
SpreadChildren n -> SpreadChildren n -> SpreadChildren n
max :: SpreadChildren n -> SpreadChildren n -> SpreadChildren n
$cmin :: forall n.
Ord n =>
SpreadChildren n -> SpreadChildren n -> SpreadChildren n
min :: SpreadChildren n -> SpreadChildren n -> SpreadChildren n
Ord, (forall a b. (a -> b) -> SpreadChildren a -> SpreadChildren b)
-> (forall a b. a -> SpreadChildren b -> SpreadChildren a)
-> Functor SpreadChildren
forall a b. a -> SpreadChildren b -> SpreadChildren a
forall a b. (a -> b) -> SpreadChildren a -> SpreadChildren b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> SpreadChildren a -> SpreadChildren b
fmap :: forall a b. (a -> b) -> SpreadChildren a -> SpreadChildren b
$c<$ :: forall a b. a -> SpreadChildren b -> SpreadChildren a
<$ :: forall a b. a -> SpreadChildren b -> SpreadChildren a
Functor, (forall m. Monoid m => SpreadChildren m -> m)
-> (forall m a. Monoid m => (a -> m) -> SpreadChildren a -> m)
-> (forall m a. Monoid m => (a -> m) -> SpreadChildren a -> m)
-> (forall a b. (a -> b -> b) -> b -> SpreadChildren a -> b)
-> (forall a b. (a -> b -> b) -> b -> SpreadChildren a -> b)
-> (forall b a. (b -> a -> b) -> b -> SpreadChildren a -> b)
-> (forall b a. (b -> a -> b) -> b -> SpreadChildren a -> b)
-> (forall a. (a -> a -> a) -> SpreadChildren a -> a)
-> (forall a. (a -> a -> a) -> SpreadChildren a -> a)
-> (forall a. SpreadChildren a -> [a])
-> (forall a. SpreadChildren a -> Bool)
-> (forall a. SpreadChildren a -> Int)
-> (forall a. Eq a => a -> SpreadChildren a -> Bool)
-> (forall a. Ord a => SpreadChildren a -> a)
-> (forall a. Ord a => SpreadChildren a -> a)
-> (forall a. Num a => SpreadChildren a -> a)
-> (forall a. Num a => SpreadChildren a -> a)
-> Foldable SpreadChildren
forall a. Eq a => a -> SpreadChildren a -> Bool
forall a. Num a => SpreadChildren a -> a
forall a. Ord a => SpreadChildren a -> a
forall m. Monoid m => SpreadChildren m -> m
forall a. SpreadChildren a -> Bool
forall a. SpreadChildren a -> Int
forall a. SpreadChildren a -> [a]
forall a. (a -> a -> a) -> SpreadChildren a -> a
forall m a. Monoid m => (a -> m) -> SpreadChildren a -> m
forall b a. (b -> a -> b) -> b -> SpreadChildren a -> b
forall a b. (a -> b -> b) -> b -> SpreadChildren a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => SpreadChildren m -> m
fold :: forall m. Monoid m => SpreadChildren m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> SpreadChildren a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> SpreadChildren a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> SpreadChildren a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> SpreadChildren a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> SpreadChildren a -> b
foldr :: forall a b. (a -> b -> b) -> b -> SpreadChildren a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> SpreadChildren a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> SpreadChildren a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> SpreadChildren a -> b
foldl :: forall b a. (b -> a -> b) -> b -> SpreadChildren a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> SpreadChildren a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> SpreadChildren a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> SpreadChildren a -> a
foldr1 :: forall a. (a -> a -> a) -> SpreadChildren a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> SpreadChildren a -> a
foldl1 :: forall a. (a -> a -> a) -> SpreadChildren a -> a
$ctoList :: forall a. SpreadChildren a -> [a]
toList :: forall a. SpreadChildren a -> [a]
$cnull :: forall a. SpreadChildren a -> Bool
null :: forall a. SpreadChildren a -> Bool
$clength :: forall a. SpreadChildren a -> Int
length :: forall a. SpreadChildren a -> Int
$celem :: forall a. Eq a => a -> SpreadChildren a -> Bool
elem :: forall a. Eq a => a -> SpreadChildren a -> Bool
$cmaximum :: forall a. Ord a => SpreadChildren a -> a
maximum :: forall a. Ord a => SpreadChildren a -> a
$cminimum :: forall a. Ord a => SpreadChildren a -> a
minimum :: forall a. Ord a => SpreadChildren a -> a
$csum :: forall a. Num a => SpreadChildren a -> a
sum :: forall a. Num a => SpreadChildren a -> a
$cproduct :: forall a. Num a => SpreadChildren a -> a
product :: forall a. Num a => SpreadChildren a -> a
Foldable, Functor SpreadChildren
Foldable SpreadChildren
(Functor SpreadChildren, Foldable SpreadChildren) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> SpreadChildren a -> f (SpreadChildren b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    SpreadChildren (f a) -> f (SpreadChildren a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> SpreadChildren a -> m (SpreadChildren b))
-> (forall (m :: * -> *) a.
    Monad m =>
    SpreadChildren (m a) -> m (SpreadChildren a))
-> Traversable SpreadChildren
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
SpreadChildren (m a) -> m (SpreadChildren a)
forall (f :: * -> *) a.
Applicative f =>
SpreadChildren (f a) -> f (SpreadChildren a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SpreadChildren a -> m (SpreadChildren b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SpreadChildren a -> f (SpreadChildren b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SpreadChildren a -> f (SpreadChildren b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SpreadChildren a -> f (SpreadChildren b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
SpreadChildren (f a) -> f (SpreadChildren a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
SpreadChildren (f a) -> f (SpreadChildren a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SpreadChildren a -> m (SpreadChildren b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SpreadChildren a -> m (SpreadChildren b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
SpreadChildren (m a) -> m (SpreadChildren a)
sequence :: forall (m :: * -> *) a.
Monad m =>
SpreadChildren (m a) -> m (SpreadChildren a)
Traversable, (forall x. SpreadChildren n -> Rep (SpreadChildren n) x)
-> (forall x. Rep (SpreadChildren n) x -> SpreadChildren n)
-> Generic (SpreadChildren n)
forall x. Rep (SpreadChildren n) x -> SpreadChildren n
forall x. SpreadChildren n -> Rep (SpreadChildren n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall n x. Rep (SpreadChildren n) x -> SpreadChildren n
forall n x. SpreadChildren n -> Rep (SpreadChildren n) x
$cfrom :: forall n x. SpreadChildren n -> Rep (SpreadChildren n) x
from :: forall x. SpreadChildren n -> Rep (SpreadChildren n) x
$cto :: forall n x. Rep (SpreadChildren n) x -> SpreadChildren n
to :: forall x. Rep (SpreadChildren n) x -> SpreadChildren n
Generic, SpreadChildren n -> ()
(SpreadChildren n -> ()) -> NFData (SpreadChildren n)
forall n. NFData n => SpreadChildren n -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall n. NFData n => SpreadChildren n -> ()
rnf :: SpreadChildren n -> ()
NFData, Eq (SpreadChildren n)
Eq (SpreadChildren n) =>
(Int -> SpreadChildren n -> Int)
-> (SpreadChildren n -> Int) -> Hashable (SpreadChildren n)
Int -> SpreadChildren n -> Int
SpreadChildren n -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall n. Hashable n => Eq (SpreadChildren n)
forall n. Hashable n => Int -> SpreadChildren n -> Int
forall n. Hashable n => SpreadChildren n -> Int
$chashWithSalt :: forall n. Hashable n => Int -> SpreadChildren n -> Int
hashWithSalt :: Int -> SpreadChildren n -> Int
$chash :: forall n. Hashable n => SpreadChildren n -> Int
hash :: SpreadChildren n -> Int
Hashable)

instance (Notation n) => Show (SpreadChildren n) where
  show :: SpreadChildren n -> String
show (SpreadLeftChild Note n
n) = Note n -> String
forall a. Show a => a -> String
show Note n
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"┘"
  show (SpreadRightChild Note n
n) = String
"└" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Note n -> String
forall a. Show a => a -> String
show Note n
n
  show (SpreadBothChildren Note n
nl Note n
nr) = Note n -> String
forall a. Show a => a -> String
show Note n
nl String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"┴" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Note n -> String
forall a. Show a => a -> String
show Note n
nr

instance (Notation n) => FromJSON (SpreadChildren n) where
  parseJSON :: Value -> Parser (SpreadChildren n)
parseJSON = String
-> (Object -> Parser (SpreadChildren n))
-> Value
-> Parser (SpreadChildren n)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"SpreadChild" ((Object -> Parser (SpreadChildren n))
 -> Value -> Parser (SpreadChildren n))
-> (Object -> Parser (SpreadChildren n))
-> Value
-> Parser (SpreadChildren n)
forall a b. (a -> b) -> a -> b
$ \Object
cld -> do
    Value
typ <- Object
cld Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
    case Value
typ of
      Value
"leftChild" -> (Note n -> SpreadChildren n)
-> Parser (Note n) -> Parser (SpreadChildren n)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Note n -> SpreadChildren n
forall n. Note n -> SpreadChildren n
SpreadLeftChild (Parser (Note n) -> Parser (SpreadChildren n))
-> Parser (Note n) -> Parser (SpreadChildren n)
forall a b. (a -> b) -> a -> b
$ Object
cld Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value" Parser Value -> (Value -> Parser (Note n)) -> Parser (Note n)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser (Note n)
forall a. FromJSON a => Value -> Parser a
parseJSON -- pure $ ToLeft 1
      Value
"rightChild" -> (Note n -> SpreadChildren n)
-> Parser (Note n) -> Parser (SpreadChildren n)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Note n -> SpreadChildren n
forall n. Note n -> SpreadChildren n
SpreadRightChild (Parser (Note n) -> Parser (SpreadChildren n))
-> Parser (Note n) -> Parser (SpreadChildren n)
forall a b. (a -> b) -> a -> b
$ Object
cld Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value" Parser Value -> (Value -> Parser (Note n)) -> Parser (Note n)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser (Note n)
forall a. FromJSON a => Value -> Parser a
parseJSON -- pure $ ToRight 1
      Value
"bothChildren" -> Object
cld Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value" Parser Value
-> (Value -> Parser (SpreadChildren n))
-> Parser (SpreadChildren n)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser (SpreadChildren n)
parseBoth -- pure ToBoth
      Value
_ -> Value -> Parser (SpreadChildren n)
forall a. Value -> Parser a
Aeson.unexpected Value
typ
   where
    parseBoth :: Value -> Parser (SpreadChildren n)
parseBoth = String
-> (Object -> Parser (SpreadChildren n))
-> Value
-> Parser (SpreadChildren n)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"SpreadBothChildren" ((Object -> Parser (SpreadChildren n))
 -> Value -> Parser (SpreadChildren n))
-> (Object -> Parser (SpreadChildren n))
-> Value
-> Parser (SpreadChildren n)
forall a b. (a -> b) -> a -> b
$ \Object
bth -> do
      Note n
left <- Object
bth Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"left" Parser Value -> (Value -> Parser (Note n)) -> Parser (Note n)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser (Note n)
forall a. FromJSON a => Value -> Parser a
parseJSON
      Note n
right <- Object
bth Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"right" Parser Value -> (Value -> Parser (Note n)) -> Parser (Note n)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser (Note n)
forall a. FromJSON a => Value -> Parser a
parseJSON
      pure $ Note n -> Note n -> SpreadChildren n
forall n. Note n -> Note n -> SpreadChildren n
SpreadBothChildren Note n
left Note n
right

instance (Notation n) => ToJSON (SpreadChildren n) where
  toJSON :: SpreadChildren n -> Value
toJSON (SpreadLeftChild Note n
n) = [Pair] -> Value
Aeson.object [Key
"type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"leftChild" :: String), Key
"value" Key -> Note n -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Note n
n]
  toJSON (SpreadRightChild Note n
n) = [Pair] -> Value
Aeson.object [Key
"type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"rightChild" :: String), Key
"value" Key -> Note n -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Note n
n]
  toJSON (SpreadBothChildren Note n
nl Note n
nr) =
    [Pair] -> Value
Aeson.object
      [ Key
"type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"bothChildren" :: String)
      , Key
"value" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object [Key
"left" Key -> Note n -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Note n
nl, Key
"right" Key -> Note n -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Note n
nr]
      ]

-- | Returns the left child of a spread note, if it exists
leftSpreadChild :: SpreadChildren n -> Maybe (Note n)
leftSpreadChild :: forall n. SpreadChildren n -> Maybe (Note n)
leftSpreadChild = \case
  (SpreadLeftChild Note n
n) -> Note n -> Maybe (Note n)
forall a. a -> Maybe a
Just Note n
n
  (SpreadBothChildren Note n
n Note n
_) -> Note n -> Maybe (Note n)
forall a. a -> Maybe a
Just Note n
n
  SpreadChildren n
_ -> Maybe (Note n)
forall a. Maybe a
Nothing

-- | Returns the right child of a spread note, if it exists
rightSpreadChild :: SpreadChildren n -> Maybe (Note n)
rightSpreadChild :: forall n. SpreadChildren n -> Maybe (Note n)
rightSpreadChild = \case
  (SpreadRightChild Note n
n) -> Note n -> Maybe (Note n)
forall a. a -> Maybe a
Just Note n
n
  (SpreadBothChildren Note n
_ Note n
n) -> Note n -> Maybe (Note n)
forall a. a -> Maybe a
Just Note n
n
  SpreadChildren n
_ -> Maybe (Note n)
forall a. Maybe a
Nothing

{- | 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 (Note n) (SpreadChildren n)) !(Edges n)
  deriving (Spread n -> Spread n -> Bool
(Spread n -> Spread n -> Bool)
-> (Spread n -> Spread n -> Bool) -> Eq (Spread n)
forall n. Eq n => Spread n -> Spread n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Spread n -> Spread n -> Bool
Eq, Eq (Spread n)
Eq (Spread n) =>
(Spread n -> Spread n -> Ordering)
-> (Spread n -> Spread n -> Bool)
-> (Spread n -> Spread n -> Bool)
-> (Spread n -> Spread n -> Bool)
-> (Spread n -> Spread n -> Bool)
-> (Spread n -> Spread n -> Spread n)
-> (Spread n -> Spread n -> Spread n)
-> Ord (Spread n)
Spread n -> Spread n -> Bool
Spread n -> Spread n -> Ordering
Spread n -> Spread n -> Spread 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 (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
$ccompare :: forall n. Ord n => Spread n -> Spread n -> Ordering
compare :: Spread n -> Spread n -> Ordering
$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
>= :: Spread n -> Spread n -> Bool
$cmax :: forall n. Ord n => Spread n -> Spread n -> Spread n
max :: Spread n -> Spread n -> Spread n
$cmin :: forall n. Ord n => Spread n -> Spread n -> Spread n
min :: Spread n -> Spread n -> Spread n
Ord, (forall x. Spread n -> Rep (Spread n) x)
-> (forall x. Rep (Spread n) x -> Spread n) -> Generic (Spread n)
forall x. Rep (Spread n) x -> Spread n
forall x. Spread n -> Rep (Spread n) x
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
$cfrom :: forall n x. Spread n -> Rep (Spread n) x
from :: forall x. Spread n -> Rep (Spread n) x
$cto :: forall n x. Rep (Spread n) x -> Spread n
to :: forall x. Rep (Spread n) x -> Spread n
Generic, Spread n -> ()
(Spread n -> ()) -> NFData (Spread n)
forall n. NFData n => Spread n -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall n. NFData n => Spread n -> ()
rnf :: Spread n -> ()
NFData, Eq (Spread n)
Eq (Spread n) =>
(Int -> Spread n -> Int)
-> (Spread n -> Int) -> Hashable (Spread n)
Int -> Spread n -> Int
Spread n -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall n. Hashable n => Eq (Spread n)
forall n. Hashable n => Int -> Spread n -> Int
forall n. Hashable n => Spread n -> Int
$chashWithSalt :: forall n. Hashable n => Int -> Spread n -> Int
hashWithSalt :: Int -> Spread n -> Int
$chash :: forall n. Hashable n => Spread n -> Int
hash :: Spread n -> Int
Hashable)

instance (Notation n) => Show (Spread n) where
  show :: Spread n -> String
show (SpreadOp HashMap (Note n) (SpreadChildren n)
dist Edges n
m) = String
"{" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," [String]
dists String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"} => " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Edges n -> String
forall a. Show a => a -> String
show Edges n
m
   where
    dists :: [String]
dists = (Note n, SpreadChildren n) -> String
forall {a} {a}. (Show a, Show a) => (a, a) -> String
showDist ((Note n, SpreadChildren n) -> String)
-> [(Note n, SpreadChildren n)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap (Note n) (SpreadChildren n) -> [(Note n, SpreadChildren n)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap (Note n) (SpreadChildren n)
dist
    showDist :: (a, a) -> String
showDist (a
n, a
to) = a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"=>" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
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 = String
-> (Object -> Parser (Spread n)) -> Value -> Parser (Spread n)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Spread" ((Object -> Parser (Spread n)) -> Value -> Parser (Spread n))
-> (Object -> Parser (Spread n)) -> Value -> Parser (Spread n)
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    [(Note n, SpreadChildren n)]
dists <- Object
v Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"children" Parser [Value]
-> ([Value] -> Parser [(Note n, SpreadChildren n)])
-> Parser [(Note n, SpreadChildren n)]
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Parser (Note n, SpreadChildren n))
-> [Value] -> Parser [(Note n, SpreadChildren n)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Parser (Note n, SpreadChildren n)
parseDist
    Edges n
edges <- Object
v Object -> Key -> Parser (Edges n)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"midEdges"
    pure $ HashMap (Note n) (SpreadChildren n) -> Edges n -> Spread n
forall n.
HashMap (Note n) (SpreadChildren n) -> Edges n -> Spread n
SpreadOp ((SpreadChildren n -> SpreadChildren n -> SpreadChildren n)
-> [(Note n, SpreadChildren n)]
-> HashMap (Note n) (SpreadChildren n)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HM.fromListWith SpreadChildren n -> SpreadChildren n -> SpreadChildren n
forall a b. a -> b -> a
const [(Note n, SpreadChildren n)]
dists) Edges n
edges
   where
    parseDist :: Value -> Parser (Note n, SpreadChildren n)
parseDist = String
-> (Object -> Parser (Note n, SpreadChildren n))
-> Value
-> Parser (Note n, SpreadChildren n)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"SpreadDist" ((Object -> Parser (Note n, SpreadChildren n))
 -> Value -> Parser (Note n, SpreadChildren n))
-> (Object -> Parser (Note n, SpreadChildren n))
-> Value
-> Parser (Note n, SpreadChildren n)
forall a b. (a -> b) -> a -> b
$ \Object
dst -> do
      Note n
parent <- Object
dst Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"parent" Parser Value -> (Value -> Parser (Note n)) -> Parser (Note n)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser (Note n)
forall a. FromJSON a => Value -> Parser a
parseJSON
      SpreadChildren n
child <- Object
dst Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"child" Parser Value
-> (Value -> Parser (SpreadChildren n))
-> Parser (SpreadChildren n)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser (SpreadChildren n)
forall a. FromJSON a => Value -> Parser a
parseJSON
      pure (Note n
parent, SpreadChildren n
child)

instance (Notation n) => ToJSON (Spread n) where
  toJSON :: Spread n -> Value
toJSON (SpreadOp HashMap (Note n) (SpreadChildren n)
dists Edges n
edges) =
    [Pair] -> Value
Aeson.object
      [ Key
"children" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ((Note n, SpreadChildren n) -> Value)
-> [(Note n, SpreadChildren n)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Note n, SpreadChildren n) -> Value
forall {v} {v}. (ToJSON v, ToJSON v) => (v, v) -> Value
distToJSON (HashMap (Note n) (SpreadChildren n) -> [(Note n, SpreadChildren n)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap (Note n) (SpreadChildren n)
dists)
      , Key
"midEdges" Key -> Edges n -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Edges n
edges
      ]
   where
    distToJSON :: (v, v) -> Value
distToJSON (v
parent, v
child) = [Pair] -> Value
Aeson.object [Key
"parent" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
parent, Key
"child" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
child]

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

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

-- -- | Helper: parses a note's pitch from JSON.
-- parseJSONNote :: (Notation n) => Aeson.Value -> Aeson.Parser (Note n)
-- parseJSONNote = _

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

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

edgeToJSON :: (ToJSON a) => (a, a) -> Aeson.Value
edgeToJSON :: forall a. ToJSON a => (a, a) -> Value
edgeToJSON (a
l, a
r) = [Pair] -> Value
Aeson.object [Key
"left" Key -> a -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= a
l, Key
"right" Key -> a -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= a
r]

-- edgeToEncoding :: (ToJSON a) => (a, a) -> Aeson.Encoding
-- edgeToEncoding (l, r) = Aeson.pairs $ ("left" .= l) <> ("right" .= r)

-- | An 'Analysis' specialized to PV types.
type PVAnalysis n = Analysis (Split n) (Freeze n) (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 = String -> IO (Either String (PVAnalysis SPitch))
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 = (PVAnalysis SPitch -> PVAnalysis SPC)
-> Either String (PVAnalysis SPitch)
-> Either String (PVAnalysis SPC)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SPitch -> SPC) -> PVAnalysis SPitch -> PVAnalysis SPC
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)) (Either String (PVAnalysis SPitch)
 -> Either String (PVAnalysis SPC))
-> IO (Either String (PVAnalysis SPitch))
-> IO (Either String (PVAnalysis SPC))
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 [[(Note SPitch, Music.RightTied)]]
slicesFromFile :: String -> IO [[(Note SPitch, RightTied)]]
slicesFromFile String
file = do
  Text
txt <- String -> IO Text
TL.readFile String
file
  case Bool -> Text -> Maybe Document
MusicXML.parseWithIds Bool
True Text
txt of
    Maybe Document
Nothing -> [[(Note SPitch, RightTied)]] -> IO [[(Note SPitch, RightTied)]]
forall a. a -> IO a
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 :: [NoteId SInterval (Ratio Int) (Maybe String)]
notes = XmlNote -> NoteId SInterval (Ratio Int) (Maybe String)
MusicXML.asNoteWithIdHeard (XmlNote -> NoteId SInterval (Ratio Int) (Maybe String))
-> [XmlNote] -> [NoteId SInterval (Ratio Int) (Maybe String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [XmlNote]
xmlNotes
          slices :: [[(NoteId SInterval (Ratio Int) (Maybe String), Tied)]]
slices = Slicer
  (NoteId SInterval (Ratio Int) (Maybe String))
  (TimeOf (NoteId SInterval (Ratio Int) (Maybe String)))
  ([NoteId SInterval (Ratio Int) (Maybe String)],
   [NoteId SInterval (Ratio Int) (Maybe String)])
  [(NoteId SInterval (Ratio Int) (Maybe String), Tied)]
-> [NoteId SInterval (Ratio Int) (Maybe String)]
-> [[(NoteId SInterval (Ratio Int) (Maybe String), Tied)]]
forall (f :: * -> *) n st s.
(Foldable f, HasTime n) =>
Slicer n (TimeOf n) st s -> f n -> [s]
Music.slicePiece Slicer
  (NoteId SInterval (Ratio Int) (Maybe String))
  (Ratio Int)
  ([NoteId SInterval (Ratio Int) (Maybe String)],
   [NoteId SInterval (Ratio Int) (Maybe String)])
  [(NoteId SInterval (Ratio Int) (Maybe String), Tied)]
Slicer
  (NoteId SInterval (Ratio Int) (Maybe String))
  (TimeOf (NoteId SInterval (Ratio Int) (Maybe String)))
  ([NoteId SInterval (Ratio Int) (Maybe String)],
   [NoteId SInterval (Ratio Int) (Maybe String)])
  [(NoteId SInterval (Ratio Int) (Maybe String), Tied)]
forall a t. Eq a => Slicer a t ([a], [a]) [(a, Tied)]
Music.tiedSlicer [NoteId SInterval (Ratio Int) (Maybe String)]
notes
      [[(Note SPitch, RightTied)]] -> IO [[(Note SPitch, RightTied)]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[(Note SPitch, RightTied)]] -> IO [[(Note SPitch, RightTied)]])
-> [[(Note SPitch, RightTied)]] -> IO [[(Note SPitch, RightTied)]]
forall a b. (a -> b) -> a -> b
$ [(NoteId SInterval (Ratio Int) (Maybe String), Tied)]
-> [(Note
       (Pitch (IntervalOf (NoteId SInterval (Ratio Int) (Maybe String)))),
     RightTied)]
[(NoteId SInterval (Ratio Int) (Maybe String), Tied)]
-> [(Note SPitch, RightTied)]
forall {i} {f :: * -> *}.
(IdOf i ~ Maybe String, Functor f, HasPitch i, Identifiable i) =>
f (i, Tied) -> f (Note (Pitch (IntervalOf i)), RightTied)
mkSlice ([(NoteId SInterval (Ratio Int) (Maybe String), Tied)]
 -> [(Note SPitch, RightTied)])
-> [[(NoteId SInterval (Ratio Int) (Maybe String), Tied)]]
-> [[(Note SPitch, RightTied)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(NoteId SInterval (Ratio Int) (Maybe String), Tied)] -> Bool)
-> [[(NoteId SInterval (Ratio Int) (Maybe String), Tied)]]
-> [[(NoteId SInterval (Ratio Int) (Maybe String), Tied)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ([(NoteId SInterval (Ratio Int) (Maybe String), Tied)] -> Bool)
-> [(NoteId SInterval (Ratio Int) (Maybe String), Tied)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(NoteId SInterval (Ratio Int) (Maybe String), Tied)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[(NoteId SInterval (Ratio Int) (Maybe String), Tied)]]
slices
 where
  mkSlice :: f (i, Tied) -> f (Note (Pitch (IntervalOf i)), RightTied)
mkSlice f (i, Tied)
notes = (i, Tied) -> (Note (Pitch (IntervalOf i)), RightTied)
forall {i}.
(IdOf i ~ Maybe String, HasPitch i, Identifiable i) =>
(i, Tied) -> (Note (Pitch (IntervalOf i)), RightTied)
mkNote ((i, Tied) -> (Note (Pitch (IntervalOf i)), RightTied))
-> f (i, Tied) -> f (Note (Pitch (IntervalOf i)), RightTied)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (i, Tied)
notes
  mkNote :: (i, Tied) -> (Note (Pitch (IntervalOf i)), RightTied)
mkNote (i
note, Tied
tie) = (Pitch (IntervalOf i) -> String -> Note (Pitch (IntervalOf i))
forall n. n -> String -> Note n
Note (i -> Pitch (IntervalOf i)
forall a. HasPitch a => a -> Pitch (IntervalOf a)
Music.pitch i
note) (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ i -> IdOf i
forall i. Identifiable i => i -> IdOf i
Music.getId i
note), Tied -> RightTied
Music.rightTie Tied
tie)

-- | Converts salami slices (as returned by 'slicesFromFile') to a path as expected by parsers.
slicesToPath
  :: forall i
   . (Interval i, Ord i, Eq i)
  => [[(Note (Pitch i), Music.RightTied)]]
  -> Path [Note (Pitch i)] [Edge (Pitch i)]
slicesToPath :: forall i.
(Interval i, Ord i, Eq i) =>
[[(Note (Pitch i), RightTied)]]
-> Path [Note (Pitch i)] [Edge (Pitch i)]
slicesToPath = Int
-> [[(Note (Pitch i), RightTied)]]
-> Path [Note (Pitch i)] [Edge (Pitch i)]
go Int
0
 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 []  = []
  mkNote :: a -> Note n -> Note n
mkNote a
i (Note n
p String
id) = n -> String -> Note n
forall n. n -> String -> Note n
Note n
p (String
"slice" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
id)
  mkEdge :: a
-> (Note n, RightTied)
-> Maybe (StartStop (Note n), StartStop (Note n))
mkEdge a
i (Note n
_, RightTied
Music.Ends) = Maybe (StartStop (Note n), StartStop (Note n))
forall a. Maybe a
Nothing
  mkEdge a
i (Note n
p, RightTied
Music.Holds) = (StartStop (Note n), StartStop (Note n))
-> Maybe (StartStop (Note n), StartStop (Note n))
forall a. a -> Maybe a
Just (Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner (Note n -> StartStop (Note n)) -> Note n -> StartStop (Note n)
forall a b. (a -> b) -> a -> b
$ a -> Note n -> Note n
forall {a} {n}. Show a => a -> Note n -> Note n
mkNote a
i Note n
p, Note n -> StartStop (Note n)
forall a. a -> StartStop a
Inner (Note n -> StartStop (Note n)) -> Note n -> StartStop (Note n)
forall a b. (a -> b) -> a -> b
$ a -> Note n -> Note n
forall {a} {n}. Show a => a -> Note n -> Note n
mkNote (a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) Note n
p)
  go :: Int -> [[(Note (Pitch i), Music.RightTied)]] -> Path [Note (Pitch i)] [Edge (Pitch i)]
  go :: Int
-> [[(Note (Pitch i), RightTied)]]
-> Path [Note (Pitch i)] [Edge (Pitch i)]
go Int
_ [] = String -> Path [Note (Pitch i)] [Edge (Pitch i)]
forall a. HasCallStack => String -> a
error String
"cannot construct path from empty list"
  go Int
i [[(Note (Pitch i), RightTied)]
notes] = [Note (Pitch i)] -> Path [Note (Pitch i)] [Edge (Pitch i)]
forall around between. around -> Path around between
PathEnd (Int -> Note (Pitch i) -> Note (Pitch i)
forall {a} {n}. Show a => a -> Note n -> Note n
mkNote Int
i (Note (Pitch i) -> Note (Pitch i))
-> ((Note (Pitch i), RightTied) -> Note (Pitch i))
-> (Note (Pitch i), RightTied)
-> Note (Pitch i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Note (Pitch i), RightTied) -> Note (Pitch i)
forall a b. (a, b) -> a
fst ((Note (Pitch i), RightTied) -> Note (Pitch i))
-> [(Note (Pitch i), RightTied)] -> [Note (Pitch i)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Note (Pitch i), RightTied)]
notes)
  go Int
i ([(Note (Pitch i), RightTied)]
notes : [[(Note (Pitch i), RightTied)]]
rest) = [Note (Pitch i)]
-> [Edge (Pitch i)]
-> Path [Note (Pitch i)] [Edge (Pitch i)]
-> Path [Note (Pitch i)] [Edge (Pitch i)]
forall around between.
around -> between -> Path around between -> Path around between
Path (Int -> Note (Pitch i) -> Note (Pitch i)
forall {a} {n}. Show a => a -> Note n -> Note n
mkNote Int
i (Note (Pitch i) -> Note (Pitch i))
-> ((Note (Pitch i), RightTied) -> Note (Pitch i))
-> (Note (Pitch i), RightTied)
-> Note (Pitch i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Note (Pitch i), RightTied) -> Note (Pitch i)
forall a b. (a, b) -> a
fst ((Note (Pitch i), RightTied) -> Note (Pitch i))
-> [(Note (Pitch i), RightTied)] -> [Note (Pitch i)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Note (Pitch i), RightTied)]
notes) (((Note (Pitch i), RightTied) -> Maybe (Edge (Pitch i)))
-> [(Note (Pitch i), RightTied)] -> [Edge (Pitch i)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Int -> (Note (Pitch i), RightTied) -> Maybe (Edge (Pitch i))
forall {a} {n}.
(Show a, Num a) =>
a
-> (Note n, RightTied)
-> Maybe (StartStop (Note n), StartStop (Note n))
mkEdge Int
i) [(Note (Pitch i), RightTied)]
notes) (Path [Note (Pitch i)] [Edge (Pitch i)]
 -> Path [Note (Pitch i)] [Edge (Pitch i)])
-> Path [Note (Pitch i)] [Edge (Pitch i)]
-> Path [Note (Pitch i)] [Edge (Pitch i)]
forall a b. (a -> b) -> a -> b
$ Int
-> [[(Note (Pitch i), RightTied)]]
-> Path [Note (Pitch i)] [Edge (Pitch i)]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [[(Note (Pitch i), RightTied)]]
rest

{- | Loads a MusicXML File and returns a surface path
 as input to parsers.
-}
loadSurface :: FilePath -> IO (Path [Note SPitch] [Edge SPitch])
loadSurface :: String -> IO (Path [Note SPitch] [Edge SPitch])
loadSurface = ([[(Note SPitch, RightTied)]] -> Path [Note SPitch] [Edge SPitch])
-> IO [[(Note SPitch, RightTied)]]
-> IO (Path [Note SPitch] [Edge SPitch])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Note SPitch, RightTied)]] -> Path [Note SPitch] [Edge SPitch]
forall i.
(Interval i, Ord i, Eq i) =>
[[(Note (Pitch i), RightTied)]]
-> Path [Note (Pitch i)] [Edge (Pitch i)]
slicesToPath (IO [[(Note SPitch, RightTied)]]
 -> IO (Path [Note SPitch] [Edge SPitch]))
-> (String -> IO [[(Note SPitch, RightTied)]])
-> String
-> IO (Path [Note SPitch] [Edge SPitch])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO [[(Note 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 [Note SPitch] [Edge SPitch])
loadSurface' :: String -> Int -> Int -> IO (Path [Note SPitch] [Edge SPitch])
loadSurface' String
fn Int
from Int
to =
  [[(Note SPitch, RightTied)]] -> Path [Note SPitch] [Edge SPitch]
forall i.
(Interval i, Ord i, Eq i) =>
[[(Note (Pitch i), RightTied)]]
-> Path [Note (Pitch i)] [Edge (Pitch i)]
slicesToPath ([[(Note SPitch, RightTied)]] -> Path [Note SPitch] [Edge SPitch])
-> ([[(Note SPitch, RightTied)]] -> [[(Note SPitch, RightTied)]])
-> [[(Note SPitch, RightTied)]]
-> Path [Note SPitch] [Edge SPitch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[(Note SPitch, RightTied)]] -> [[(Note SPitch, RightTied)]]
forall a. Int -> [a] -> [a]
drop Int
from ([[(Note SPitch, RightTied)]] -> [[(Note SPitch, RightTied)]])
-> ([[(Note SPitch, RightTied)]] -> [[(Note SPitch, RightTied)]])
-> [[(Note SPitch, RightTied)]]
-> [[(Note SPitch, RightTied)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[(Note SPitch, RightTied)]] -> [[(Note SPitch, RightTied)]]
forall a. Int -> [a] -> [a]
take (Int
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
from Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([[(Note SPitch, RightTied)]] -> Path [Note SPitch] [Edge SPitch])
-> IO [[(Note SPitch, RightTied)]]
-> IO (Path [Note SPitch] [Edge SPitch])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [[(Note 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 n) (Spread n)]
deriv Path (Edges n) (Notes n)
top) = do
  [Leftmost (Split n') (Freeze n') (Spread n')]
deriv' <- (Leftmost (Split n) (Freeze n) (Spread n)
 -> f (Leftmost (Split n') (Freeze n') (Spread n')))
-> [Leftmost (Split n) (Freeze n) (Spread n)]
-> f [Leftmost (Split n') (Freeze n') (Spread n')]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((n -> f n')
-> Leftmost (Split n) (Freeze n) (Spread n)
-> f (Leftmost (Split n') (Freeze n') (Spread n'))
forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n', Ord n') =>
(n -> f n')
-> Leftmost (Split n) (Freeze n) (Spread n)
-> f (Leftmost (Split n') (Freeze n') (Spread n'))
leftmostTraversePitch n -> f n'
f) [Leftmost (Split n) (Freeze n) (Spread n)]
deriv
  Path (Edges n') (Notes n')
top' <- (n -> f n')
-> Path (Edges n) (Notes n) -> f (Path (Edges n') (Notes n'))
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 $ [Leftmost (Split n') (Freeze n') (Spread n')]
-> Path (Edges n') (Notes n') -> PVAnalysis n'
forall s f h tr slc.
[Leftmost s f h] -> Path tr slc -> Analysis s f h tr slc
Analysis [Leftmost (Split n') (Freeze n') (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 = Identity (PVAnalysis n') -> PVAnalysis n'
forall a. Identity a -> a
runIdentity (Identity (PVAnalysis n') -> PVAnalysis n')
-> (PVAnalysis n -> Identity (PVAnalysis n'))
-> PVAnalysis n
-> PVAnalysis n'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Identity n') -> PVAnalysis n -> Identity (PVAnalysis n')
forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n', Ord n') =>
(n -> f n') -> PVAnalysis n -> f (PVAnalysis n')
analysisTraversePitch (n' -> Identity n'
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (n' -> Identity n') -> (n -> n') -> n -> Identity n'
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' <- (n -> f n') -> Edges n -> f (Edges n')
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' <- (n -> f n') -> Notes n -> f (Notes n')
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' <- (n -> f n')
-> Path (Edges n) (Notes n) -> f (Path (Edges n') (Notes n'))
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 $ Edges n'
-> Notes n'
-> Path (Edges n') (Notes n')
-> Path (Edges n') (Notes n')
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) = Edges n' -> Path (Edges n') (Notes n')
forall around between. around -> Path around between
PathEnd (Edges n' -> Path (Edges n') (Notes n'))
-> f (Edges n') -> f (Path (Edges n') (Notes n'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (n -> f n') -> Edges n -> f (Edges n')
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) = (,) (n' -> n' -> (n', n')) -> f n' -> f (n' -> (n', n'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> n -> f n'
f n
n1 f (n' -> (n', n')) -> f n' -> f (n', n')
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> n -> f n'
f n
n2

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 HashSet (Note a)
notes) = HashSet (Note n) -> Notes n
forall n. HashSet (Note n) -> Notes n
Notes (HashSet (Note n) -> Notes n)
-> f (HashSet (Note n)) -> f (Notes n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Note a -> f (Note n)) -> HashSet (Note a) -> f (HashSet (Note n))
forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet ((a -> f n) -> Note a -> f (Note n)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse a -> f n
f) HashSet (Note 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 (Note n'), StartStop (Note n'))
reg' <- (Edge n -> f (StartStop (Note n'), StartStop (Note n')))
-> HashSet (Edge n)
-> f (HashSet (StartStop (Note n'), StartStop (Note n')))
forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet ((StartStop (Note n) -> f (StartStop (Note n')))
-> Edge n -> f (StartStop (Note n'), StartStop (Note n'))
forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge ((StartStop (Note n) -> f (StartStop (Note n')))
 -> Edge n -> f (StartStop (Note n'), StartStop (Note n')))
-> (StartStop (Note n) -> f (StartStop (Note n')))
-> Edge n
-> f (StartStop (Note n'), StartStop (Note n'))
forall a b. (a -> b) -> a -> b
$ (Note n -> f (Note n'))
-> StartStop (Note n) -> f (StartStop (Note n'))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StartStop a -> f (StartStop b)
traverse ((Note n -> f (Note n'))
 -> StartStop (Note n) -> f (StartStop (Note n')))
-> (Note n -> f (Note n'))
-> StartStop (Note n)
-> f (StartStop (Note n'))
forall a b. (a -> b) -> a -> b
$ (n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) HashSet (Edge n)
reg
  MultiSet (Note n', Note n')
pass' <- (InnerEdge n -> f (Note n', Note n'))
-> MultiSet (InnerEdge n) -> f (MultiSet (Note n', Note n'))
forall b (f :: * -> *) a.
(Eq b, Hashable b, Applicative f) =>
(a -> f b) -> MultiSet a -> f (MultiSet b)
MS.traverse ((Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n')
forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge ((Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n'))
-> (Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n')
forall a b. (a -> b) -> a -> b
$ (n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) MultiSet (InnerEdge n)
pass
  pure $ HashSet (StartStop (Note n'), StartStop (Note n'))
-> MultiSet (Note n', Note n') -> Edges n'
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (StartStop (Note n'), StartStop (Note n'))
reg' MultiSet (Note n', Note n')
pass'

leftmostTraversePitch
  :: (Applicative f, Eq n', Hashable n', Ord n')
  => (n -> f n')
  -> Leftmost (Split n) (Freeze n) (Spread n)
  -> f (Leftmost (Split n') (Freeze n') (Spread n'))
leftmostTraversePitch :: forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n', Ord n') =>
(n -> f n')
-> Leftmost (Split n) (Freeze n) (Spread n)
-> f (Leftmost (Split n') (Freeze n') (Spread n'))
leftmostTraversePitch n -> f n'
f Leftmost (Split n) (Freeze n) (Spread n)
lm = case Leftmost (Split n) (Freeze n) (Spread n)
lm of
  LMSplitLeft Split n
s -> Split n' -> Leftmost (Split n') (Freeze n') (Spread n')
forall s f h. s -> Leftmost s f h
LMSplitLeft (Split n' -> Leftmost (Split n') (Freeze n') (Spread n'))
-> f (Split n') -> f (Leftmost (Split n') (Freeze n') (Spread n'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (n -> f n') -> Split n -> f (Split n')
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 -> Split n' -> Leftmost (Split n') (Freeze n') (Spread n')
forall s f h. s -> Leftmost s f h
LMSplitRight (Split n' -> Leftmost (Split n') (Freeze n') (Spread n'))
-> f (Split n') -> f (Leftmost (Split n') (Freeze n') (Spread n'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (n -> f n') -> Split n -> f (Split n')
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 -> Split n' -> Leftmost (Split n') (Freeze n') (Spread n')
forall s f h. s -> Leftmost s f h
LMSplitOnly (Split n' -> Leftmost (Split n') (Freeze n') (Spread n'))
-> f (Split n') -> f (Leftmost (Split n') (Freeze n') (Spread n'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (n -> f n') -> Split n -> f (Split n')
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 n
fr -> Freeze n' -> Leftmost (Split n') (Freeze n') (Spread n')
forall f s h. f -> Leftmost s f h
LMFreezeLeft (Freeze n' -> Leftmost (Split n') (Freeze n') (Spread n'))
-> f (Freeze n') -> f (Leftmost (Split n') (Freeze n') (Spread n'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (n -> f n') -> Freeze n -> f (Freeze n')
forall (f :: * -> *) n' n.
(Applicative f, Hashable n') =>
(n -> f n') -> Freeze n -> f (Freeze n')
freezeTraversePitch n -> f n'
f Freeze n
fr
  LMFreezeOnly Freeze n
fr -> Freeze n' -> Leftmost (Split n') (Freeze n') (Spread n')
forall f s h. f -> Leftmost s f h
LMFreezeOnly (Freeze n' -> Leftmost (Split n') (Freeze n') (Spread n'))
-> f (Freeze n') -> f (Leftmost (Split n') (Freeze n') (Spread n'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (n -> f n') -> Freeze n -> f (Freeze n')
forall (f :: * -> *) n' n.
(Applicative f, Hashable n') =>
(n -> f n') -> Freeze n -> f (Freeze n')
freezeTraversePitch n -> f n'
f Freeze n
fr
  LMSpread Spread n
h -> Spread n' -> Leftmost (Split n') (Freeze n') (Spread n')
forall h s f. h -> Leftmost s f h
LMSpread (Spread n' -> Leftmost (Split n') (Freeze n') (Spread n'))
-> f (Spread n') -> f (Leftmost (Split n') (Freeze n') (Spread n'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (n -> f n') -> Spread n -> f (Spread n')
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) [(Note n, DoubleOrnament)]
reg Map (InnerEdge n) [(Note n, PassingOrnament)]
pass Map (Note n) [(Note n, RightOrnament)]
ls Map (Note n) [(Note n, LeftOrnament)]
rs HashSet (Edge n)
kl HashSet (Edge n)
kr MultiSet (InnerEdge n)
pl MultiSet (InnerEdge n)
pr) = do
  Map
  (StartStop (Note n'), StartStop (Note n'))
  [(Note n', DoubleOrnament)]
reg' <- (Edge n -> f (StartStop (Note n'), StartStop (Note n')))
-> Map (Edge n) [(Note n, DoubleOrnament)]
-> f (Map
        (StartStop (Note n'), StartStop (Note n'))
        [(Note n', DoubleOrnament)])
forall p p' o.
Ord p' =>
(p -> f p') -> Map p [(Note n, o)] -> f (Map p' [(Note n', o)])
traverseElabo ((StartStop (Note n) -> f (StartStop (Note n')))
-> Edge n -> f (StartStop (Note n'), StartStop (Note n'))
forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge ((StartStop (Note n) -> f (StartStop (Note n')))
 -> Edge n -> f (StartStop (Note n'), StartStop (Note n')))
-> (StartStop (Note n) -> f (StartStop (Note n')))
-> Edge n
-> f (StartStop (Note n'), StartStop (Note n'))
forall a b. (a -> b) -> a -> b
$ (Note n -> f (Note n'))
-> StartStop (Note n) -> f (StartStop (Note n'))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StartStop a -> f (StartStop b)
traverse ((Note n -> f (Note n'))
 -> StartStop (Note n) -> f (StartStop (Note n')))
-> (Note n -> f (Note n'))
-> StartStop (Note n)
-> f (StartStop (Note n'))
forall a b. (a -> b) -> a -> b
$ (n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) Map (Edge n) [(Note n, DoubleOrnament)]
reg
  Map (Note n', Note n') [(Note n', PassingOrnament)]
pass' <- (InnerEdge n -> f (Note n', Note n'))
-> Map (InnerEdge n) [(Note n, PassingOrnament)]
-> f (Map (Note n', Note n') [(Note n', PassingOrnament)])
forall p p' o.
Ord p' =>
(p -> f p') -> Map p [(Note n, o)] -> f (Map p' [(Note n', o)])
traverseElabo ((Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n')
forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge ((Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n'))
-> (Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n')
forall a b. (a -> b) -> a -> b
$ (n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) Map (InnerEdge n) [(Note n, PassingOrnament)]
pass
  Map (Note n') [(Note n', RightOrnament)]
ls' <- (Note n -> f (Note n'))
-> Map (Note n) [(Note n, RightOrnament)]
-> f (Map (Note n') [(Note n', RightOrnament)])
forall p p' o.
Ord p' =>
(p -> f p') -> Map p [(Note n, o)] -> f (Map p' [(Note n', o)])
traverseElabo ((n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) Map (Note n) [(Note n, RightOrnament)]
ls
  Map (Note n') [(Note n', LeftOrnament)]
rs' <- (Note n -> f (Note n'))
-> Map (Note n) [(Note n, LeftOrnament)]
-> f (Map (Note n') [(Note n', LeftOrnament)])
forall p p' o.
Ord p' =>
(p -> f p') -> Map p [(Note n, o)] -> f (Map p' [(Note n', o)])
traverseElabo ((n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) Map (Note n) [(Note n, LeftOrnament)]
rs
  HashSet (StartStop (Note n'), StartStop (Note n'))
kl' <- (Edge n -> f (StartStop (Note n'), StartStop (Note n')))
-> HashSet (Edge n)
-> f (HashSet (StartStop (Note n'), StartStop (Note n')))
forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet ((StartStop (Note n) -> f (StartStop (Note n')))
-> Edge n -> f (StartStop (Note n'), StartStop (Note n'))
forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge ((StartStop (Note n) -> f (StartStop (Note n')))
 -> Edge n -> f (StartStop (Note n'), StartStop (Note n')))
-> (StartStop (Note n) -> f (StartStop (Note n')))
-> Edge n
-> f (StartStop (Note n'), StartStop (Note n'))
forall a b. (a -> b) -> a -> b
$ (Note n -> f (Note n'))
-> StartStop (Note n) -> f (StartStop (Note n'))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StartStop a -> f (StartStop b)
traverse ((Note n -> f (Note n'))
 -> StartStop (Note n) -> f (StartStop (Note n')))
-> (Note n -> f (Note n'))
-> StartStop (Note n)
-> f (StartStop (Note n'))
forall a b. (a -> b) -> a -> b
$ (n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) HashSet (Edge n)
kl
  HashSet (StartStop (Note n'), StartStop (Note n'))
kr' <- (Edge n -> f (StartStop (Note n'), StartStop (Note n')))
-> HashSet (Edge n)
-> f (HashSet (StartStop (Note n'), StartStop (Note n')))
forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet ((StartStop (Note n) -> f (StartStop (Note n')))
-> Edge n -> f (StartStop (Note n'), StartStop (Note n'))
forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge ((StartStop (Note n) -> f (StartStop (Note n')))
 -> Edge n -> f (StartStop (Note n'), StartStop (Note n')))
-> (StartStop (Note n) -> f (StartStop (Note n')))
-> Edge n
-> f (StartStop (Note n'), StartStop (Note n'))
forall a b. (a -> b) -> a -> b
$ (Note n -> f (Note n'))
-> StartStop (Note n) -> f (StartStop (Note n'))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StartStop a -> f (StartStop b)
traverse ((Note n -> f (Note n'))
 -> StartStop (Note n) -> f (StartStop (Note n')))
-> (Note n -> f (Note n'))
-> StartStop (Note n)
-> f (StartStop (Note n'))
forall a b. (a -> b) -> a -> b
$ (n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) HashSet (Edge n)
kr
  MultiSet (Note n', Note n')
pl' <- (InnerEdge n -> f (Note n', Note n'))
-> MultiSet (InnerEdge n) -> f (MultiSet (Note n', Note n'))
forall b (f :: * -> *) a.
(Eq b, Hashable b, Applicative f) =>
(a -> f b) -> MultiSet a -> f (MultiSet b)
MS.traverse ((Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n')
forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge ((Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n'))
-> (Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n')
forall a b. (a -> b) -> a -> b
$ (n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) MultiSet (InnerEdge n)
pl
  MultiSet (Note n', Note n')
pr' <- (InnerEdge n -> f (Note n', Note n'))
-> MultiSet (InnerEdge n) -> f (MultiSet (Note n', Note n'))
forall b (f :: * -> *) a.
(Eq b, Hashable b, Applicative f) =>
(a -> f b) -> MultiSet a -> f (MultiSet b)
MS.traverse ((Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n')
forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge ((Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n'))
-> (Note n -> f (Note n')) -> InnerEdge n -> f (Note n', Note n')
forall a b. (a -> b) -> a -> b
$ (n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) MultiSet (InnerEdge n)
pr
  pure $ Map
  (StartStop (Note n'), StartStop (Note n'))
  [(Note n', DoubleOrnament)]
-> Map (Note n', Note n') [(Note n', PassingOrnament)]
-> Map (Note n') [(Note n', RightOrnament)]
-> Map (Note n') [(Note n', LeftOrnament)]
-> HashSet (StartStop (Note n'), StartStop (Note n'))
-> HashSet (StartStop (Note n'), StartStop (Note n'))
-> MultiSet (Note n', Note n')
-> MultiSet (Note n', Note n')
-> Split n'
forall n.
Map (Edge n) [(Note n, DoubleOrnament)]
-> Map (InnerEdge n) [(Note n, PassingOrnament)]
-> Map (Note n) [(Note n, RightOrnament)]
-> Map (Note n) [(Note n, LeftOrnament)]
-> HashSet (Edge n)
-> HashSet (Edge n)
-> MultiSet (InnerEdge n)
-> MultiSet (InnerEdge n)
-> Split n
SplitOp Map
  (StartStop (Note n'), StartStop (Note n'))
  [(Note n', DoubleOrnament)]
reg' Map (Note n', Note n') [(Note n', PassingOrnament)]
pass' Map (Note n') [(Note n', RightOrnament)]
ls' Map (Note n') [(Note n', LeftOrnament)]
rs' HashSet (StartStop (Note n'), StartStop (Note n'))
kl' HashSet (StartStop (Note n'), StartStop (Note n'))
kr' MultiSet (Note n', Note n')
pl' MultiSet (Note n', Note n')
pr'
 where
  traverseElabo
    :: forall p p' o
     . (Ord p')
    => (p -> f p')
    -> M.Map p [(Note n, o)]
    -> f (M.Map p' [(Note n', o)])
  traverseElabo :: forall p p' o.
Ord p' =>
(p -> f p') -> Map p [(Note n, o)] -> f (Map p' [(Note n', o)])
traverseElabo p -> f p'
fparent Map p [(Note n, o)]
mp = ([(p', [(Note n', o)])] -> Map p' [(Note n', o)])
-> f [(p', [(Note n', o)])] -> f (Map p' [(Note n', o)])
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(p', [(Note n', o)])] -> Map p' [(Note n', o)]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (f [(p', [(Note n', o)])] -> f (Map p' [(Note n', o)]))
-> f [(p', [(Note n', o)])] -> f (Map p' [(Note n', o)])
forall a b. (a -> b) -> a -> b
$ [(p, [(Note n, o)])]
-> ((p, [(Note n, o)]) -> f (p', [(Note n', o)]))
-> f [(p', [(Note n', o)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map p [(Note n, o)] -> [(p, [(Note n, o)])]
forall k a. Map k a -> [(k, a)]
M.toList Map p [(Note n, o)]
mp) (((p, [(Note n, o)]) -> f (p', [(Note n', o)]))
 -> f [(p', [(Note n', o)])])
-> ((p, [(Note n, o)]) -> f (p', [(Note n', o)]))
-> f [(p', [(Note n', o)])]
forall a b. (a -> b) -> a -> b
$ \(p
e, [(Note n, o)]
cs) ->
    do
      p'
e' <- p -> f p'
fparent p
e
      [(Note n', o)]
cs' <- ((Note n, o) -> f (Note n', o))
-> [(Note n, o)] -> f [(Note n', o)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(Note n
n, o
o) -> (,o
o) (Note n' -> (Note n', o)) -> f (Note n') -> f (Note n', o)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f Note n
n) [(Note n, o)]
cs
      pure (p'
e', [(Note 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 (Note n) (SpreadChildren n)
dist Edges n
edges) = do
  [(Note n', SpreadChildren n')]
dist' <- ((Note n, SpreadChildren n) -> f (Note n', SpreadChildren n'))
-> [(Note n, SpreadChildren n)] -> f [(Note n', SpreadChildren n')]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Note n, SpreadChildren n) -> f (Note n', SpreadChildren n')
forall {t :: * -> *} {t :: * -> *}.
(Traversable t, Traversable t) =>
(t n, t n) -> f (t n', t n')
travDist ([(Note n, SpreadChildren n)] -> f [(Note n', SpreadChildren n')])
-> [(Note n, SpreadChildren n)] -> f [(Note n', SpreadChildren n')]
forall a b. (a -> b) -> a -> b
$ HashMap (Note n) (SpreadChildren n) -> [(Note n, SpreadChildren n)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap (Note n) (SpreadChildren n)
dist
  Edges n'
edges' <- (n -> f n') -> Edges n -> f (Edges n')
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 $ HashMap (Note n') (SpreadChildren n') -> Edges n' -> Spread n'
forall n.
HashMap (Note n) (SpreadChildren n) -> Edges n -> Spread n
SpreadOp ((SpreadChildren n' -> SpreadChildren n' -> SpreadChildren n')
-> [(Note n', SpreadChildren n')]
-> HashMap (Note n') (SpreadChildren n')
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HM.fromListWith SpreadChildren n' -> SpreadChildren n' -> SpreadChildren n'
forall a b. a -> b -> a
const [(Note n', SpreadChildren n')]
dist') Edges n'
edges'
 where
  travDist :: (t n, t n) -> f (t n', t n')
travDist (t n
k, t n
v) = do
    t n'
k' <- (n -> f n') -> t n -> f (t n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse n -> f n'
f t n
k
    t n'
v' <- (n -> f n') -> t n -> f (t n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse n -> f n'
f t n
v
    pure (t n'
k', t n'
v')

freezeTraversePitch :: (Applicative f, Hashable n') => (n -> f n') -> Freeze n -> f (Freeze n')
freezeTraversePitch :: forall (f :: * -> *) n' n.
(Applicative f, Hashable n') =>
(n -> f n') -> Freeze n -> f (Freeze n')
freezeTraversePitch n -> f n'
f (FreezeOp HashSet (Edge n)
ties) = HashSet (Edge n') -> Freeze n'
forall n. HashSet (Edge n) -> Freeze n
FreezeOp (HashSet (Edge n') -> Freeze n')
-> f (HashSet (Edge n')) -> f (Freeze n')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Edge n -> f (Edge n'))
-> HashSet (Edge n) -> f (HashSet (Edge n'))
forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet ((StartStop (Note n) -> f (StartStop (Note n')))
-> Edge n -> f (Edge n')
forall (f :: * -> *) n n'.
Applicative f =>
(n -> f n') -> (n, n) -> f (n', n')
traverseEdge ((StartStop (Note n) -> f (StartStop (Note n')))
 -> Edge n -> f (Edge n'))
-> (StartStop (Note n) -> f (StartStop (Note n')))
-> Edge n
-> f (Edge n')
forall a b. (a -> b) -> a -> b
$ (Note n -> f (Note n'))
-> StartStop (Note n) -> f (StartStop (Note n'))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StartStop a -> f (StartStop b)
traverse ((Note n -> f (Note n'))
 -> StartStop (Note n) -> f (StartStop (Note n')))
-> (Note n -> f (Note n'))
-> StartStop (Note n)
-> f (StartStop (Note n'))
forall a b. (a -> b) -> a -> b
$ (n -> f n') -> Note n -> f (Note n')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
traverse n -> f n'
f) HashSet (Edge n)
ties