{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

{- | 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 (..)

    -- * 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
  ) 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
  )
import Debug.Trace qualified as DT
import GHC.Generics (Generic)
import Inference.Conjugate

-- import qualified Inference.Conjugate           as IC
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)

-- | 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 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
$cto :: forall (f :: * -> *) x. Rep (PVParamsOuter f) x -> PVParamsOuter f
$cfrom :: forall (f :: * -> *) x. PVParamsOuter f -> Rep (PVParamsOuter f) x
Generic)

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

makeLenses ''PVParamsOuter

{- | 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
  , forall (f :: * -> *). PVParamsInner f -> f Beta
_pSpreadRepetitionEdge :: f Beta
  }
  deriving (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
$cto :: forall (f :: * -> *) x. Rep (PVParamsInner f) x -> PVParamsInner f
$cfrom :: forall (f :: * -> *) x. PVParamsInner f -> Rep (PVParamsInner f) x
Generic)

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

makeLenses ''PVParamsInner

-- | 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 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
$cto :: forall (f :: * -> *) x. Rep (PVParams f) x -> PVParams f
$cfrom :: forall (f :: * -> *) x. PVParams f -> Rep (PVParams f) x
Generic)

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

makeLenses ''PVParams

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

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

{- | 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 [PVLeftmost SPitch])
roundtrip String
fn = do
  Either String (PVAnalysis SPitch)
anaE <- String -> IO (Either String (PVAnalysis SPitch))
loadAnalysis String
fn
  case Either String (PVAnalysis SPitch)
anaE of
    Left String
err -> 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' forall a b. (a -> b) -> a -> b
$ 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 -> forall a. HasCallStack => String -> a
error String
err
        Right Trace PVParams
trace -> do
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (r :: (* -> *) -> *) a. Trace r -> TraceTraceI r a -> a
traceTrace Trace PVParams
trace forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m (Categorical 3), SampleCtx m Binomial,
 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
  Either String (PVAnalysis SPitch)
anaE <- String -> IO (Either String (PVAnalysis SPitch))
loadAnalysis String
fn
  case Either String (PVAnalysis SPitch)
anaE of
    Left String
err -> 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' forall a b. (a -> b) -> a -> b
$ 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 -> 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
uniformPrior @PVParams
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (r :: (* -> *) -> *) a.
r HyperRep -> Trace r -> UpdatePriorsI r a -> Maybe (r HyperRep)
getPosterior PVParams HyperRep
prior Trace PVParams
trace (forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m (Categorical 3), SampleCtx m Binomial,
 RandomInterpreter m PVParams) =>
Path (Edges SPitch) (Notes SPitch)
-> m (Either String [PVLeftmost SPitch])
sampleDerivation forall a b. (a -> b) -> a -> b
$ forall s f h tr slc. Analysis s f h tr slc -> Path tr slc
anaTop PVAnalysis SPitch
ana)

-- | A shorthand for 'sampleDerivation' starting from ⋊——⋉.
sampleDerivation' :: _ => m (Either String [PVLeftmost SPitch])
sampleDerivation' :: m (Either String [PVLeftmost SPitch])
sampleDerivation' = forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m (Categorical 3), SampleCtx m Binomial,
 RandomInterpreter m PVParams) =>
Path (Edges SPitch) (Notes SPitch)
-> m (Either String [PVLeftmost SPitch])
sampleDerivation forall a b. (a -> b) -> a -> b
$ forall around between. around -> Path around between
PathEnd 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 forall a b. (a -> b) -> a -> b
$ forall around between. around -> Path around between
PathEnd 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 = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}.
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m (Categorical 3), SampleCtx m Binomial,
 RandomInterpreter m PVParams) =>
StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> ExceptT String m [PVLeftmost SPitch]
go 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
      LeftmostSingle (Split SPitch) Freeze
step <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 RandomInterpreter m PVParams) =>
ContextSingle SPitch -> m (LeftmostSingle (Split SPitch) Freeze)
sampleSingleStep (StartStop (Notes SPitch)
sl, Edges SPitch
t, forall a. StartStop a
Stop)
      case LeftmostSingle (Split SPitch) Freeze
step of
        LMSingleSplit Split SPitch
splitOp -> do
          (Edges SPitch
ctl, Notes SPitch
cs, Edges SPitch
ctr) <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ 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
          [PVLeftmost SPitch]
nextSteps <- StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> ExceptT String m [PVLeftmost SPitch]
go StartStop (Notes SPitch)
sl (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctl Notes SPitch
cs (forall around between. around -> Path around between
PathEnd Edges SPitch
ctr)) Bool
False
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s f h. s -> Leftmost s f h
LMSplitOnly Split SPitch
splitOp forall a. a -> [a] -> [a]
: [PVLeftmost SPitch]
nextSteps
        LMSingleFreeze Freeze
freezeOp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall f s h. f -> Leftmost s f h
LMFreezeOnly Freeze
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 forall a. StartStop a
Stop Bool
ars 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 (forall a. a -> StartStop a
Inner Notes SPitch
sr) Bool
ars (\Edges SPitch
tr' -> 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
    LeftmostDouble (Split SPitch) Freeze (Spread SPitch)
step <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric1,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 SampleCtx m (Categorical 3), SampleCtx m Binomial,
 RandomInterpreter m PVParams) =>
ContextDouble SPitch
-> Bool -> m (LeftmostDouble (Split SPitch) Freeze (Spread SPitch))
sampleDoubleStep (StartStop (Notes SPitch)
sl, Edges SPitch
tl, Notes SPitch
sm, Edges SPitch
tr, StartStop (Notes SPitch)
sr) Bool
ars
    case LeftmostDouble (Split SPitch) Freeze (Spread SPitch)
step of
      LMDoubleSplitLeft Split SPitch
splitOp -> do
        (Edges SPitch
ctl, Notes SPitch
cs, Edges SPitch
ctr) <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ 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
        [PVLeftmost SPitch]
nextSteps <- StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> ExceptT String m [PVLeftmost SPitch]
go StartStop (Notes SPitch)
sl (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctl Notes SPitch
cs (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctr Notes SPitch
sm (Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkrest Edges SPitch
tr))) Bool
False
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s f h. s -> Leftmost s f h
LMSplitLeft Split SPitch
splitOp forall a. a -> [a] -> [a]
: [PVLeftmost SPitch]
nextSteps
      LMDoubleFreezeLeft Freeze
freezeOp -> do
        [PVLeftmost SPitch]
nextSteps <- StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> ExceptT String m [PVLeftmost SPitch]
go (forall a. a -> StartStop a
Inner Notes SPitch
sm) (Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkrest Edges SPitch
tr) Bool
False
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall f s h. f -> Leftmost s f h
LMFreezeLeft Freeze
freezeOp forall a. a -> [a] -> [a]
: [PVLeftmost SPitch]
nextSteps
      LMDoubleSplitRight Split SPitch
splitOp -> do
        (Edges SPitch
ctl, Notes SPitch
cs, Edges SPitch
ctr) <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ 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
        [PVLeftmost SPitch]
nextSteps <- StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> ExceptT String m [PVLeftmost SPitch]
go StartStop (Notes SPitch)
sl (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
tl Notes SPitch
sm (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctl Notes SPitch
cs (Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkrest Edges SPitch
ctr))) Bool
True
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s f h. s -> Leftmost s f h
LMSplitRight Split SPitch
splitOp forall a. a -> [a] -> [a]
: [PVLeftmost SPitch]
nextSteps
      LMDoubleSpread Spread SPitch
spreadOp -> do
        (Edges SPitch
ctl, Notes SPitch
csl, Edges SPitch
ctm, Notes SPitch
csr, Edges SPitch
ctr) <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ 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
        [PVLeftmost SPitch]
nextSteps <- StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> ExceptT String m [PVLeftmost SPitch]
go StartStop (Notes SPitch)
sl (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctl Notes SPitch
csl (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctm Notes SPitch
csr (Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkrest Edges SPitch
ctr))) Bool
False
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall h s f. h -> Leftmost s f h
LMSpread Spread SPitch
spreadOp forall a. a -> [a] -> [a]
: [PVLeftmost SPitch]
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 =
  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]
-> PVObs ()
go forall a. StartStop a
Start Path (Edges SPitch) (Notes SPitch)
top Bool
False [PVLeftmost SPitch]
deriv)
    (forall (r :: (* -> *) -> *). Seq Dynamic -> Trace r
Trace 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]
-> PVObs ()
go StartStop (Notes SPitch)
_sl Path (Edges SPitch) (Notes SPitch)
_surface Bool
_ars [] = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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
single -> do
      ContextSingle SPitch
-> LeftmostSingle (Split SPitch) Freeze -> PVObs ()
observeSingleStep (StartStop (Notes SPitch)
sl, Edges SPitch
trans, forall a. StartStop a
Stop) LeftmostSingle (Split SPitch) Freeze
single
      case LeftmostSingle (Split SPitch) Freeze
single of
        LMSingleFreeze Freeze
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        LMSingleSplit Split SPitch
splitOp -> do
          (Edges SPitch
ctl, Notes SPitch
cs, Edges SPitch
ctr) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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
          StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> [PVLeftmost SPitch]
-> PVObs ()
go StartStop (Notes SPitch)
sl (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctl Notes SPitch
cs (forall around between. around -> Path around between
PathEnd Edges SPitch
ctr)) Bool
False [PVLeftmost SPitch]
rest
    LMDouble LeftmostDouble (Split SPitch) Freeze (Spread SPitch)
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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))
-> PVObs ()
goDouble PVLeftmost SPitch
op [PVLeftmost SPitch]
rest Bool
ars (StartStop (Notes SPitch)
sl, Edges SPitch
tl, Notes SPitch
sm, Edges SPitch
tr, forall a. StartStop a
Stop) 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))
-> PVObs ()
goDouble PVLeftmost SPitch
op [PVLeftmost SPitch]
derivRest Bool
ars (StartStop (Notes SPitch)
sl, Edges SPitch
tl, Notes SPitch
sm, Edges SPitch
tr, forall a. a -> StartStop a
Inner Notes SPitch
sr) forall a b. (a -> b) -> a -> b
$
      \Edges SPitch
tr' -> 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))
-> PVObs ()
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
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"Single operation with several transitions left."
    LMDouble LeftmostDouble (Split SPitch) Freeze (Spread SPitch)
double -> do
      ContextDouble SPitch
-> Bool
-> LeftmostDouble (Split SPitch) Freeze (Spread SPitch)
-> PVObs ()
observeDoubleStep (StartStop (Notes SPitch)
sl, Edges SPitch
tl, Notes SPitch
sm, Edges SPitch
tr, StartStop (Notes SPitch)
sr) Bool
ars LeftmostDouble (Split SPitch) Freeze (Spread SPitch)
double
      case LeftmostDouble (Split SPitch) Freeze (Spread SPitch)
double of
        LMDoubleFreezeLeft Freeze
_ -> do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ars forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"FreezeLeft after SplitRight."
          StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> [PVLeftmost SPitch]
-> PVObs ()
go (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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ars forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"SplitLeft after SplitRight."
          (Edges SPitch
ctl, Notes SPitch
cs, Edges SPitch
ctr) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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
          StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> [PVLeftmost SPitch]
-> PVObs ()
go StartStop (Notes SPitch)
sl (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctl Notes SPitch
cs forall a b. (a -> b) -> a -> b
$ forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctr Notes SPitch
sm forall a b. (a -> b) -> a -> b
$ Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkRest Edges SPitch
tr) Bool
False [PVLeftmost SPitch]
rest
        LMDoubleSplitRight Split SPitch
splitOp -> do
          (Edges SPitch
ctl, Notes SPitch
cs, Edges SPitch
ctr) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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
          StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> [PVLeftmost SPitch]
-> PVObs ()
go StartStop (Notes SPitch)
sl (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
tl Notes SPitch
sm forall a b. (a -> b) -> a -> b
$ forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctl Notes SPitch
cs forall a b. (a -> b) -> a -> b
$ Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkRest Edges SPitch
ctr) Bool
True [PVLeftmost SPitch]
rest
        LMDoubleSpread Spread SPitch
spreadOp -> do
          (Edges SPitch
ctl, Notes SPitch
csl, Edges SPitch
ctm, Notes SPitch
csr, Edges SPitch
ctr) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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
          StartStop (Notes SPitch)
-> Path (Edges SPitch) (Notes SPitch)
-> Bool
-> [PVLeftmost SPitch]
-> PVObs ()
go StartStop (Notes SPitch)
sl (forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctl Notes SPitch
csl forall a b. (a -> b) -> a -> b
$ forall around between.
around -> between -> Path around between -> Path around between
Path Edges SPitch
ctm Notes SPitch
csr forall a b. (a -> b) -> a -> b
$ Edges SPitch -> Path (Edges SPitch) (Notes SPitch)
mkRest Edges SPitch
ctr) Bool
False [PVLeftmost SPitch]
rest

sampleSingleStep
  :: _ => ContextSingle SPitch -> m (LeftmostSingle (Split SPitch) Freeze)
sampleSingleStep :: ContextSingle SPitch -> m (LeftmostSingle (Split SPitch) Freeze)
sampleSingleStep parents :: ContextSingle SPitch
parents@(StartStop (Notes SPitch)
_, Edges SPitch
trans, StartStop (Notes SPitch)
_) =
  if forall n. (Eq (IntervalOf n), HasPitch n) => Edges n -> Bool
freezable Edges SPitch
trans
    then do
      Bool
shouldFreeze <-
        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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pSingleFreeze
      if Bool
shouldFreeze
        then forall s f. f -> LeftmostSingle s f
LMSingleFreeze forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) n.
RandomInterpreter m PVParams =>
ContextSingle n -> m Freeze
sampleFreeze ContextSingle SPitch
parents
        else forall s f. s -> LeftmostSingle s f
LMSingleSplit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(SampleCtx m Geometric1, SampleCtx m Bernoulli,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 RandomInterpreter m PVParams) =>
ContextSingle SPitch -> m (Split SPitch)
sampleSplit ContextSingle SPitch
parents
    else forall s f. s -> LeftmostSingle s f
LMSingleSplit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(SampleCtx m Geometric1, SampleCtx m Bernoulli,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 RandomInterpreter m PVParams) =>
ContextSingle SPitch -> m (Split SPitch)
sampleSplit ContextSingle SPitch
parents

observeSingleStep
  :: ContextSingle SPitch -> LeftmostSingle (Split SPitch) Freeze -> PVObs ()
observeSingleStep :: ContextSingle SPitch
-> LeftmostSingle (Split SPitch) Freeze -> PVObs ()
observeSingleStep parents :: ContextSingle SPitch
parents@(StartStop (Notes SPitch)
_, Edges SPitch
trans, StartStop (Notes SPitch)
_) LeftmostSingle (Split SPitch) Freeze
singleOp =
  if forall n. (Eq (IntervalOf n), HasPitch n) => Edges n -> Bool
freezable Edges SPitch
trans
    then case LeftmostSingle (Split SPitch) Freeze
singleOp of
      LMSingleFreeze Freeze
f -> do
        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
          (forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pSingleFreeze)
          Bool
True
        ContextSingle SPitch -> Freeze -> PVObs ()
observeFreeze ContextSingle SPitch
parents Freeze
f
      LMSingleSplit Split SPitch
s -> do
        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
          (forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pSingleFreeze)
          Bool
False
        ContextSingle SPitch -> Split SPitch -> PVObs ()
observeSplit ContextSingle SPitch
parents Split SPitch
s
    else case LeftmostSingle (Split SPitch) Freeze
singleOp of
      LMSingleFreeze Freeze
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"Freezing a non-freezable transition."
      LMSingleSplit Split SPitch
s -> ContextSingle SPitch -> Split SPitch -> PVObs ()
observeSplit ContextSingle SPitch
parents Split SPitch
s

sampleDoubleStep
  :: _
  => ContextDouble SPitch
  -> Bool
  -> m (LeftmostDouble (Split SPitch) Freeze (Spread SPitch))
sampleDoubleStep :: ContextDouble SPitch
-> Bool -> m (LeftmostDouble (Split SPitch) Freeze (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
      Bool
shouldSplitRight <-
        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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleRightSplit
      if Bool
shouldSplitRight
        then forall s f h. s -> LeftmostDouble s f h
LMDoubleSplitRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(SampleCtx m Geometric1, SampleCtx m Bernoulli,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 RandomInterpreter m PVParams) =>
ContextSingle SPitch -> m (Split SPitch)
sampleSplit (forall a. a -> StartStop a
Inner Notes SPitch
sliceM, Edges SPitch
transR, StartStop (Notes SPitch)
sliceR)
        else forall s f h. h -> LeftmostDouble s f h
LMDoubleSpread forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(SampleCtx m (Categorical 3), SampleCtx m Binomial,
 SampleCtx m Bernoulli, SampleCtx m Geometric0,
 RandomInterpreter m PVParams) =>
ContextDouble SPitch -> m (Spread SPitch)
sampleSpread ContextDouble SPitch
parents
    else do
      Bool
continueLeft <-
        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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleLeft
      if Bool
continueLeft
        then
          if forall n. (Eq (IntervalOf n), HasPitch n) => Edges n -> Bool
freezable Edges SPitch
transL
            then do
              Bool
shouldFreeze <-
                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 forall a b. (a -> b) -> a -> b
$
                  forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleLeftFreeze
              if Bool
shouldFreeze
                then
                  forall s f h. f -> LeftmostDouble s f h
LMDoubleFreezeLeft
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) n.
RandomInterpreter m PVParams =>
ContextSingle n -> m Freeze
sampleFreeze (StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, forall a. a -> StartStop a
Inner Notes SPitch
sliceM)
                else
                  forall s f h. s -> LeftmostDouble s f h
LMDoubleSplitLeft
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(SampleCtx m Geometric1, SampleCtx m Bernoulli,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 RandomInterpreter m PVParams) =>
ContextSingle SPitch -> m (Split SPitch)
sampleSplit (StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, forall a. a -> StartStop a
Inner Notes SPitch
sliceM)
            else forall s f h. s -> LeftmostDouble s f h
LMDoubleSplitLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(SampleCtx m Geometric1, SampleCtx m Bernoulli,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 RandomInterpreter m PVParams) =>
ContextSingle SPitch -> m (Split SPitch)
sampleSplit (StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, forall a. a -> StartStop a
Inner Notes SPitch
sliceM)
        else ContextDouble SPitch
-> Bool -> m (LeftmostDouble (Split SPitch) Freeze (Spread SPitch))
sampleDoubleStep ContextDouble SPitch
parents Bool
True

observeDoubleStep
  :: ContextDouble SPitch
  -> Bool
  -> LeftmostDouble (Split SPitch) Freeze (Spread SPitch)
  -> PVObs ()
observeDoubleStep :: ContextDouble SPitch
-> Bool
-> LeftmostDouble (Split SPitch) Freeze (Spread SPitch)
-> PVObs ()
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 (Spread SPitch)
doubleOp =
  case LeftmostDouble (Split SPitch) Freeze (Spread SPitch)
doubleOp of
    LMDoubleFreezeLeft Freeze
f -> do
      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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleLeft) Bool
True
      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
        (forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleLeftFreeze)
        Bool
True
      ContextSingle SPitch -> Freeze -> PVObs ()
observeFreeze (StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, forall a. a -> StartStop a
Inner Notes SPitch
sliceM) Freeze
f
    LMDoubleSplitLeft Split SPitch
s -> do
      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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleLeft) Bool
True
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall n. (Eq (IntervalOf n), HasPitch n) => Edges n -> Bool
freezable Edges SPitch
transL) forall a b. (a -> b) -> a -> b
$
        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
          (forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleLeftFreeze)
          Bool
False
      ContextSingle SPitch -> Split SPitch -> PVObs ()
observeSplit (StartStop (Notes SPitch)
sliceL, Edges SPitch
transL, forall a. a -> StartStop a
Inner Notes SPitch
sliceM) Split SPitch
s
    LMDoubleSplitRight Split SPitch
s -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
afterRightSplit forall a b. (a -> b) -> a -> b
$
        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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleLeft) Bool
False
      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
        (forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleRightSplit)
        Bool
True
      ContextSingle SPitch -> Split SPitch -> PVObs ()
observeSplit (forall a. a -> StartStop a
Inner Notes SPitch
sliceM, Edges SPitch
transR, StartStop (Notes SPitch)
sliceR) Split SPitch
s
    LMDoubleSpread Spread SPitch
h -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
afterRightSplit forall a b. (a -> b) -> a -> b
$
        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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleLeft) Bool
False
      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
        (forall (f :: * -> *). Lens' (PVParams f) (PVParamsOuter f)
pOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsOuter f) (f Beta)
pDoubleRightSplit)
        Bool
False
      ContextDouble SPitch -> Spread SPitch -> PVObs ()
observeSpread ContextDouble SPitch
parents Spread SPitch
h

sampleFreeze :: RandomInterpreter m PVParams => ContextSingle n -> m Freeze
sampleFreeze :: forall (m :: * -> *) n.
RandomInterpreter m PVParams =>
ContextSingle n -> m Freeze
sampleFreeze ContextSingle n
_parents = forall (f :: * -> *) a. Applicative f => a -> f a
pure Freeze
FreezeOp

observeFreeze :: ContextSingle SPitch -> Freeze -> PVObs ()
observeFreeze :: ContextSingle SPitch -> Freeze -> PVObs ()
observeFreeze ContextSingle SPitch
_parents Freeze
FreezeOp = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

-- helper for sampleSplit and observeSplit
collectNotes
  :: [(Edge SPitch, [(SPitch, o1)])]
  -> [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
  -> [(SPitch, [(SPitch, o2)])]
  -> [(SPitch, [(SPitch, o3)])]
  -> [SPitch]
collectNotes :: forall o1 o2 o3.
[(Edge SPitch, [(SPitch, o1)])]
-> [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
-> [(SPitch, [(SPitch, o2)])]
-> [(SPitch, [(SPitch, o3)])]
-> [SPitch]
collectNotes [(Edge SPitch, [(SPitch, o1)])]
childrenT [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
childrenNT [(SPitch, [(SPitch, o2)])]
childrenL [(SPitch, [(SPitch, o3)])]
childrenR =
  let notesT :: [SPitch]
notesT = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Edge SPitch, [(SPitch, o1)])]
childrenT
      notesNT :: [SPitch]
notesNT = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
childrenNT
      notesFromL :: [SPitch]
notesFromL = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(SPitch, [(SPitch, o2)])]
childrenL
      notesFromR :: [SPitch]
notesFromR = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(SPitch, [(SPitch, o3)])]
childrenR
   in forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ [SPitch]
notesT forall a. Semigroup a => a -> a -> a
<> [SPitch]
notesNT forall a. Semigroup a => a -> a -> a
<> [SPitch]
notesFromL forall a. Semigroup a => a -> a -> a
<> [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
  [(Edge SPitch, [(SPitch, DoubleOrnament)])]
childrenT <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(SampleCtx m Geometric1, SampleCtx m Bernoulli,
 SampleCtx m Geometric0, SampleCtx m MagicalOctaves,
 RandomInterpreter m PVParams) =>
Edge SPitch -> m (Edge SPitch, [(SPitch, DoubleOrnament)])
sampleT forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
S.toList HashSet (Edge SPitch)
ts
  -- DT.traceM $ "childrenT (smp): " <> show childrenT
  -- ornament passing edges exactly once
  [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
childrenNT <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
(InnerEdge SPitch, Int)
-> m (InnerEdge SPitch, [(SPitch, PassingOrnament)])
sampleNT forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet (InnerEdge SPitch)
nts
  -- DT.traceM $ "childrenNT (smp): " <> show childrenNT
  -- ornament left notes
  [(SPitch, [(SPitch, RightOrnament)])]
childrenL <- case forall a. StartStop a -> Maybe a
getInner StartStop (Notes SPitch)
sliceL of
    Maybe (Notes SPitch)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just (Notes MultiSet SPitch
notes) -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(SampleCtx m Geometric0, SampleCtx m Bernoulli,
 SampleCtx m MagicalOctaves, RandomInterpreter m PVParams) =>
SPitch -> m (SPitch, [(SPitch, RightOrnament)])
sampleL forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. MultiSet a -> [a]
MS.toList MultiSet SPitch
notes
  -- DT.traceM $ "childrenL (smp): " <> show childrenL
  -- ornament right notes
  [(SPitch, [(SPitch, LeftOrnament)])]
childrenR <- case forall a. StartStop a -> Maybe a
getInner StartStop (Notes SPitch)
sliceR of
    Maybe (Notes SPitch)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just (Notes MultiSet SPitch
notes) -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(SampleCtx m Geometric0, SampleCtx m Bernoulli,
 SampleCtx m MagicalOctaves, RandomInterpreter m PVParams) =>
SPitch -> m (SPitch, [(SPitch, LeftOrnament)])
sampleR forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. MultiSet a -> [a]
MS.toList MultiSet SPitch
notes
  -- DT.traceM $ "childrenR (smp): " <> show childrenR
  -- introduce new passing edges left and right
  let notes :: [SPitch]
notes = forall o1 o2 o3.
[(Edge SPitch, [(SPitch, o1)])]
-> [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
-> [(SPitch, [(SPitch, o2)])]
-> [(SPitch, [(SPitch, o3)])]
-> [SPitch]
collectNotes [(Edge SPitch, [(SPitch, DoubleOrnament)])]
childrenT [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
childrenNT [(SPitch, [(SPitch, RightOrnament)])]
childrenL [(SPitch, [(SPitch, LeftOrnament)])]
childrenR
  MultiSet (InnerEdge SPitch)
passLeft <- case forall a. StartStop a -> Maybe a
getInner StartStop (Notes SPitch)
sliceL of
    Maybe (Notes SPitch)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. MultiSet a
MS.empty
    Just (Notes MultiSet SPitch
notesl) ->
      forall (m :: * -> *).
(SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
[SPitch]
-> [SPitch]
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> m (MultiSet (InnerEdge SPitch))
samplePassing (forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. MultiSet a -> [a]
MS.toList MultiSet SPitch
notesl) [SPitch]
notes forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNewPassingLeft
  MultiSet (InnerEdge SPitch)
passRight <- case forall a. StartStop a -> Maybe a
getInner StartStop (Notes SPitch)
sliceR of
    Maybe (Notes SPitch)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. MultiSet a
MS.empty
    Just (Notes MultiSet SPitch
notesr) ->
      forall (m :: * -> *).
(SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
[SPitch]
-> [SPitch]
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> m (MultiSet (InnerEdge SPitch))
samplePassing [SPitch]
notes (forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. MultiSet a -> [a]
MS.toList MultiSet SPitch
notesr) forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNewPassingRight
  let (Map (Edge SPitch) [(SPitch, DoubleOrnament)]
splitReg, Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
splitPass, Map SPitch [(SPitch, RightOrnament)]
fromLeft, Map SPitch [(SPitch, LeftOrnament)]
fromRight, HashSet (Edge SPitch)
leftEdges, HashSet (Edge SPitch)
rightEdges) =
        forall o1 o2 o3.
[(Edge SPitch, [(SPitch, o1)])]
-> [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
-> [(SPitch, [(SPitch, o2)])]
-> [(SPitch, [(SPitch, o3)])]
-> (Map (Edge SPitch) [(SPitch, o1)],
    Map (InnerEdge SPitch) [(SPitch, PassingOrnament)],
    Map SPitch [(SPitch, o2)], Map SPitch [(SPitch, o3)],
    HashSet (Edge SPitch), HashSet (Edge SPitch))
collectElabos [(Edge SPitch, [(SPitch, DoubleOrnament)])]
childrenT [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
childrenNT [(SPitch, [(SPitch, RightOrnament)])]
childrenL [(SPitch, [(SPitch, LeftOrnament)])]
childrenR
  -- decide which edges to keep
  HashSet (Edge SPitch)
keepLeft <- forall e (m :: * -> *).
(SampleCtx m Bernoulli, RandomInterpreter m PVParams, Ord e,
 Hashable e) =>
(forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> HashSet e -> m (HashSet e)
sampleKeepEdges forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pKeepL HashSet (Edge SPitch)
leftEdges
  HashSet (Edge SPitch)
keepRight <- forall e (m :: * -> *).
(SampleCtx m Bernoulli, RandomInterpreter m PVParams, Ord e,
 Hashable e) =>
(forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> HashSet e -> m (HashSet e)
sampleKeepEdges forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pKeepR HashSet (Edge SPitch)
rightEdges
  -- combine all sampling results into split operation
  let splitOp :: Split SPitch
splitOp =
        SplitOp
          { Map (Edge SPitch) [(SPitch, DoubleOrnament)]
splitReg :: Map (Edge SPitch) [(SPitch, DoubleOrnament)]
splitReg :: Map (Edge SPitch) [(SPitch, DoubleOrnament)]
splitReg
          , Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
splitPass :: Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
splitPass :: Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
splitPass
          , Map SPitch [(SPitch, RightOrnament)]
fromLeft :: Map SPitch [(SPitch, RightOrnament)]
fromLeft :: Map SPitch [(SPitch, RightOrnament)]
fromLeft
          , Map SPitch [(SPitch, LeftOrnament)]
fromRight :: Map SPitch [(SPitch, LeftOrnament)]
fromRight :: Map SPitch [(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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Split SPitch
splitOp

observeSplit :: ContextSingle SPitch -> Split SPitch -> PVObs ()
observeSplit :: ContextSingle SPitch -> Split SPitch -> PVObs ()
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) [(SPitch, DoubleOrnament)]
splitTs Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
splitNTs Map SPitch [(SPitch, RightOrnament)]
fromLeft Map SPitch [(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
    [(Edge SPitch, [(SPitch, DoubleOrnament)])]
childrenT <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map (Edge SPitch) [(SPitch, DoubleOrnament)]
-> Edge SPitch -> PVObs (Edge SPitch, [(SPitch, DoubleOrnament)])
observeT Map (Edge SPitch) [(SPitch, DoubleOrnament)]
splitTs) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
S.toList HashSet (Edge SPitch)
ts
    -- DT.traceM $ "childrenT (obs): " <> show childrenT
    -- observe ornaments of passing edges
    [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
childrenNT <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
-> (InnerEdge SPitch, Int)
-> PVObs (InnerEdge SPitch, [(SPitch, PassingOrnament)])
observeNT Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
splitNTs) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet (InnerEdge SPitch)
nts
    -- DT.traceM $ "childrenNT (obs): " <> show childrenNT
    -- observe ornaments of left notes
    [(SPitch, [(SPitch, RightOrnament)])]
childrenL <- case forall a. StartStop a -> Maybe a
getInner StartStop (Notes SPitch)
sliceL of
      Maybe (Notes SPitch)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just (Notes MultiSet SPitch
notes) -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map SPitch [(SPitch, RightOrnament)]
-> SPitch -> PVObs (SPitch, [(SPitch, RightOrnament)])
observeL Map SPitch [(SPitch, RightOrnament)]
fromLeft) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. MultiSet a -> [a]
MS.toList MultiSet SPitch
notes
    -- DT.traceM $ "childrenL (obs): " <> show childrenL
    -- observe ornaments of right notes
    [(SPitch, [(SPitch, LeftOrnament)])]
childrenR <- case forall a. StartStop a -> Maybe a
getInner StartStop (Notes SPitch)
sliceR of
      Maybe (Notes SPitch)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just (Notes MultiSet SPitch
notes) ->
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map SPitch [(SPitch, LeftOrnament)]
-> SPitch -> PVObs (SPitch, [(SPitch, LeftOrnament)])
observeR Map SPitch [(SPitch, LeftOrnament)]
fromRight) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. MultiSet a -> [a]
MS.toList MultiSet SPitch
notes
    -- DT.traceM $ "childrenR (obs): " <> show childrenR
    -- observe new passing edges
    let notes :: [SPitch]
notes = forall o1 o2 o3.
[(Edge SPitch, [(SPitch, o1)])]
-> [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
-> [(SPitch, [(SPitch, o2)])]
-> [(SPitch, [(SPitch, o3)])]
-> [SPitch]
collectNotes [(Edge SPitch, [(SPitch, DoubleOrnament)])]
childrenT [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
childrenNT [(SPitch, [(SPitch, RightOrnament)])]
childrenL [(SPitch, [(SPitch, LeftOrnament)])]
childrenR
    case forall a. StartStop a -> Maybe a
getInner StartStop (Notes SPitch)
sliceL of
      Maybe (Notes SPitch)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just (Notes MultiSet SPitch
notesl) ->
        [SPitch]
-> [SPitch]
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> MultiSet (InnerEdge SPitch)
-> PVObs ()
observePassing
          (forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. MultiSet a -> [a]
MS.toList MultiSet SPitch
notesl)
          [SPitch]
notes
          forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNewPassingLeft
          MultiSet (InnerEdge SPitch)
passLeft
    case forall a. StartStop a -> Maybe a
getInner StartStop (Notes SPitch)
sliceR of
      Maybe (Notes SPitch)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just (Notes MultiSet SPitch
notesr) ->
        [SPitch]
-> [SPitch]
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> MultiSet (InnerEdge SPitch)
-> PVObs ()
observePassing
          [SPitch]
notes
          (forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. MultiSet a -> [a]
MS.toList MultiSet SPitch
notesr)
          forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNewPassingRight
          MultiSet (InnerEdge SPitch)
passRight
    -- observe which edges are kept
    let (Map (Edge SPitch) [(SPitch, DoubleOrnament)]
_, Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
_, Map SPitch [(SPitch, RightOrnament)]
_, Map SPitch [(SPitch, LeftOrnament)]
_, HashSet (Edge SPitch)
leftEdges, HashSet (Edge SPitch)
rightEdges) =
          forall o1 o2 o3.
[(Edge SPitch, [(SPitch, o1)])]
-> [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
-> [(SPitch, [(SPitch, o2)])]
-> [(SPitch, [(SPitch, o3)])]
-> (Map (Edge SPitch) [(SPitch, o1)],
    Map (InnerEdge SPitch) [(SPitch, PassingOrnament)],
    Map SPitch [(SPitch, o2)], Map SPitch [(SPitch, o3)],
    HashSet (Edge SPitch), HashSet (Edge SPitch))
collectElabos [(Edge SPitch, [(SPitch, DoubleOrnament)])]
childrenT [(InnerEdge SPitch, [(SPitch, PassingOrnament)])]
childrenNT [(SPitch, [(SPitch, RightOrnament)])]
childrenL [(SPitch, [(SPitch, LeftOrnament)])]
childrenR
    forall e.
(Eq e, Hashable e, Ord e) =>
(forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> HashSet e -> HashSet e -> PVObs ()
observeKeepEdges forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pKeepL HashSet (Edge SPitch)
leftEdges HashSet (Edge SPitch)
keepLeft
    forall e.
(Eq e, Hashable e, Ord e) =>
(forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> HashSet e -> HashSet e -> PVObs ()
observeKeepEdges forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pKeepR HashSet (Edge SPitch)
rightEdges HashSet (Edge SPitch)
keepRight

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

observeRootNote :: SPitch -> PVObs ()
observeRootNote :: SPitch -> PVObs ()
observeRootNote SPitch
child = do
  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
0.5 Bool
fifthsSign
  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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRootFifths) Int
fifthsN
  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 () (forall i. Spelled i => i -> Int
octaves SPitch
child forall a. Num a => a -> a -> a
- Int
4)
 where
  -- DT.traceM $ "root note (obs): " <> show child

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

sampleOctaveShift :: _ => String -> m SInterval
sampleOctaveShift :: String -> m SInterval
sampleOctaveShift String
name = do
  Int
n <- 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
os = forall i. Interval i => i
octave forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* (Int
n forall a. Num a => a -> a -> a
- Int
4)
  -- DT.traceM $ "octave shift (smp) " <> show os
  forall (f :: * -> *) a. Applicative f => a -> f a
pure SInterval
os

observeOctaveShift :: _ => String -> SInterval -> PVObs ()
observeOctaveShift :: String -> SInterval -> PVObs ()
observeOctaveShift String
name SInterval
interval = do
  let n :: Int
n = forall i. Spelled i => i -> Int
octaves (SInterval
interval forall v. AdditiveGroup v => v -> v -> v
^+^ forall i. Interval i => ImperfectInterval i -> i
major ImperfectInterval SInterval
second)
  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 () forall a b. (a -> b) -> a -> b
$ Int
n 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
  Bool
chromatic <- 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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNBChromatic
  SInterval
os <- forall (m :: * -> *) {r :: (* -> *) -> *}.
(SampleCtx m MagicalOctaves, RandomInterpreter m r) =>
String -> m SInterval
sampleOctaveShift String
"nbOctShift"
  Int
alt <- forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"nbAlt" Geometric0
Geometric0 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNBAlt
  let altInterval :: IOf SIC
altInterval = forall i. IntervalClass i => i -> IOf i
emb (Int
alt forall v. VectorSpace v => Scalar v -> v -> v
*^ forall i. Chromatic i => i
chromaticSemitone @SIC)
  if Bool
chromatic
    then do
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SPitch
ref forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ SInterval
os forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ if Bool
stepUp then IOf SIC
altInterval else forall i. Interval i => i -> i
down IOf SIC
altInterval
    else do
      Bool
altUp <- forall (m :: * -> *) (r :: (* -> *) -> *) d.
(RandomInterpreter m r, Distribution d, SampleCtx m d) =>
String -> d -> Params d -> m (Support d)
sampleConst String
"nbAltUp" Bernoulli
Bernoulli Double
0.5
      let step :: SInterval
step =
            if Bool
altUp forall a. Eq a => a -> a -> Bool
== Bool
stepUp
              then forall i. Interval i => ImperfectInterval i -> i
major ImperfectInterval SInterval
second forall v. AdditiveGroup v => v -> v -> v
^+^ IOf SIC
altInterval
              else forall i. Chromatic i => ImperfectInterval i -> i
minor ImperfectInterval SInterval
second forall v. AdditiveGroup v => v -> v -> v
^-^ IOf SIC
altInterval
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SPitch
ref forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ SInterval
os forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ if Bool
stepUp then SInterval
step else forall i. Interval i => i -> i
down SInterval
step

observeNeighbor :: Bool -> SPitch -> SPitch -> PVObs ()
observeNeighbor :: Bool -> SPitch -> SPitch -> PVObs ()
observeNeighbor Bool
goesUp SPitch
ref SPitch
nb = do
  let interval :: ICOf SInterval
interval = forall i. Interval i => i -> ICOf i
ic forall a b. (a -> b) -> a -> b
$ SPitch
ref forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
nb
      isChromatic :: Bool
isChromatic = forall i. Spelled i => i -> Int
diasteps ICOf SInterval
interval forall a. Eq a => a -> a -> Bool
== Int
0
  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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNBChromatic) Bool
isChromatic
  String -> SInterval -> PVObs ()
observeOctaveShift String
"nbOctShift" (SPitch
ref forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
nb)
  if Bool
isChromatic
    then do
      let alt :: Int
alt = forall a. Num a => a -> a
abs (forall i. Spelled i => i -> Int
alteration ICOf SInterval
interval)
      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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNBAlt) Int
alt
    else do
      let alt :: Int
alt = forall i. Spelled i => i -> Int
alteration (forall i. Interval i => i -> i
iabs ICOf SInterval
interval)
          altUp :: Bool
altUp = (Int
alt forall a. Ord a => a -> a -> Bool
>= Int
0) forall a. Eq a => a -> a -> Bool
== Bool
goesUp
          altN :: Int
altN = if Int
alt forall a. Ord a => a -> a -> Bool
>= Int
0 then Int
alt else (-Int
alt) forall a. Num a => a -> a -> a
- Int
1
      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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNBAlt) Int
altN
      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
0.5 Bool
altUp

sampleDoubleChild :: _ => SPitch -> SPitch -> m (SPitch, DoubleOrnament)
sampleDoubleChild :: SPitch -> SPitch -> m (SPitch, DoubleOrnament)
sampleDoubleChild SPitch
pl SPitch
pr
  | forall i. Spelled i => i -> Int
degree SPitch
pl forall a. Eq a => a -> a -> Bool
== forall i. Spelled i => i -> Int
degree SPitch
pr = do
      Bool
rep <-
        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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatOverNeighbor
      if Bool
rep
        then do
          SInterval
os <- forall (m :: * -> *) {r :: (* -> *) -> *}.
(SampleCtx m MagicalOctaves, RandomInterpreter m r) =>
String -> m SInterval
sampleOctaveShift String
"doubleChildOctave"
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPitch
pl forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ SInterval
os, DoubleOrnament
FullRepeat)
        else do
          Bool
stepUp <- forall (m :: * -> *) (r :: (* -> *) -> *) d.
(RandomInterpreter m r, Distribution d, SampleCtx m d) =>
String -> d -> Params d -> m (Support d)
sampleConst String
"stepUp" Bernoulli
Bernoulli Double
0.5
          (,DoubleOrnament
FullNeighbor) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
Bool -> SPitch -> m SPitch
sampleNeighbor Bool
stepUp SPitch
pl
  | Bool
otherwise = do
      Bool
repeatLeft <-
        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 forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatLeftOverRight
      Bool
repeatAlter <- forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"repeatAlter" Bernoulli
Bernoulli forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatAlter
      SInterval
alt <-
        if Bool
repeatAlter
          then do
            Bool
alterUp <-
              forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"repeatAlterUp" Bernoulli
Bernoulli forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatAlterUp
            Int
semis <-
              forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"repeatAlterSemis" Geometric1
Geometric1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatAlterSemis
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (if Bool
alterUp then forall a. a -> a
id else forall i. Interval i => i -> i
down) forall a b. (a -> b) -> a -> b
$ forall i. Chromatic i => i
chromaticSemitone forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Int
semis
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall i. Interval i => i
unison
      SInterval
os <- forall (m :: * -> *) {r :: (* -> *) -> *}.
(SampleCtx m MagicalOctaves, RandomInterpreter m r) =>
String -> m SInterval
sampleOctaveShift String
"doubleChildOctave"
      if Bool
repeatLeft
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPitch
pl forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ SInterval
os forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ SInterval
alt, DoubleOrnament
RightRepeatOfLeft)
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPitch
pr forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ SInterval
os forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ SInterval
alt, DoubleOrnament
LeftRepeatOfRight)

observeDoubleChild :: SPitch -> SPitch -> SPitch -> PVObs ()
observeDoubleChild :: SPitch -> SPitch -> SPitch -> PVObs ()
observeDoubleChild SPitch
pl SPitch
pr SPitch
child
  | forall i. Spelled i => i -> Int
degree SPitch
pl forall a. Eq a => a -> a -> Bool
== forall i. Spelled i => i -> Int
degree SPitch
pr = do
      let isRep :: Bool
isRep = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child forall a. Eq a => a -> a -> Bool
== forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl
      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
        (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatOverNeighbor)
        Bool
isRep
      if Bool
isRep
        then do
          String -> SInterval -> PVObs ()
observeOctaveShift String
"doubleChildOctave" (SPitch
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
child)
        else do
          let dir :: Ordering
dir = forall i. Interval i => i -> Ordering
direction (forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child)
          let goesUp :: Bool
goesUp = Ordering
dir forall a. Eq a => a -> a -> Bool
== Ordering
GT
          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
0.5 Bool
goesUp
          Bool -> SPitch -> SPitch -> PVObs ()
observeNeighbor Bool
goesUp SPitch
pl SPitch
child
  | Bool
otherwise = do
      let repeatLeft :: Bool
repeatLeft = forall i. Spelled i => i -> Int
degree SPitch
pl forall a. Eq a => a -> a -> Bool
== forall i. Spelled i => i -> Int
degree SPitch
child
          ref :: SPitch
ref = if Bool
repeatLeft then SPitch
pl else SPitch
pr
          alt :: Int
alt = forall i. Spelled i => i -> Int
alteration SPitch
child forall a. Num a => a -> a -> a
- forall i. Spelled i => i -> Int
alteration SPitch
ref
      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
        (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatLeftOverRight)
        Bool
repeatLeft
      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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatAlter) (Int
alt forall a. Eq a => a -> a -> Bool
/= Int
0)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
alt forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$ do
        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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatAlterUp) (Int
alt forall a. Ord a => a -> a -> Bool
> Int
0)
        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
          (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatAlterSemis)
          (forall a. Num a => a -> a
abs Int
alt)
      String -> SInterval -> PVObs ()
observeOctaveShift String
"doubleChildOctave" forall a b. (a -> b) -> a -> b
$ SPitch
ref forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
child

sampleT :: _ => Edge SPitch -> m (Edge SPitch, [(SPitch, DoubleOrnament)])
sampleT :: Edge SPitch -> m (Edge SPitch, [(SPitch, DoubleOrnament)])
sampleT (StartStop SPitch
l, StartStop SPitch
r) = do
  -- DT.traceM $ "elaborating T (smp): " <> show (l, r)
  Int
n <- 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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pElaborateRegular
  [Maybe (SPitch, DoubleOrnament)]
children <- forall (m :: * -> *) (r :: (* -> *) -> *) a.
(RandomInterpreter m r, Ord a) =>
Int -> m a -> m [a]
permutationPlate Int
n forall a b. (a -> b) -> a -> b
$ case (StartStop SPitch
l, StartStop SPitch
r) of
    (StartStop SPitch
Start, StartStop SPitch
Stop) -> do
      SPitch
child <- forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m Geometric0,
 SampleCtx m MagicalOctaves, RandomInterpreter m PVParams) =>
m SPitch
sampleRootNote
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (SPitch
child, DoubleOrnament
RootNote)
    (Inner SPitch
pl, Inner SPitch
pr) -> do
      (SPitch
child, DoubleOrnament
orn) <- forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, SampleCtx m Geometric1,
 RandomInterpreter m PVParams) =>
SPitch -> SPitch -> m (SPitch, DoubleOrnament)
sampleDoubleChild SPitch
pl SPitch
pr
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (SPitch
child, DoubleOrnament
orn)
    Edge SPitch
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ((StartStop SPitch
l, StartStop SPitch
r), forall a. [Maybe a] -> [a]
catMaybes [Maybe (SPitch, DoubleOrnament)]
children)

observeT
  :: M.Map (Edge SPitch) [(SPitch, DoubleOrnament)]
  -> Edge SPitch
  -> PVObs (Edge SPitch, [(SPitch, DoubleOrnament)])
observeT :: Map (Edge SPitch) [(SPitch, DoubleOrnament)]
-> Edge SPitch -> PVObs (Edge SPitch, [(SPitch, DoubleOrnament)])
observeT Map (Edge SPitch) [(SPitch, DoubleOrnament)]
splitTs Edge SPitch
parents = do
  -- DT.traceM $ "elaborating T (obs): " <> show parents
  let children :: [(SPitch, DoubleOrnament)]
children = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Edge SPitch
parents Map (Edge SPitch) [(SPitch, DoubleOrnament)]
splitTs
  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
    (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pElaborateRegular)
    (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(SPitch, DoubleOrnament)]
children)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(SPitch, DoubleOrnament)]
children forall a b. (a -> b) -> a -> b
$ \(SPitch
child, DoubleOrnament
_) -> case Edge SPitch
parents of
    (StartStop SPitch
Start, StartStop SPitch
Stop) -> do
      SPitch -> PVObs ()
observeRootNote SPitch
child
    (Inner SPitch
pl, Inner SPitch
pr) -> do
      SPitch -> SPitch -> SPitch -> PVObs ()
observeDoubleChild SPitch
pl SPitch
pr SPitch
child
    Edge SPitch
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Invalid parent edge " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Edge SPitch
parents forall a. Semigroup a => a -> a -> a
<> String
"."
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Edge SPitch
parents, [(SPitch, DoubleOrnament)]
children)

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

observeChromPassing :: SPitch -> SPitch -> SPitch -> PVObs ()
observeChromPassing :: SPitch -> SPitch -> SPitch -> PVObs ()
observeChromPassing SPitch
pl SPitch
pr SPitch
child = do
  let isLeft :: Bool
isLeft = forall i. Spelled i => i -> Int
degree SPitch
pl forall a. Eq a => a -> a -> Bool
== forall i. Spelled i => i -> Int
degree SPitch
child
  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
    (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pConnectChromaticLeftOverRight)
    Bool
isLeft
  String -> SInterval -> PVObs ()
observeOctaveShift
    String
"connectChromaticOctave"
    ((if Bool
isLeft then SPitch
pl else SPitch
pr) 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
  SPitch
child <- forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
Bool -> SPitch -> m SPitch
sampleNeighbor (forall i. Interval i => i -> Ordering
direction (forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr) forall a. Eq a => a -> a -> Bool
== Ordering
GT) SPitch
pl
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPitch
child, PassingOrnament
PassingMid)

observeMidPassing :: SPitch -> SPitch -> SPitch -> PVObs ()
observeMidPassing :: SPitch -> SPitch -> SPitch -> PVObs ()
observeMidPassing SPitch
pl SPitch
pr =
  Bool -> SPitch -> SPitch -> PVObs ()
observeNeighbor (forall i. Interval i => i -> Ordering
direction (forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr) 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
  Bool
left <-
    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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pPassLeftOverRight
  -- TODO: sampling like this overgenerates, since it allows passing motions to change direction
  -- the direction of a passing edge should be tracked explicitly!
  Bool
dirUp <- forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"passUp" Bernoulli
Bernoulli forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pPassUp
  -- let dirUp = direction (pc pl `pto` pc pr) == GT
  if Bool
left
    then do
      SPitch
child <- forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
Bool -> SPitch -> m SPitch
sampleNeighbor Bool
dirUp SPitch
pl
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPitch
child, PassingOrnament
PassingLeft)
    else do
      SPitch
child <- forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
Bool -> SPitch -> m SPitch
sampleNeighbor (Bool -> Bool
not Bool
dirUp) SPitch
pr
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPitch
child, PassingOrnament
PassingRight)

observeNonMidPassing :: SPitch -> SPitch -> SPitch -> PassingOrnament -> PVObs ()
observeNonMidPassing :: SPitch -> SPitch -> SPitch -> PassingOrnament -> PVObs ()
observeNonMidPassing SPitch
pl SPitch
pr SPitch
child PassingOrnament
orn = do
  let left :: Bool
left = PassingOrnament
orn forall a. Eq a => a -> a -> Bool
== PassingOrnament
PassingLeft
      dirUp :: Bool
dirUp =
        if Bool
left
          then forall i. Interval i => i -> Ordering
direction (forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child) forall a. Eq a => a -> a -> Bool
== Ordering
GT
          else forall i. Interval i => i -> Ordering
direction (forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child) forall a. Eq a => a -> a -> Bool
== Ordering
LT
  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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pPassLeftOverRight) Bool
left
  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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pPassUp) Bool
dirUp
  if Bool
left
    then Bool -> SPitch -> SPitch -> PVObs ()
observeNeighbor Bool
dirUp SPitch
pl SPitch
child
    else Bool -> SPitch -> SPitch -> PVObs ()
observeNeighbor (Bool -> Bool
not Bool
dirUp) SPitch
pr SPitch
child

sampleNT
  :: _ => (InnerEdge SPitch, Int) -> m (InnerEdge SPitch, [(SPitch, PassingOrnament)])
sampleNT :: (InnerEdge SPitch, Int)
-> m (InnerEdge SPitch, [(SPitch, PassingOrnament)])
sampleNT ((SPitch
pl, SPitch
pr), Int
n) = do
  -- DT.traceM $ "Elaborating edge (smp): " <> show ((pl, pr), n)
  let dist :: Int
dist = forall i. Spelled i => i -> Int
degree forall a b. (a -> b) -> a -> b
$ forall i. Interval i => i -> i
iabs forall a b. (a -> b) -> a -> b
$ forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr
  -- DT.traceM    $  "passing from "    <> showNotation pl    <> " to "    <> showNotation pr    <> ": "    <> show dist    <> " steps."
  [(SPitch, PassingOrnament)]
children <- forall (m :: * -> *) (r :: (* -> *) -> *) a.
(RandomInterpreter m r, Ord a) =>
Int -> m a -> m [a]
permutationPlate Int
n forall a b. (a -> b) -> a -> b
$ case Int
dist of
    Int
1 -> forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 RandomInterpreter m PVParams) =>
SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleChromPassing SPitch
pl SPitch
pr
    Int
2 -> do
      Bool
connect <- 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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pConnect
      if Bool
connect then forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleMidPassing SPitch
pl SPitch
pr else forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleNonMidPassing SPitch
pl SPitch
pr
    Int
_ -> forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
SPitch -> SPitch -> m (SPitch, PassingOrnament)
sampleNonMidPassing SPitch
pl SPitch
pr
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SPitch
pl, SPitch
pr), [(SPitch, PassingOrnament)]
children)

observeNT
  :: _
  => M.Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
  -> (InnerEdge SPitch, Int)
  -> PVObs (InnerEdge SPitch, [(SPitch, PassingOrnament)])
observeNT :: Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
-> (InnerEdge SPitch, Int)
-> PVObs (InnerEdge SPitch, [(SPitch, PassingOrnament)])
observeNT Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
splitNTs ((SPitch
pl, SPitch
pr), Int
_n) = do
  -- DT.traceM $ "Elaborating edge (obs): " <> show ((pl, pr), n)
  let children :: [(SPitch, PassingOrnament)]
children = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (SPitch
pl, SPitch
pr) Map (InnerEdge SPitch) [(SPitch, PassingOrnament)]
splitNTs
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(SPitch, PassingOrnament)]
children forall a b. (a -> b) -> a -> b
$ \(SPitch
child, PassingOrnament
orn) -> case forall i. Spelled i => i -> Int
degree forall a b. (a -> b) -> a -> b
$ forall i. Interval i => i -> i
iabs forall a b. (a -> b) -> a -> b
$ forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pl forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
pr of
    Int
1 -> SPitch -> SPitch -> SPitch -> PVObs ()
observeChromPassing SPitch
pl SPitch
pr SPitch
child
    Int
2 -> case PassingOrnament
orn of
      PassingOrnament
PassingMid -> do
        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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pConnect) Bool
True
        SPitch -> SPitch -> SPitch -> PVObs ()
observeMidPassing SPitch
pl SPitch
pr SPitch
child
      PassingOrnament
_ -> do
        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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pConnect) Bool
False
        SPitch -> SPitch -> SPitch -> PassingOrnament -> PVObs ()
observeNonMidPassing SPitch
pl SPitch
pr SPitch
child PassingOrnament
orn
    Int
_ -> SPitch -> SPitch -> SPitch -> PassingOrnament -> PVObs ()
observeNonMidPassing SPitch
pl SPitch
pr SPitch
child PassingOrnament
orn
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SPitch
pl, SPitch
pr), [(SPitch, PassingOrnament)]
children)

sampleSingleOrn
  :: _
  => SPitch
  -> o
  -> o
  -> Accessor PVParamsInner Beta
  -> m (SPitch, [(SPitch, o)])
sampleSingleOrn :: SPitch
-> o
-> o
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> m (SPitch, [(SPitch, o)])
sampleSingleOrn SPitch
parent o
oRepeat o
oNeighbor forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pElaborate = do
  Int
n <- 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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pElaborate
  [(SPitch, o)]
children <- forall (m :: * -> *) (r :: (* -> *) -> *) a.
(RandomInterpreter m r, Ord a) =>
Int -> m a -> m [a]
permutationPlate Int
n forall a b. (a -> b) -> a -> b
$ do
    Bool
rep <-
      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 forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatOverNeighbor
    if Bool
rep
      then do
        SInterval
os <- forall (m :: * -> *) {r :: (* -> *) -> *}.
(SampleCtx m MagicalOctaves, RandomInterpreter m r) =>
String -> m SInterval
sampleOctaveShift String
"singleChildOctave"
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPitch
parent forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ SInterval
os, o
oRepeat)
      else do
        Bool
stepUp <- forall (m :: * -> *) (r :: (* -> *) -> *) d.
(RandomInterpreter m r, Distribution d, SampleCtx m d) =>
String -> d -> Params d -> m (Support d)
sampleConst String
"singleUp" Bernoulli
Bernoulli Double
0.5
        SPitch
child <- forall (m :: * -> *).
(SampleCtx m Bernoulli, SampleCtx m MagicalOctaves,
 SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
Bool -> SPitch -> m SPitch
sampleNeighbor Bool
stepUp SPitch
parent
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPitch
child, o
oNeighbor)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPitch
parent, [(SPitch, o)]
children)

observeSingleOrn
  :: M.Map SPitch [(SPitch, o)]
  -> SPitch
  -> Accessor PVParamsInner Beta
  -> PVObs (SPitch, [(SPitch, o)])
observeSingleOrn :: forall o.
Map SPitch [(SPitch, o)]
-> SPitch
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> PVObs (SPitch, [(SPitch, o)])
observeSingleOrn Map SPitch [(SPitch, o)]
table SPitch
parent forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pElaborate = do
  let children :: [(SPitch, o)]
children = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SPitch
parent Map SPitch [(SPitch, o)]
table
  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
    (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pElaborate)
    (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(SPitch, o)]
children)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(SPitch, o)]
children forall a b. (a -> b) -> a -> b
$ \(SPitch
child, o
_) -> do
    let rep :: Bool
rep = forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child forall a. Eq a => a -> a -> Bool
== forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
parent
    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
      (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pRepeatOverNeighbor)
      Bool
rep
    if Bool
rep
      then do
        String -> SInterval -> PVObs ()
observeOctaveShift String
"singleChildOctave" (SPitch
parent forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` SPitch
child)
      else do
        let dir :: Ordering
dir = forall i. Interval i => i -> Ordering
direction (forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
parent forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
child)
            up :: Bool
up = Ordering
dir forall a. Eq a => a -> a -> Bool
== Ordering
GT
        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
0.5 Bool
up
        Bool -> SPitch -> SPitch -> PVObs ()
observeNeighbor Bool
up SPitch
parent SPitch
child
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPitch
parent, [(SPitch, o)]
children)

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

observeL
  :: M.Map SPitch [(SPitch, RightOrnament)]
  -> SPitch
  -> PVObs (SPitch, [(SPitch, RightOrnament)])
observeL :: Map SPitch [(SPitch, RightOrnament)]
-> SPitch -> PVObs (SPitch, [(SPitch, RightOrnament)])
observeL Map SPitch [(SPitch, RightOrnament)]
ls SPitch
parent = forall o.
Map SPitch [(SPitch, o)]
-> SPitch
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> PVObs (SPitch, [(SPitch, o)])
observeSingleOrn Map SPitch [(SPitch, RightOrnament)]
ls SPitch
parent forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pElaborateL

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

observeR
  :: M.Map SPitch [(SPitch, LeftOrnament)]
  -> SPitch
  -> PVObs (SPitch, [(SPitch, LeftOrnament)])
observeR :: Map SPitch [(SPitch, LeftOrnament)]
-> SPitch -> PVObs (SPitch, [(SPitch, LeftOrnament)])
observeR Map SPitch [(SPitch, LeftOrnament)]
rs SPitch
parent = forall o.
Map SPitch [(SPitch, o)]
-> SPitch
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> PVObs (SPitch, [(SPitch, o)])
observeSingleOrn Map SPitch [(SPitch, LeftOrnament)]
rs SPitch
parent forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pElaborateR

sampleKeepEdges
  :: _ => Accessor PVParamsInner Beta -> S.HashSet e -> m (S.HashSet e)
sampleKeepEdges :: (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> HashSet e -> m (HashSet e)
sampleKeepEdges forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pKeep HashSet e
set = do
  [Maybe e]
kept <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM e -> m (Maybe e)
sKeep (forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
S.toList HashSet e
set)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe e]
kept
 where
  sKeep :: e -> m (Maybe e)
sKeep e
elt = do
    Bool
keep <- 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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pKeep)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
keep then forall a. a -> Maybe a
Just e
elt else forall a. Maybe a
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 :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> HashSet e -> HashSet e -> PVObs ()
observeKeepEdges forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pKeep HashSet e
candidates HashSet e
kept =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    e -> PVObs ()
oKeep
    (forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
S.toList HashSet e
candidates)
 where
  oKeep :: e -> PVObs ()
oKeep e
edge =
    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 (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pKeep) (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 MultiSet SPitch
sliceM, Edges SPitch
_transR, StartStop (Notes SPitch)
_sliceR) = do
  -- distribute notes
  [((SPitch, Int), SpreadDirection)]
dists <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {a}.
(SampleCtx m (Categorical 3), SampleCtx m Binomial,
 RandomInterpreter m PVParams) =>
(a, Int) -> m ((a, Int), SpreadDirection)
distNote forall a b. (a -> b) -> a -> b
$ forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet SPitch
sliceM
  let notesLeft :: [SPitch]
notesLeft = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((SPitch, Int), SpreadDirection)]
dists forall a b. (a -> b) -> a -> b
$ \((SPitch
note, Int
n), SpreadDirection
to) -> case SpreadDirection
to of
        ToRight Int
dl -> if Int
n forall a. Num a => a -> a -> a
- Int
dl forall a. Ord a => a -> a -> Bool
> Int
0 then forall a. a -> Maybe a
Just SPitch
note else forall a. Maybe a
Nothing
        SpreadDirection
_ -> forall a. a -> Maybe a
Just SPitch
note
      notesRight :: [SPitch]
notesRight = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((SPitch, Int), SpreadDirection)]
dists forall a b. (a -> b) -> a -> b
$ \((SPitch
note, Int
n), SpreadDirection
to) -> case SpreadDirection
to of
        ToLeft Int
dr -> if Int
n forall a. Num a => a -> a -> a
- Int
dr forall a. Ord a => a -> a -> Bool
> Int
0 then forall a. a -> Maybe a
Just SPitch
note else forall a. Maybe a
Nothing
        SpreadDirection
_ -> forall a. a -> Maybe a
Just SPitch
note
  -- generate repetition edges
  [Maybe (Edge SPitch)]
repeats <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ do
    -- List
    SPitch
l <- [SPitch]
notesLeft
    SPitch
r <- [SPitch]
notesRight
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
l forall a. Eq a => a -> a -> Bool
== forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
r
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
      -- m
      Bool
rep <-
        forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"spreadRepeatEdge" Bernoulli
Bernoulli forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pSpreadRepetitionEdge
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
rep then forall a. a -> Maybe a
Just (forall a. a -> StartStop a
Inner SPitch
l, forall a. a -> StartStop a
Inner SPitch
r) else forall a. Maybe a
Nothing
  let repEdges :: HashSet (Edge SPitch)
repEdges = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe (Edge SPitch)]
repeats
  -- generate passing edges
  MultiSet (InnerEdge SPitch)
passEdges <- forall (m :: * -> *).
(SampleCtx m Geometric0, RandomInterpreter m PVParams) =>
[SPitch]
-> [SPitch]
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> m (MultiSet (InnerEdge SPitch))
samplePassing [SPitch]
notesLeft [SPitch]
notesRight forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNewPassingMid
  -- construct result
  let distMap :: HashMap SPitch SpreadDirection
distMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bi.first forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((SPitch, Int), SpreadDirection)]
dists)
      edges :: Edges SPitch
edges = forall n. HashSet (Edge n) -> MultiSet (InnerEdge n) -> Edges n
Edges HashSet (Edge SPitch)
repEdges MultiSet (InnerEdge SPitch)
passEdges
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall n. HashMap n SpreadDirection -> Edges n -> Spread n
SpreadOp HashMap SPitch SpreadDirection
distMap Edges SPitch
edges
 where
  -- distribute a note to the two child slices
  distNote :: (a, Int) -> m ((a, Int), SpreadDirection)
distNote (a
note, Int
n) = do
    Int
dir <-
      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) forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f (Dirichlet 3))
pNoteSpreadDirection
    SpreadDirection
to <- case Int
dir of
      Int
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SpreadDirection
ToBoth
      Int
1 -> do
        Int
nother <-
          forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"notesOnOtherSide" (Int -> Binomial
Binomial forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNotesOnOtherSide
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> SpreadDirection
ToLeft forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
- Int
nother
      Int
_ -> do
        Int
nother <-
          forall (m :: * -> *) (r :: (* -> *) -> *) p l.
(RandomInterpreter m r, Conjugate p l, SampleCtx m l) =>
String -> l -> Accessor r p -> m (Support l)
sampleValue String
"notesOnOtherSide" (Int -> Binomial
Binomial forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNotesOnOtherSide
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> SpreadDirection
ToRight forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
- Int
nother
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a
note, Int
n), SpreadDirection
to)

observeSpread :: ContextDouble SPitch -> Spread SPitch -> PVObs ()
observeSpread :: ContextDouble SPitch -> Spread SPitch -> PVObs ()
observeSpread (StartStop (Notes SPitch)
_sliceL, Edges SPitch
_transL, Notes MultiSet SPitch
sliceM, Edges SPitch
_transR, StartStop (Notes SPitch)
_sliceR) (SpreadOp HashMap SPitch SpreadDirection
obsDists (Edges HashSet (Edge SPitch)
repEdges MultiSet (InnerEdge SPitch)
passEdges)) =
  do
    -- observe note distribution
    [((SPitch, Int), SpreadDirection)]
dists <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a}.
(Hashable a, Notation a) =>
HashMap a SpreadDirection
-> (a, Int)
-> StateT
     (Trace PVParams) (Either String) ((a, Int), SpreadDirection)
observeNoteDist HashMap SPitch SpreadDirection
obsDists) forall a b. (a -> b) -> a -> b
$ forall k. MultiSet k -> [(k, Int)]
MS.toOccurList MultiSet SPitch
sliceM
    let notesLeft :: [SPitch]
notesLeft = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((SPitch, Int), SpreadDirection)]
dists forall a b. (a -> b) -> a -> b
$ \((SPitch
note, Int
n), SpreadDirection
to) ->
          case SpreadDirection
to of
            ToRight Int
dl -> if Int
n forall a. Num a => a -> a -> a
- Int
dl forall a. Ord a => a -> a -> Bool
> Int
0 then forall a. a -> Maybe a
Just SPitch
note else forall a. Maybe a
Nothing
            SpreadDirection
_ -> forall a. a -> Maybe a
Just SPitch
note
        notesRight :: [SPitch]
notesRight = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((SPitch, Int), SpreadDirection)]
dists forall a b. (a -> b) -> a -> b
$ \((SPitch
note, Int
n), SpreadDirection
to) ->
          case SpreadDirection
to of
            ToLeft Int
dr -> if Int
n forall a. Num a => a -> a -> a
- Int
dr forall a. Ord a => a -> a -> Bool
> Int
0 then forall a. a -> Maybe a
Just SPitch
note else forall a. Maybe a
Nothing
            SpreadDirection
_ -> forall a. a -> Maybe a
Just SPitch
note
    -- observe repetition edges
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ do
      -- List
      SPitch
l <- [SPitch]
notesLeft
      SPitch
r <- [SPitch]
notesRight
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
l forall a. Eq a => a -> a -> Bool
== forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
r
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        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
"spreadRepeatEdge"
          Bernoulli
Bernoulli
          (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pSpreadRepetitionEdge)
          (forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member (forall a. a -> StartStop a
Inner SPitch
l, forall a. a -> StartStop a
Inner SPitch
r) HashSet (Edge SPitch)
repEdges)
    -- observe passing edges
    [SPitch]
-> [SPitch]
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> MultiSet (InnerEdge SPitch)
-> PVObs ()
observePassing [SPitch]
notesLeft [SPitch]
notesRight forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNewPassingMid MultiSet (InnerEdge SPitch)
passEdges
 where
  observeNoteDist :: HashMap a SpreadDirection
-> (a, Int)
-> StateT
     (Trace PVParams) (Either String) ((a, Int), SpreadDirection)
observeNoteDist HashMap a SpreadDirection
distMap (a
parent, Int
n) = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup a
parent HashMap a SpreadDirection
distMap of
    Maybe SpreadDirection
Nothing ->
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Note " forall a. Semigroup a => a -> a -> a
<> forall i. Notation i => i -> String
showNotation a
parent forall a. Semigroup a => a -> a -> a
<> String
" is not distributed."
    Just SpreadDirection
dir -> do
      case SpreadDirection
dir of
        SpreadDirection
ToBoth -> do
          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)
            (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f (Dirichlet 3))
pNoteSpreadDirection)
            Int
0
        ToLeft Int
ndiff -> do
          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)
            (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f (Dirichlet 3))
pNoteSpreadDirection)
            Int
1
          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
"notesOnOtherSide"
            (Int -> Binomial
Binomial forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
- Int
1)
            (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNotesOnOtherSide)
            (Int
n forall a. Num a => a -> a -> a
- Int
ndiff)
        ToRight Int
ndiff -> do
          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)
            (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f (Dirichlet 3))
pNoteSpreadDirection)
            Int
2
          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
"notesOnOtherSide"
            (Int -> Binomial
Binomial forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
- Int
1)
            (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNotesOnOtherSide)
            (Int
n forall a. Num a => a -> a -> a
- Int
ndiff)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a
parent, Int
n), SpreadDirection
dir)

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

observePassing
  :: [SPitch]
  -> [SPitch]
  -> Accessor PVParamsInner Beta
  -> MS.MultiSet (InnerEdge SPitch)
  -> PVObs ()
observePassing :: [SPitch]
-> [SPitch]
-> (forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta))
-> MultiSet (InnerEdge SPitch)
-> PVObs ()
observePassing [SPitch]
notesLeft [SPitch]
notesRight forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNewPassing MultiSet (InnerEdge SPitch)
edges = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ 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
  SPitch
l <- [SPitch]
notesLeft
  SPitch
r <- [SPitch]
notesRight
  let step :: SIC
step = forall i. Interval i => i -> i
iabs (forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
l forall {v}. AdditiveGroup v => Pitch v -> Pitch v -> v
`pto` forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc SPitch
r)
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall i. Spelled i => i -> Int
degree SIC
step forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
|| (forall i. Spelled i => i -> Int
degree SIC
step forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& forall i. Spelled i => i -> Int
alteration SIC
step forall a. Ord a => a -> a -> Bool
>= Int
0)
  -- DT.traceM $ "parent edge (obs)" <> show (l, r)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    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
"newPassing"
      Geometric0
Geometric0
      (forall (f :: * -> *). Lens' (PVParams f) (PVParamsInner f)
pInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Lens' (PVParamsInner f) (f Beta)
pNewPassing)
      (MultiSet (InnerEdge SPitch)
edges forall k. (Eq k, Hashable k) => MultiSet k -> k -> Int
MS.! (SPitch
l, SPitch
r))