{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# HLINT ignore "Use for_" #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{- | This module contains a simple (and musically rather naive)
 probabilistic model of protovoice derivations.
 This model can be used to sample a derivation,
 evaluate a derivations probability,
 or infer posterior distributions of the model parmeters from given derivations
 (i.e., "learn" the model's probabilities).

 This model is a /locally conjugate/ model:
 It samples a derivation using a sequence of random decisions with certain probabilities.
 These probabilities are generally unknown, so they are themselves modeled as random variables with prior distributions.
 The full model \(p(d, \theta)\) thus splits into
 \[p(D, \theta) = p(d \mid \theta) \cdot p(\theta),\]
 the prior over the probability variables
 \[p(\theta) = \prod_i p(\theta_i),\]
 and the likelihood of the derivation(s) given these probabilities
 \[p(D \mid \theta) = \prod_{d \in D} p(d \mid \theta) = \prod_{d \in D} \prod_i p(d_i \mid \theta, d_0, \ldots, d_{i-1}).\]
 Given all prior decisions, the likelihood of a decision \(d_i\) based on some parameter \(\theta_a\)
 \[p(d_i \mid \theta, d_{<i})\]
 is [conjugate](https://en.wikipedia.org/wiki/Conjugate_prior) with the prior of that parameter \(p(\theta_a)\),
 which means that the posterior of the parameters given one (or several) derivation(s) \(p(\theta \mid D)\)
 can be computed analytically.

 The parameters \(\theta\) and their prior distributions
 are represented by the higher-kinded type 'PVParams'.
 Different instantiations of this type (using 'Hyper' or 'Probs') results in concrete record types
 that represent prior or posterior distributions
 or concrete values (probabilities) for the parameters.
 'PVParams' also supports 'jeffreysPrior' and 'uniformPrior' as default priors,
as well as 'sampleProbs' for sampling from a prior (see "Inferenc.Conjugate").

 The likelihood \(p(d \mid \theta)\) of a derivation is represented by
 'sampleDerivation'.
 It can be executed under different "modes" (probability monads)
 for sampling, inference, or tracing (see "Inference.Conjugate").
 The decisions during the derivation are represented by a 'Trace' (here @Trace PVParams@).
 In order to learn from a given derivation,
 the corresponding trace can be obtained using 'observeDerivation'.
 A combination of getting a trace and learning from it
 is provided by 'trainSinglePiece'.
-}
module PVGrammar.Prob.Simple
  ( -- * Model Parameters

    -- | A higher-kinded type that represents the global parameters (probabilities) of the model.
    -- Use it as 'Hyper PVParams' to represent hyperparameters (priors and posteriors)
    -- or as 'Probs PVParams' to represent actual probabilites.
    -- Each record field corresponds to one parameter
    -- that influences a specific type of decision in the generation process.
    PVParams (..)
  , PVParamsOuter (..)
  , PVParamsInner (..)
  , savePVHyper
  , loadPVHyper

    -- * Likelihood Model

    -- | 'sampleDerivation' represents a probabilistic program that samples a derivation.
    -- that can be interpreted in various modes for
    --
    -- - sampling ('sampleTrace', 'sampleResult'),
    -- - inference ('evalTraceLogP', 'getPosterior'),
    -- - tracing ('showTrace', 'traceTrace').
    --
    -- 'observeDerivation' takes and existing derivation and returns the corresponding trace.
  , sampleDerivation
  , sampleDerivation'
  , observeDerivation
  , observeDerivation'

    -- * Utilities
  , roundtrip
  , trainSinglePiece

    -- * Likelihood model for parsing

    -- | We need these specialized functions because of a dependency across steps:
    -- During a double step (elaborating two transitions),
    -- the process must decide whether to elaborate the left or right transition.
    -- To normalize the derivation order, we can't elaborate the left transition
    -- after the right one.
    -- That means that the model *sometimes* has to make the decision to go right,
    -- and sometimes not (i.e., after a right split).
    -- During parsing, we don't know whether this decision had to be made or not,
    -- since we don't know the previous derivation step yet.
    -- Therefore, we don't include the decision in the current step,
    -- but at the end of the previous one (in generation order),
    -- where the context is known.
    -- As a consequence, the result of this decision (if made)
    -- needs to be passed to the functions scoring the previous step.
    -- When parsing, make sure to maintain this information.
  , sampleSingleStepParsing
  , observeSingleStepParsing
  , evalSingleStep
  , sampleDoubleStepParsing
  , observeDoubleStepParsing
  , evalDoubleStep
  ) where

import Common
  ( Analysis
      ( anaDerivation
      , anaTop
      )
  , Leftmost (..)
  , LeftmostDouble (..)
  , LeftmostSingle (..)
  , Path (..)
  , StartStop (..)
  , getInner
  )
import PVGrammar
import PVGrammar.Generate
  ( applySplit
  , applySpread
  , freezable
  )

import Control.Monad
  ( guard
  , unless
  , when
  )
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
  ( except
  , runExceptT
  )
import Control.Monad.Trans.State
  ( StateT
  , execStateT
  )
import Data.Bifunctor qualified as Bi
import Data.Foldable (forM_)
import Data.HashMap.Strict qualified as HM
import Data.HashSet qualified as S
import Data.Hashable (Hashable)
import Data.List qualified as L
import Data.Map.Strict qualified as M
import Data.Maybe
  ( catMaybes
  , fromMaybe
  , mapMaybe
  )
import Debug.Trace qualified as DT
import GHC.Generics (Generic)
import Inference.Conjugate

-- import qualified Inference.Conjugate           as IC

import Data.Aeson (FromJSON, ToJSON, eitherDecodeFileStrict, encodeFile)
import Internal.MultiSet qualified as MS
import Lens.Micro.TH (makeLenses)
import Musicology.Pitch as MP hiding
  ( a
  , b
  , c
  , d
  , e
  , f
  , g
  )
import System.Random.MWC.Probability (categorical, uniform)

-- orphan instances
-- ================

deriving instance Generic (HyperRep Beta)
deriving newtype instance ToJSON (HyperRep Beta)
deriving newtype instance FromJSON (HyperRep Beta)

deriving instance Generic (HyperRep (Dirichlet 3))
deriving newtype instance ToJSON (HyperRep (Dirichlet 3))
deriving newtype instance FromJSON (HyperRep (Dirichlet 3))

-- parameters
-- ==========

-- | Parameters for decisions about outer operations (split, spread, freeze).
data PVParamsOuter f = PVParamsOuter
  { forall (f :: * -> *). PVParamsOuter f -> f Beta
_pSingleFreeze :: f Beta
  , forall (f :: * -> *). PVParamsOuter f -> f Beta
_pDoubleLeft :: f Beta
  , forall (f :: * -> *). PVParamsOuter f -> f Beta
_pDoubleLeftFreeze :: f Beta
  , forall (f :: * -> *). PVParamsOuter f -> f Beta
_pDoubleRightSplit :: f Beta
  }
  deriving ((forall x. PVParamsOuter f -> Rep (PVParamsOuter f) x)
-> (forall x. Rep (PVParamsOuter f) x -> PVParamsOuter f)
-> Generic (PVParamsOuter f)
forall x. Rep (PVParamsOuter f) x -> PVParamsOuter f
forall x. PVParamsOuter f -> Rep (PVParamsOuter f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (PVParamsOuter f) x -> PVParamsOuter f
forall (f :: * -> *) x. PVParamsOuter f -> Rep (PVParamsOuter f) x
$cfrom :: forall (f :: * -> *) x. PVParamsOuter f -> Rep (PVParamsOuter f) x
from :: forall x. PVParamsOuter f -> Rep (PVParamsOuter f) x
$cto :: forall (f :: * -> *) x. Rep (PVParamsOuter f) x -> PVParamsOuter f
to :: forall x. Rep (PVParamsOuter f) x -> PVParamsOuter f
Generic)

makeLenses ''PVParamsOuter

deriving instance (Show (f Beta)) => Show (PVParamsOuter f)
deriving instance (ToJSON (f Beta)) => ToJSON (PVParamsOuter f)
deriving instance (FromJSON (f Beta)) => FromJSON (PVParamsOuter f)

{- | Parameters for decisions about inner operations
 (elaboration and distribution within splits and spreads).
-}
data PVParamsInner f = PVParamsInner
  -- split
  { forall (f :: * -> *). PVParamsInner f -> f Beta
_pElaborateRegular :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pElaborateL :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pElaborateR :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pRootFifths :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pKeepL :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pKeepR :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pRepeatOverNeighbor :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pNBChromatic :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pNBAlt :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pRepeatLeftOverRight :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pRepeatAlter :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pRepeatAlterUp :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pRepeatAlterSemis :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pConnect :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pConnectChromaticLeftOverRight :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pPassUp :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pPassLeftOverRight :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pNewPassingLeft :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pNewPassingRight :: f Beta
  , -- spread
    forall (f :: * -> *). PVParamsInner f -> f Beta
_pNewPassingMid :: f Beta
  , forall (f :: * -> *). PVParamsInner f -> f (Dirichlet 3)
_pNoteSpreadDirection :: f (Dirichlet 3)
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pNotesOnOtherSide :: f Beta -- TODO: remove this, not needed anymore
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pSpreadRepetitionEdge :: f Beta
  }
  deriving ((forall x. PVParamsInner f -> Rep (PVParamsInner f) x)
-> (forall x. Rep (PVParamsInner f) x -> PVParamsInner f)
-> Generic (PVParamsInner f)
forall x. Rep (PVParamsInner f) x -> PVParamsInner f
forall x. PVParamsInner f -> Rep (PVParamsInner f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (PVParamsInner f) x -> PVParamsInner f
forall (f :: * -> *) x. PVParamsInner f -> Rep (PVParamsInner f) x
$cfrom :: forall (f :: * -> *) x. PVParamsInner f -> Rep (PVParamsInner f) x
from :: forall x. PVParamsInner f -> Rep (PVParamsInner f) x
$cto :: forall (f :: * -> *) x. Rep (PVParamsInner f) x -> PVParamsInner f
to :: forall x. Rep (PVParamsInner f) x -> PVParamsInner f
Generic)

makeLenses ''PVParamsInner

deriving instance
  ( Show (f Beta)
  , Show (f (Dirichlet 3))
  )
  => Show (PVParamsInner f)

deriving instance
  ( ToJSON (f Beta)
  , ToJSON (f (Dirichlet 3))
  )
  => ToJSON (PVParamsInner f)

deriving instance
  ( FromJSON (f Beta)
  , FromJSON (f (Dirichlet 3))
  )
  => FromJSON (PVParamsInner f)

-- | The combined parameters for inner and outer operations.
data PVParams f = PVParams
  { forall (f :: * -> *). PVParams f -> PVParamsOuter f
_pOuter :: PVParamsOuter f
  , forall (f :: * -> *). PVParams f -> PVParamsInner f
_pInner :: PVParamsInner f
  }
  deriving ((forall x. PVParams f -> Rep (PVParams f) x)
-> (forall x. Rep (PVParams f) x -> PVParams f)
-> Generic (PVParams f)
forall x. Rep (PVParams f) x -> PVParams f
forall x. PVParams f -> Rep (PVParams f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (PVParams f) x -> PVParams f
forall (f :: * -> *) x. PVParams f -> Rep (PVParams f) x
$cfrom :: forall (f :: * -> *) x. PVParams f -> Rep (PVParams f) x
from :: forall x. PVParams f -> Rep (PVParams f) x
$cto :: forall (f :: * -> *) x. Rep (PVParams f) x -> PVParams f
to :: forall x. Rep (PVParams f) x -> PVParams f
Generic)

makeLenses ''PVParams

deriving instance
  ( Show (f Beta)
  , Show (f (Dirichlet 3))
  )
  => Show (PVParams f)

deriving instance
  ( ToJSON (f Beta)
  , ToJSON (f (Dirichlet 3))
  )
  => ToJSON (PVParams f)

deriving instance
  ( FromJSON (f Beta)
  , FromJSON (f (Dirichlet 3))
  )
  => FromJSON (PVParams f)

savePVHyper :: FilePath -> Hyper PVParams -> IO ()
savePVHyper :: String -> Hyper PVParams -> IO ()
savePVHyper = String -> Hyper PVParams -> IO ()
String -> PVParams HyperRep -> IO ()
forall a. ToJSON a => String -> a -> IO ()
encodeFile

loadPVHyper :: FilePath -> IO (Either String (Hyper PVParams))
loadPVHyper :: String -> IO (Either String (Hyper PVParams))
loadPVHyper = String -> IO (Either String (Hyper PVParams))
String -> IO (Either String (PVParams HyperRep))
forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict

type PVProbs = PVParams ProbsRep
type PVProbsInner = PVParamsInner ProbsRep

type ContextSingle n = (StartStop (Notes n), Edges n, StartStop (Notes n))
type ContextDouble n =
  (StartStop (Notes n), Edges n, Notes n, Edges n, StartStop (Notes n))

type PVObs a = StateT (Trace PVParams) (Either String) a

-- helper distributions
-- ====================

data MagicalOctaves = MagicalOctaves
  deriving (MagicalOctaves -> MagicalOctaves -> Bool
(MagicalOctaves -> MagicalOctaves -> Bool)
-> (MagicalOctaves -> MagicalOctaves -> Bool) -> Eq MagicalOctaves
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MagicalOctaves -> MagicalOctaves -> Bool
== :: MagicalOctaves -> MagicalOctaves -> Bool
$c/= :: MagicalOctaves -> MagicalOctaves -> Bool
/= :: MagicalOctaves -> MagicalOctaves -> Bool
Eq, Eq MagicalOctaves
Eq MagicalOctaves =>
(MagicalOctaves -> MagicalOctaves -> Ordering)
-> (MagicalOctaves -> MagicalOctaves -> Bool)
-> (MagicalOctaves -> MagicalOctaves -> Bool)
-> (MagicalOctaves -> MagicalOctaves -> Bool)
-> (MagicalOctaves -> MagicalOctaves -> Bool)
-> (MagicalOctaves -> MagicalOctaves -> MagicalOctaves)
-> (MagicalOctaves -> MagicalOctaves -> MagicalOctaves)
-> Ord MagicalOctaves
MagicalOctaves -> MagicalOctaves -> Bool
MagicalOctaves -> MagicalOctaves -> Ordering
MagicalOctaves -> MagicalOctaves -> MagicalOctaves
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 :: MagicalOctaves -> MagicalOctaves -> Ordering
compare :: MagicalOctaves -> MagicalOctaves -> Ordering
$c< :: MagicalOctaves -> MagicalOctaves -> Bool
< :: MagicalOctaves -> MagicalOctaves -> Bool
$c<= :: MagicalOctaves -> MagicalOctaves -> Bool
<= :: MagicalOctaves -> MagicalOctaves -> Bool
$c> :: MagicalOctaves -> MagicalOctaves -> Bool
> :: MagicalOctaves -> MagicalOctaves -> Bool
$c>= :: MagicalOctaves -> MagicalOctaves -> Bool
>= :: MagicalOctaves -> MagicalOctaves -> Bool
$cmax :: MagicalOctaves -> MagicalOctaves -> MagicalOctaves
max :: MagicalOctaves -> MagicalOctaves -> MagicalOctaves
$cmin :: MagicalOctaves -> MagicalOctaves -> MagicalOctaves
min :: MagicalOctaves -> MagicalOctaves -> MagicalOctaves
Ord, Int -> MagicalOctaves -> ShowS
[MagicalOctaves] -> ShowS
MagicalOctaves -> String
(Int -> MagicalOctaves -> ShowS)
-> (MagicalOctaves -> String)
-> ([MagicalOctaves] -> ShowS)
-> Show MagicalOctaves
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MagicalOctaves -> ShowS
showsPrec :: Int -> MagicalOctaves -> ShowS
$cshow :: MagicalOctaves -> String
show :: MagicalOctaves -> String
$cshowList :: [MagicalOctaves] -> ShowS
showList :: [MagicalOctaves] -> ShowS
Show)

instance Distribution MagicalOctaves where
  type Params MagicalOctaves = ()
  type Support MagicalOctaves = Int
  distSample :: forall (m :: * -> *).
PrimMonad m =>
MagicalOctaves
-> Params MagicalOctaves -> Prob m (Support MagicalOctaves)
distSample MagicalOctaves
_ Params MagicalOctaves
_ = (Int -> Int -> Int
forall a. Num a => a -> a -> a
`subtract` Int
2) (Int -> Int) -> Prob m Int -> Prob m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double] -> Prob m Int
forall (f :: * -> *) (m :: * -> *).
(Foldable f, PrimMonad m) =>
f Double -> Prob m Int
categorical [Double
0.1, Double
0.2, Double
0.4, Double
0.2, Double
0.1]
  distLogP :: MagicalOctaves
-> Params MagicalOctaves -> Support MagicalOctaves -> Double
distLogP MagicalOctaves
_ Params MagicalOctaves
_ Support MagicalOctaves
_ = Double
0

data MagicalID = MagicalID
  deriving (MagicalID -> MagicalID -> Bool
(MagicalID -> MagicalID -> Bool)
-> (MagicalID -> MagicalID -> Bool) -> Eq MagicalID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MagicalID -> MagicalID -> Bool
== :: MagicalID -> MagicalID -> Bool
$c/= :: MagicalID -> MagicalID -> Bool
/= :: MagicalID -> MagicalID -> Bool
Eq, Eq MagicalID
Eq MagicalID =>
(MagicalID -> MagicalID -> Ordering)
-> (MagicalID -> MagicalID -> Bool)
-> (MagicalID -> MagicalID -> Bool)
-> (MagicalID -> MagicalID -> Bool)
-> (MagicalID -> MagicalID -> Bool)
-> (MagicalID -> MagicalID -> MagicalID)
-> (MagicalID -> MagicalID -> MagicalID)
-> Ord MagicalID
MagicalID -> MagicalID -> Bool
MagicalID -> MagicalID -> Ordering
MagicalID -> MagicalID -> MagicalID
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 :: MagicalID -> MagicalID -> Ordering
compare :: MagicalID -> MagicalID -> Ordering
$c< :: MagicalID -> MagicalID -> Bool
< :: MagicalID -> MagicalID -> Bool
$c<= :: MagicalID -> MagicalID -> Bool
<= :: MagicalID -> MagicalID -> Bool
$c> :: MagicalID -> MagicalID -> Bool
> :: MagicalID -> MagicalID -> Bool
$c>= :: MagicalID -> MagicalID -> Bool
>= :: MagicalID -> MagicalID -> Bool
$cmax :: MagicalID -> MagicalID -> MagicalID
max :: MagicalID -> MagicalID -> MagicalID
$cmin :: MagicalID -> MagicalID -> MagicalID
min :: MagicalID -> MagicalID -> MagicalID
Ord, Int -> MagicalID -> ShowS
[MagicalID] -> ShowS
MagicalID -> String
(Int -> MagicalID -> ShowS)
-> (MagicalID -> String)
-> ([MagicalID] -> ShowS)
-> Show MagicalID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MagicalID -> ShowS
showsPrec :: Int -> MagicalID -> ShowS
$cshow :: MagicalID -> String
show :: MagicalID -> String
$cshowList :: [MagicalID] -> ShowS
showList :: [MagicalID] -> ShowS
Show)

instance Distribution MagicalID where
  type Params MagicalID = ()
  type Support MagicalID = String
  distSample :: forall (m :: * -> *).
PrimMonad m =>
MagicalID -> Params MagicalID -> Prob m (Support MagicalID)
distSample MagicalID
_ Params MagicalID
_ = do
    i <- forall (m :: * -> *) a. (PrimMonad m, Variate a) => Prob m a
uniform @_ @Int
    pure $ "id" <> show i
  distLogP :: MagicalID -> Params MagicalID -> Support MagicalID -> Double
distLogP MagicalID
_ Params MagicalID
_ Support MagicalID
_ = Double
0

{- | A helper function that tests whether 'observeDerivation''
 followed by 'sampleDerivation'' restores the original derivation.
 Useful for testing the compatibility of the two functions.
-}
roundtrip :: FilePath -> IO (Either String ()) -- [PVLeftmost SPitch])
roundtrip :: String -> IO (Either String ())
roundtrip String
fn = do
  anaE <- String -> IO (Either String (PVAnalysis SPitch))
loadAnalysis String
fn
  case anaE of
    Left String
err -> String -> IO (Either String ())
forall a. HasCallStack => String -> a
error String
err
    Right PVAnalysis SPitch
ana -> do
      let traceE :: Either String (Trace PVParams)
traceE = [PVLeftmost SPitch] -> Either String (Trace PVParams)
observeDerivation' ([PVLeftmost SPitch] -> Either String (Trace PVParams))
-> [PVLeftmost SPitch] -> Either String (Trace PVParams)
forall a b. (a -> b) -> a -> b
$ PVAnalysis SPitch -> [PVLeftmost SPitch]
forall s f h tr slc. Analysis s f h tr slc -> [Leftmost s f h]
anaDerivation PVAnalysis SPitch
ana
      case Either String (Trace PVParams)
traceE of
        Left String
err -> String -> IO (Either String ())
forall a. HasCallStack => String -> a
error String
err
        Right Trace PVParams
trace -> do
          Trace PVParams -> IO ()
forall a. Show a => a -> IO ()
print Trace PVParams
trace
          Either String () -> IO (Either String ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> [PVLeftmost SPitch] -> ()
forall a b. a -> b -> a
const () ([PVLeftmost SPitch] -> ())
-> Either String [PVLeftmost SPitch] -> Either String ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Trace PVParams
-> TraceTraceI PVParams (Either String [PVLeftmost SPitch])
-> Either String [PVLeftmost SPitch]
forall (r :: (* -> *) -> *) a. Trace r -> TraceTraceI r a -> a
traceTrace Trace PVParams
trace TraceTraceI PVParams (Either String [PVLeftmost SPitch])
forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, SampleCtx m (Categorical 3),
 RandomInterpreter m PVParams) =>
m (Either String [PVLeftmost SPitch])
sampleDerivation'

{- | Helper function: Load a single derivation
 and infer the corresponding posterior for a uniform prior.
-}
trainSinglePiece :: FilePath -> IO (Maybe (PVParams HyperRep))
trainSinglePiece :: String -> IO (Maybe (PVParams HyperRep))
trainSinglePiece String
fn = do
  anaE <- String -> IO (Either String (PVAnalysis SPitch))
loadAnalysis String
fn
  case anaE of
    Left String
err -> String -> IO (Maybe (PVParams HyperRep))
forall a. HasCallStack => String -> a
error String
err
    Right PVAnalysis SPitch
ana -> do
      let traceE :: Either String (Trace PVParams)
traceE = [PVLeftmost SPitch] -> Either String (Trace PVParams)
observeDerivation' ([PVLeftmost SPitch] -> Either String (Trace PVParams))
-> [PVLeftmost SPitch] -> Either String (Trace PVParams)
forall a b. (a -> b) -> a -> b
$ PVAnalysis SPitch -> [PVLeftmost SPitch]
forall s f h tr slc. Analysis s f h tr slc -> [Leftmost s f h]
anaDerivation PVAnalysis SPitch
ana
      case Either String (Trace PVParams)
traceE of
        Left String
err -> String -> IO (Maybe (PVParams HyperRep))
forall a. HasCallStack => String -> a
error String
err
        Right Trace PVParams
trace -> do
          let prior :: Hyper PVParams
prior = forall {k} (a :: k). Uniform a => Hyper a
forall (a :: (* -> *) -> *). Uniform a => Hyper a
uniformPrior @PVParams
          Maybe (PVParams HyperRep) -> IO (Maybe (PVParams HyperRep))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PVParams HyperRep) -> IO (Maybe (PVParams HyperRep)))
-> Maybe (PVParams HyperRep) -> IO (Maybe (PVParams HyperRep))
forall a b. (a -> b) -> a -> b
$ PVParams HyperRep
-> Trace PVParams
-> UpdatePriorsI PVParams (Either String [PVLeftmost SPitch])
-> Maybe (PVParams HyperRep)
forall (r :: (* -> *) -> *) a.
r HyperRep -> Trace r -> UpdatePriorsI r a -> Maybe (r HyperRep)
getPosterior PVParams HyperRep
prior Trace PVParams
trace (Path (Edges SPitch) (Notes SPitch)
-> UpdatePriorsI PVParams (Either String [PVLeftmost SPitch])
forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, SampleCtx m (Categorical 3),
 RandomInterpreter m PVParams) =>
Path (Edges SPitch) (Notes SPitch)
-> m (Either String [PVLeftmost SPitch])
sampleDerivation (Path (Edges SPitch) (Notes SPitch)
 -> UpdatePriorsI PVParams (Either String [PVLeftmost SPitch]))
-> Path (Edges SPitch) (Notes SPitch)
-> UpdatePriorsI PVParams (Either String [PVLeftmost SPitch])
forall a b. (a -> b) -> a -> b
$ PVAnalysis SPitch -> Path (Edges SPitch) (Notes SPitch)
forall s f h tr slc. Analysis s f h tr slc -> Path tr slc
anaTop PVAnalysis SPitch
ana)

-- the generative process
-- ======================

-- | A shorthand for 'sampleDerivation' starting from ⋊——⋉.
sampleDerivation' :: (_) => m (Either String [PVLeftmost SPitch])
sampleDerivation' :: m (Either String [PVLeftmost SPitch])
sampleDerivation' = Path (Edges SPitch) (Notes SPitch)
-> m (Either String [PVLeftmost SPitch])
forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, SampleCtx m (Categorical 3),
 RandomInterpreter m PVParams) =>
Path (Edges SPitch) (Notes SPitch)
-> m (Either String [PVLeftmost SPitch])
sampleDerivation (Path (Edges SPitch) (Notes SPitch)
 -> m (Either String [PVLeftmost SPitch]))
-> Path (Edges SPitch) (Notes SPitch)
-> m (Either String [PVLeftmost SPitch])
forall a b. (a -> b) -> a -> b
$ Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
forall around between. around -> Path around between
PathEnd Edges SPitch
forall n. Hashable n => Edges n
topEdges

-- | A shorthand for 'observeDerivation' starting from ⋊——⋉.
observeDerivation' :: [PVLeftmost SPitch] -> Either String (Trace PVParams)
observeDerivation' :: [PVLeftmost SPitch] -> Either String (Trace PVParams)
observeDerivation' [PVLeftmost SPitch]
deriv = [PVLeftmost SPitch]
-> Path (Edges SPitch) (Notes SPitch)
-> Either String (Trace PVParams)
observeDerivation [PVLeftmost SPitch]
deriv (Path (Edges SPitch) (Notes SPitch)
 -> Either String (Trace PVParams))
-> Path (Edges SPitch) (Notes SPitch)
-> Either String (Trace PVParams)
forall a b. (a -> b) -> a -> b
$ Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
forall around between. around -> Path around between
PathEnd Edges SPitch
forall n. Hashable n => Edges n
topEdges

{- | A probabilistic program that samples a derivation starting from a given root path.
 Can be interpreted by the interpreter functions in "Inference.Conjugate".
-}
sampleDerivation
  :: (_)
  => Path (Edges SPitch) (Notes SPitch)
  -- ^ root path
  -> m (Either String [PVLeftmost SPitch])
  -- ^ a probabilistic program
sampleDerivation :: Path (Edges SPitch) (Notes SPitch)
-> m (Either String [PVLeftmost SPitch])
sampleDerivation Path (Edges SPitch) (Notes SPitch)
top = ExceptT String m [PVLeftmost SPitch]
-> m (Either String [PVLeftmost SPitch])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String m [PVLeftmost SPitch]
 -> m (Either String [PVLeftmost SPitch]))
-> ExceptT String m [PVLeftmost SPitch]
-> m (Either String [PVLeftmost SPitch])
forall a b. (a -> b) -> a -> b
$ StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> ExceptT String m [PVLeftmost SPitch]
forall {m :: * -> *}.
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, SampleCtx m (Categorical 3),
 RandomInterpreter m PVParams) =>
StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> ExceptT String m [PVLeftmost SPitch]
go StartStop (Notes SPitch)
forall a. StartStop a
Start Path (Edges SPitch) (Notes SPitch)
top Bool
False
 where
  go :: StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> ExceptT String m [PVLeftmost SPitch]
go StartStop (Notes SPitch)
sl Path (Edges SPitch) (Notes SPitch)
surface Bool
ars = case Path (Edges SPitch) (Notes SPitch)
surface of
    -- 1 trans left:
    PathEnd Edges SPitch
t -> do
      step <- m (LeftmostSingle (Split SPitch) (Freeze SPitch))
-> ExceptT String m (LeftmostSingle (Split SPitch) (Freeze SPitch))
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (LeftmostSingle (Split SPitch) (Freeze SPitch))
 -> ExceptT
      String m (LeftmostSingle (Split SPitch) (Freeze SPitch)))
-> m (LeftmostSingle (Split SPitch) (Freeze SPitch))
-> ExceptT String m (LeftmostSingle (Split SPitch) (Freeze SPitch))
forall a b. (a -> b) -> a -> b
$ ContextSingle SPitch
-> m (LeftmostSingle (Split SPitch) (Freeze SPitch))
forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, RandomInterpreter m PVParams) =>
ContextSingle SPitch
-> m (LeftmostSingle (Split SPitch) (Freeze SPitch))
sampleSingleStep (StartStop (Notes SPitch)
sl, Edges SPitch
t, StartStop (Notes SPitch)
forall a. StartStop a
Stop)
      case step of
        LMSingleSplit Split SPitch
splitOp -> do
          (ctl, cs, ctr) <- Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> ExceptT String m (Edges SPitch, Notes SPitch, Edges SPitch)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String (Edges SPitch, Notes SPitch, Edges SPitch)
 -> ExceptT String m (Edges SPitch, Notes SPitch, Edges SPitch))
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> ExceptT String m (Edges SPitch, Notes SPitch, Edges SPitch)
forall a b. (a -> b) -> a -> b
$ Split SPitch
-> Edges SPitch
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit Split SPitch
splitOp Edges SPitch
t
          nextSteps <- go sl (Path ctl cs (PathEnd ctr)) False
          pure $ LMSplitOnly splitOp : nextSteps
        LMSingleFreeze Freeze SPitch
freezeOp -> [PVLeftmost SPitch] -> ExceptT String m [PVLeftmost SPitch]
forall a. a -> ExceptT String m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Freeze SPitch -> PVLeftmost SPitch
forall f s h. f -> Leftmost s f h
LMFreezeOnly Freeze SPitch
freezeOp]
    -- 2 trans left
    Path Edges SPitch
tl Notes SPitch
sm (PathEnd Edges SPitch
tr) -> StartStop (Notes SPitch)
-> Edges SPitch
-> Notes SPitch
-> Edges SPitch
-> StartStop (Notes SPitch)
-> Bool
-> (Edges SPitch -> Path (Edges SPitch) (Notes SPitch))
-> ExceptT String m [PVLeftmost SPitch]
goDouble StartStop (Notes SPitch)
sl Edges SPitch
tl Notes SPitch
sm Edges SPitch
tr StartStop (Notes SPitch)
forall a. StartStop a
Stop Bool
ars Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
forall around between. around -> Path around between
PathEnd
    -- 3 or more trans left
    Path Edges SPitch
tl Notes SPitch
sm (Path Edges SPitch
tr Notes SPitch
sr Path (Edges SPitch) (Notes SPitch)
rest) ->
      StartStop (Notes SPitch)
-> Edges SPitch
-> Notes SPitch
-> Edges SPitch
-> StartStop (Notes SPitch)
-> Bool
-> (Edges SPitch -> Path (Edges SPitch) (Notes SPitch))
-> ExceptT String m [PVLeftmost SPitch]
goDouble StartStop (Notes SPitch)
sl Edges SPitch
tl Notes SPitch
sm Edges SPitch
tr (Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sr) Bool
ars (\Edges SPitch
tr' -> Edges SPitch
-> Notes SPitch
-> Path (Edges SPitch) (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
tr' Notes SPitch
sr Path (Edges SPitch) (Notes SPitch)
rest)

  -- helper for the two cases of 2+ edges (2 and 3+):
  goDouble :: StartStop (Notes SPitch)
-> Edges SPitch
-> Notes SPitch
-> Edges SPitch
-> StartStop (Notes SPitch)
-> Bool
-> (Edges SPitch -> Path (Edges SPitch) (Notes SPitch))
-> ExceptT String m [PVLeftmost SPitch]
goDouble StartStop (Notes SPitch)
sl Edges SPitch
tl Notes SPitch
sm Edges SPitch
tr StartStop (Notes SPitch)
sr Bool
ars Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkrest = do
    step <- m (LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch))
-> ExceptT
     String
     m
     (LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch))
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch))
 -> ExceptT
      String
      m
      (LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)))
-> m (LeftmostDouble
        (Split SPitch) (Freeze SPitch) (Spread SPitch))
-> ExceptT
     String
     m
     (LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch))
forall a b. (a -> b) -> a -> b
$ ContextDouble SPitch
-> Bool
-> m (LeftmostDouble
        (Split SPitch) (Freeze SPitch) (Spread SPitch))
forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, SampleCtx m (Categorical 3),
 RandomInterpreter m PVParams) =>
ContextDouble SPitch
-> Bool
-> m (LeftmostDouble
        (Split SPitch) (Freeze SPitch) (Spread SPitch))
sampleDoubleStep (StartStop (Notes SPitch)
sl, Edges SPitch
tl, Notes SPitch
sm, Edges SPitch
tr, StartStop (Notes SPitch)
sr) Bool
ars
    case step of
      LMDoubleSplitLeft Split SPitch
splitOp -> do
        (ctl, cs, ctr) <- Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> ExceptT String m (Edges SPitch, Notes SPitch, Edges SPitch)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String (Edges SPitch, Notes SPitch, Edges SPitch)
 -> ExceptT String m (Edges SPitch, Notes SPitch, Edges SPitch))
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> ExceptT String m (Edges SPitch, Notes SPitch, Edges SPitch)
forall a b. (a -> b) -> a -> b
$ Split SPitch
-> Edges SPitch
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit Split SPitch
splitOp Edges SPitch
tl
        nextSteps <- go sl (Path ctl cs (Path ctr sm (mkrest tr))) False
        pure $ LMSplitLeft splitOp : nextSteps
      LMDoubleFreezeLeft Freeze SPitch
freezeOp -> do
        nextSteps <- StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> ExceptT String m [PVLeftmost SPitch]
go (Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sm) (Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkrest Edges SPitch
tr) Bool
False
        pure $ LMFreezeLeft freezeOp : nextSteps
      LMDoubleSplitRight Split SPitch
splitOp -> do
        (ctl, cs, ctr) <- Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> ExceptT String m (Edges SPitch, Notes SPitch, Edges SPitch)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String (Edges SPitch, Notes SPitch, Edges SPitch)
 -> ExceptT String m (Edges SPitch, Notes SPitch, Edges SPitch))
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> ExceptT String m (Edges SPitch, Notes SPitch, Edges SPitch)
forall a b. (a -> b) -> a -> b
$ Split SPitch
-> Edges SPitch
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit Split SPitch
splitOp Edges SPitch
tr
        nextSteps <- go sl (Path tl sm (Path ctl cs (mkrest ctr))) True
        pure $ LMSplitRight splitOp : nextSteps
      LMDoubleSpread Spread SPitch
spreadOp -> do
        (ctl, csl, ctm, csr, ctr) <- Either
  String
  (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
   Edges SPitch)
-> ExceptT
     String
     m
     (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
      Edges SPitch)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either
   String
   (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
    Edges SPitch)
 -> ExceptT
      String
      m
      (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
       Edges SPitch))
-> Either
     String
     (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
      Edges SPitch)
-> ExceptT
     String
     m
     (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
      Edges SPitch)
forall a b. (a -> b) -> a -> b
$ Spread SPitch
-> Edges SPitch
-> Notes SPitch
-> Edges SPitch
-> Either
     String
     (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
      Edges SPitch)
forall n.
(Ord n, Notation n, Hashable n) =>
Spread n
-> Edges n
-> Notes n
-> Edges n
-> Either String (Edges n, Notes n, Edges n, Notes n, Edges n)
applySpread Spread SPitch
spreadOp Edges SPitch
tl Notes SPitch
sm Edges SPitch
tr
        nextSteps <- go sl (Path ctl csl (Path ctm csr (mkrest ctr))) False
        pure $ LMSpread spreadOp : nextSteps

{- | Walk through a derivation (starting at a given root path)
 and return the corresponding 'Trace' (if possible).
 The trace can be used together with 'sampleDerivation'
 for inference ('getPosterior') or for showing the trace ('printTrace').
-}
observeDerivation
  :: [PVLeftmost SPitch]
  -> Path (Edges SPitch) (Notes SPitch)
  -> Either String (Trace PVParams)
observeDerivation :: [PVLeftmost SPitch]
-> Path (Edges SPitch) (Notes SPitch)
-> Either String (Trace PVParams)
observeDerivation [PVLeftmost SPitch]
deriv Path (Edges SPitch) (Notes SPitch)
top =
  StateT (Trace PVParams) (Either String) ()
-> Trace PVParams -> Either String (Trace PVParams)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT
    (StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> [PVLeftmost SPitch]
-> StateT (Trace PVParams) (Either String) ()
go StartStop (Notes SPitch)
forall a. StartStop a
Start Path (Edges SPitch) (Notes SPitch)
top Bool
False [PVLeftmost SPitch]
deriv)
    (Seq (String, Dynamic) -> Trace PVParams
forall (r :: (* -> *) -> *). Seq (String, Dynamic) -> Trace r
Trace Seq (String, Dynamic)
forall a. Monoid a => a
mempty)
 where
  go
    :: StartStop (Notes SPitch)
    -> Path (Edges SPitch) (Notes SPitch)
    -> Bool
    -> [PVLeftmost SPitch]
    -> PVObs ()
  go :: StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> [PVLeftmost SPitch]
-> StateT (Trace PVParams) (Either String) ()
go StartStop (Notes SPitch)
_sl Path (Edges SPitch) (Notes SPitch)
_surface Bool
_ars [] = Either String () -> StateT (Trace PVParams) (Either String) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String () -> StateT (Trace PVParams) (Either String) ())
-> Either String () -> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"Derivation incomplete."
  go StartStop (Notes SPitch)
sl (PathEnd Edges SPitch
trans) Bool
_ars (PVLeftmost SPitch
op : [PVLeftmost SPitch]
rest) = case PVLeftmost SPitch
op of
    LMSingle LeftmostSingle (Split SPitch) (Freeze SPitch)
single -> do
      ContextSingle SPitch
-> LeftmostSingle (Split SPitch) (Freeze SPitch)
-> StateT (Trace PVParams) (Either String) ()
observeSingleStep (StartStop (Notes SPitch)
sl, Edges SPitch
trans, StartStop (Notes SPitch)
forall a. StartStop a
Stop) LeftmostSingle (Split SPitch) (Freeze SPitch)
single
      case LeftmostSingle (Split SPitch) (Freeze SPitch)
single of
        LMSingleFreeze Freeze SPitch
_ -> () -> StateT (Trace PVParams) (Either String) ()
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        LMSingleSplit Split SPitch
splitOp -> do
          (ctl, cs, ctr) <- Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> StateT
     (Trace PVParams)
     (Either String)
     (Edges SPitch, Notes SPitch, Edges SPitch)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String (Edges SPitch, Notes SPitch, Edges SPitch)
 -> StateT
      (Trace PVParams)
      (Either String)
      (Edges SPitch, Notes SPitch, Edges SPitch))
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> StateT
     (Trace PVParams)
     (Either String)
     (Edges SPitch, Notes SPitch, Edges SPitch)
forall a b. (a -> b) -> a -> b
$ Split SPitch
-> Edges SPitch
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit Split SPitch
splitOp Edges SPitch
trans
          go sl (Path ctl cs (PathEnd ctr)) False rest
    LMDouble LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
_ -> Either String () -> StateT (Trace PVParams) (Either String) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String () -> StateT (Trace PVParams) (Either String) ())
-> Either String () -> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"Double operation on single transition."
  go StartStop (Notes SPitch)
sl (Path Edges SPitch
tl Notes SPitch
sm (PathEnd Edges SPitch
tr)) Bool
ars (PVLeftmost SPitch
op : [PVLeftmost SPitch]
rest) =
    PVLeftmost SPitch
-> [PVLeftmost SPitch]
-> Bool
-> ContextDouble SPitch
-> (Edges SPitch -> Path (Edges SPitch) (Notes SPitch))
-> StateT (Trace PVParams) (Either String) ()
goDouble PVLeftmost SPitch
op [PVLeftmost SPitch]
rest Bool
ars (StartStop (Notes SPitch)
sl, Edges SPitch
tl, Notes SPitch
sm, Edges SPitch
tr, StartStop (Notes SPitch)
forall a. StartStop a
Stop) Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
forall around between. around -> Path around between
PathEnd
  go StartStop (Notes SPitch)
sl (Path Edges SPitch
tl Notes SPitch
sm (Path Edges SPitch
tr Notes SPitch
sr Path (Edges SPitch) (Notes SPitch)
pathRest)) Bool
ars (PVLeftmost SPitch
op : [PVLeftmost SPitch]
derivRest) =
    PVLeftmost SPitch
-> [PVLeftmost SPitch]
-> Bool
-> ContextDouble SPitch
-> (Edges SPitch -> Path (Edges SPitch) (Notes SPitch))
-> StateT (Trace PVParams) (Either String) ()
goDouble PVLeftmost SPitch
op [PVLeftmost SPitch]
derivRest Bool
ars (StartStop (Notes SPitch)
sl, Edges SPitch
tl, Notes SPitch
sm, Edges SPitch
tr, Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sr) ((Edges SPitch -> Path (Edges SPitch) (Notes SPitch))
 -> StateT (Trace PVParams) (Either String) ())
-> (Edges SPitch -> Path (Edges SPitch) (Notes SPitch))
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$
      \Edges SPitch
tr' -> Edges SPitch
-> Notes SPitch
-> Path (Edges SPitch) (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
tr' Notes SPitch
sr Path (Edges SPitch) (Notes SPitch)
pathRest

  goDouble :: PVLeftmost SPitch
-> [PVLeftmost SPitch]
-> Bool
-> ContextDouble SPitch
-> (Edges SPitch -> Path (Edges SPitch) (Notes SPitch))
-> StateT (Trace PVParams) (Either String) ()
goDouble PVLeftmost SPitch
op [PVLeftmost SPitch]
rest Bool
ars (StartStop (Notes SPitch)
sl, Edges SPitch
tl, Notes SPitch
sm, Edges SPitch
tr, StartStop (Notes SPitch)
sr) Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkRest = case PVLeftmost SPitch
op of
    LMSingle LeftmostSingle (Split SPitch) (Freeze SPitch)
_ -> Either String () -> StateT (Trace PVParams) (Either String) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String () -> StateT (Trace PVParams) (Either String) ())
-> Either String () -> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"Single operation with several transitions left."
    LMDouble LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
double -> do
      ContextDouble SPitch
-> Bool
-> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
-> StateT (Trace PVParams) (Either String) ()
observeDoubleStep (StartStop (Notes SPitch)
sl, Edges SPitch
tl, Notes SPitch
sm, Edges SPitch
tr, StartStop (Notes SPitch)
sr) Bool
ars LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
double
      case LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
double of
        LMDoubleFreezeLeft Freeze SPitch
_ -> do
          Bool
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ars (StateT (Trace PVParams) (Either String) ()
 -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ Either String () -> StateT (Trace PVParams) (Either String) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String () -> StateT (Trace PVParams) (Either String) ())
-> Either String () -> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"FreezeLeft after SplitRight."
          StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> [PVLeftmost SPitch]
-> StateT (Trace PVParams) (Either String) ()
go (Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sm) (Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkRest Edges SPitch
tr) Bool
False [PVLeftmost SPitch]
rest
        LMDoubleSplitLeft Split SPitch
splitOp -> do
          Bool
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ars (StateT (Trace PVParams) (Either String) ()
 -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ Either String () -> StateT (Trace PVParams) (Either String) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String () -> StateT (Trace PVParams) (Either String) ())
-> Either String () -> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"SplitLeft after SplitRight."
          (ctl, cs, ctr) <- Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> StateT
     (Trace PVParams)
     (Either String)
     (Edges SPitch, Notes SPitch, Edges SPitch)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String (Edges SPitch, Notes SPitch, Edges SPitch)
 -> StateT
      (Trace PVParams)
      (Either String)
      (Edges SPitch, Notes SPitch, Edges SPitch))
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> StateT
     (Trace PVParams)
     (Either String)
     (Edges SPitch, Notes SPitch, Edges SPitch)
forall a b. (a -> b) -> a -> b
$ Split SPitch
-> Edges SPitch
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit Split SPitch
splitOp Edges SPitch
tl
          go sl (Path ctl cs $ Path ctr sm $ mkRest tr) False rest
        LMDoubleSplitRight Split SPitch
splitOp -> do
          (ctl, cs, ctr) <- Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> StateT
     (Trace PVParams)
     (Either String)
     (Edges SPitch, Notes SPitch, Edges SPitch)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String (Edges SPitch, Notes SPitch, Edges SPitch)
 -> StateT
      (Trace PVParams)
      (Either String)
      (Edges SPitch, Notes SPitch, Edges SPitch))
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
-> StateT
     (Trace PVParams)
     (Either String)
     (Edges SPitch, Notes SPitch, Edges SPitch)
forall a b. (a -> b) -> a -> b
$ Split SPitch
-> Edges SPitch
-> Either String (Edges SPitch, Notes SPitch, Edges SPitch)
forall n.
(Ord n, Notation n, Hashable n) =>
Split n -> Edges n -> Either String (Edges n, Notes n, Edges n)
applySplit Split SPitch
splitOp Edges SPitch
tr
          go sl (Path tl sm $ Path ctl cs $ mkRest ctr) True rest
        LMDoubleSpread Spread SPitch
spreadOp -> do
          (ctl, csl, ctm, csr, ctr) <- Either
  String
  (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
   Edges SPitch)
-> StateT
     (Trace PVParams)
     (Either String)
     (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
      Edges SPitch)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either
   String
   (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
    Edges SPitch)
 -> StateT
      (Trace PVParams)
      (Either String)
      (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
       Edges SPitch))
-> Either
     String
     (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
      Edges SPitch)
-> StateT
     (Trace PVParams)
     (Either String)
     (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
      Edges SPitch)
forall a b. (a -> b) -> a -> b
$ Spread SPitch
-> Edges SPitch
-> Notes SPitch
-> Edges SPitch
-> Either
     String
     (Edges SPitch, Notes SPitch, Edges SPitch, Notes SPitch,
      Edges SPitch)
forall n.
(Ord n, Notation n, Hashable n) =>
Spread n
-> Edges n
-> Notes n
-> Edges n
-> Either String (Edges n, Notes n, Edges n, Notes n, Edges n)
applySpread Spread SPitch
spreadOp Edges SPitch
tl Notes SPitch
sm Edges SPitch
tr
          go sl (Path ctl csl $ Path ctm csr $ mkRest ctr) False rest

sampleSingleStep
  :: (_) => ContextSingle SPitch -> m (LeftmostSingle (Split SPitch) (Freeze SPitch))
sampleSingleStep :: ContextSingle SPitch
-> m (LeftmostSingle (Split SPitch) (Freeze SPitch))
sampleSingleStep parents :: ContextSingle SPitch
parents@(StartStop (Notes SPitch)
_, Edges SPitch
trans, StartStop (Notes SPitch)
_) =
  if Edges SPitch -> Bool
forall n. (Eq (IntervalOf n), HasPitch n) => Edges n -> Bool
freezable Edges SPitch
trans
    then do
      shouldFreeze <-
        String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"shouldFreeze (single)" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pSingleFreeze
      if shouldFreeze
        then LMSingleFreeze <$> sampleFreeze parents
        else LMSingleSplit <$> sampleSplit parents
    else Split SPitch -> LeftmostSingle (Split SPitch) (Freeze SPitch)
forall s f. s -> LeftmostSingle s f
LMSingleSplit (Split SPitch -> LeftmostSingle (Split SPitch) (Freeze SPitch))
-> m (Split SPitch)
-> m (LeftmostSingle (Split SPitch) (Freeze SPitch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContextSingle SPitch -> m (Split SPitch)
forall (m :: * -> *).
(SampleCtx m Geometric1, SampleCtx m Bernoulli,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, RandomInterpreter m PVParams) =>
ContextSingle SPitch -> m (Split SPitch)
sampleSplit ContextSingle SPitch
parents

observeSingleStep
  :: ContextSingle SPitch -> LeftmostSingle (Split SPitch) (Freeze SPitch) -> PVObs ()
observeSingleStep :: ContextSingle SPitch
-> LeftmostSingle (Split SPitch) (Freeze SPitch)
-> StateT (Trace PVParams) (Either String) ()
observeSingleStep parents :: ContextSingle SPitch
parents@(StartStop (Notes SPitch)
_, Edges SPitch
trans, StartStop (Notes SPitch)
_) LeftmostSingle (Split SPitch) (Freeze SPitch)
singleOp =
  if Edges SPitch -> Bool
forall n. (Eq (IntervalOf n), HasPitch n) => Edges n -> Bool
freezable Edges SPitch
trans
    then case LeftmostSingle (Split SPitch) (Freeze SPitch)
singleOp of
      LMSingleFreeze Freeze SPitch
f -> do
        String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
          String
"shouldFreeze (single)"
          Bernoulli
Bernoulli
          ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pSingleFreeze)
          Bool
Support Bernoulli
True
        ContextSingle SPitch
-> Freeze SPitch -> StateT (Trace PVParams) (Either String) ()
observeFreeze ContextSingle SPitch
parents Freeze SPitch
f
      LMSingleSplit Split SPitch
s -> do
        String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
          String
"shouldFreeze (single)"
          Bernoulli
Bernoulli
          ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pSingleFreeze)
          Bool
Support Bernoulli
False
        ContextSingle SPitch
-> Split SPitch -> StateT (Trace PVParams) (Either String) ()
observeSplit ContextSingle SPitch
parents Split SPitch
s
    else case LeftmostSingle (Split SPitch) (Freeze SPitch)
singleOp of
      LMSingleFreeze Freeze SPitch
_ -> Either String () -> StateT (Trace PVParams) (Either String) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String () -> StateT (Trace PVParams) (Either String) ())
-> Either String () -> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"Freezing a non-freezable transition."
      LMSingleSplit Split SPitch
s -> ContextSingle SPitch
-> Split SPitch -> StateT (Trace PVParams) (Either String) ()
observeSplit ContextSingle SPitch
parents Split SPitch
s

sampleDoubleStep
  :: (_)
  => ContextDouble SPitch
  -> Bool
  -> m (LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch))
sampleDoubleStep :: ContextDouble SPitch
-> Bool
-> m (LeftmostDouble
        (Split SPitch) (Freeze SPitch) (Spread SPitch))
sampleDoubleStep parents :: ContextDouble SPitch
parents@(StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, Notes SPitch
sliceM, Edges SPitch
transR, StartStop (Notes SPitch)
sliceR) Bool
afterRightSplit =
  if Bool
afterRightSplit
    then do
      shouldSplitRight <-
        String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"shouldSplitRight" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleRightSplit
      if shouldSplitRight
        then LMDoubleSplitRight <$> sampleSplit (Inner sliceM, transR, sliceR)
        else LMDoubleSpread <$> sampleSpread parents
    else do
      continueLeft <-
        String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"continueLeft" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeft
      if continueLeft
        then
          if freezable transL
            then do
              shouldFreeze <-
                sampleValue "shouldFreeze (double)" Bernoulli $
                  pOuter
                    . pDoubleLeftFreeze
              if shouldFreeze
                then
                  LMDoubleFreezeLeft
                    <$> sampleFreeze (sliceL, transL, Inner sliceM)
                else
                  LMDoubleSplitLeft
                    <$> sampleSplit (sliceL, transL, Inner sliceM)
            else LMDoubleSplitLeft <$> sampleSplit (sliceL, transL, Inner sliceM)
        else sampleDoubleStep parents True

observeDoubleStep
  :: ContextDouble SPitch
  -> Bool
  -> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
  -> PVObs ()
observeDoubleStep :: ContextDouble SPitch
-> Bool
-> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
-> StateT (Trace PVParams) (Either String) ()
observeDoubleStep parents :: ContextDouble SPitch
parents@(StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, Notes SPitch
sliceM, Edges SPitch
transR, StartStop (Notes SPitch)
sliceR) Bool
afterRightSplit LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
doubleOp =
  case LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
doubleOp of
    LMDoubleFreezeLeft Freeze SPitch
f -> do
      String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"continueLeft" Bernoulli
Bernoulli ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeft) Bool
Support Bernoulli
True
      String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
        String
"shouldFreeze (double)"
        Bernoulli
Bernoulli
        ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeftFreeze)
        Bool
Support Bernoulli
True
      ContextSingle SPitch
-> Freeze SPitch -> StateT (Trace PVParams) (Either String) ()
observeFreeze (StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sliceM) Freeze SPitch
f
    LMDoubleSplitLeft Split SPitch
s -> do
      String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"continueLeft" Bernoulli
Bernoulli ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeft) Bool
Support Bernoulli
True
      Bool
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Edges SPitch -> Bool
forall n. (Eq (IntervalOf n), HasPitch n) => Edges n -> Bool
freezable Edges SPitch
transL) (StateT (Trace PVParams) (Either String) ()
 -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$
        String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
          String
"shouldFreeze (double)"
          Bernoulli
Bernoulli
          ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeftFreeze)
          Bool
Support Bernoulli
False
      ContextSingle SPitch
-> Split SPitch -> StateT (Trace PVParams) (Either String) ()
observeSplit (StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sliceM) Split SPitch
s
    LMDoubleSplitRight Split SPitch
s -> do
      Bool
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
afterRightSplit (StateT (Trace PVParams) (Either String) ()
 -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$
        String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"continueLeft" Bernoulli
Bernoulli ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeft) Bool
Support Bernoulli
False
      String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
        String
"shouldSplitRight"
        Bernoulli
Bernoulli
        ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleRightSplit)
        Bool
Support Bernoulli
True
      ContextSingle SPitch
-> Split SPitch -> StateT (Trace PVParams) (Either String) ()
observeSplit (Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sliceM, Edges SPitch
transR, StartStop (Notes SPitch)
sliceR) Split SPitch
s
    LMDoubleSpread Spread SPitch
h -> do
      Bool
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
afterRightSplit (StateT (Trace PVParams) (Either String) ()
 -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$
        String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"continueLeft" Bernoulli
Bernoulli ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeft) Bool
Support Bernoulli
False
      String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
        String
"shouldSplitRight"
        Bernoulli
Bernoulli
        ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleRightSplit)
        Bool
Support Bernoulli
False
      ContextDouble SPitch
-> Spread SPitch -> StateT (Trace PVParams) (Either String) ()
observeSpread ContextDouble SPitch
parents Spread SPitch
h

sampleFreeze :: (RandomInterpreter m PVParams) => ContextSingle SPitch -> m (Freeze SPitch)
sampleFreeze :: forall (m :: * -> *).
RandomInterpreter m PVParams =>
ContextSingle SPitch -> m (Freeze SPitch)
sampleFreeze (StartStop (Notes SPitch)
_, Edges HashSet (Edge SPitch)
reg MultiSet (InnerEdge SPitch)
pass, StartStop (Notes SPitch)
_) = Freeze SPitch -> m (Freeze SPitch)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet (Edge SPitch) -> Freeze SPitch
forall n. HashSet (Edge n) -> Freeze n
FreezeOp HashSet (Edge SPitch)
reg)

observeFreeze :: ContextSingle SPitch -> (Freeze SPitch) -> PVObs ()
observeFreeze :: ContextSingle SPitch
-> Freeze SPitch -> StateT (Trace PVParams) (Either String) ()
observeFreeze ContextSingle SPitch
_parents (FreezeOp HashSet (Edge SPitch)
_) = () -> StateT (Trace PVParams) (Either String) ()
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- helper for sampleSplit and observeSplit
collectElabos
  :: [(Edge SPitch, [(Note SPitch, o1)])]
  -> [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
  -> [(Note SPitch, [(Note SPitch, o2)])]
  -> [(Note SPitch, [(Note SPitch, o3)])]
  -> ( M.Map (StartStop (Note SPitch), StartStop (Note SPitch)) [(Note SPitch, o1)]
     , M.Map (Note SPitch, Note SPitch) [(Note SPitch, PassingOrnament)]
     , M.Map (Note SPitch) [(Note SPitch, o2)]
     , M.Map (Note SPitch) [(Note SPitch, o3)]
     , S.HashSet (Edge SPitch)
     , S.HashSet (Edge SPitch)
     )
collectElabos :: forall o1 o2 o3.
[(Edge SPitch, [(Note SPitch, o1)])]
-> [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
-> [(Note SPitch, [(Note SPitch, o2)])]
-> [(Note SPitch, [(Note SPitch, o3)])]
-> (Map (Edge SPitch) [(Note SPitch, o1)],
    Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)],
    Map (Note SPitch) [(Note SPitch, o2)],
    Map (Note SPitch) [(Note SPitch, o3)], HashSet (Edge SPitch),
    HashSet (Edge SPitch))
collectElabos [(Edge SPitch, [(Note SPitch, o1)])]
childrenT [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
childrenNT [(Note SPitch, [(Note SPitch, o2)])]
childrenL [(Note SPitch, [(Note SPitch, o3)])]
childrenR =
  let splitTs :: Map (Edge SPitch) [(Note SPitch, o1)]
splitTs = [(Edge SPitch, [(Note SPitch, o1)])]
-> Map (Edge SPitch) [(Note SPitch, o1)]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Edge SPitch, [(Note SPitch, o1)])]
childrenT
      splitNTs :: Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
splitNTs = [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
-> Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
childrenNT
      fromLeft :: Map (Note SPitch) [(Note SPitch, o2)]
fromLeft = [(Note SPitch, [(Note SPitch, o2)])]
-> Map (Note SPitch) [(Note SPitch, o2)]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Note SPitch, [(Note SPitch, o2)])]
childrenL
      fromRight :: Map (Note SPitch) [(Note SPitch, o3)]
fromRight = [(Note SPitch, [(Note SPitch, o3)])]
-> Map (Note SPitch) [(Note SPitch, o3)]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Note SPitch, [(Note SPitch, o3)])]
childrenR
      keepLeftT :: [Edge SPitch]
keepLeftT = [(Edge SPitch, [(Note SPitch, o1)])]
-> (Edge SPitch -> Note SPitch -> Edge SPitch) -> [Edge SPitch]
forall p c o.
[(p, [(c, o)])] -> (p -> c -> Edge SPitch) -> [Edge SPitch]
getEdges [(Edge SPitch, [(Note SPitch, o1)])]
childrenT (\Edge SPitch
p Note SPitch
m -> (Edge SPitch -> StartStop (Note SPitch)
forall a b. (a, b) -> a
fst Edge SPitch
p, Note SPitch -> StartStop (Note SPitch)
forall a. a -> StartStop a
Inner Note SPitch
m))
      keepLeftL :: [Edge SPitch]
keepLeftL = [(Note SPitch, [(Note SPitch, o2)])]
-> (Note SPitch -> Note SPitch -> Edge SPitch) -> [Edge SPitch]
forall p c o.
[(p, [(c, o)])] -> (p -> c -> Edge SPitch) -> [Edge SPitch]
getEdges [(Note SPitch, [(Note SPitch, o2)])]
childrenL (\Note SPitch
l Note SPitch
m -> (Note SPitch -> StartStop (Note SPitch)
forall a. a -> StartStop a
Inner Note SPitch
l, Note SPitch -> StartStop (Note SPitch)
forall a. a -> StartStop a
Inner Note SPitch
m))
      keepLeftNT :: [Edge SPitch]
keepLeftNT = do
        -- List
        ((l, _), cs) <- [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
childrenNT
        (m, orn) <- cs
        guard $ orn /= PassingRight
        pure (Inner l, Inner m)
      leftEdges :: HashSet (Edge SPitch)
leftEdges = [Edge SPitch] -> HashSet (Edge SPitch)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Edge SPitch] -> HashSet (Edge SPitch))
-> [Edge SPitch] -> HashSet (Edge SPitch)
forall a b. (a -> b) -> a -> b
$ [Edge SPitch]
keepLeftT [Edge SPitch] -> [Edge SPitch] -> [Edge SPitch]
forall a. Semigroup a => a -> a -> a
<> [Edge SPitch]
keepLeftNT [Edge SPitch] -> [Edge SPitch] -> [Edge SPitch]
forall a. Semigroup a => a -> a -> a
<> [Edge SPitch]
keepLeftL
      keepRightT :: [Edge SPitch]
keepRightT = [(Edge SPitch, [(Note SPitch, o1)])]
-> (Edge SPitch -> Note SPitch -> Edge SPitch) -> [Edge SPitch]
forall p c o.
[(p, [(c, o)])] -> (p -> c -> Edge SPitch) -> [Edge SPitch]
getEdges [(Edge SPitch, [(Note SPitch, o1)])]
childrenT (\Edge SPitch
p Note SPitch
m -> (Note SPitch -> StartStop (Note SPitch)
forall a. a -> StartStop a
Inner Note SPitch
m, Edge SPitch -> StartStop (Note SPitch)
forall a b. (a, b) -> b
snd Edge SPitch
p))
      keepRightR :: [Edge SPitch]
keepRightR = [(Note SPitch, [(Note SPitch, o3)])]
-> (Note SPitch -> Note SPitch -> Edge SPitch) -> [Edge SPitch]
forall p c o.
[(p, [(c, o)])] -> (p -> c -> Edge SPitch) -> [Edge SPitch]
getEdges [(Note SPitch, [(Note SPitch, o3)])]
childrenR (\Note SPitch
r Note SPitch
m -> (Note SPitch -> StartStop (Note SPitch)
forall a. a -> StartStop a
Inner Note SPitch
m, Note SPitch -> StartStop (Note SPitch)
forall a. a -> StartStop a
Inner Note SPitch
r))
      keepRightNT :: [Edge SPitch]
keepRightNT = do
        -- List
        ((_, r), cs) <- [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
childrenNT
        (m, orn) <- cs
        guard $ orn /= PassingLeft
        pure (Inner m, Inner r)
      rightEdges :: HashSet (Edge SPitch)
rightEdges = [Edge SPitch] -> HashSet (Edge SPitch)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Edge SPitch] -> HashSet (Edge SPitch))
-> [Edge SPitch] -> HashSet (Edge SPitch)
forall a b. (a -> b) -> a -> b
$ [Edge SPitch]
keepRightT [Edge SPitch] -> [Edge SPitch] -> [Edge SPitch]
forall a. Semigroup a => a -> a -> a
<> [Edge SPitch]
keepRightNT [Edge SPitch] -> [Edge SPitch] -> [Edge SPitch]
forall a. Semigroup a => a -> a -> a
<> [Edge SPitch]
keepRightR
   in (Map (Edge SPitch) [(Note SPitch, o1)]
splitTs, Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
splitNTs, Map (Note SPitch) [(Note SPitch, o2)]
fromLeft, Map (Note SPitch) [(Note SPitch, o3)]
fromRight, HashSet (Edge SPitch)
leftEdges, HashSet (Edge SPitch)
rightEdges)
 where
  getEdges :: [(p, [(c, o)])] -> (p -> c -> Edge SPitch) -> [Edge SPitch]
  getEdges :: forall p c o.
[(p, [(c, o)])] -> (p -> c -> Edge SPitch) -> [Edge SPitch]
getEdges [(p, [(c, o)])]
elabos p -> c -> Edge SPitch
mkEdge = do
    -- List
    (p, cs) <- [(p, [(c, o)])]
elabos
    (c, _) <- cs
    pure $ mkEdge p c

-- helper for sampleSplit and observeSplit
collectNotes
  :: [(Edge SPitch, [(Note SPitch, o1)])]
  -> [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
  -> [(Note SPitch, [(Note SPitch, o2)])]
  -> [(Note SPitch, [(Note SPitch, o3)])]
  -> [Note SPitch]
collectNotes :: forall o1 o2 o3.
[(Edge SPitch, [(Note SPitch, o1)])]
-> [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
-> [(Note SPitch, [(Note SPitch, o2)])]
-> [(Note SPitch, [(Note SPitch, o3)])]
-> [Note SPitch]
collectNotes [(Edge SPitch, [(Note SPitch, o1)])]
childrenT [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
childrenNT [(Note SPitch, [(Note SPitch, o2)])]
childrenL [(Note SPitch, [(Note SPitch, o3)])]
childrenR =
  let notesT :: [Note SPitch]
notesT = ((Edge SPitch, [(Note SPitch, o1)]) -> [Note SPitch])
-> [(Edge SPitch, [(Note SPitch, o1)])] -> [Note SPitch]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Note SPitch, o1) -> Note SPitch)
-> [(Note SPitch, o1)] -> [Note SPitch]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Note SPitch, o1) -> Note SPitch
forall a b. (a, b) -> a
fst ([(Note SPitch, o1)] -> [Note SPitch])
-> ((Edge SPitch, [(Note SPitch, o1)]) -> [(Note SPitch, o1)])
-> (Edge SPitch, [(Note SPitch, o1)])
-> [Note SPitch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Edge SPitch, [(Note SPitch, o1)]) -> [(Note SPitch, o1)]
forall a b. (a, b) -> b
snd) [(Edge SPitch, [(Note SPitch, o1)])]
childrenT
      notesNT :: [Note SPitch]
notesNT = ((InnerEdge SPitch, [(Note SPitch, PassingOrnament)])
 -> [Note SPitch])
-> [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
-> [Note SPitch]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Note SPitch, PassingOrnament) -> Note SPitch)
-> [(Note SPitch, PassingOrnament)] -> [Note SPitch]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Note SPitch, PassingOrnament) -> Note SPitch
forall a b. (a, b) -> a
fst ([(Note SPitch, PassingOrnament)] -> [Note SPitch])
-> ((InnerEdge SPitch, [(Note SPitch, PassingOrnament)])
    -> [(Note SPitch, PassingOrnament)])
-> (InnerEdge SPitch, [(Note SPitch, PassingOrnament)])
-> [Note SPitch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InnerEdge SPitch, [(Note SPitch, PassingOrnament)])
-> [(Note SPitch, PassingOrnament)]
forall a b. (a, b) -> b
snd) [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
childrenNT
      notesFromL :: [Note SPitch]
notesFromL = ((Note SPitch, [(Note SPitch, o2)]) -> [Note SPitch])
-> [(Note SPitch, [(Note SPitch, o2)])] -> [Note SPitch]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Note SPitch, o2) -> Note SPitch)
-> [(Note SPitch, o2)] -> [Note SPitch]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Note SPitch, o2) -> Note SPitch
forall a b. (a, b) -> a
fst ([(Note SPitch, o2)] -> [Note SPitch])
-> ((Note SPitch, [(Note SPitch, o2)]) -> [(Note SPitch, o2)])
-> (Note SPitch, [(Note SPitch, o2)])
-> [Note SPitch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Note SPitch, [(Note SPitch, o2)]) -> [(Note SPitch, o2)]
forall a b. (a, b) -> b
snd) [(Note SPitch, [(Note SPitch, o2)])]
childrenL
      notesFromR :: [Note SPitch]
notesFromR = ((Note SPitch, [(Note SPitch, o3)]) -> [Note SPitch])
-> [(Note SPitch, [(Note SPitch, o3)])] -> [Note SPitch]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Note SPitch, o3) -> Note SPitch)
-> [(Note SPitch, o3)] -> [Note SPitch]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Note SPitch, o3) -> Note SPitch
forall a b. (a, b) -> a
fst ([(Note SPitch, o3)] -> [Note SPitch])
-> ((Note SPitch, [(Note SPitch, o3)]) -> [(Note SPitch, o3)])
-> (Note SPitch, [(Note SPitch, o3)])
-> [Note SPitch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Note SPitch, [(Note SPitch, o3)]) -> [(Note SPitch, o3)]
forall a b. (a, b) -> b
snd) [(Note SPitch, [(Note SPitch, o3)])]
childrenR
   in [Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ [Note SPitch]
notesT [Note SPitch] -> [Note SPitch] -> [Note SPitch]
forall a. Semigroup a => a -> a -> a
<> [Note SPitch]
notesNT [Note SPitch] -> [Note SPitch] -> [Note SPitch]
forall a. Semigroup a => a -> a -> a
<> [Note SPitch]
notesFromL [Note SPitch] -> [Note SPitch] -> [Note SPitch]
forall a. Semigroup a => a -> a -> a
<> [Note SPitch]
notesFromR

sampleSplit :: forall m. (_) => ContextSingle SPitch -> m (Split SPitch)
sampleSplit :: ContextSingle SPitch -> m (Split SPitch)
sampleSplit (StartStop (Notes SPitch)
sliceL, edges :: Edges SPitch
edges@(Edges HashSet (Edge SPitch)
ts MultiSet (InnerEdge SPitch)
nts), StartStop (Notes SPitch)
sliceR) = do
  -- DT.traceM $ "\nPerforming split (smp) on: " <> show edges
  -- ornament regular edges at least once
  childrenT <- (Edge SPitch -> m (Edge SPitch, [(Note SPitch, DoubleOrnament)]))
-> [Edge SPitch]
-> m [(Edge SPitch, [(Note SPitch, 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 Edge SPitch -> m (Edge SPitch, [(Note SPitch, DoubleOrnament)])
forall (m :: * -> *).
(SampleCtx m Geometric1, SampleCtx m Bernoulli,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, RandomInterpreter m PVParams) =>
Edge SPitch -> m (Edge SPitch, [(Note SPitch, DoubleOrnament)])
sampleT ([Edge SPitch]
 -> m [(Edge SPitch, [(Note SPitch, DoubleOrnament)])])
-> [Edge SPitch]
-> m [(Edge SPitch, [(Note SPitch, DoubleOrnament)])]
forall a b. (a -> b) -> a -> b
$ [Edge SPitch] -> [Edge SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Edge SPitch] -> [Edge SPitch]) -> [Edge SPitch] -> [Edge SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Edge SPitch) -> [Edge SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Edge SPitch)
ts
  -- DT.traceM $ "childrenT (smp): " <> show childrenT
  -- ornament passing edges exactly once
  childrenNT <- mapM sampleNT $ L.sort $ MS.toOccurList nts
  -- DT.traceM $ "childrenNT (smp): " <> show childrenNT
  -- ornament left notes
  childrenL <- case getInner sliceL of
    Maybe (Notes SPitch)
Nothing -> [(Note SPitch, [(Note SPitch, RightOrnament)])]
-> m [(Note SPitch, [(Note SPitch, RightOrnament)])]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just (Notes HashSet (Note SPitch)
notes) -> (Note SPitch -> m (Note SPitch, [(Note SPitch, RightOrnament)]))
-> [Note SPitch]
-> m [(Note SPitch, [(Note SPitch, 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 Note SPitch -> m (Note SPitch, [(Note SPitch, RightOrnament)])
forall (m :: * -> *).
(SampleCtx m Geometric0, SampleCtx m Bernoulli,
 SampleCtx m MagicalOctaves, SampleCtx m MagicalID,
 RandomInterpreter m PVParams) =>
Note SPitch -> m (Note SPitch, [(Note SPitch, RightOrnament)])
sampleL ([Note SPitch]
 -> m [(Note SPitch, [(Note SPitch, RightOrnament)])])
-> [Note SPitch]
-> m [(Note SPitch, [(Note SPitch, RightOrnament)])]
forall a b. (a -> b) -> a -> b
$ [Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Note SPitch) -> [Note SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Note SPitch)
notes
  -- DT.traceM $ "childrenL (smp): " <> show childrenL
  -- ornament right notes
  childrenR <- case getInner sliceR of
    Maybe (Notes SPitch)
Nothing -> [(Note SPitch, [(Note SPitch, LeftOrnament)])]
-> m [(Note SPitch, [(Note SPitch, LeftOrnament)])]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just (Notes HashSet (Note SPitch)
notes) -> (Note SPitch -> m (Note SPitch, [(Note SPitch, LeftOrnament)]))
-> [Note SPitch]
-> m [(Note SPitch, [(Note SPitch, 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 Note SPitch -> m (Note SPitch, [(Note SPitch, LeftOrnament)])
forall (m :: * -> *).
(SampleCtx m Geometric0, SampleCtx m Bernoulli,
 SampleCtx m MagicalOctaves, SampleCtx m MagicalID,
 RandomInterpreter m PVParams) =>
Note SPitch -> m (Note SPitch, [(Note SPitch, LeftOrnament)])
sampleR ([Note SPitch] -> m [(Note SPitch, [(Note SPitch, LeftOrnament)])])
-> [Note SPitch]
-> m [(Note SPitch, [(Note SPitch, LeftOrnament)])]
forall a b. (a -> b) -> a -> b
$ [Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Note SPitch) -> [Note SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Note SPitch)
notes
  -- DT.traceM $ "childrenR (smp): " <> show childrenR
  -- introduce new passing edges left and right
  let notes = [(Edge SPitch, [(Note SPitch, DoubleOrnament)])]
-> [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
-> [(Note SPitch, [(Note SPitch, RightOrnament)])]
-> [(Note SPitch, [(Note SPitch, LeftOrnament)])]
-> [Note SPitch]
forall o1 o2 o3.
[(Edge SPitch, [(Note SPitch, o1)])]
-> [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
-> [(Note SPitch, [(Note SPitch, o2)])]
-> [(Note SPitch, [(Note SPitch, o3)])]
-> [Note SPitch]
collectNotes [(Edge SPitch, [(Note SPitch, DoubleOrnament)])]
childrenT [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
childrenNT [(Note SPitch, [(Note SPitch, RightOrnament)])]
childrenL [(Note SPitch, [(Note SPitch, LeftOrnament)])]
childrenR
  passLeft <- case getInner sliceL of
    Maybe (Notes SPitch)
Nothing -> MultiSet (InnerEdge SPitch) -> m (MultiSet (InnerEdge SPitch))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultiSet (InnerEdge SPitch)
forall a. MultiSet a
MS.empty
    Just (Notes HashSet (Note SPitch)
notesl) ->
      [Note SPitch]
-> [Note SPitch]
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> m (MultiSet (InnerEdge SPitch))
forall (m :: * -> *).
(SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
[Note SPitch]
-> [Note SPitch]
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> m (MultiSet (InnerEdge SPitch))
samplePassing ([Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Note SPitch) -> [Note SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Note SPitch)
notesl) [Note SPitch]
notes (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pNewPassingLeft
  passRight <- case getInner sliceR of
    Maybe (Notes SPitch)
Nothing -> MultiSet (InnerEdge SPitch) -> m (MultiSet (InnerEdge SPitch))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultiSet (InnerEdge SPitch)
forall a. MultiSet a
MS.empty
    Just (Notes HashSet (Note SPitch)
notesr) ->
      [Note SPitch]
-> [Note SPitch]
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> m (MultiSet (InnerEdge SPitch))
forall (m :: * -> *).
(SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
[Note SPitch]
-> [Note SPitch]
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> m (MultiSet (InnerEdge SPitch))
samplePassing [Note SPitch]
notes ([Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Note SPitch) -> [Note SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Note SPitch)
notesr) (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pNewPassingRight
  let (splitReg, splitPass, fromLeft, fromRight, leftEdges, rightEdges) =
        collectElabos childrenT childrenNT childrenL childrenR
  -- decide which edges to keep
  keepLeft <- sampleKeepEdges pKeepL leftEdges
  keepRight <- sampleKeepEdges pKeepR rightEdges
  -- combine all sampling results into split operation
  let splitOp =
        SplitOp
          { Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
splitReg :: Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
splitReg :: Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
splitReg
          , Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
splitPass :: Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
splitPass :: Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
splitPass
          , Map (Note SPitch) [(Note SPitch, RightOrnament)]
fromLeft :: Map (Note SPitch) [(Note SPitch, RightOrnament)]
fromLeft :: Map (Note SPitch) [(Note SPitch, RightOrnament)]
fromLeft
          , Map (Note SPitch) [(Note SPitch, LeftOrnament)]
fromRight :: Map (Note SPitch) [(Note SPitch, LeftOrnament)]
fromRight :: Map (Note SPitch) [(Note SPitch, LeftOrnament)]
fromRight
          , HashSet (Edge SPitch)
keepLeft :: HashSet (Edge SPitch)
keepLeft :: HashSet (Edge SPitch)
keepLeft
          , HashSet (Edge SPitch)
keepRight :: HashSet (Edge SPitch)
keepRight :: HashSet (Edge SPitch)
keepRight
          , MultiSet (InnerEdge SPitch)
passLeft :: MultiSet (InnerEdge SPitch)
passLeft :: MultiSet (InnerEdge SPitch)
passLeft
          , MultiSet (InnerEdge SPitch)
passRight :: MultiSet (InnerEdge SPitch)
passRight :: MultiSet (InnerEdge SPitch)
passRight
          }
  -- DT.traceM $ "Performing split (smp): " <> show splitOp
  pure splitOp

observeSplit :: ContextSingle SPitch -> Split SPitch -> PVObs ()
observeSplit :: ContextSingle SPitch
-> Split SPitch -> StateT (Trace PVParams) (Either String) ()
observeSplit (StartStop (Notes SPitch)
sliceL, _edges :: Edges SPitch
_edges@(Edges HashSet (Edge SPitch)
ts MultiSet (InnerEdge SPitch)
nts), StartStop (Notes SPitch)
sliceR) _splitOp :: Split SPitch
_splitOp@(SplitOp Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
splitTs Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
splitNTs Map (Note SPitch) [(Note SPitch, RightOrnament)]
fromLeft Map (Note SPitch) [(Note SPitch, LeftOrnament)]
fromRight HashSet (Edge SPitch)
keepLeft HashSet (Edge SPitch)
keepRight MultiSet (InnerEdge SPitch)
passLeft MultiSet (InnerEdge SPitch)
passRight) =
  do
    -- DT.traceM $ "\nPerforming split (obs): " <> show splitOp
    -- observe ornaments of regular edges
    childrenT <- (Edge SPitch
 -> StateT
      (Trace PVParams)
      (Either String)
      (Edge SPitch, [(Note SPitch, DoubleOrnament)]))
-> [Edge SPitch]
-> StateT
     (Trace PVParams)
     (Either String)
     [(Edge SPitch, [(Note SPitch, 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 (Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
-> Edge SPitch
-> StateT
     (Trace PVParams)
     (Either String)
     (Edge SPitch, [(Note SPitch, DoubleOrnament)])
observeT Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
splitTs) ([Edge SPitch]
 -> StateT
      (Trace PVParams)
      (Either String)
      [(Edge SPitch, [(Note SPitch, DoubleOrnament)])])
-> [Edge SPitch]
-> StateT
     (Trace PVParams)
     (Either String)
     [(Edge SPitch, [(Note SPitch, DoubleOrnament)])]
forall a b. (a -> b) -> a -> b
$ [Edge SPitch] -> [Edge SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Edge SPitch] -> [Edge SPitch]) -> [Edge SPitch] -> [Edge SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Edge SPitch) -> [Edge SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Edge SPitch)
ts
    -- DT.traceM $ "childrenT (obs): " <> show childrenT
    -- observe ornaments of passing edges
    childrenNT <- mapM (observeNT splitNTs) $ L.sort $ MS.toOccurList nts
    -- DT.traceM $ "childrenNT (obs): " <> show childrenNT
    -- observe ornaments of left notes
    childrenL <- case getInner sliceL of
      Maybe (Notes SPitch)
Nothing -> [(Note SPitch, [(Note SPitch, RightOrnament)])]
-> StateT
     (Trace PVParams)
     (Either String)
     [(Note SPitch, [(Note SPitch, RightOrnament)])]
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just (Notes HashSet (Note SPitch)
notes) -> (Note SPitch
 -> StateT
      (Trace PVParams)
      (Either String)
      (Note SPitch, [(Note SPitch, RightOrnament)]))
-> [Note SPitch]
-> StateT
     (Trace PVParams)
     (Either String)
     [(Note SPitch, [(Note SPitch, 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 (Map (Note SPitch) [(Note SPitch, RightOrnament)]
-> Note SPitch
-> StateT
     (Trace PVParams)
     (Either String)
     (Note SPitch, [(Note SPitch, RightOrnament)])
observeL Map (Note SPitch) [(Note SPitch, RightOrnament)]
fromLeft) ([Note SPitch]
 -> StateT
      (Trace PVParams)
      (Either String)
      [(Note SPitch, [(Note SPitch, RightOrnament)])])
-> [Note SPitch]
-> StateT
     (Trace PVParams)
     (Either String)
     [(Note SPitch, [(Note SPitch, RightOrnament)])]
forall a b. (a -> b) -> a -> b
$ [Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Note SPitch) -> [Note SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Note SPitch)
notes
    -- DT.traceM $ "childrenL (obs): " <> show childrenL
    -- observe ornaments of right notes
    childrenR <- case getInner sliceR of
      Maybe (Notes SPitch)
Nothing -> [(Note SPitch, [(Note SPitch, LeftOrnament)])]
-> StateT
     (Trace PVParams)
     (Either String)
     [(Note SPitch, [(Note SPitch, LeftOrnament)])]
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just (Notes HashSet (Note SPitch)
notes) ->
        (Note SPitch
 -> StateT
      (Trace PVParams)
      (Either String)
      (Note SPitch, [(Note SPitch, LeftOrnament)]))
-> [Note SPitch]
-> StateT
     (Trace PVParams)
     (Either String)
     [(Note SPitch, [(Note SPitch, 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 (Map (Note SPitch) [(Note SPitch, LeftOrnament)]
-> Note SPitch
-> StateT
     (Trace PVParams)
     (Either String)
     (Note SPitch, [(Note SPitch, LeftOrnament)])
observeR Map (Note SPitch) [(Note SPitch, LeftOrnament)]
fromRight) ([Note SPitch]
 -> StateT
      (Trace PVParams)
      (Either String)
      [(Note SPitch, [(Note SPitch, LeftOrnament)])])
-> [Note SPitch]
-> StateT
     (Trace PVParams)
     (Either String)
     [(Note SPitch, [(Note SPitch, LeftOrnament)])]
forall a b. (a -> b) -> a -> b
$ [Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Note SPitch) -> [Note SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Note SPitch)
notes
    -- DT.traceM $ "childrenR (obs): " <> show childrenR
    -- observe new passing edges
    let notes = [(Edge SPitch, [(Note SPitch, DoubleOrnament)])]
-> [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
-> [(Note SPitch, [(Note SPitch, RightOrnament)])]
-> [(Note SPitch, [(Note SPitch, LeftOrnament)])]
-> [Note SPitch]
forall o1 o2 o3.
[(Edge SPitch, [(Note SPitch, o1)])]
-> [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
-> [(Note SPitch, [(Note SPitch, o2)])]
-> [(Note SPitch, [(Note SPitch, o3)])]
-> [Note SPitch]
collectNotes [(Edge SPitch, [(Note SPitch, DoubleOrnament)])]
childrenT [(InnerEdge SPitch, [(Note SPitch, PassingOrnament)])]
childrenNT [(Note SPitch, [(Note SPitch, RightOrnament)])]
childrenL [(Note SPitch, [(Note SPitch, LeftOrnament)])]
childrenR
    case getInner sliceL of
      Maybe (Notes SPitch)
Nothing -> () -> StateT (Trace PVParams) (Either String) ()
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just (Notes HashSet (Note SPitch)
notesl) ->
        [Note SPitch]
-> [Note SPitch]
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> MultiSet (InnerEdge SPitch)
-> StateT (Trace PVParams) (Either String) ()
observePassing
          ([Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Note SPitch) -> [Note SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Note SPitch)
notesl)
          [Note SPitch]
notes
          (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pNewPassingLeft
          MultiSet (InnerEdge SPitch)
passLeft
    case getInner sliceR of
      Maybe (Notes SPitch)
Nothing -> () -> StateT (Trace PVParams) (Either String) ()
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just (Notes HashSet (Note SPitch)
notesr) ->
        [Note SPitch]
-> [Note SPitch]
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> MultiSet (InnerEdge SPitch)
-> StateT (Trace PVParams) (Either String) ()
observePassing
          [Note SPitch]
notes
          ([Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Note SPitch) -> [Note SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Note SPitch)
notesr)
          (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pNewPassingRight
          MultiSet (InnerEdge SPitch)
passRight
    -- observe which edges are kept
    let (_, _, _, _, leftEdges, rightEdges) =
          collectElabos childrenT childrenNT childrenL childrenR
    observeKeepEdges pKeepL leftEdges keepLeft
    observeKeepEdges pKeepR rightEdges keepRight

sampleRootNote :: (_) => Int -> m (Note SPitch)
sampleRootNote :: Int -> m (Note SPitch)
sampleRootNote Int
i = do
  fifthsSign <- String -> Bernoulli -> Params Bernoulli -> m (Support Bernoulli)
forall d.
(Distribution d, SampleCtx m d) =>
String -> d -> Params d -> m (Support d)
forall (m :: * -> *) (r :: (* -> *) -> *) d.
(RandomInterpreter m r, Distribution d, SampleCtx m d) =>
String -> d -> Params d -> m (Support d)
sampleConst String
"rootFifthsSign" Bernoulli
Bernoulli Double
Params Bernoulli
0.5
  fifthsN <- sampleValue "rootFifthsN" Geometric0 $ pInner . pRootFifths
  os <- sampleConst "rootOctave" MagicalOctaves ()
  let fs = if Bool
fifthsSign then Int
fifthsN else Int -> Int
forall a. Num a => a -> a
negate (Int
fifthsN Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      p = (SIC -> IOf SIC
SIC -> SInterval
forall i. IntervalClass i => i -> IOf i
emb (SIC -> SInterval) -> Pitch SIC -> SPitch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Pitch SIC
spc Int
fs) SPitch -> SInterval -> SPitch
forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ (SInterval
forall i. Interval i => i
octave SInterval -> Int -> SInterval
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* (Int
os Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4))
  -- DT.traceM $ "root note (sample): " <> show p
  pure $ Note p ("root" <> show i)

observeRootNote :: (Note SPitch) -> PVObs ()
observeRootNote :: Note SPitch -> StateT (Trace PVParams) (Either String) ()
observeRootNote (Note SPitch
child String
_) = do
  String
-> Bernoulli
-> Params Bernoulli
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"rootFifthsSign" Bernoulli
Bernoulli Double
Params Bernoulli
0.5 Bool
Support Bernoulli
fifthsSign
  String
-> Geometric0
-> Accessor PVParams Beta
-> Support Geometric0
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"rootFifthsN" Geometric0
Geometric0 ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pRootFifths) Int
Support Geometric0
fifthsN
  String
-> MagicalOctaves
-> Params MagicalOctaves
-> Support MagicalOctaves
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"rootOctave" MagicalOctaves
MagicalOctaves () (SPitch -> Int
forall i. Spelled i => i -> Int
octaves SPitch
child Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)
 where
  -- DT.traceM $ "root note (obs): " <> show child

  fs :: Int
fs = SPitch -> Int
forall i. Spelled i => i -> Int
fifths SPitch
child
  fifthsSign :: Bool
fifthsSign = Int
fs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
  fifthsN :: Int
fifthsN = if Bool
fifthsSign then Int
fs else Int -> Int
forall a. Num a => a -> a
negate Int
fs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

sampleOctaveShift :: (_) => String -> m SInterval
sampleOctaveShift :: String -> m SInterval
sampleOctaveShift String
name = do
  n <- String
-> MagicalOctaves
-> Params MagicalOctaves
-> m (Support MagicalOctaves)
forall d.
(Distribution d, SampleCtx m d) =>
String -> d -> Params d -> m (Support d)
forall (m :: * -> *) (r :: (* -> *) -> *) d.
(RandomInterpreter m r, Distribution d, SampleCtx m d) =>
String -> d -> Params d -> m (Support d)
sampleConst String
name MagicalOctaves
MagicalOctaves ()
  let os = SInterval
forall i. Interval i => i
octave SInterval -> Int -> SInterval
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)
  -- DT.traceM $ "octave shift (smp) " <> show os
  pure os

observeOctaveShift :: (_) => String -> SInterval -> PVObs ()
observeOctaveShift :: String -> SInterval -> StateT (Trace PVParams) (Either String) ()
observeOctaveShift String
name SInterval
interval = do
  let n :: Int
n = SInterval -> Int
forall i. Spelled i => i -> Int
octaves (SInterval
interval SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^+^ ImperfectInterval SInterval -> SInterval
forall i. Interval i => ImperfectInterval i -> i
major ImperfectInterval SInterval
second)
  String
-> MagicalOctaves
-> Params MagicalOctaves
-> Support MagicalOctaves
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
name MagicalOctaves
MagicalOctaves () (Support MagicalOctaves
 -> StateT (Trace PVParams) (Either String) ())
-> Support MagicalOctaves
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4

-- DT.traceM $ "octave shift (obs) " <> show (octave @SInterval ^* n)

sampleNeighbor :: (_) => Bool -> SPitch -> m SPitch
sampleNeighbor :: Bool -> SPitch -> m SPitch
sampleNeighbor Bool
stepUp SPitch
ref = do
  chromatic <- String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"nbChromatic" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pNBChromatic
  os <- sampleOctaveShift "nbOctShift"
  alt <- sampleValue "nbAlt" Geometric0 $ pInner . pNBAlt
  let altInterval = SIC -> IOf SIC
forall i. IntervalClass i => i -> IOf i
emb (Int
Scalar SIC
alt Scalar SIC -> SIC -> SIC
forall v. VectorSpace v => Scalar v -> v -> v
*^ forall i. Chromatic i => i
chromaticSemitone @SIC)
  if chromatic
    then do
      pure $ ref +^ os +^ if stepUp then altInterval else down altInterval
    else do
      altUp <- sampleConst "nbAltUp" Bernoulli 0.5
      let step =
            if Bool
altUp Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
stepUp
              then ImperfectInterval SInterval -> SInterval
forall i. Interval i => ImperfectInterval i -> i
major ImperfectInterval SInterval
second SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^+^ IOf SIC
SInterval
altInterval
              else ImperfectInterval SInterval -> SInterval
forall i. Chromatic i => ImperfectInterval i -> i
minor ImperfectInterval SInterval
second SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^-^ IOf SIC
SInterval
altInterval
      pure $ ref +^ os +^ if stepUp then step else down step

observeNeighbor :: Bool -> SPitch -> SPitch -> PVObs ()
observeNeighbor :: Bool
-> SPitch -> SPitch -> StateT (Trace PVParams) (Either String) ()
observeNeighbor Bool
goesUp SPitch
ref SPitch
nb = do
  let interval :: ICOf SInterval
interval = SInterval -> ICOf SInterval
forall i. Interval i => i -> ICOf i
ic (SInterval -> ICOf SInterval) -> SInterval -> ICOf SInterval
forall a b. (a -> b) -> a -> b
$ SPitch
ref SPitch -> SPitch -> SInterval
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
nb
      isChromatic :: Bool
isChromatic = SIC -> Int
forall i. Spelled i => i -> Int
diasteps ICOf SInterval
SIC
interval Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
  String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"nbChromatic" Bernoulli
Bernoulli ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pNBChromatic) Bool
Support Bernoulli
isChromatic
  String -> SInterval -> StateT (Trace PVParams) (Either String) ()
observeOctaveShift String
"nbOctShift" (SPitch
ref SPitch -> SPitch -> SInterval
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
nb)
  if Bool
isChromatic
    then do
      let alt :: Int
alt = Int -> Int
forall a. Num a => a -> a
abs (SIC -> Int
forall i. Spelled i => i -> Int
alteration ICOf SInterval
SIC
interval)
      String
-> Geometric0
-> Accessor PVParams Beta
-> Support Geometric0
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"nbAlt" Geometric0
Geometric0 ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pNBAlt) Int
Support Geometric0
alt
    else do
      let alt :: Int
alt = SIC -> Int
forall i. Spelled i => i -> Int
alteration (SIC -> SIC
forall i. Interval i => i -> i
iabs ICOf SInterval
SIC
interval)
          altUp :: Bool
altUp = (Int
alt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
goesUp
          altN :: Int
altN = if Int
alt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 then Int
alt else (-Int
alt) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      String
-> Geometric0
-> Accessor PVParams Beta
-> Support Geometric0
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"nbAlt" Geometric0
Geometric0 ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pNBAlt) Int
Support Geometric0
altN
      String
-> Bernoulli
-> Params Bernoulli
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"nbAltUp" Bernoulli
Bernoulli Double
Params Bernoulli
0.5 Bool
Support Bernoulli
altUp

-- mkChildId1 pid i o = "(" <> pid <> ")-" <> o <> show i
-- mkChildId2 il ir i o = "(" <> il <> ")-" <> o <> show i <> "-(" <> ir <> ")"

sampleDoubleChild :: (_) => i -> Note SPitch -> Note SPitch -> m (Note SPitch, DoubleOrnament)
sampleDoubleChild :: i -> Note SPitch -> Note SPitch -> m (Note SPitch, DoubleOrnament)
sampleDoubleChild i
i (Note SPitch
pl String
il) (Note SPitch
pr String
ir)
  | SPitch -> Int
forall i. Spelled i => i -> Int
degree SPitch
pl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== SPitch -> Int
forall i. Spelled i => i -> Int
degree SPitch
pr = do
      rep <-
        String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"repeatOverNeighbor" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pRepeatOverNeighbor
      if rep
        then do
          os <- sampleOctaveShift "doubleChildOctave"
          cid <- sampleConst "doubleChildId" MagicalID ()
          pure (Note (pl +^ os) cid, FullRepeat)
        else do
          stepUp <- sampleConst "stepUp" Bernoulli 0.5
          nb <- sampleNeighbor stepUp pl
          cid <- sampleConst "doubleChildId" MagicalID ()
          pure (Note nb cid, FullNeighbor)
  | Bool
otherwise = do
      repeatLeft <-
        String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"repeatLeftOverRight" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$
          (PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner
            ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pRepeatLeftOverRight
      repeatAlter <- sampleValue "repeatAlter" Bernoulli $ pInner . pRepeatAlter
      alt <-
        if repeatAlter
          then do
            alterUp <-
              sampleValue "repeatAlterUp" Bernoulli $ pInner . pRepeatAlterUp
            semis <-
              sampleValue "repeatAlterSemis" Geometric1 $ pInner . pRepeatAlterSemis
            pure $ (if alterUp then id else down) $ chromaticSemitone ^* semis
          else pure unison
      os <- sampleOctaveShift "doubleChildOctave"
      cid <- sampleConst "doubleChildId" MagicalID ()
      if repeatLeft
        then pure (Note (pl +^ os +^ alt) cid, RightRepeatOfLeft)
        else pure (Note (pr +^ os +^ alt) cid, LeftRepeatOfRight)

observeDoubleChild :: Note SPitch -> Note SPitch -> Note SPitch -> PVObs ()
observeDoubleChild :: Note SPitch
-> Note SPitch
-> Note SPitch
-> StateT (Trace PVParams) (Either String) ()
observeDoubleChild (Note SPitch
pl String
_) (Note SPitch
pr String
_) (Note SPitch
child String
cid)
  | SPitch -> Int
forall i. Spelled i => i -> Int
degree SPitch
pl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== SPitch -> Int
forall i. Spelled i => i -> Int
degree SPitch
pr = do
      let isRep :: Bool
isRep = SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child Pitch SIC -> Pitch SIC -> Bool
forall a. Eq a => a -> a -> Bool
== SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl
      String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
        String
"repeatOverNeighbor"
        Bernoulli
Bernoulli
        ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pRepeatOverNeighbor)
        Bool
Support Bernoulli
isRep
      if Bool
isRep
        then do
          String -> SInterval -> StateT (Trace PVParams) (Either String) ()
observeOctaveShift String
"doubleChildOctave" (SPitch
pl SPitch -> SPitch -> SInterval
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
child)
          String
-> MagicalID
-> Params MagicalID
-> Support MagicalID
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"doubleChildId" MagicalID
MagicalID () String
Support MagicalID
cid
        else do
          let dir :: Ordering
dir = SIC -> Ordering
forall i. Interval i => i -> Ordering
direction (SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child)
          let goesUp :: Bool
goesUp = Ordering
dir Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
          String
-> Bernoulli
-> Params Bernoulli
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"stepUp" Bernoulli
Bernoulli Double
Params Bernoulli
0.5 Bool
Support Bernoulli
goesUp
          Bool
-> SPitch -> SPitch -> StateT (Trace PVParams) (Either String) ()
observeNeighbor Bool
goesUp SPitch
pl SPitch
child
          String
-> MagicalID
-> Params MagicalID
-> Support MagicalID
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"doubleChildId" MagicalID
MagicalID () String
Support MagicalID
cid
  | Bool
otherwise = do
      let repeatLeft :: Bool
repeatLeft = SPitch -> Int
forall i. Spelled i => i -> Int
degree SPitch
pl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== SPitch -> Int
forall i. Spelled i => i -> Int
degree SPitch
child
          ref :: SPitch
ref = if Bool
repeatLeft then SPitch
pl else SPitch
pr
          alt :: Int
alt = SPitch -> Int
forall i. Spelled i => i -> Int
alteration SPitch
child Int -> Int -> Int
forall a. Num a => a -> a -> a
- SPitch -> Int
forall i. Spelled i => i -> Int
alteration SPitch
ref
      String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
        String
"repeatLeftOverRight"
        Bernoulli
Bernoulli
        ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pRepeatLeftOverRight)
        Bool
Support Bernoulli
repeatLeft
      String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"repeatAlter" Bernoulli
Bernoulli ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pRepeatAlter) (Int
alt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0)
      Bool
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
alt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (StateT (Trace PVParams) (Either String) ()
 -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ do
        String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"repeatAlterUp" Bernoulli
Bernoulli ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pRepeatAlterUp) (Int
alt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
        String
-> Geometric1
-> Accessor PVParams Beta
-> Support Geometric1
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
          String
"repeatAlterSemis"
          Geometric1
Geometric1
          ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pRepeatAlterSemis)
          (Int -> Int
forall a. Num a => a -> a
abs Int
alt)
      String -> SInterval -> StateT (Trace PVParams) (Either String) ()
observeOctaveShift String
"doubleChildOctave" (SInterval -> StateT (Trace PVParams) (Either String) ())
-> SInterval -> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ SPitch
ref SPitch -> SPitch -> SInterval
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
child
      String
-> MagicalID
-> Params MagicalID
-> Support MagicalID
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"doubleChildId" MagicalID
MagicalID () String
Support MagicalID
cid

sampleT :: (_) => Edge SPitch -> m (Edge SPitch, [(Note SPitch, DoubleOrnament)])
sampleT :: Edge SPitch -> m (Edge SPitch, [(Note SPitch, DoubleOrnament)])
sampleT (StartStop (Note SPitch)
l, StartStop (Note SPitch)
r) = do
  -- DT.traceM $ "elaborating T (smp): " <> show (l, r)
  n <- String
-> Geometric1 -> Accessor PVParams Beta -> m (Support Geometric1)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"elaborateRegular" Geometric1
Geometric1 (Accessor PVParams Beta -> m (Support Geometric1))
-> Accessor PVParams Beta -> m (Support Geometric1)
forall a b. (a -> b) -> a -> b
$ (PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pElaborateRegular
  children <- permutationPlate n $ \Int
i -> case (StartStop (Note SPitch)
l, StartStop (Note SPitch)
r) of
    (StartStop (Note SPitch)
Start, StartStop (Note SPitch)
Stop) -> do
      child <- Int -> m (Note SPitch)
forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric0,
 SampleCtx m MagicalOctaves, RandomInterpreter m PVParams) =>
Int -> m (Note SPitch)
sampleRootNote Int
i
      pure $ Just (child, RootNote)
    (Inner Note SPitch
nl, Inner Note SPitch
nr) -> do
      (child, orn) <- Int
-> Note SPitch -> Note SPitch -> m (Note SPitch, DoubleOrnament)
forall i (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, SampleCtx m Geometric0,
 SampleCtx m Geometric1, RandomInterpreter m PVParams) =>
i -> Note SPitch -> Note SPitch -> m (Note SPitch, DoubleOrnament)
sampleDoubleChild Int
i Note SPitch
nl Note SPitch
nr
      pure $ Just (child, orn)
    Edge SPitch
_ -> Maybe (Note SPitch, DoubleOrnament)
-> m (Maybe (Note SPitch, DoubleOrnament))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Note SPitch, DoubleOrnament)
forall a. Maybe a
Nothing
  pure ((l, r), catMaybes children)

observeT
  :: M.Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
  -> Edge SPitch
  -> PVObs (Edge SPitch, [(Note SPitch, DoubleOrnament)])
observeT :: Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
-> Edge SPitch
-> StateT
     (Trace PVParams)
     (Either String)
     (Edge SPitch, [(Note SPitch, DoubleOrnament)])
observeT Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
splitTs Edge SPitch
parents = do
  -- DT.traceM $ "elaborating T (obs): " <> show parents
  let children :: [(Note SPitch, DoubleOrnament)]
children = [(Note SPitch, DoubleOrnament)]
-> Maybe [(Note SPitch, DoubleOrnament)]
-> [(Note SPitch, DoubleOrnament)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Note SPitch, DoubleOrnament)]
 -> [(Note SPitch, DoubleOrnament)])
-> Maybe [(Note SPitch, DoubleOrnament)]
-> [(Note SPitch, DoubleOrnament)]
forall a b. (a -> b) -> a -> b
$ Edge SPitch
-> Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
-> Maybe [(Note SPitch, DoubleOrnament)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Edge SPitch
parents Map (Edge SPitch) [(Note SPitch, DoubleOrnament)]
splitTs
  String
-> Geometric1
-> Accessor PVParams Beta
-> Support Geometric1
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
    String
"elaborateRegular"
    Geometric1
Geometric1
    ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pElaborateRegular)
    ([(Note SPitch, DoubleOrnament)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Note SPitch, DoubleOrnament)]
children)
  [(Note SPitch, DoubleOrnament)]
-> ((Note SPitch, DoubleOrnament)
    -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Note SPitch, DoubleOrnament)]
children (((Note SPitch, DoubleOrnament)
  -> StateT (Trace PVParams) (Either String) ())
 -> StateT (Trace PVParams) (Either String) ())
-> ((Note SPitch, DoubleOrnament)
    -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ \(Note SPitch
child, DoubleOrnament
_) -> case Edge SPitch
parents of
    (StartStop (Note SPitch)
Start, StartStop (Note SPitch)
Stop) -> do
      Note SPitch -> StateT (Trace PVParams) (Either String) ()
observeRootNote Note SPitch
child
    (Inner Note SPitch
pl, Inner Note SPitch
pr) -> do
      Note SPitch
-> Note SPitch
-> Note SPitch
-> StateT (Trace PVParams) (Either String) ()
observeDoubleChild Note SPitch
pl Note SPitch
pr Note SPitch
child
    Edge SPitch
_ -> Either String () -> StateT (Trace PVParams) (Either String) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String () -> StateT (Trace PVParams) (Either String) ())
-> Either String () -> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid parent edge " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Edge SPitch -> String
forall a. Show a => a -> String
show Edge SPitch
parents String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."
  (Edge SPitch, [(Note SPitch, DoubleOrnament)])
-> StateT
     (Trace PVParams)
     (Either String)
     (Edge SPitch, [(Note SPitch, DoubleOrnament)])
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Edge SPitch
parents, [(Note SPitch, DoubleOrnament)]
children)

-- requires distance >= M2
sampleChromPassing :: (_) => SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleChromPassing :: SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleChromPassing SPitch
pl SPitch
pr = do
  atLeft <-
    String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"connectChromaticLeftOverRight" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$
      (PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner
        ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pConnectChromaticLeftOverRight
  os <- sampleOctaveShift "connectChromaticOctave"
  let dir = if SIC -> Ordering
forall i. Interval i => i -> Ordering
direction (SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT then SInterval -> SInterval
forall a. a -> a
id else SInterval -> SInterval
forall i. Interval i => i -> i
down
      child =
        if Bool
atLeft
          then SPitch
pl SPitch -> SInterval -> SPitch
forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ SInterval -> SInterval
dir SInterval
forall i. Chromatic i => i
chromaticSemitone
          else SPitch
pr SPitch -> SInterval -> SPitch
forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
-^ SInterval -> SInterval
dir SInterval
forall i. Chromatic i => i
chromaticSemitone
  pure (child +^ os, PassingMid)

observeChromPassing :: SPitch -> SPitch -> SPitch -> PVObs ()
observeChromPassing :: SPitch
-> SPitch -> SPitch -> StateT (Trace PVParams) (Either String) ()
observeChromPassing SPitch
pl SPitch
pr SPitch
child = do
  let isLeft :: Bool
isLeft = SPitch -> Int
forall i. Spelled i => i -> Int
degree SPitch
pl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== SPitch -> Int
forall i. Spelled i => i -> Int
degree SPitch
child
  String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
    String
"connectChromaticLeftOverRight"
    Bernoulli
Bernoulli
    ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pConnectChromaticLeftOverRight)
    Bool
Support Bernoulli
isLeft
  String -> SInterval -> StateT (Trace PVParams) (Either String) ()
observeOctaveShift
    String
"connectChromaticOctave"
    ((if Bool
isLeft then SPitch
pl else SPitch
pr) SPitch -> SPitch -> SInterval
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
child)

sampleMidPassing :: (_) => SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleMidPassing :: SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleMidPassing SPitch
pl SPitch
pr = do
  child <- Bool -> SPitch -> m SPitch
forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
Bool -> SPitch -> m SPitch
sampleNeighbor (SIC -> Ordering
forall i. Interval i => i -> Ordering
direction (SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT) SPitch
pl
  pure (child, PassingMid)

observeMidPassing :: SPitch -> SPitch -> SPitch -> PVObs ()
observeMidPassing :: SPitch
-> SPitch -> SPitch -> StateT (Trace PVParams) (Either String) ()
observeMidPassing SPitch
pl SPitch
pr =
  Bool
-> SPitch -> SPitch -> StateT (Trace PVParams) (Either String) ()
observeNeighbor (SIC -> Ordering
forall i. Interval i => i -> Ordering
direction (SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT) SPitch
pl

sampleNonMidPassing :: (_) => SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleNonMidPassing :: SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleNonMidPassing SPitch
pl SPitch
pr = do
  left <-
    String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"passLeftOverRight" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pPassLeftOverRight
  -- TODO: sampling like this overgenerates, since it allows passing motions to change direction
  -- the direction of a passing edge should be tracked explicitly!
  dirUp <- sampleValue "passUp" Bernoulli $ pInner . pPassUp
  -- let dirUp = direction (pc pl `pto` pc pr) == GT
  if left
    then do
      child <- sampleNeighbor dirUp pl
      pure (child, PassingLeft)
    else do
      child <- sampleNeighbor (not dirUp) pr
      pure (child, PassingRight)

observeNonMidPassing :: SPitch -> SPitch -> SPitch -> PassingOrnament -> PVObs ()
observeNonMidPassing :: SPitch
-> SPitch
-> SPitch
-> PassingOrnament
-> StateT (Trace PVParams) (Either String) ()
observeNonMidPassing SPitch
pl SPitch
pr SPitch
child PassingOrnament
orn = do
  let left :: Bool
left = PassingOrnament
orn PassingOrnament -> PassingOrnament -> Bool
forall a. Eq a => a -> a -> Bool
== PassingOrnament
PassingLeft
      dirUp :: Bool
dirUp =
        if Bool
left
          then SIC -> Ordering
forall i. Interval i => i -> Ordering
direction (SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
          else SIC -> Ordering
forall i. Interval i => i -> Ordering
direction (SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT
  String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"passLeftOverRight" Bernoulli
Bernoulli ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pPassLeftOverRight) Bool
Support Bernoulli
left
  String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"passUp" Bernoulli
Bernoulli ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pPassUp) Bool
Support Bernoulli
dirUp
  if Bool
left
    then Bool
-> SPitch -> SPitch -> StateT (Trace PVParams) (Either String) ()
observeNeighbor Bool
dirUp SPitch
pl SPitch
child
    else Bool
-> SPitch -> SPitch -> StateT (Trace PVParams) (Either String) ()
observeNeighbor (Bool -> Bool
not Bool
dirUp) SPitch
pr SPitch
child

sampleNT
  :: (_) => (InnerEdge SPitch, Int) -> m (InnerEdge SPitch, [(Note SPitch, PassingOrnament)])
sampleNT :: (InnerEdge SPitch, Int)
-> m (InnerEdge SPitch, [(Note SPitch, PassingOrnament)])
sampleNT ((nl :: Note SPitch
nl@(Note SPitch
pl String
il), nr :: Note SPitch
nr@(Note SPitch
pr String
ir)), Int
n) = do
  -- DT.traceM $ "Elaborating edge (smp): " <> show ((pl, pr), n)
  let dist :: Int
dist = SIC -> Int
forall i. Spelled i => i -> Int
degree (SIC -> Int) -> SIC -> Int
forall a b. (a -> b) -> a -> b
$ SIC -> SIC
forall i. Interval i => i -> i
iabs (SIC -> SIC) -> SIC -> SIC
forall a b. (a -> b) -> a -> b
$ SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr
  -- DT.traceM    $  "passing from "    <> showNotation pl    <> " to "    <> showNotation pr    <> ": "    <> show dist    <> " steps."
  children <- Int
-> (Int -> m (Note SPitch, PassingOrnament))
-> m [(Note SPitch, PassingOrnament)]
forall a. Ord a => Int -> (Int -> m a) -> m [a]
forall (m :: * -> *) (r :: (* -> *) -> *) a.
(RandomInterpreter m r, Ord a) =>
Int -> (Int -> m a) -> m [a]
permutationPlate Int
n ((Int -> m (Note SPitch, PassingOrnament))
 -> m [(Note SPitch, PassingOrnament)])
-> (Int -> m (Note SPitch, PassingOrnament))
-> m [(Note SPitch, PassingOrnament)]
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    (child, orn) <- case Int
dist of
      Int
1 -> SPitch -> SPitch -> m (SPitch, PassingOrnament)
forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 RandomInterpreter m PVParams) =>
SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleChromPassing SPitch
pl SPitch
pr
      Int
2 -> do
        connect <- String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"passingConnect" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pConnect
        if connect then sampleMidPassing pl pr else sampleNonMidPassing pl pr
      Int
_ -> SPitch -> SPitch -> m (SPitch, PassingOrnament)
forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleNonMidPassing SPitch
pl SPitch
pr
    cid <- sampleConst "passingChildId" MagicalID ()
    pure (Note child $ cid, orn)
  pure ((nl, nr), children)

observeNT
  :: (_)
  => M.Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
  -> (InnerEdge SPitch, Int)
  -> PVObs (InnerEdge SPitch, [(Note SPitch, PassingOrnament)])
observeNT :: Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
-> (InnerEdge SPitch, Int)
-> StateT
     (Trace PVParams)
     (Either String)
     (InnerEdge SPitch, [(Note SPitch, PassingOrnament)])
observeNT Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
splitNTs ((nl :: Note SPitch
nl@(Note SPitch
pl String
_), nr :: Note SPitch
nr@(Note SPitch
pr String
_)), Int
_n) = do
  -- DT.traceM $ "Elaborating edge (obs): " <> show ((pl, pr), n)
  let children :: [(Note SPitch, PassingOrnament)]
children = [(Note SPitch, PassingOrnament)]
-> Maybe [(Note SPitch, PassingOrnament)]
-> [(Note SPitch, PassingOrnament)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Note SPitch, PassingOrnament)]
 -> [(Note SPitch, PassingOrnament)])
-> Maybe [(Note SPitch, PassingOrnament)]
-> [(Note SPitch, PassingOrnament)]
forall a b. (a -> b) -> a -> b
$ InnerEdge SPitch
-> Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
-> Maybe [(Note SPitch, PassingOrnament)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Note SPitch
nl, Note SPitch
nr) Map (InnerEdge SPitch) [(Note SPitch, PassingOrnament)]
splitNTs
  [(Note SPitch, PassingOrnament)]
-> ((Note SPitch, PassingOrnament)
    -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Note SPitch, PassingOrnament)]
children (((Note SPitch, PassingOrnament)
  -> StateT (Trace PVParams) (Either String) ())
 -> StateT (Trace PVParams) (Either String) ())
-> ((Note SPitch, PassingOrnament)
    -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ \(Note SPitch
child String
cid, PassingOrnament
orn) -> do
    case SIC -> Int
forall i. Spelled i => i -> Int
degree (SIC -> Int) -> SIC -> Int
forall a b. (a -> b) -> a -> b
$ SIC -> SIC
forall i. Interval i => i -> i
iabs (SIC -> SIC) -> SIC -> SIC
forall a b. (a -> b) -> a -> b
$ SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr of
      Int
1 -> SPitch
-> SPitch -> SPitch -> StateT (Trace PVParams) (Either String) ()
observeChromPassing SPitch
pl SPitch
pr SPitch
child
      Int
2 -> case PassingOrnament
orn of
        PassingOrnament
PassingMid -> do
          String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"passingConnect" Bernoulli
Bernoulli ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pConnect) Bool
Support Bernoulli
True
          SPitch
-> SPitch -> SPitch -> StateT (Trace PVParams) (Either String) ()
observeMidPassing SPitch
pl SPitch
pr SPitch
child
        PassingOrnament
_ -> do
          String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"passingConnect" Bernoulli
Bernoulli ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pConnect) Bool
Support Bernoulli
False
          SPitch
-> SPitch
-> SPitch
-> PassingOrnament
-> StateT (Trace PVParams) (Either String) ()
observeNonMidPassing SPitch
pl SPitch
pr SPitch
child PassingOrnament
orn
      Int
_ -> SPitch
-> SPitch
-> SPitch
-> PassingOrnament
-> StateT (Trace PVParams) (Either String) ()
observeNonMidPassing SPitch
pl SPitch
pr SPitch
child PassingOrnament
orn
    String
-> MagicalID
-> Params MagicalID
-> Support MagicalID
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"passingChildId" MagicalID
MagicalID () String
Support MagicalID
cid
  (InnerEdge SPitch, [(Note SPitch, PassingOrnament)])
-> StateT
     (Trace PVParams)
     (Either String)
     (InnerEdge SPitch, [(Note SPitch, PassingOrnament)])
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Note SPitch
nl, Note SPitch
nr), [(Note SPitch, PassingOrnament)]
children)

sampleSingleOrn
  :: (_)
  => Note SPitch
  -> o
  -> o
  -> Accessor PVParamsInner Beta
  -> m (Note SPitch, [(Note SPitch, o)])
sampleSingleOrn :: Note SPitch
-> o
-> o
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> m (Note SPitch, [(Note SPitch, o)])
sampleSingleOrn parent :: Note SPitch
parent@(Note SPitch
ppitch String
pid) o
oRepeat o
oNeighbor forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pElaborate = do
  n <- String
-> Geometric0 -> Accessor PVParams Beta -> m (Support Geometric0)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"elaborateSingle" Geometric0
Geometric0 (Accessor PVParams Beta -> m (Support Geometric0))
-> Accessor PVParams Beta -> m (Support Geometric0)
forall a b. (a -> b) -> a -> b
$ (PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pElaborate
  children <- permutationPlate n $ \Int
i -> do
    rep <-
      String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"repeatOverNeighborSingle" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$
        (PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner
          ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pRepeatOverNeighbor
    if rep
      then do
        os <- sampleOctaveShift "singleChildOctave"
        cid <- sampleConst "singleChildId" MagicalID ()
        pure (Note (ppitch +^ os) cid, oRepeat)
      else do
        stepUp <- sampleConst "singleUp" Bernoulli 0.5
        child <- sampleNeighbor stepUp ppitch
        cid <- sampleConst "singleChildId" MagicalID ()
        pure (Note child cid, oNeighbor)
  pure (parent, children)

observeSingleOrn
  :: M.Map (Note SPitch) [(Note SPitch, o)]
  -> Note SPitch
  -> Accessor PVParamsInner Beta
  -> PVObs (Note SPitch, [(Note SPitch, o)])
observeSingleOrn :: forall o.
Map (Note SPitch) [(Note SPitch, o)]
-> Note SPitch
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> PVObs (Note SPitch, [(Note SPitch, o)])
observeSingleOrn Map (Note SPitch) [(Note SPitch, o)]
table parent :: Note SPitch
parent@(Note SPitch
ppitch String
_) forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pElaborate = do
  let children :: [(Note SPitch, o)]
children = [(Note SPitch, o)]
-> Maybe [(Note SPitch, o)] -> [(Note SPitch, o)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Note SPitch, o)] -> [(Note SPitch, o)])
-> Maybe [(Note SPitch, o)] -> [(Note SPitch, o)]
forall a b. (a -> b) -> a -> b
$ Note SPitch
-> Map (Note SPitch) [(Note SPitch, o)] -> Maybe [(Note SPitch, o)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Note SPitch
parent Map (Note SPitch) [(Note SPitch, o)]
table
  String
-> Geometric0
-> Accessor PVParams Beta
-> Support Geometric0
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
    String
"elaborateSingle"
    Geometric0
Geometric0
    ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pElaborate)
    ([(Note SPitch, o)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Note SPitch, o)]
children)
  [(Note SPitch, o)]
-> ((Note SPitch, o) -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Note SPitch, o)]
children (((Note SPitch, o) -> StateT (Trace PVParams) (Either String) ())
 -> StateT (Trace PVParams) (Either String) ())
-> ((Note SPitch, o) -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ \(Note SPitch
child String
cid, o
_) -> do
    let rep :: Bool
rep = SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child Pitch SIC -> Pitch SIC -> Bool
forall a. Eq a => a -> a -> Bool
== SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
ppitch
    String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
      String
"repeatOverNeighborSingle"
      Bernoulli
Bernoulli
      ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pRepeatOverNeighbor)
      Bool
Support Bernoulli
rep
    if Bool
rep
      then do
        String -> SInterval -> StateT (Trace PVParams) (Either String) ()
observeOctaveShift String
"singleChildOctave" (SPitch
ppitch SPitch -> SPitch -> SInterval
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
child)
        String
-> MagicalID
-> Params MagicalID
-> Support MagicalID
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"singleChildId" MagicalID
MagicalID () String
Support MagicalID
cid
      else do
        let dir :: Ordering
dir = SIC -> Ordering
forall i. Interval i => i -> Ordering
direction (SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
ppitch Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child)
            up :: Bool
up = Ordering
dir Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
        String
-> Bernoulli
-> Params Bernoulli
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"singleUp" Bernoulli
Bernoulli Double
Params Bernoulli
0.5 Bool
Support Bernoulli
up
        Bool
-> SPitch -> SPitch -> StateT (Trace PVParams) (Either String) ()
observeNeighbor Bool
up SPitch
ppitch SPitch
child
        String
-> MagicalID
-> Params MagicalID
-> Support MagicalID
-> StateT (Trace PVParams) (Either String) ()
forall d (m :: * -> *) (r :: (* -> *) -> *).
(Distribution d, Typeable (Support d), Monad m) =>
String -> d -> Params d -> Support d -> StateT (Trace r) m ()
observeConst String
"singleChildId" MagicalID
MagicalID () String
Support MagicalID
cid
  (Note SPitch, [(Note SPitch, o)])
-> StateT
     (Trace PVParams) (Either String) (Note SPitch, [(Note SPitch, o)])
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note SPitch
parent, [(Note SPitch, o)]
children)

sampleL :: (_) => Note SPitch -> m (Note SPitch, [(Note SPitch, RightOrnament)])
sampleL :: Note SPitch -> m (Note SPitch, [(Note SPitch, RightOrnament)])
sampleL Note SPitch
parent = Note SPitch
-> RightOrnament
-> RightOrnament
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> m (Note SPitch, [(Note SPitch, RightOrnament)])
forall o (m :: * -> *).
(SampleCtx m Geometric0, SampleCtx m Bernoulli,
 SampleCtx m MagicalOctaves, SampleCtx m MagicalID,
 RandomInterpreter m PVParams, Ord o) =>
Note SPitch
-> o
-> o
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> m (Note SPitch, [(Note SPitch, o)])
sampleSingleOrn Note SPitch
parent RightOrnament
RightRepeat RightOrnament
RightNeighbor (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pElaborateL

observeL
  :: M.Map (Note SPitch) [(Note SPitch, RightOrnament)]
  -> Note SPitch
  -> PVObs (Note SPitch, [(Note SPitch, RightOrnament)])
observeL :: Map (Note SPitch) [(Note SPitch, RightOrnament)]
-> Note SPitch
-> StateT
     (Trace PVParams)
     (Either String)
     (Note SPitch, [(Note SPitch, RightOrnament)])
observeL Map (Note SPitch) [(Note SPitch, RightOrnament)]
ls Note SPitch
parent = Map (Note SPitch) [(Note SPitch, RightOrnament)]
-> Note SPitch
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> StateT
     (Trace PVParams)
     (Either String)
     (Note SPitch, [(Note SPitch, RightOrnament)])
forall o.
Map (Note SPitch) [(Note SPitch, o)]
-> Note SPitch
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> PVObs (Note SPitch, [(Note SPitch, o)])
observeSingleOrn Map (Note SPitch) [(Note SPitch, RightOrnament)]
ls Note SPitch
parent (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pElaborateL

sampleR :: (_) => Note SPitch -> m (Note SPitch, [(Note SPitch, LeftOrnament)])
sampleR :: Note SPitch -> m (Note SPitch, [(Note SPitch, LeftOrnament)])
sampleR Note SPitch
parent = Note SPitch
-> LeftOrnament
-> LeftOrnament
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> m (Note SPitch, [(Note SPitch, LeftOrnament)])
forall o (m :: * -> *).
(SampleCtx m Geometric0, SampleCtx m Bernoulli,
 SampleCtx m MagicalOctaves, SampleCtx m MagicalID,
 RandomInterpreter m PVParams, Ord o) =>
Note SPitch
-> o
-> o
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> m (Note SPitch, [(Note SPitch, o)])
sampleSingleOrn Note SPitch
parent LeftOrnament
LeftRepeat LeftOrnament
LeftNeighbor (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pElaborateR

observeR
  :: M.Map (Note SPitch) [(Note SPitch, LeftOrnament)]
  -> Note SPitch
  -> PVObs (Note SPitch, [(Note SPitch, LeftOrnament)])
observeR :: Map (Note SPitch) [(Note SPitch, LeftOrnament)]
-> Note SPitch
-> StateT
     (Trace PVParams)
     (Either String)
     (Note SPitch, [(Note SPitch, LeftOrnament)])
observeR Map (Note SPitch) [(Note SPitch, LeftOrnament)]
rs Note SPitch
parent = Map (Note SPitch) [(Note SPitch, LeftOrnament)]
-> Note SPitch
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> StateT
     (Trace PVParams)
     (Either String)
     (Note SPitch, [(Note SPitch, LeftOrnament)])
forall o.
Map (Note SPitch) [(Note SPitch, o)]
-> Note SPitch
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> PVObs (Note SPitch, [(Note SPitch, o)])
observeSingleOrn Map (Note SPitch) [(Note SPitch, LeftOrnament)]
rs Note SPitch
parent (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pElaborateR

sampleKeepEdges
  :: (_) => Accessor PVParamsInner Beta -> S.HashSet e -> m (S.HashSet e)
sampleKeepEdges :: (forall (f :: * -> *) (f :: * -> *).
 Functor f =>
 (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> HashSet e -> m (HashSet e)
sampleKeepEdges forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pKeep HashSet e
set = do
  kept <- (e -> m (Maybe e)) -> [e] -> m [Maybe e]
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 e -> m (Maybe e)
sKeep ([e] -> [e]
forall a. Ord a => [a] -> [a]
L.sort ([e] -> [e]) -> [e] -> [e]
forall a b. (a -> b) -> a -> b
$ HashSet e -> [e]
forall a. HashSet a -> [a]
S.toList HashSet e
set)
  pure $ S.fromList $ catMaybes kept
 where
  sKeep :: e -> m (Maybe e)
sKeep e
elt = do
    keep <- String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"keep" Bernoulli
Bernoulli ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pKeep)
    pure $ if keep then Just elt else Nothing

observeKeepEdges
  :: (Eq e, Hashable e, Ord e)
  => Accessor PVParamsInner Beta
  -> S.HashSet e
  -> S.HashSet e
  -> PVObs ()
observeKeepEdges :: forall e.
(Eq e, Hashable e, Ord e) =>
(forall (f :: * -> *) (f :: * -> *).
 Functor f =>
 (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> HashSet e
-> HashSet e
-> StateT (Trace PVParams) (Either String) ()
observeKeepEdges forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pKeep HashSet e
candidates HashSet e
kept =
  (e -> StateT (Trace PVParams) (Either String) ())
-> [e] -> StateT (Trace PVParams) (Either String) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    e -> StateT (Trace PVParams) (Either String) ()
oKeep
    ([e] -> [e]
forall a. Ord a => [a] -> [a]
L.sort ([e] -> [e]) -> [e] -> [e]
forall a b. (a -> b) -> a -> b
$ HashSet e -> [e]
forall a. HashSet a -> [a]
S.toList HashSet e
candidates)
 where
  oKeep :: e -> StateT (Trace PVParams) (Either String) ()
oKeep e
edge =
    String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"keep" Bernoulli
Bernoulli ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pKeep) (e -> HashSet e -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member e
edge HashSet e
kept)

sampleSpread :: (_) => ContextDouble SPitch -> m (Spread SPitch)
sampleSpread :: ContextDouble SPitch -> m (Spread SPitch)
sampleSpread (StartStop (Notes SPitch)
_sliceL, Edges SPitch
_transL, Notes HashSet (Note SPitch)
sliceM, Edges SPitch
_transR, StartStop (Notes SPitch)
_sliceR) = do
  -- distribute notes
  let notes :: [Note SPitch]
notes = [Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Note SPitch) -> [Note SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Note SPitch)
sliceM
  dists <- (Note SPitch -> m (SpreadChildren SPitch))
-> [Note SPitch] -> m [SpreadChildren SPitch]
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 Note SPitch -> m (SpreadChildren SPitch)
forall {m :: * -> *} {n}.
(SampleCtx m (Categorical 3), RandomInterpreter m PVParams) =>
Note n -> m (SpreadChildren n)
distNote [Note SPitch]
notes
  -- DT.traceM $ "dists (sm):" <> show dists
  let notesLeft = (SpreadChildren SPitch -> Maybe (Note SPitch))
-> [SpreadChildren SPitch] -> [Note SPitch]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SpreadChildren SPitch -> Maybe (Note SPitch)
forall n. SpreadChildren n -> Maybe (Note n)
leftSpreadChild [SpreadChildren SPitch]
dists
      notesRight = (SpreadChildren SPitch -> Maybe (Note SPitch))
-> [SpreadChildren SPitch] -> [Note SPitch]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SpreadChildren SPitch -> Maybe (Note SPitch)
forall n. SpreadChildren n -> Maybe (Note n)
rightSpreadChild [SpreadChildren SPitch]
dists
  -- generate repetition edges
  repeats <- sequence $ do
    -- List
    l <- notesLeft
    r <- notesRight
    guard $ pc (notePitch l) == pc (notePitch r)
    pure $ do
      -- m
      rep <-
        sampleValue "spreadRepeatEdge" Bernoulli $
          pInner
            . pSpreadRepetitionEdge
      pure $ if rep then Just (Inner l, Inner r) else Nothing
  let repEdges = [Edge SPitch] -> HashSet (Edge SPitch)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Edge SPitch] -> HashSet (Edge SPitch))
-> [Edge SPitch] -> HashSet (Edge SPitch)
forall a b. (a -> b) -> a -> b
$ [Maybe (Edge SPitch)] -> [Edge SPitch]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Edge SPitch)]
repeats
  -- generate passing edges
  passEdges <- samplePassing notesLeft notesRight pNewPassingMid
  -- construct result
  let distMap = [(Note SPitch, SpreadChildren SPitch)]
-> HashMap (Note SPitch) (SpreadChildren SPitch)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([Note SPitch]
-> [SpreadChildren SPitch]
-> [(Note SPitch, SpreadChildren SPitch)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Note SPitch]
notes [SpreadChildren SPitch]
dists)
      edges = HashSet (Edge SPitch)
-> MultiSet (InnerEdge SPitch) -> Edges SPitch
forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge SPitch)
repEdges MultiSet (InnerEdge SPitch)
passEdges
  pure $ SpreadOp distMap edges
 where
  leftifyID :: Note n -> Note n
leftifyID (Note n
p String
i) = n -> String -> Note n
forall n. n -> String -> Note n
Note n
p (String
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"l")
  rightifyID :: Note n -> Note n
rightifyID (Note n
p String
i) = n -> String -> Note n
forall n. n -> String -> Note n
Note n
p (String
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"r")
  -- distribute a note to the two child slices
  distNote :: Note n -> m (SpreadChildren n)
distNote Note n
note = do
    dir <-
      String
-> Categorical 3
-> Accessor PVParams (Dirichlet 3)
-> m (Support (Categorical 3))
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"noteSpreadDirection" (forall (n :: Nat). Categorical n
Categorical @3) (Accessor PVParams (Dirichlet 3) -> m (Support (Categorical 3)))
-> Accessor PVParams (Dirichlet 3) -> m (Support (Categorical 3))
forall a b. (a -> b) -> a -> b
$
        (PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner
          ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f (Dirichlet 3) -> f (f (Dirichlet 3)))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParamsInner f -> f (PVParamsInner f)
pNoteSpreadDirection
    pure $ case dir of
      Int
0 -> Note n -> Note n -> SpreadChildren n
forall n. Note n -> Note n -> SpreadChildren n
SpreadBothChildren (Note n -> Note n
forall {n}. Note n -> Note n
leftifyID Note n
note) (Note n -> Note n
forall {n}. Note n -> Note n
rightifyID Note n
note)
      Int
1 -> Note n -> SpreadChildren n
forall n. Note n -> SpreadChildren n
SpreadLeftChild (Note n -> SpreadChildren n) -> Note n -> SpreadChildren n
forall a b. (a -> b) -> a -> b
$ Note n -> Note n
forall {n}. Note n -> Note n
leftifyID Note n
note
      Int
2 -> Note n -> SpreadChildren n
forall n. Note n -> SpreadChildren n
SpreadRightChild (Note n -> SpreadChildren n) -> Note n -> SpreadChildren n
forall a b. (a -> b) -> a -> b
$ Note n -> Note n
forall {n}. Note n -> Note n
rightifyID Note n
note

-- 0 -> pure ToBoth
-- 1 -> do
--   nother <-
--     sampleValue "notesOnOtherSide" (Binomial $ n - 1) $
--       pInner
--         . pNotesOnOtherSide
--   pure $ ToLeft $ n - nother
-- _ -> do
--   nother <-
--     sampleValue "notesOnOtherSide" (Binomial $ n - 1) $
--       pInner
--         . pNotesOnOtherSide
--   pure $ ToRight $ n - nother
-- pure ((note, n), to)

observeSpread :: ContextDouble SPitch -> Spread SPitch -> PVObs ()
observeSpread :: ContextDouble SPitch
-> Spread SPitch -> StateT (Trace PVParams) (Either String) ()
observeSpread (StartStop (Notes SPitch)
_sliceL, Edges SPitch
_transL, Notes HashSet (Note SPitch)
sliceM, Edges SPitch
_transR, StartStop (Notes SPitch)
_sliceR) (SpreadOp HashMap (Note SPitch) (SpreadChildren SPitch)
obsDists (Edges HashSet (Edge SPitch)
repEdges MultiSet (InnerEdge SPitch)
passEdges)) =
  do
    -- observe note distribution
    dists <- (Note SPitch
 -> StateT (Trace PVParams) (Either String) (SpreadChildren SPitch))
-> [Note SPitch]
-> StateT (Trace PVParams) (Either String) [SpreadChildren SPitch]
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 (HashMap (Note SPitch) (SpreadChildren SPitch)
-> Note SPitch
-> StateT (Trace PVParams) (Either String) (SpreadChildren SPitch)
forall {a} {n}.
(Hashable a, Show a) =>
HashMap a (SpreadChildren n)
-> a -> StateT (Trace PVParams) (Either String) (SpreadChildren n)
observeNoteDist HashMap (Note SPitch) (SpreadChildren SPitch)
obsDists) ([Note SPitch]
 -> StateT (Trace PVParams) (Either String) [SpreadChildren SPitch])
-> [Note SPitch]
-> StateT (Trace PVParams) (Either String) [SpreadChildren SPitch]
forall a b. (a -> b) -> a -> b
$ [Note SPitch] -> [Note SPitch]
forall a. Ord a => [a] -> [a]
L.sort ([Note SPitch] -> [Note SPitch]) -> [Note SPitch] -> [Note SPitch]
forall a b. (a -> b) -> a -> b
$ HashSet (Note SPitch) -> [Note SPitch]
forall a. HashSet a -> [a]
S.toList HashSet (Note SPitch)
sliceM
    let notesLeft = (SpreadChildren SPitch -> Maybe (Note SPitch))
-> [SpreadChildren SPitch] -> [Note SPitch]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SpreadChildren SPitch -> Maybe (Note SPitch)
forall n. SpreadChildren n -> Maybe (Note n)
leftSpreadChild [SpreadChildren SPitch]
dists
        notesRight = (SpreadChildren SPitch -> Maybe (Note SPitch))
-> [SpreadChildren SPitch] -> [Note SPitch]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SpreadChildren SPitch -> Maybe (Note SPitch)
forall n. SpreadChildren n -> Maybe (Note n)
rightSpreadChild [SpreadChildren SPitch]
dists
    -- observe repetition edges
    sequence_ $ do
      -- List
      l <- notesLeft
      r <- notesRight
      guard $ pc (notePitch l) == pc (notePitch r)
      pure $
        observeValue
          "spreadRepeatEdge"
          Bernoulli
          (pInner . pSpreadRepetitionEdge)
          (S.member (Inner l, Inner r) repEdges)
    -- observe passing edges
    observePassing notesLeft notesRight pNewPassingMid passEdges
 where
  observeNoteDist :: HashMap a (SpreadChildren n)
-> a -> StateT (Trace PVParams) (Either String) (SpreadChildren n)
observeNoteDist HashMap a (SpreadChildren n)
distMap a
parent = case a -> HashMap a (SpreadChildren n) -> Maybe (SpreadChildren n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup a
parent HashMap a (SpreadChildren n)
distMap of
    Maybe (SpreadChildren n)
Nothing ->
      Either String (SpreadChildren n)
-> StateT (Trace PVParams) (Either String) (SpreadChildren n)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Trace PVParams) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String (SpreadChildren n)
 -> StateT (Trace PVParams) (Either String) (SpreadChildren n))
-> Either String (SpreadChildren n)
-> StateT (Trace PVParams) (Either String) (SpreadChildren n)
forall a b. (a -> b) -> a -> b
$ String -> Either String (SpreadChildren n)
forall a b. a -> Either a b
Left (String -> Either String (SpreadChildren n))
-> String -> Either String (SpreadChildren n)
forall a b. (a -> b) -> a -> b
$ String
"Note " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
parent String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not distributed."
    Just SpreadChildren n
dir -> do
      case SpreadChildren n
dir of
        SpreadBothChildren Note n
_ Note n
_ ->
          String
-> Categorical 3
-> Accessor PVParams (Dirichlet 3)
-> Support (Categorical 3)
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
            String
"noteSpreadDirection"
            (forall (n :: Nat). Categorical n
Categorical @3)
            ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f (Dirichlet 3) -> f (f (Dirichlet 3)))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParamsInner f -> f (PVParamsInner f)
pNoteSpreadDirection)
            Int
Support (Categorical 3)
0
        SpreadLeftChild Note n
_ ->
          String
-> Categorical 3
-> Accessor PVParams (Dirichlet 3)
-> Support (Categorical 3)
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
            String
"noteSpreadDirection"
            (forall (n :: Nat). Categorical n
Categorical @3)
            ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f (Dirichlet 3) -> f (f (Dirichlet 3)))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParamsInner f -> f (PVParamsInner f)
pNoteSpreadDirection)
            Int
Support (Categorical 3)
1
        SpreadRightChild Note n
_ -> do
          String
-> Categorical 3
-> Accessor PVParams (Dirichlet 3)
-> Support (Categorical 3)
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue
            String
"noteSpreadDirection"
            (forall (n :: Nat). Categorical n
Categorical @3)
            ((PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsInner f -> f (PVParamsInner f))
-> PVParams f -> f (PVParams f)
pInner ((PVParamsInner f -> f (PVParamsInner f))
 -> PVParams f -> f (PVParams f))
-> ((f (Dirichlet 3) -> f (f (Dirichlet 3)))
    -> PVParamsInner f -> f (PVParamsInner f))
-> (f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParamsInner f -> f (PVParamsInner f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f (Dirichlet 3) -> f (f (Dirichlet 3)))
-> PVParamsInner f -> f (PVParamsInner f)
pNoteSpreadDirection)
            Int
Support (Categorical 3)
2
      SpreadChildren n
-> StateT (Trace PVParams) (Either String) (SpreadChildren n)
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpreadChildren n
dir

samplePassing
  :: (_)
  => [Note SPitch]
  -> [Note SPitch]
  -> Accessor PVParamsInner Beta
  -> m (MS.MultiSet (InnerEdge SPitch))
samplePassing :: [Note SPitch]
-> [Note SPitch]
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> m (MultiSet (InnerEdge SPitch))
samplePassing [Note SPitch]
notesLeft [Note SPitch]
notesRight forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pNewPassing =
  ([[InnerEdge SPitch]] -> MultiSet (InnerEdge SPitch))
-> m [[InnerEdge SPitch]] -> m (MultiSet (InnerEdge SPitch))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([InnerEdge SPitch] -> MultiSet (InnerEdge SPitch)
forall (t :: * -> *) a.
(Foldable t, Eq a, Hashable a) =>
t a -> MultiSet a
MS.fromList ([InnerEdge SPitch] -> MultiSet (InnerEdge SPitch))
-> ([[InnerEdge SPitch]] -> [InnerEdge SPitch])
-> [[InnerEdge SPitch]]
-> MultiSet (InnerEdge SPitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[InnerEdge SPitch]] -> [InnerEdge SPitch]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (m [[InnerEdge SPitch]] -> m (MultiSet (InnerEdge SPitch)))
-> m [[InnerEdge SPitch]] -> m (MultiSet (InnerEdge SPitch))
forall a b. (a -> b) -> a -> b
$ [m [InnerEdge SPitch]] -> m [[InnerEdge SPitch]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([m [InnerEdge SPitch]] -> m [[InnerEdge SPitch]])
-> [m [InnerEdge SPitch]] -> m [[InnerEdge SPitch]]
forall a b. (a -> b) -> a -> b
$ do
    -- List
    -- DT.traceM $ "notesLeft (smp)" <> show notesLeft
    -- DT.traceM $ "notesRight (smp)" <> show notesRight
    l <- [Note SPitch]
notesLeft
    r <- notesRight
    let step = SIC -> SIC
forall i. Interval i => i -> i
iabs (SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Note SPitch -> SPitch
forall n. Note n -> n
notePitch Note SPitch
l) Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Note SPitch -> SPitch
forall n. Note n -> n
notePitch Note SPitch
r))
    guard $ degree step >= 2 || (degree step == 1 && alteration step >= 0)
    -- DT.traceM $ "parent edge (sample)" <> show (l, r)
    pure $ do
      -- m
      n <- sampleValue "newPassing" Geometric0 $ pInner . pNewPassing
      pure $ replicate n (l, r)

observePassing
  :: [Note SPitch]
  -> [Note SPitch]
  -> Accessor PVParamsInner Beta
  -> MS.MultiSet (InnerEdge SPitch)
  -> PVObs ()
observePassing :: [Note SPitch]
-> [Note SPitch]
-> (forall (f :: * -> *) (f :: * -> *).
    Functor f =>
    (f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f))
-> MultiSet (InnerEdge SPitch)
-> StateT (Trace PVParams) (Either String) ()
observePassing [Note SPitch]
notesLeft [Note SPitch]
notesRight forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsInner f -> f (PVParamsInner f)
pNewPassing MultiSet (InnerEdge SPitch)
edges = [StateT (Trace PVParams) (Either String) ()]
-> StateT (Trace PVParams) (Either String) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([StateT (Trace PVParams) (Either String) ()]
 -> StateT (Trace PVParams) (Either String) ())
-> [StateT (Trace PVParams) (Either String) ()]
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$ do
  -- DT.traceM $ "edges (obs)" <> show edges
  -- DT.traceM $ "notesLeft (obs)" <> show notesLeft
  -- DT.traceM $ "notesRight (obs)" <> show notesRight
  l <- [Note SPitch]
notesLeft
  r <- notesRight
  let step = SIC -> SIC
forall i. Interval i => i -> i
iabs (SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Note SPitch -> SPitch
forall n. Note n -> n
notePitch Note SPitch
l) Pitch SIC -> Pitch SIC -> SIC
forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch -> Pitch (ICOf SInterval)
forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc (Note SPitch -> SPitch
forall n. Note n -> n
notePitch Note SPitch
r))
  guard $ degree step >= 2 || (degree step == 1 && alteration step >= 0)
  -- DT.traceM $ "parent edge (obs)" <> show (l, r)
  pure $
    observeValue
      "newPassing"
      Geometric0
      (pInner . pNewPassing)
      (edges MS.! (l, r))

-- Helpers for bottom-up evaluation (parsing)
-- ------------------------------------------

{- | Sample a single step in a bottom-up context.
Only used for evaluating the probability of a step, therefore returns '()'.
-}
sampleSingleStepParsing :: (_) => ContextSingle SPitch -> m ()
sampleSingleStepParsing :: ContextSingle SPitch -> m ()
sampleSingleStepParsing ContextSingle SPitch
parents = do
  op <- ContextSingle SPitch
-> m (LeftmostSingle (Split SPitch) (Freeze SPitch))
forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, RandomInterpreter m PVParams) =>
ContextSingle SPitch
-> m (LeftmostSingle (Split SPitch) (Freeze SPitch))
sampleSingleStep ContextSingle SPitch
parents
  case op of
    LMSingleFreeze Freeze SPitch
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    LMSingleSplit Split SPitch
_ -> do
      String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"continueLeft" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeft
      () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{- | Observerse a single step in a bottom-up context.
Since double operations don't know whether they have to make a "continueLeft" decision
when going bottom-up, this decision is moved to the previous step, where the context is know.
Therefore, if the following step would have to make this decision, it is added here.
-}
observeSingleStepParsing
  :: ContextSingle SPitch
  -- ^ the parent path
  -> Maybe Bool
  -- ^ If the following (generative) step is a double op,
  -- this is the result of the "continueLeft" decision,
  -- i.e., 'Just True' for split-left and freeze-left,
  -- and 'Just False' for spread and split-right.
  -- If the following step is a single op, this is 'Nothing' (as no decision is made).
  -> LeftmostSingle (Split SPitch) (Freeze SPitch)
  -- ^ the performed operation
  -> Either String (Trace PVParams)
observeSingleStepParsing :: ContextSingle SPitch
-> Maybe Bool
-> LeftmostSingle (Split SPitch) (Freeze SPitch)
-> Either String (Trace PVParams)
observeSingleStepParsing ContextSingle SPitch
parent Maybe Bool
decision LeftmostSingle (Split SPitch) (Freeze SPitch)
op = (StateT (Trace PVParams) (Either String) ()
 -> Trace PVParams -> Either String (Trace PVParams))
-> Trace PVParams
-> StateT (Trace PVParams) (Either String) ()
-> Either String (Trace PVParams)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Trace PVParams) (Either String) ()
-> Trace PVParams -> Either String (Trace PVParams)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Seq (String, Dynamic) -> Trace PVParams
forall (r :: (* -> *) -> *). Seq (String, Dynamic) -> Trace r
Trace Seq (String, Dynamic)
forall a. Monoid a => a
mempty) (StateT (Trace PVParams) (Either String) ()
 -> Either String (Trace PVParams))
-> StateT (Trace PVParams) (Either String) ()
-> Either String (Trace PVParams)
forall a b. (a -> b) -> a -> b
$ do
  -- observe the step as normal
  ContextSingle SPitch
-> LeftmostSingle (Split SPitch) (Freeze SPitch)
-> StateT (Trace PVParams) (Either String) ()
observeSingleStep ContextSingle SPitch
parent LeftmostSingle (Split SPitch) (Freeze SPitch)
op
  -- account for possible extra decision in next step
  case Maybe Bool
decision of
    Maybe Bool
Nothing -> () -> StateT (Trace PVParams) (Either String) ()
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Bool
goLeft -> String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"continueLeft" Bernoulli
Bernoulli ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeft) Bool
Support Bernoulli
goLeft

evalSingleStep
  :: Probs PVParams
  -> ContextSingle SPitch
  -> LeftmostSingle (Split SPitch) (Freeze SPitch)
  -> Maybe Bool
  -> Either String (Maybe ((), Double))
evalSingleStep :: Probs PVParams
-> ContextSingle SPitch
-> LeftmostSingle (Split SPitch) (Freeze SPitch)
-> Maybe Bool
-> Either String (Maybe ((), Double))
evalSingleStep Probs PVParams
probs ContextSingle SPitch
parents LeftmostSingle (Split SPitch) (Freeze SPitch)
op Maybe Bool
decision = do
  trace <- ContextSingle SPitch
-> Maybe Bool
-> LeftmostSingle (Split SPitch) (Freeze SPitch)
-> Either String (Trace PVParams)
observeSingleStepParsing ContextSingle SPitch
parents Maybe Bool
decision LeftmostSingle (Split SPitch) (Freeze SPitch)
op
  -- DT.traceM "evalSingleStep"
  -- DT.traceM $ show $ runTrace trace
  -- let !_ = traceTrace trace $ sampleSingleStepParsing parents
  pure $ evalTraceLogP probs trace $ sampleSingleStepParsing parents

{- | Sample a double step in a bottom-up context.
Only used for evaluating the probability of a step,
therefore takes the "resulting" op and returns '()'.
-}
sampleDoubleStepParsing
  :: (_)
  => ContextDouble SPitch
  -> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
  -> m ()
sampleDoubleStepParsing :: ContextDouble SPitch
-> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
-> m ()
sampleDoubleStepParsing parents :: ContextDouble SPitch
parents@(StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, Notes SPitch
sliceM, Edges SPitch
transR, StartStop (Notes SPitch)
sliceR) LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
op = do
  if Bool
continueLeft
    then
      if Edges SPitch -> Bool
forall n. (Eq (IntervalOf n), HasPitch n) => Edges n -> Bool
freezable Edges SPitch
transL
        then do
          shouldFreeze <-
            String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"shouldFreeze (double)" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeftFreeze
          if shouldFreeze
            then
              LMDoubleFreezeLeft <$> sampleFreeze (sliceL, transL, Inner sliceM)
            else
              LMDoubleSplitLeft <$> sampleSplit (sliceL, transL, Inner sliceM)
        else Split SPitch
-> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
forall s f h. s -> LeftmostDouble s f h
LMDoubleSplitLeft (Split SPitch
 -> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch))
-> m (Split SPitch)
-> m (LeftmostDouble
        (Split SPitch) (Freeze SPitch) (Spread SPitch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContextSingle SPitch -> m (Split SPitch)
forall (m :: * -> *).
(SampleCtx m Geometric1, SampleCtx m Bernoulli,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m MagicalID, RandomInterpreter m PVParams) =>
ContextSingle SPitch -> m (Split SPitch)
sampleSplit (StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sliceM)
    else do
      shouldSplitRight <-
        String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"shouldSplitRight" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleRightSplit
      if shouldSplitRight
        then LMDoubleSplitRight <$> sampleSplit (Inner sliceM, transR, sliceR)
        else LMDoubleSpread <$> sampleSpread parents
  case LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
op of
    -- split right? no extra decision
    LMDoubleSplitRight Split SPitch
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- reached the end? next step is single, so no extra decision
    LMDoubleFreezeLeft Freeze SPitch
_
      | StartStop (Notes SPitch)
sliceR StartStop (Notes SPitch) -> StartStop (Notes SPitch) -> Bool
forall a. Eq a => a -> a -> Bool
== StartStop (Notes SPitch)
forall a. StartStop a
Stop -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- all other cases: extra "continueLeft" decision in next step
    LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
_ -> do
      String
-> Bernoulli -> Accessor PVParams Beta -> m (Support Bernoulli)
forall p l.
(Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor PVParams p -> m (Support l)
forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"continueLeft" Bernoulli
Bernoulli (Accessor PVParams Beta -> m (Support Bernoulli))
-> Accessor PVParams Beta -> m (Support Bernoulli)
forall a b. (a -> b) -> a -> b
$ (PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeft
      () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  continueLeft :: Bool
continueLeft = case LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
op of
    LMDoubleFreezeLeft Freeze SPitch
_ -> Bool
True
    LMDoubleSplitLeft Split SPitch
_ -> Bool
True
    LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
_ -> Bool
False

{- | Observerse a double step without knowing
if it happened after a right split (e.g., when parsing).
The extra decision that is necessary if it doesn't follow a right split
is "moved" to the previous step.
Therefore, this step is rated as if it follows a right split (not making the decision).
In addition, if the following step would have to make the extra decision, it is added here.
-}
observeDoubleStepParsing
  :: ContextDouble SPitch
  -- ^ the parent path
  -> Maybe Bool
  -- ^ If the following (generative) step is a double op,
  -- this is the result of the "continueLeft" decision,
  -- i.e., 'Just True' for split-left
  -- and freeze-left and 'Just False' for spread and split-right.
  -- If the following step is a single op, this is 'Nothing', as not decision is made.
  -> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
  -- ^ the performed operation
  -> Either String (Trace PVParams)
observeDoubleStepParsing :: ContextDouble SPitch
-> Maybe Bool
-> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
-> Either String (Trace PVParams)
observeDoubleStepParsing parents :: ContextDouble SPitch
parents@(StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, Notes SPitch
sliceM, Edges SPitch
transR, StartStop (Notes SPitch)
sliceR) Maybe Bool
decision LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
op =
  (StateT (Trace PVParams) (Either String) ()
 -> Trace PVParams -> Either String (Trace PVParams))
-> Trace PVParams
-> StateT (Trace PVParams) (Either String) ()
-> Either String (Trace PVParams)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Trace PVParams) (Either String) ()
-> Trace PVParams -> Either String (Trace PVParams)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Seq (String, Dynamic) -> Trace PVParams
forall (r :: (* -> *) -> *). Seq (String, Dynamic) -> Trace r
Trace Seq (String, Dynamic)
forall a. Monoid a => a
mempty) (StateT (Trace PVParams) (Either String) ()
 -> Either String (Trace PVParams))
-> StateT (Trace PVParams) (Either String) ()
-> Either String (Trace PVParams)
forall a b. (a -> b) -> a -> b
$ do
    -- observe step but skip "continueLeft" decisions
    case LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
op of
      LMDoubleFreezeLeft Freeze SPitch
f -> do
        String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"shouldFreeze (double)" Bernoulli
Bernoulli ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeftFreeze) Bool
Support Bernoulli
True
        ContextSingle SPitch
-> Freeze SPitch -> StateT (Trace PVParams) (Either String) ()
observeFreeze (StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sliceM) Freeze SPitch
f
      LMDoubleSplitLeft Split SPitch
s -> do
        Bool
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Edges SPitch -> Bool
forall n. (Eq (IntervalOf n), HasPitch n) => Edges n -> Bool
freezable Edges SPitch
transL) (StateT (Trace PVParams) (Either String) ()
 -> StateT (Trace PVParams) (Either String) ())
-> StateT (Trace PVParams) (Either String) ()
-> StateT (Trace PVParams) (Either String) ()
forall a b. (a -> b) -> a -> b
$
          String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"shouldFreeze (double)" Bernoulli
Bernoulli ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeftFreeze) Bool
Support Bernoulli
False
        ContextSingle SPitch
-> Split SPitch -> StateT (Trace PVParams) (Either String) ()
observeSplit (StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sliceM) Split SPitch
s
      LMDoubleSplitRight Split SPitch
s -> do
        String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"shouldSplitRight" Bernoulli
Bernoulli ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleRightSplit) Bool
Support Bernoulli
True
        ContextSingle SPitch
-> Split SPitch -> StateT (Trace PVParams) (Either String) ()
observeSplit (Notes SPitch -> StartStop (Notes SPitch)
forall a. a -> StartStop a
Inner Notes SPitch
sliceM, Edges SPitch
transR, StartStop (Notes SPitch)
sliceR) Split SPitch
s
      LMDoubleSpread Spread SPitch
h -> do
        String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"shouldSplitRight" Bernoulli
Bernoulli ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleRightSplit) Bool
Support Bernoulli
False
        ContextDouble SPitch
-> Spread SPitch -> StateT (Trace PVParams) (Either String) ()
observeSpread ContextDouble SPitch
parents Spread SPitch
h
    -- account for possible extra decision in next step, if this is a right split
    case LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
op of
      -- right split? no extra decision can follow
      LMDoubleSplitRight Split SPitch
_ -> () -> StateT (Trace PVParams) (Either String) ()
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      -- otherwise? possible extra decision
      LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
_ -> case Maybe Bool
decision of
        Maybe Bool
Nothing -> () -> StateT (Trace PVParams) (Either String) ()
forall a. a -> StateT (Trace PVParams) (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Bool
goLeft -> String
-> Bernoulli
-> Accessor PVParams Beta
-> Support Bernoulli
-> StateT (Trace PVParams) (Either String) ()
forall p l (m :: * -> *) (r :: (* -> *) -> *).
(Conjugate p l, Typeable (Support l), Monad m) =>
String -> l -> Accessor r p -> Support l -> StateT (Trace r) m ()
observeValue String
"continueLeft" Bernoulli
Bernoulli ((PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(PVParamsOuter f -> f (PVParamsOuter f))
-> PVParams f -> f (PVParams f)
pOuter ((PVParamsOuter f -> f (PVParamsOuter f))
 -> PVParams f -> f (PVParams f))
-> ((f Beta -> f (f Beta))
    -> PVParamsOuter f -> f (PVParamsOuter f))
-> (f Beta -> f (f Beta))
-> PVParams f
-> f (PVParams f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(f Beta -> f (f Beta)) -> PVParamsOuter f -> f (PVParamsOuter f)
pDoubleLeft) Bool
Support Bernoulli
goLeft

evalDoubleStep
  :: Probs PVParams
  -> ContextDouble SPitch
  -> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
  -> Maybe Bool
  -> Either String (Maybe ((), Double))
evalDoubleStep :: Probs PVParams
-> ContextDouble SPitch
-> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
-> Maybe Bool
-> Either String (Maybe ((), Double))
evalDoubleStep Probs PVParams
probs ContextDouble SPitch
parents LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
op Maybe Bool
decision = do
  trace <- ContextDouble SPitch
-> Maybe Bool
-> LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
-> Either String (Trace PVParams)
observeDoubleStepParsing ContextDouble SPitch
parents Maybe Bool
decision LeftmostDouble (Split SPitch) (Freeze SPitch) (Spread SPitch)
op
  -- DT.traceM "evalDoubleStep"
  -- DT.traceM $ show $ runTrace trace
  -- let !_ = traceTrace trace $ sampleDoubleStepParsing parents op
  pure $ evalTraceLogP probs trace $ sampleDoubleStepParsing parents op