-- |
-- Module      : Harmonic.Evaluation.Analysis.KeyArea
-- Description : Whole-progression key-area detection and chordscale layers
--
-- Chord-scale analysis over a finished progression: a cyclic Viterbi walk
-- over a 24-key lattice (12 major + 12 /composite/ minor areas) assigns
-- every bar a key area and a scale form, from which the M (mode, 7-PC) and
-- S (anhemitonic pentatonic, 5-PC) layers of gen \/ genJ contexts are
-- derived ('chordscale').
--
-- A minor key is COMPOSITE: one tonic with three interchangeable forms —
-- natural (the relative-major set), harmonic minor, melodic minor — chosen
-- per bar by chord fit. A minor ii-V-i therefore reads as ONE key area:
-- the iiO7 and V7b9 bars take the harmonic form (Locrian ♮6 \/ Phrygian
-- dominant), the tonic bars the melodic\/natural forms. Melodic minor is
-- never an independent key whose ii-V-i sits on its own scale degrees.
--
-- BOUNDARY: analysis is a PURE, DERIVED annotation computed over a finished
-- progression. The generation system deliberately operates without key
-- awareness — each state is abstract and deterministic, upholding the
-- Markov property — so nothing here may feed back into generation, become
-- part of a generation state, or appear in a generation-path signature.
-- Producers attach the RESULTS to the finished context ('chordscale');
-- the walking bass reads the same detector ('barPalettes'). Under identity
-- chord selection the walk and the layers therefore agree; under a
-- reordering selection the walk re-analyses the PERFORMED bar sequence —
-- deliberately — and its lines also add chromatic approach tones beyond
-- any stored set.
--
-- All numeric constants are probe-calibrated — see
-- @archive\/analysis\/keyarea.md@ \/ @penta.md@ (2026-08-29): the lambda \/
-- bonus sweep on live gen\/genJ output plus hand-encoded cyclic standards
-- froze @kaLambda = 6@, @kaDomBonus = 3@, @kaTonicBonus = 1.5@ (97-98%
-- chord-in-key coverage at ~3.8-bar mean segments) and @kaPentaLambda = 4@
-- (~3.3 pentatonic switches per progression, 80% guide-tone coverage, zero
-- avoid-note hits).
module Harmonic.Evaluation.Analysis.KeyArea
  ( -- * Types
    KeyQuality(..)
  , KeyArea(..)
  , KeyForm(..)
  , ModeTier(..)
  , BarAnalysis(..)
  , showKeyArea

    -- * Analysis
  , analyzeProgression
  , barPalettes

    -- * Layer derivation
  , chordscale

    -- * Calibrated constants
  , kaLambda
  , kaDomBonus
  , kaTonicBonus
  , kaPentaLambda
  ) where

import           Data.Foldable (toList)
import           Data.List (maximumBy, nub, sort)
import qualified Data.Map.Strict as Map
import           Data.Ord (comparing)
import qualified Data.Set as Set
import           Data.Set (Set)
import qualified Data.Vector as V

import qualified Harmonic.Rules.Import.Jazz as J
import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as Pt
import qualified Harmonic.Rules.Types.Progression as Pr
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import qualified Harmonic.Rules.Types.Scale as Sc

-------------------------------------------------------------------------------
-- Key lattice
-------------------------------------------------------------------------------

-- |Major, or composite minor (natural + harmonic + melodic forms).
data KeyQuality = MajorKey | MinorKey
  deriving (KeyQuality -> KeyQuality -> Bool
(KeyQuality -> KeyQuality -> Bool)
-> (KeyQuality -> KeyQuality -> Bool) -> Eq KeyQuality
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyQuality -> KeyQuality -> Bool
== :: KeyQuality -> KeyQuality -> Bool
$c/= :: KeyQuality -> KeyQuality -> Bool
/= :: KeyQuality -> KeyQuality -> Bool
Eq, Eq KeyQuality
Eq KeyQuality =>
(KeyQuality -> KeyQuality -> Ordering)
-> (KeyQuality -> KeyQuality -> Bool)
-> (KeyQuality -> KeyQuality -> Bool)
-> (KeyQuality -> KeyQuality -> Bool)
-> (KeyQuality -> KeyQuality -> Bool)
-> (KeyQuality -> KeyQuality -> KeyQuality)
-> (KeyQuality -> KeyQuality -> KeyQuality)
-> Ord KeyQuality
KeyQuality -> KeyQuality -> Bool
KeyQuality -> KeyQuality -> Ordering
KeyQuality -> KeyQuality -> KeyQuality
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: KeyQuality -> KeyQuality -> Ordering
compare :: KeyQuality -> KeyQuality -> Ordering
$c< :: KeyQuality -> KeyQuality -> Bool
< :: KeyQuality -> KeyQuality -> Bool
$c<= :: KeyQuality -> KeyQuality -> Bool
<= :: KeyQuality -> KeyQuality -> Bool
$c> :: KeyQuality -> KeyQuality -> Bool
> :: KeyQuality -> KeyQuality -> Bool
$c>= :: KeyQuality -> KeyQuality -> Bool
>= :: KeyQuality -> KeyQuality -> Bool
$cmax :: KeyQuality -> KeyQuality -> KeyQuality
max :: KeyQuality -> KeyQuality -> KeyQuality
$cmin :: KeyQuality -> KeyQuality -> KeyQuality
min :: KeyQuality -> KeyQuality -> KeyQuality
Ord, Int -> KeyQuality -> ShowS
[KeyQuality] -> ShowS
KeyQuality -> [Char]
(Int -> KeyQuality -> ShowS)
-> (KeyQuality -> [Char])
-> ([KeyQuality] -> ShowS)
-> Show KeyQuality
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyQuality -> ShowS
showsPrec :: Int -> KeyQuality -> ShowS
$cshow :: KeyQuality -> [Char]
show :: KeyQuality -> [Char]
$cshowList :: [KeyQuality] -> ShowS
showList :: [KeyQuality] -> ShowS
Show, Int -> KeyQuality
KeyQuality -> Int
KeyQuality -> [KeyQuality]
KeyQuality -> KeyQuality
KeyQuality -> KeyQuality -> [KeyQuality]
KeyQuality -> KeyQuality -> KeyQuality -> [KeyQuality]
(KeyQuality -> KeyQuality)
-> (KeyQuality -> KeyQuality)
-> (Int -> KeyQuality)
-> (KeyQuality -> Int)
-> (KeyQuality -> [KeyQuality])
-> (KeyQuality -> KeyQuality -> [KeyQuality])
-> (KeyQuality -> KeyQuality -> [KeyQuality])
-> (KeyQuality -> KeyQuality -> KeyQuality -> [KeyQuality])
-> Enum KeyQuality
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: KeyQuality -> KeyQuality
succ :: KeyQuality -> KeyQuality
$cpred :: KeyQuality -> KeyQuality
pred :: KeyQuality -> KeyQuality
$ctoEnum :: Int -> KeyQuality
toEnum :: Int -> KeyQuality
$cfromEnum :: KeyQuality -> Int
fromEnum :: KeyQuality -> Int
$cenumFrom :: KeyQuality -> [KeyQuality]
enumFrom :: KeyQuality -> [KeyQuality]
$cenumFromThen :: KeyQuality -> KeyQuality -> [KeyQuality]
enumFromThen :: KeyQuality -> KeyQuality -> [KeyQuality]
$cenumFromTo :: KeyQuality -> KeyQuality -> [KeyQuality]
enumFromTo :: KeyQuality -> KeyQuality -> [KeyQuality]
$cenumFromThenTo :: KeyQuality -> KeyQuality -> KeyQuality -> [KeyQuality]
enumFromThenTo :: KeyQuality -> KeyQuality -> KeyQuality -> [KeyQuality]
Enum, KeyQuality
KeyQuality -> KeyQuality -> Bounded KeyQuality
forall a. a -> a -> Bounded a
$cminBound :: KeyQuality
minBound :: KeyQuality
$cmaxBound :: KeyQuality
maxBound :: KeyQuality
Bounded)

-- |A key area: tonic pitch class + quality.
data KeyArea = KeyArea
  { KeyArea -> Int
kaTonic   :: !Int
  , KeyArea -> KeyQuality
kaQuality :: !KeyQuality
  } deriving (KeyArea -> KeyArea -> Bool
(KeyArea -> KeyArea -> Bool)
-> (KeyArea -> KeyArea -> Bool) -> Eq KeyArea
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyArea -> KeyArea -> Bool
== :: KeyArea -> KeyArea -> Bool
$c/= :: KeyArea -> KeyArea -> Bool
/= :: KeyArea -> KeyArea -> Bool
Eq, Eq KeyArea
Eq KeyArea =>
(KeyArea -> KeyArea -> Ordering)
-> (KeyArea -> KeyArea -> Bool)
-> (KeyArea -> KeyArea -> Bool)
-> (KeyArea -> KeyArea -> Bool)
-> (KeyArea -> KeyArea -> Bool)
-> (KeyArea -> KeyArea -> KeyArea)
-> (KeyArea -> KeyArea -> KeyArea)
-> Ord KeyArea
KeyArea -> KeyArea -> Bool
KeyArea -> KeyArea -> Ordering
KeyArea -> KeyArea -> KeyArea
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: KeyArea -> KeyArea -> Ordering
compare :: KeyArea -> KeyArea -> Ordering
$c< :: KeyArea -> KeyArea -> Bool
< :: KeyArea -> KeyArea -> Bool
$c<= :: KeyArea -> KeyArea -> Bool
<= :: KeyArea -> KeyArea -> Bool
$c> :: KeyArea -> KeyArea -> Bool
> :: KeyArea -> KeyArea -> Bool
$c>= :: KeyArea -> KeyArea -> Bool
>= :: KeyArea -> KeyArea -> Bool
$cmax :: KeyArea -> KeyArea -> KeyArea
max :: KeyArea -> KeyArea -> KeyArea
$cmin :: KeyArea -> KeyArea -> KeyArea
min :: KeyArea -> KeyArea -> KeyArea
Ord, Int -> KeyArea -> ShowS
[KeyArea] -> ShowS
KeyArea -> [Char]
(Int -> KeyArea -> ShowS)
-> (KeyArea -> [Char]) -> ([KeyArea] -> ShowS) -> Show KeyArea
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyArea -> ShowS
showsPrec :: Int -> KeyArea -> ShowS
$cshow :: KeyArea -> [Char]
show :: KeyArea -> [Char]
$cshowList :: [KeyArea] -> ShowS
showList :: [KeyArea] -> ShowS
Show)

-- |Which scale form realises a bar inside its key area.
data KeyForm = MajForm | NatForm | HarmForm | MelForm
  deriving (KeyForm -> KeyForm -> Bool
(KeyForm -> KeyForm -> Bool)
-> (KeyForm -> KeyForm -> Bool) -> Eq KeyForm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyForm -> KeyForm -> Bool
== :: KeyForm -> KeyForm -> Bool
$c/= :: KeyForm -> KeyForm -> Bool
/= :: KeyForm -> KeyForm -> Bool
Eq, Eq KeyForm
Eq KeyForm =>
(KeyForm -> KeyForm -> Ordering)
-> (KeyForm -> KeyForm -> Bool)
-> (KeyForm -> KeyForm -> Bool)
-> (KeyForm -> KeyForm -> Bool)
-> (KeyForm -> KeyForm -> Bool)
-> (KeyForm -> KeyForm -> KeyForm)
-> (KeyForm -> KeyForm -> KeyForm)
-> Ord KeyForm
KeyForm -> KeyForm -> Bool
KeyForm -> KeyForm -> Ordering
KeyForm -> KeyForm -> KeyForm
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: KeyForm -> KeyForm -> Ordering
compare :: KeyForm -> KeyForm -> Ordering
$c< :: KeyForm -> KeyForm -> Bool
< :: KeyForm -> KeyForm -> Bool
$c<= :: KeyForm -> KeyForm -> Bool
<= :: KeyForm -> KeyForm -> Bool
$c> :: KeyForm -> KeyForm -> Bool
> :: KeyForm -> KeyForm -> Bool
$c>= :: KeyForm -> KeyForm -> Bool
>= :: KeyForm -> KeyForm -> Bool
$cmax :: KeyForm -> KeyForm -> KeyForm
max :: KeyForm -> KeyForm -> KeyForm
$cmin :: KeyForm -> KeyForm -> KeyForm
min :: KeyForm -> KeyForm -> KeyForm
Ord, Int -> KeyForm -> ShowS
[KeyForm] -> ShowS
KeyForm -> [Char]
(Int -> KeyForm -> ShowS)
-> (KeyForm -> [Char]) -> ([KeyForm] -> ShowS) -> Show KeyForm
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyForm -> ShowS
showsPrec :: Int -> KeyForm -> ShowS
$cshow :: KeyForm -> [Char]
show :: KeyForm -> [Char]
$cshowList :: [KeyForm] -> ShowS
showList :: [KeyForm] -> ShowS
Show, Int -> KeyForm
KeyForm -> Int
KeyForm -> [KeyForm]
KeyForm -> KeyForm
KeyForm -> KeyForm -> [KeyForm]
KeyForm -> KeyForm -> KeyForm -> [KeyForm]
(KeyForm -> KeyForm)
-> (KeyForm -> KeyForm)
-> (Int -> KeyForm)
-> (KeyForm -> Int)
-> (KeyForm -> [KeyForm])
-> (KeyForm -> KeyForm -> [KeyForm])
-> (KeyForm -> KeyForm -> [KeyForm])
-> (KeyForm -> KeyForm -> KeyForm -> [KeyForm])
-> Enum KeyForm
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: KeyForm -> KeyForm
succ :: KeyForm -> KeyForm
$cpred :: KeyForm -> KeyForm
pred :: KeyForm -> KeyForm
$ctoEnum :: Int -> KeyForm
toEnum :: Int -> KeyForm
$cfromEnum :: KeyForm -> Int
fromEnum :: KeyForm -> Int
$cenumFrom :: KeyForm -> [KeyForm]
enumFrom :: KeyForm -> [KeyForm]
$cenumFromThen :: KeyForm -> KeyForm -> [KeyForm]
enumFromThen :: KeyForm -> KeyForm -> [KeyForm]
$cenumFromTo :: KeyForm -> KeyForm -> [KeyForm]
enumFromTo :: KeyForm -> KeyForm -> [KeyForm]
$cenumFromThenTo :: KeyForm -> KeyForm -> KeyForm -> [KeyForm]
enumFromThenTo :: KeyForm -> KeyForm -> KeyForm -> [KeyForm]
Enum, KeyForm
KeyForm -> KeyForm -> Bounded KeyForm
forall a. a -> a -> Bounded a
$cminBound :: KeyForm
minBound :: KeyForm
$cmaxBound :: KeyForm
maxBound :: KeyForm
Bounded)

-- |Which tier of the override ladder produced a bar's M set: the key form
-- itself, the seeded special cases, the generic 28-mode search, or the
-- best-coverage gap fallback (chord not fully contained).
data ModeTier = TierForm | TierSeed | TierSearch | TierGap
  deriving (ModeTier -> ModeTier -> Bool
(ModeTier -> ModeTier -> Bool)
-> (ModeTier -> ModeTier -> Bool) -> Eq ModeTier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ModeTier -> ModeTier -> Bool
== :: ModeTier -> ModeTier -> Bool
$c/= :: ModeTier -> ModeTier -> Bool
/= :: ModeTier -> ModeTier -> Bool
Eq, Eq ModeTier
Eq ModeTier =>
(ModeTier -> ModeTier -> Ordering)
-> (ModeTier -> ModeTier -> Bool)
-> (ModeTier -> ModeTier -> Bool)
-> (ModeTier -> ModeTier -> Bool)
-> (ModeTier -> ModeTier -> Bool)
-> (ModeTier -> ModeTier -> ModeTier)
-> (ModeTier -> ModeTier -> ModeTier)
-> Ord ModeTier
ModeTier -> ModeTier -> Bool
ModeTier -> ModeTier -> Ordering
ModeTier -> ModeTier -> ModeTier
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ModeTier -> ModeTier -> Ordering
compare :: ModeTier -> ModeTier -> Ordering
$c< :: ModeTier -> ModeTier -> Bool
< :: ModeTier -> ModeTier -> Bool
$c<= :: ModeTier -> ModeTier -> Bool
<= :: ModeTier -> ModeTier -> Bool
$c> :: ModeTier -> ModeTier -> Bool
> :: ModeTier -> ModeTier -> Bool
$c>= :: ModeTier -> ModeTier -> Bool
>= :: ModeTier -> ModeTier -> Bool
$cmax :: ModeTier -> ModeTier -> ModeTier
max :: ModeTier -> ModeTier -> ModeTier
$cmin :: ModeTier -> ModeTier -> ModeTier
min :: ModeTier -> ModeTier -> ModeTier
Ord, Int -> ModeTier -> ShowS
[ModeTier] -> ShowS
ModeTier -> [Char]
(Int -> ModeTier -> ShowS)
-> (ModeTier -> [Char]) -> ([ModeTier] -> ShowS) -> Show ModeTier
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ModeTier -> ShowS
showsPrec :: Int -> ModeTier -> ShowS
$cshow :: ModeTier -> [Char]
show :: ModeTier -> [Char]
$cshowList :: [ModeTier] -> ShowS
showList :: [ModeTier] -> ShowS
Show, Int -> ModeTier
ModeTier -> Int
ModeTier -> [ModeTier]
ModeTier -> ModeTier
ModeTier -> ModeTier -> [ModeTier]
ModeTier -> ModeTier -> ModeTier -> [ModeTier]
(ModeTier -> ModeTier)
-> (ModeTier -> ModeTier)
-> (Int -> ModeTier)
-> (ModeTier -> Int)
-> (ModeTier -> [ModeTier])
-> (ModeTier -> ModeTier -> [ModeTier])
-> (ModeTier -> ModeTier -> [ModeTier])
-> (ModeTier -> ModeTier -> ModeTier -> [ModeTier])
-> Enum ModeTier
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ModeTier -> ModeTier
succ :: ModeTier -> ModeTier
$cpred :: ModeTier -> ModeTier
pred :: ModeTier -> ModeTier
$ctoEnum :: Int -> ModeTier
toEnum :: Int -> ModeTier
$cfromEnum :: ModeTier -> Int
fromEnum :: ModeTier -> Int
$cenumFrom :: ModeTier -> [ModeTier]
enumFrom :: ModeTier -> [ModeTier]
$cenumFromThen :: ModeTier -> ModeTier -> [ModeTier]
enumFromThen :: ModeTier -> ModeTier -> [ModeTier]
$cenumFromTo :: ModeTier -> ModeTier -> [ModeTier]
enumFromTo :: ModeTier -> ModeTier -> [ModeTier]
$cenumFromThenTo :: ModeTier -> ModeTier -> ModeTier -> [ModeTier]
enumFromThenTo :: ModeTier -> ModeTier -> ModeTier -> [ModeTier]
Enum, ModeTier
ModeTier -> ModeTier -> Bounded ModeTier
forall a. a -> a -> Bounded a
$cminBound :: ModeTier
minBound :: ModeTier
$cmaxBound :: ModeTier
maxBound :: ModeTier
Bounded)

-- |Per-bar analysis result.
data BarAnalysis = BarAnalysis
  { BarAnalysis -> KeyArea
baKey        :: !KeyArea
  , BarAnalysis -> KeyForm
baForm       :: !KeyForm
  , BarAnalysis -> Set Int
baModeSet    :: !(Set Int)        -- ^ absolute M-layer pitch classes
  , BarAnalysis -> Maybe Mode
baMode       :: !(Maybe Sc.Mode)  -- ^ classified at the harmonic root
  , BarAnalysis -> ModeTier
baTier       :: !ModeTier
  , BarAnalysis -> Int
baPentaRoot  :: !Int              -- ^ root of the anhemitonic pentatonic
  , BarAnalysis -> Bool
baPentaInKey :: !Bool             -- ^ pentatonic sits inside the M set
  , BarAnalysis -> Bool
baBoundary   :: !Bool             -- ^ key differs from the previous bar (cyclic)
  } deriving (BarAnalysis -> BarAnalysis -> Bool
(BarAnalysis -> BarAnalysis -> Bool)
-> (BarAnalysis -> BarAnalysis -> Bool) -> Eq BarAnalysis
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BarAnalysis -> BarAnalysis -> Bool
== :: BarAnalysis -> BarAnalysis -> Bool
$c/= :: BarAnalysis -> BarAnalysis -> Bool
/= :: BarAnalysis -> BarAnalysis -> Bool
Eq, Int -> BarAnalysis -> ShowS
[BarAnalysis] -> ShowS
BarAnalysis -> [Char]
(Int -> BarAnalysis -> ShowS)
-> (BarAnalysis -> [Char])
-> ([BarAnalysis] -> ShowS)
-> Show BarAnalysis
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BarAnalysis -> ShowS
showsPrec :: Int -> BarAnalysis -> ShowS
$cshow :: BarAnalysis -> [Char]
show :: BarAnalysis -> [Char]
$cshowList :: [BarAnalysis] -> ShowS
showList :: [BarAnalysis] -> ShowS
Show)

-- |Render a key area the way musicians say it: @\"Bb\"@, @\"Gm\"@.
showKeyArea :: KeyArea -> String
showKeyArea :: KeyArea -> [Char]
showKeyArea (KeyArea Int
t KeyQuality
q) =
  NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
Pt.flat (Int -> PitchClass
Pt.mkPitchClass Int
t)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (case KeyQuality
q of KeyQuality
MajorKey -> [Char]
""; KeyQuality
MinorKey -> [Char]
"m")

allKeys :: [KeyArea]
allKeys :: [KeyArea]
allKeys = [ Int -> KeyQuality -> KeyArea
KeyArea Int
t KeyQuality
q | KeyQuality
q <- [KeyQuality
MajorKey, KeyQuality
MinorKey], Int
t <- [Int
0 .. Int
11] ]

scaleSetAt :: Int -> [Int] -> Set Int
scaleSetAt :: Int -> [Int] -> Set Int
scaleSetAt Int
t [Int]
steps = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [ (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
s <- [Int]
steps ]

majSteps, harmSteps, melSteps, altSteps :: [Int]
majSteps :: [Int]
majSteps  = [Int
0, Int
2, Int
4, Int
5, Int
7, Int
9, Int
11]
harmSteps :: [Int]
harmSteps = [Int
0, Int
2, Int
3, Int
5, Int
7, Int
8, Int
11]
melSteps :: [Int]
melSteps  = [Int
0, Int
2, Int
3, Int
5, Int
7, Int
9, Int
11]
altSteps :: [Int]
altSteps  = [Int
0, Int
1, Int
3, Int
4, Int
6, Int
8, Int
10]

-- |The form sets of a key area, in preference order.
keyForms :: KeyArea -> [(KeyForm, Set Int)]
keyForms :: KeyArea -> [(KeyForm, Set Int)]
keyForms (KeyArea Int
t KeyQuality
MajorKey) = [(KeyForm
MajForm, Int -> [Int] -> Set Int
scaleSetAt Int
t [Int]
majSteps)]
keyForms (KeyArea Int
t KeyQuality
MinorKey) =
  [ (KeyForm
NatForm,  Int -> [Int] -> Set Int
scaleSetAt ((Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
majSteps)
  , (KeyForm
HarmForm, Int -> [Int] -> Set Int
scaleSetAt Int
t [Int]
harmSteps)
  , (KeyForm
MelForm,  Int -> [Int] -> Set Int
scaleSetAt Int
t [Int]
melSteps)
  ]

-------------------------------------------------------------------------------
-- Bar facts
-------------------------------------------------------------------------------

data BarFacts = BarFacts
  { BarFacts -> Int
bfRoot    :: !Int        -- harmonic root (post inversion detection)
  , BarFacts -> Set Int
bfAbs     :: !(Set Int)  -- absolute chord pitch classes
  , BarFacts -> [Int]
bfZero    :: ![Int]      -- zero-form above the harmonic root
  , BarFacts -> Set Int
bfZeroSet :: !(Set Int)  -- the same, as a set (hot in the DP inner loop)
  , BarFacts -> BassVocab
bfVocab   :: !J.BassVocab
  }

-- Harmonic root via the chord namer (the bass of an inverted gen triad is
-- NOT the root); bassVocabFor is total over any zero-form set, so one
-- fact extractor serves classical triads and jazz extensions alike.
barFacts :: H.CadenceState -> BarFacts
barFacts :: CadenceState -> BarFacts
barFacts CadenceState
cs =
  let bassPC :: Int
bassPC = PitchClass -> Int
Pt.unPitchClass (NoteName -> PitchClass
Pt.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs))
      absPCs :: Set Int
absPCs = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [ (Int
bassPC Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PitchClass -> Int
Pt.unPitchClass PitchClass
iv) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                            | PitchClass
iv <- Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs) ]
      harmR :: Int
harmR  = PitchClass -> Int
Pt.unPitchClass (NoteName -> PitchClass
Pt.pitchClass (Chord -> NoteName
H.chordNoteName (CadenceState -> Chord
H.fromCadenceState CadenceState
cs)))
      zf :: [Int]
zf     = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [ (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
harmR) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
p <- Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
absPCs ]
  in Int -> Set Int -> [Int] -> Set Int -> BassVocab -> BarFacts
BarFacts Int
harmR Set Int
absPCs [Int]
zf ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int]
zf) ([Int] -> BassVocab
J.bassVocabFor [Int]
zf)

absOf :: Int -> [Int] -> [Int]
absOf :: Int -> [Int] -> [Int]
absOf Int
r = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)

-------------------------------------------------------------------------------
-- Emission: how well a bar sits in a key
-------------------------------------------------------------------------------

-- Weighted membership of the bar's tones in one candidate form set. The
-- BassVocab tiers grade structural importance (target > strong > passing);
-- notated colour tones still count — a V7b9's b9 is the harmonic-minor
-- marker, not noise — but at the lightest weight.
membScore :: BarFacts -> Set Int -> Double
membScore :: BarFacts -> Set Int -> Double
membScore BarFacts
bf Set Int
_form
  -- A silent bar (no chord tones) is key-neutral: without this guard the
  -- fabricated default vocabulary (root C, fifth G) would cast real votes
  -- and a rest could tug the whole key path. DP continuity carries the
  -- neighbouring key across instead.
  | Set Int -> Bool
forall a. Set a -> Bool
Set.null (BarFacts -> Set Int
bfAbs BarFacts
bf) = Double
0
membScore BarFacts
bf Set Int
form =
  let v :: BassVocab
v        = BarFacts -> BassVocab
bfVocab BarFacts
bf
      tgt :: [Int]
tgt      = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub (Int -> [Int] -> [Int]
absOf (BarFacts -> Int
bfRoot BarFacts
bf) (BassVocab -> [Int]
J.bvTarget BassVocab
v))
      strong :: [Int]
strong   = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub (Int -> [Int] -> [Int]
absOf (BarFacts -> Int
bfRoot BarFacts
bf) (BassVocab -> [Int]
J.bvStrong BassVocab
v)) [Int] -> [Int] -> [Int]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => [a] -> t a -> [a]
`minus` [Int]
tgt
      passing :: [Int]
passing  = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub (Int -> [Int] -> [Int]
absOf (BarFacts -> Int
bfRoot BarFacts
bf) (BassVocab -> [Int]
J.bvPassing BassVocab
v)) [Int] -> [Int] -> [Int]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => [a] -> t a -> [a]
`minus` ([Int]
tgt [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
strong)
      colour :: [Int]
colour   = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (BarFacts -> Set Int
bfAbs BarFacts
bf) [Int] -> [Int] -> [Int]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => [a] -> t a -> [a]
`minus` ([Int]
tgt [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
strong [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
passing)
      minus :: [a] -> t a -> [a]
minus [a]
xs t a
ys = [ a
x | a
x <- [a]
xs, a
x a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t a
ys ]
      score :: a -> a -> [Int] -> a
score a
w a
wOut [Int]
ps = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ if Int
p Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
form then a
w else a
wOut | Int
p <- [Int]
ps ]
  in Double -> Double -> [Int] -> Double
forall {a}. Num a => a -> a -> [Int] -> a
score Double
3 (-Double
4) [Int]
tgt Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double -> [Int] -> Double
forall {a}. Num a => a -> a -> [Int] -> a
score Double
2 (-Double
2) [Int]
strong Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double -> [Int] -> Double
forall {a}. Num a => a -> a -> [Int] -> a
score Double
1 (-Double
0.5) [Int]
passing
     Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double -> [Int] -> Double
forall {a}. Num a => a -> a -> [Int] -> a
score Double
1 (-Double
1) [Int]
colour

-- Functional-harmony votes: the retired walk votesFor table re-based onto
-- the 24-key lattice with first-class minor evidence (an altered dominant
-- is V of a MINOR tonic; a half-diminished is ii of minor before vii of
-- major; mM7 \/ m6 mark a tonic minor; a plain major triad is also V of a
-- harmonic-minor key). Triadic tones state a chord's identity; the tones
-- ABOVE the triad state which key it belongs to, so extension evidence is
-- read before the plain seventh-and-triad cases.
votes :: BarFacts -> [(KeyArea, Double)]
votes :: BarFacts -> [(KeyArea, Double)]
votes BarFacts
bf =
  let ivs :: Set Int
ivs = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (BarFacts -> [Int]
bfZero BarFacts
bf)
      has :: Int -> Bool
has = (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
ivs)
      altered :: Bool
altered   = Int -> Bool
has Int
1 Bool -> Bool -> Bool
|| Int -> Bool
has Int
8 Bool -> Bool -> Bool
|| (Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Int -> Bool
has Int
4)
      unaltered :: Bool
unaltered = Int -> Bool
has Int
2 Bool -> Bool -> Bool
|| Int -> Bool
has Int
9
      r :: Int
r = BarFacts -> Int
bfRoot BarFacts
bf
      k :: KeyQuality -> Int -> KeyArea
k KeyQuality
q Int
off = Int -> KeyQuality -> KeyArea
KeyArea ((Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) KeyQuality
q
      offsets :: [(KeyArea, Double)]
offsets
        | Int -> Bool
has Int
4 Bool -> Bool -> Bool
&& Int -> Bool
has Int
10 Bool -> Bool -> Bool
&& Bool
altered = [ (KeyQuality -> Int -> KeyArea
k KeyQuality
MinorKey Int
5, Double
6), (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
5, Double
2) ]
        | Int -> Bool
has Int
4 Bool -> Bool -> Bool
&& Int -> Bool
has Int
10 Bool -> Bool -> Bool
&& Bool
unaltered Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
has Int
6) =
            [ (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
5, Double
7), (KeyQuality -> Int -> KeyArea
k KeyQuality
MinorKey Int
5, Double
2) ]
        | Int -> Bool
has Int
4 Bool -> Bool -> Bool
&& Int -> Bool
has Int
10            = [ (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
5, Double
6), (KeyQuality -> Int -> KeyArea
k KeyQuality
MinorKey Int
5, Double
3) ]
        | Int -> Bool
has Int
4 Bool -> Bool -> Bool
&& Int -> Bool
has Int
11 Bool -> Bool -> Bool
&& Int -> Bool
has Int
6 Bool -> Bool -> Bool
&& Int -> Bool
has Int
7 = [ (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
0, Double
5) ]
        | Int -> Bool
has Int
4 Bool -> Bool -> Bool
&& Int -> Bool
has Int
11            = [ (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
0, Double
4), (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
7, Double
2)
                                       , (KeyQuality -> Int -> KeyArea
k KeyQuality
MinorKey Int
9, Double
2) ]
        | Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Int -> Bool
has Int
11            = [ (KeyQuality -> Int -> KeyArea
k KeyQuality
MinorKey Int
0, Double
6) ]
        | Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Int -> Bool
has Int
9 Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
has Int
10) = [ (KeyQuality -> Int -> KeyArea
k KeyQuality
MinorKey Int
0, Double
5), (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
10, Double
2) ]
        | Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Int -> Bool
has Int
6 Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
has Int
4) = [ (KeyQuality -> Int -> KeyArea
k KeyQuality
MinorKey Int
10, Double
5), (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
1, Double
3) ]
        | Int -> Bool
has Int
3                      = [ (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
10, Double
4), (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
3, Double
3)
                                       , (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
8, Double
2), (KeyQuality -> Int -> KeyArea
k KeyQuality
MinorKey Int
0, Double
3)
                                       , (KeyQuality -> Int -> KeyArea
k KeyQuality
MinorKey Int
7, Double
1) ]
        | Int -> Bool
has Int
4                      = [ (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
0, Double
4), (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
7, Double
2)
                                       , (KeyQuality -> Int -> KeyArea
k KeyQuality
MajorKey Int
5, Double
2), (KeyQuality -> Int -> KeyArea
k KeyQuality
MinorKey Int
5, Double
2) ]
        | Bool
otherwise                  = []
  in [(KeyArea, Double)]
offsets

-- Best form for the bar within one key, plus this key's functional votes.
emission :: Map.Map KeyArea Double -> BarFacts -> KeyArea -> (Double, KeyForm)
emission :: Map KeyArea Double -> BarFacts -> KeyArea -> (Double, KeyForm)
emission Map KeyArea Double
voteMap BarFacts
bf KeyArea
key =
  let (Double
best, KeyForm
fm) = ((Double, KeyForm) -> (Double, KeyForm) -> Ordering)
-> [(Double, KeyForm)] -> (Double, KeyForm)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Double, KeyForm) -> Double)
-> (Double, KeyForm) -> (Double, KeyForm) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Double, KeyForm) -> Double
forall a b. (a, b) -> a
fst)
                     [ (BarFacts -> Set Int -> Double
membScore BarFacts
bf Set Int
s, KeyForm
f) | (KeyForm
f, Set Int
s) <- KeyArea -> [(KeyForm, Set Int)]
keyForms KeyArea
key ]
  in (Double
best Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> KeyArea -> Map KeyArea Double -> Double
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Double
0 KeyArea
key Map KeyArea Double
voteMap, KeyForm
fm)

-------------------------------------------------------------------------------
-- Transition cost and the cyclic Viterbi
-------------------------------------------------------------------------------

-- |Key-switch penalty (probe-calibrated, see module header).
kaLambda :: Double
kaLambda :: Double
kaLambda = Double
6

-- |Boundary bonus when the bar BEFORE the switch is dominant-functioning
-- of the new key (V7 shell a P5 above the tonic, or a dim\/half-dim shell
-- a semitone below it) — modulations announced by their dominant switch
-- cheaper.
kaDomBonus :: Double
kaDomBonus :: Double
kaDomBonus = Double
3

-- |Boundary bonus when the arrival bar is tonic-functioning in the new key.
kaTonicBonus :: Double
kaTonicBonus :: Double
kaTonicBonus = Double
1.5

isDomOf :: BarFacts -> KeyArea -> Bool
isDomOf :: BarFacts -> KeyArea -> Bool
isDomOf BarFacts
bf (KeyArea Int
t KeyQuality
_) =
  let ivs :: Set Int
ivs = BarFacts -> Set Int
bfZeroSet BarFacts
bf
      off :: Int
off = (BarFacts -> Int
bfRoot BarFacts
bf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
  in (Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7 Bool -> Bool -> Bool
&& Int
4 Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
ivs Bool -> Bool -> Bool
&& Int
10 Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
ivs)
     Bool -> Bool -> Bool
|| (Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
11 Bool -> Bool -> Bool
&& Int
3 Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
ivs Bool -> Bool -> Bool
&& Int
6 Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
ivs)

isTonicOf :: BarFacts -> KeyArea -> Bool
isTonicOf :: BarFacts -> KeyArea -> Bool
isTonicOf BarFacts
bf (KeyArea Int
t KeyQuality
q) =
  BarFacts -> Int
bfRoot BarFacts
bf Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
t Bool -> Bool -> Bool
&& case KeyQuality
q of
    KeyQuality
MajorKey -> Int
4 Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` BarFacts -> Set Int
bfZeroSet BarFacts
bf
    KeyQuality
MinorKey -> Int
3 Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` BarFacts -> Set Int
bfZeroSet BarFacts
bf

-- The switch cost depends only on the TARGET key (and the two bars around
-- the boundary), never on the source key or the Viterbi conditioning
-- start — so it is computed once per bar step as a target-indexed map and
-- shared across the whole inner loop and all 24 conditioned runs.
switchCostTo :: BarFacts -> BarFacts -> Map.Map KeyArea Double
switchCostTo :: BarFacts -> BarFacts -> Map KeyArea Double
switchCostTo BarFacts
prevBf BarFacts
curBf = [(KeyArea, Double)] -> Map KeyArea Double
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (KeyArea
k', Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Double
kaLambda Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
4) (Double
kaLambda Double -> Double -> Double
forall a. Num a => a -> a -> a
- KeyArea -> Double
bonus KeyArea
k')) | KeyArea
k' <- [KeyArea]
allKeys ]
  where
    bonus :: KeyArea -> Double
bonus KeyArea
k' = (if BarFacts -> KeyArea -> Bool
isDomOf BarFacts
prevBf KeyArea
k' then Double
kaDomBonus else Double
0)
             Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if BarFacts -> KeyArea -> Bool
isTonicOf BarFacts
curBf KeyArea
k' then Double
kaTonicBonus else Double
0)

-- Exact cyclic Viterbi: condition on bar 0's key, run the linear DP, close
-- the wrap edge, take the global optimum. Ties resolve deterministically
-- (lowest tonic pitch class, major before minor).
bestKeyPath :: [BarFacts] -> [(KeyArea, KeyForm)]
bestKeyPath :: [BarFacts] -> [(KeyArea, KeyForm)]
bestKeyPath []  = []
bestKeyPath [BarFacts]
bfs =
  let vms :: [Map KeyArea Double]
vms  = (BarFacts -> Map KeyArea Double)
-> [BarFacts] -> [Map KeyArea Double]
forall a b. (a -> b) -> [a] -> [b]
map ((Double -> Double -> Double)
-> [(KeyArea, Double)] -> Map KeyArea Double
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) ([(KeyArea, Double)] -> Map KeyArea Double)
-> (BarFacts -> [(KeyArea, Double)])
-> BarFacts
-> Map KeyArea Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BarFacts -> [(KeyArea, Double)]
votes) [BarFacts]
bfs
      emit :: [Map KeyArea (Double, KeyForm)]
emit = [ [(KeyArea, (Double, KeyForm))] -> Map KeyArea (Double, KeyForm)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (KeyArea
key, Map KeyArea Double -> BarFacts -> KeyArea -> (Double, KeyForm)
emission Map KeyArea Double
vm BarFacts
bf KeyArea
key) | KeyArea
key <- [KeyArea]
allKeys ]
             | (BarFacts
bf, Map KeyArea Double
vm) <- [BarFacts]
-> [Map KeyArea Double] -> [(BarFacts, Map KeyArea Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BarFacts]
bfs [Map KeyArea Double]
vms ]
      n :: Int
n    = [BarFacts] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BarFacts]
bfs
      bfV :: Vector BarFacts
bfV  = [BarFacts] -> Vector BarFacts
forall a. [a] -> Vector a
V.fromList [BarFacts]
bfs
      emV :: Vector (Map KeyArea (Double, KeyForm))
emV  = [Map KeyArea (Double, KeyForm)]
-> Vector (Map KeyArea (Double, KeyForm))
forall a. [a] -> Vector a
V.fromList [Map KeyArea (Double, KeyForm)]
emit
      -- Per-step target-indexed switch costs, shared across all 24 runs.
      costV :: Vector (Map KeyArea Double)
costV = [Map KeyArea Double] -> Vector (Map KeyArea Double)
forall a. [a] -> Vector a
V.fromList
        [ BarFacts -> BarFacts -> Map KeyArea Double
switchCostTo (Vector BarFacts
bfV Vector BarFacts -> Int -> BarFacts
forall a. Vector a -> Int -> a
V.! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Vector BarFacts
bfV Vector BarFacts -> Int -> BarFacts
forall a. Vector a -> Int -> a
V.! Int
i) | Int
i <- [Int
1 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
      wrapCost :: Map KeyArea Double
wrapCost = BarFacts -> BarFacts -> Map KeyArea Double
switchCostTo (Vector BarFacts
bfV Vector BarFacts -> Int -> BarFacts
forall a. Vector a -> Int -> a
V.! (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Vector BarFacts
bfV Vector BarFacts -> Int -> BarFacts
forall a. Vector a -> Int -> a
V.! Int
0)
      run :: KeyArea -> (Double, [KeyArea])
run KeyArea
k0 =
        let e0 :: Double
e0 = (Double, KeyForm) -> Double
forall a b. (a, b) -> a
fst (Vector (Map KeyArea (Double, KeyForm))
emV Vector (Map KeyArea (Double, KeyForm))
-> Int -> Map KeyArea (Double, KeyForm)
forall a. Vector a -> Int -> a
V.! Int
0 Map KeyArea (Double, KeyForm) -> KeyArea -> (Double, KeyForm)
forall k a. Ord k => Map k a -> k -> a
Map.! KeyArea
k0)
            step :: (Map KeyArea Double, Map Int (Map KeyArea KeyArea))
-> Int -> (Map KeyArea Double, Map Int (Map KeyArea KeyArea))
step (Map KeyArea Double
scores, Map Int (Map KeyArea KeyArea)
bps) Int
i =
              let costTo :: Map KeyArea Double
costTo = Vector (Map KeyArea Double)
costV Vector (Map KeyArea Double) -> Int -> Map KeyArea Double
forall a. Vector a -> Int -> a
V.! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                  scores' :: Map KeyArea (Double, KeyArea)
scores' = [(KeyArea, (Double, KeyArea))] -> Map KeyArea (Double, KeyArea)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                    [ (KeyArea
k', (Double, KeyArea)
cand)
                    | KeyArea
k' <- [KeyArea]
allKeys
                    , let e :: Double
e   = (Double, KeyForm) -> Double
forall a b. (a, b) -> a
fst (Vector (Map KeyArea (Double, KeyForm))
emV Vector (Map KeyArea (Double, KeyForm))
-> Int -> Map KeyArea (Double, KeyForm)
forall a. Vector a -> Int -> a
V.! Int
i Map KeyArea (Double, KeyForm) -> KeyArea -> (Double, KeyForm)
forall k a. Ord k => Map k a -> k -> a
Map.! KeyArea
k')
                          c :: Double
c   = Map KeyArea Double
costTo Map KeyArea Double -> KeyArea -> Double
forall k a. Ord k => Map k a -> k -> a
Map.! KeyArea
k'
                          cand :: (Double, KeyArea)
cand = ((Double, KeyArea) -> (Double, KeyArea) -> Ordering)
-> [(Double, KeyArea)] -> (Double, KeyArea)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Double, KeyArea) -> Double)
-> (Double, KeyArea) -> (Double, KeyArea) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Double, KeyArea) -> Double
forall a b. (a, b) -> a
fst)
                            [ ( Map KeyArea Double
scores Map KeyArea Double -> KeyArea -> Double
forall k a. Ord k => Map k a -> k -> a
Map.! KeyArea
k Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
e Double -> Double -> Double
forall a. Num a => a -> a -> a
- (if KeyArea
k KeyArea -> KeyArea -> Bool
forall a. Eq a => a -> a -> Bool
== KeyArea
k' then Double
0 else Double
c)
                              , KeyArea
k )
                            | KeyArea
k <- [KeyArea]
allKeys ]
                    ]
              in ( ((Double, KeyArea) -> Double)
-> Map KeyArea (Double, KeyArea) -> Map KeyArea Double
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Double, KeyArea) -> Double
forall a b. (a, b) -> a
fst Map KeyArea (Double, KeyArea)
scores', Int
-> Map KeyArea KeyArea
-> Map Int (Map KeyArea KeyArea)
-> Map Int (Map KeyArea KeyArea)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
i (((Double, KeyArea) -> KeyArea)
-> Map KeyArea (Double, KeyArea) -> Map KeyArea KeyArea
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Double, KeyArea) -> KeyArea
forall a b. (a, b) -> b
snd Map KeyArea (Double, KeyArea)
scores') Map Int (Map KeyArea KeyArea)
bps )
            init0 :: (Map KeyArea Double, Map k a)
init0 = ( [(KeyArea, Double)] -> Map KeyArea Double
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                        [ (KeyArea
k, if KeyArea
k KeyArea -> KeyArea -> Bool
forall a. Eq a => a -> a -> Bool
== KeyArea
k0 then Double
e0 else -Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0) | KeyArea
k <- [KeyArea]
allKeys ]
                    , Map k a
forall k a. Map k a
Map.empty )
            (Map KeyArea Double
final, Map Int (Map KeyArea KeyArea)
paths) = ((Map KeyArea Double, Map Int (Map KeyArea KeyArea))
 -> Int -> (Map KeyArea Double, Map Int (Map KeyArea KeyArea)))
-> (Map KeyArea Double, Map Int (Map KeyArea KeyArea))
-> [Int]
-> (Map KeyArea Double, Map Int (Map KeyArea KeyArea))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map KeyArea Double, Map Int (Map KeyArea KeyArea))
-> Int -> (Map KeyArea Double, Map Int (Map KeyArea KeyArea))
step (Map KeyArea Double, Map Int (Map KeyArea KeyArea))
forall {k} {a}. (Map KeyArea Double, Map k a)
init0 [Int
1 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
            wrap :: KeyArea -> Double
wrap KeyArea
k = Map KeyArea Double
final Map KeyArea Double -> KeyArea -> Double
forall k a. Ord k => Map k a -> k -> a
Map.! KeyArea
k Double -> Double -> Double
forall a. Num a => a -> a -> a
- (if KeyArea
k KeyArea -> KeyArea -> Bool
forall a. Eq a => a -> a -> Bool
== KeyArea
k0 then Double
0 else Map KeyArea Double
wrapCost Map KeyArea Double -> KeyArea -> Double
forall k a. Ord k => Map k a -> k -> a
Map.! KeyArea
k0)
            kLast :: KeyArea
kLast  = (KeyArea -> KeyArea -> Ordering) -> [KeyArea] -> KeyArea
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((KeyArea -> Double) -> KeyArea -> KeyArea -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing KeyArea -> Double
wrap) [KeyArea]
allKeys
            walkBack :: Int -> KeyArea -> [KeyArea] -> [KeyArea]
walkBack Int
i KeyArea
k [KeyArea]
acc
              | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = KeyArea
k KeyArea -> [KeyArea] -> [KeyArea]
forall a. a -> [a] -> [a]
: [KeyArea]
acc
              | Bool
otherwise = Int -> KeyArea -> [KeyArea] -> [KeyArea]
walkBack (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ((Map Int (Map KeyArea KeyArea)
paths Map Int (Map KeyArea KeyArea) -> Int -> Map KeyArea KeyArea
forall k a. Ord k => Map k a -> k -> a
Map.! Int
i) Map KeyArea KeyArea -> KeyArea -> KeyArea
forall k a. Ord k => Map k a -> k -> a
Map.! KeyArea
k) (KeyArea
k KeyArea -> [KeyArea] -> [KeyArea]
forall a. a -> [a] -> [a]
: [KeyArea]
acc)
        in (KeyArea -> Double
wrap KeyArea
kLast, if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then [KeyArea
k0] else Int -> KeyArea -> [KeyArea] -> [KeyArea]
walkBack (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) KeyArea
kLast [])
      (Double
_, [KeyArea]
keys) = ((Double, [KeyArea]) -> (Double, [KeyArea]) -> Ordering)
-> [(Double, [KeyArea])] -> (Double, [KeyArea])
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Double, [KeyArea]) -> Double)
-> (Double, [KeyArea]) -> (Double, [KeyArea]) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Double, [KeyArea]) -> Double
forall a b. (a, b) -> a
fst) ((KeyArea -> (Double, [KeyArea]))
-> [KeyArea] -> [(Double, [KeyArea])]
forall a b. (a -> b) -> [a] -> [b]
map KeyArea -> (Double, [KeyArea])
run [KeyArea]
allKeys)
  in [ (KeyArea
key, (Double, KeyForm) -> KeyForm
forall a b. (a, b) -> b
snd (Vector (Map KeyArea (Double, KeyForm))
emV Vector (Map KeyArea (Double, KeyForm))
-> Int -> Map KeyArea (Double, KeyForm)
forall a. Vector a -> Int -> a
V.! Int
i Map KeyArea (Double, KeyForm) -> KeyArea -> (Double, KeyForm)
forall k a. Ord k => Map k a -> k -> a
Map.! KeyArea
key)) | (Int
i, KeyArea
key) <- [Int] -> [KeyArea] -> [(Int, KeyArea)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [KeyArea]
keys ]

-------------------------------------------------------------------------------
-- M set: the key form, or the override ladder
-------------------------------------------------------------------------------

allModeSetsAt :: Int -> [(Sc.ModeQuality, Set Int)]
allModeSetsAt :: Int -> [(ModeQuality, Set Int)]
allModeSetsAt Int
r =
  [ ( ModeQuality
q
    , [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
Pt.unPitchClass (Mode -> [PitchClass]
Sc.modeChroma (ModeQuality -> PitchClass -> Mode
Sc.Mode ModeQuality
q (Int -> PitchClass
Pt.mkPitchClass Int
r)))) )
  | ModeQuality
q <- [ModeQuality
forall a. Bounded a => a
minBound .. ModeQuality
forall a. Bounded a => a
maxBound] ]

-- The bar's 7-PC mode set. When the chord sits inside its key form, the
-- form IS the mode set (chord-scale theory: one parent scale per key
-- area, expressed as the mode on each bar's root). Otherwise the ladder:
-- seeded special cases (half-diminished outside a minor area -> harmonic
-- minor a whole step below; altered dominant -> its altered scale), then
-- a generic search of the 28-quality vocabulary rooted at the harmonic
-- root (chord contained, fewest tones foreign to the key form), then the
-- best-coverage gap fallback. Override sets are always built FROM mode
-- templates, so they can never escape the vocabulary.
mSetFor :: BarFacts -> (KeyArea, KeyForm) -> (Set Int, ModeTier)
mSetFor :: BarFacts -> (KeyArea, KeyForm) -> (Set Int, ModeTier)
mSetFor BarFacts
bf (KeyArea
key, KeyForm
formNm) =
  let formSet :: Set Int
formSet = Set Int -> (Set Int -> Set Int) -> Maybe (Set Int) -> Set Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Int
forall a. Set a
Set.empty Set Int -> Set Int
forall a. a -> a
id (KeyForm -> [(KeyForm, Set Int)] -> Maybe (Set Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup KeyForm
formNm (KeyArea -> [(KeyForm, Set Int)]
keyForms KeyArea
key))
      chord :: Set Int
chord   = BarFacts -> Set Int
bfAbs BarFacts
bf
      ivs :: Set Int
ivs     = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (BarFacts -> [Int]
bfZero BarFacts
bf)
      has :: Int -> Bool
has     = (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
ivs)
      r :: Int
r       = BarFacts -> Int
bfRoot BarFacts
bf
      seeded :: Maybe (Set Int)
seeded
        | Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Int -> Bool
has Int
6 Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
has Int
4) = Set Int -> Maybe (Set Int)
forall a. a -> Maybe a
Just (Int -> [Int] -> Set Int
scaleSetAt ((Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
harmSteps)
        | Int -> Bool
has Int
4 Bool -> Bool -> Bool
&& Int -> Bool
has Int
10 Bool -> Bool -> Bool
&& (Int -> Bool
has Int
1 Bool -> Bool -> Bool
|| Int -> Bool
has Int
3) = Set Int -> Maybe (Set Int)
forall a. a -> Maybe a
Just (Int -> [Int] -> Set Int
scaleSetAt Int
r [Int]
altSteps)
        | Bool
otherwise = Maybe (Set Int)
forall a. Maybe a
Nothing
      fits :: Set Int -> Bool
fits Set Int
s = Set Int
chord Set Int -> Set Int -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Int
s
      foreignTo :: Set Int -> Int
foreignTo Set Int
s = Set Int -> Int
forall a. Set a -> Int
Set.size (Set Int
s Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Int
formSet)
      searched :: Maybe (Set Int)
searched = case ((ModeQuality, Set Int) -> Bool)
-> [(ModeQuality, Set Int)] -> [(ModeQuality, Set Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Set Int -> Bool
fits (Set Int -> Bool)
-> ((ModeQuality, Set Int) -> Set Int)
-> (ModeQuality, Set Int)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModeQuality, Set Int) -> Set Int
forall a b. (a, b) -> b
snd) (Int -> [(ModeQuality, Set Int)]
allModeSetsAt Int
r) of
                   [] -> Maybe (Set Int)
forall a. Maybe a
Nothing
                   [(ModeQuality, Set Int)]
xs -> Set Int -> Maybe (Set Int)
forall a. a -> Maybe a
Just ((ModeQuality, Set Int) -> Set Int
forall a b. (a, b) -> b
snd (((ModeQuality, Set Int) -> Int)
-> [(ModeQuality, Set Int)] -> (ModeQuality, Set Int)
forall {t :: * -> *} {a} {t}.
(Foldable t, Ord a) =>
(t -> a) -> t t -> t
minimumOn (Set Int -> Int
foreignTo (Set Int -> Int)
-> ((ModeQuality, Set Int) -> Set Int)
-> (ModeQuality, Set Int)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModeQuality, Set Int) -> Set Int
forall a b. (a, b) -> b
snd) [(ModeQuality, Set Int)]
xs))
      coverage :: Set Int -> Int
coverage Set Int
s = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ Int
p | Int
p <- Int -> [Int] -> [Int]
absOf Int
r (BassVocab -> [Int]
J.bvTarget (BarFacts -> BassVocab
bfVocab BarFacts
bf)
                                              [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ BassVocab -> [Int]
J.bvStrong (BarFacts -> BassVocab
bfVocab BarFacts
bf))
                              , Int
p Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
s ]
      gapBest :: Set Int
gapBest = (ModeQuality, Set Int) -> Set Int
forall a b. (a, b) -> b
snd (((ModeQuality, Set Int) -> (ModeQuality, Set Int) -> Ordering)
-> [(ModeQuality, Set Int)] -> (ModeQuality, Set Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((ModeQuality, Set Int) -> Int)
-> (ModeQuality, Set Int) -> (ModeQuality, Set Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Set Int -> Int
coverage (Set Int -> Int)
-> ((ModeQuality, Set Int) -> Set Int)
-> (ModeQuality, Set Int)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModeQuality, Set Int) -> Set Int
forall a b. (a, b) -> b
snd)) (Int -> [(ModeQuality, Set Int)]
allModeSetsAt Int
r))
  in if Set Int -> Bool
fits Set Int
formSet then (Set Int
formSet, ModeTier
TierForm)
     else case Maybe (Set Int)
seeded of
            Just Set Int
s | Set Int -> Bool
fits Set Int
s -> (Set Int
s, ModeTier
TierSeed)
            Maybe (Set Int)
_ -> case Maybe (Set Int)
searched of
                   Just Set Int
s  -> (Set Int
s, ModeTier
TierSearch)
                   Maybe (Set Int)
Nothing -> (Set Int
gapBest, ModeTier
TierGap)
  where minimumOn :: (t -> a) -> t t -> t
minimumOn t -> a
f = (t -> t -> t) -> t t -> t
forall a. (a -> a -> a) -> t a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\t
a t
b -> if t -> a
f t
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= t -> a
f t
b then t
a else t
b)

-------------------------------------------------------------------------------
-- S set: the pentatonic pass
-------------------------------------------------------------------------------

-- |Pentatonic-switch penalty (probe-calibrated, see module header).
kaPentaLambda :: Double
kaPentaLambda :: Double
kaPentaLambda = Double
4

-- The S vocabulary is exactly 'Sc.MajorPenta' — the one anhemitonic
-- pentatonic set class (its rotations include the minor pentatonic).
pentaSteps :: [Int]
pentaSteps :: [Int]
pentaSteps = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
Pt.unPitchClass (PentaFamily -> [PitchClass]
Sc.familyChroma PentaFamily
Sc.MajorPenta)

pentaSet :: Int -> Set Int
pentaSet :: Int -> Set Int
pentaSet Int
r = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [ (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
s <- [Int]
pentaSteps ]

-- Guide-tone coverage first, avoid tones hard-penalised, foreign tones
-- (outside the bar's M set) priced but not forbidden — an out-of-key
-- pentatonic wins only where the harmony demands it (chromaticism enabled
-- by the pentatonic's melodic self-sufficiency).
pentaEmission :: BarFacts -> Set Int -> Int -> Double
pentaEmission :: BarFacts -> Set Int -> Int -> Double
pentaEmission BarFacts
bf Set Int
mset Int
pr =
  let p :: Set Int
p       = Int -> Set Int
pentaSet Int
pr
      v :: BassVocab
v       = BarFacts -> BassVocab
bfVocab BarFacts
bf
      tgt :: [Int]
tgt     = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub (Int -> [Int] -> [Int]
absOf (BarFacts -> Int
bfRoot BarFacts
bf) (BassVocab -> [Int]
J.bvTarget BassVocab
v))
      strong :: [Int]
strong  = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub (Int -> [Int] -> [Int]
absOf (BarFacts -> Int
bfRoot BarFacts
bf) (BassVocab -> [Int]
J.bvStrong BassVocab
v)) [Int] -> [Int] -> [Int]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => [a] -> t a -> [a]
`minus` [Int]
tgt
      avoid :: [Int]
avoid   = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub (Int -> [Int] -> [Int]
absOf (BarFacts -> Int
bfRoot BarFacts
bf) (BassVocab -> [Int]
J.bvAvoid BassVocab
v))
      minus :: [a] -> t a -> [a]
minus [a]
xs t a
ys = [ a
x | a
x <- [a]
xs, a
x a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t a
ys ]
      count :: [Int] -> b
count [Int]
ps = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ Int
x | Int
x <- [Int]
ps, Int
x Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
p ])
      foreignN :: Double
foreignN = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Set Int -> Int
forall a. Set a -> Int
Set.size (Set Int
p Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Int
mset))
  in Double
3 Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Int] -> Double
forall {b}. Num b => [Int] -> b
count [Int]
tgt Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Int] -> Double
forall {b}. Num b => [Int] -> b
count [Int]
strong Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
3 Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Int] -> Double
forall {b}. Num b => [Int] -> b
count [Int]
avoid Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
foreignN

pentaPath :: [BarFacts] -> [Set Int] -> [Int]
pentaPath :: [BarFacts] -> [Set Int] -> [Int]
pentaPath [] [Set Int]
_ = []
pentaPath [BarFacts]
bfs [Set Int]
msets =
  let n :: Int
n    = [BarFacts] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BarFacts]
bfs
      emit :: Vector (Map Int Double)
emit = [Map Int Double] -> Vector (Map Int Double)
forall a. [a] -> Vector a
V.fromList
               [ [(Int, Double)] -> Map Int Double
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Int
pr, BarFacts -> Set Int -> Int -> Double
pentaEmission BarFacts
bf Set Int
ms Int
pr) | Int
pr <- [Int
0 .. Int
11] ]
               | (BarFacts
bf, Set Int
ms) <- [BarFacts] -> [Set Int] -> [(BarFacts, Set Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BarFacts]
bfs [Set Int]
msets ]
      run :: Int -> (Double, [Int])
run Int
p0 =
        let step :: (Map Int Double, Map Int (Map Int Int))
-> Int -> (Map Int Double, Map Int (Map Int Int))
step (Map Int Double
scores, Map Int (Map Int Int)
bps) Int
i =
              let scores' :: Map Int (Double, Int)
scores' = [(Int, (Double, Int))] -> Map Int (Double, Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                    [ (Int
p', (Double, Int)
cand)
                    | Int
p' <- [Int
0 .. Int
11]
                    , let cand :: (Double, Int)
cand = ((Double, Int) -> (Double, Int) -> Ordering)
-> [(Double, Int)] -> (Double, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Double, Int) -> Double)
-> (Double, Int) -> (Double, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Double, Int) -> Double
forall a b. (a, b) -> a
fst)
                            [ ( Map Int Double
scores Map Int Double -> Int -> Double
forall k a. Ord k => Map k a -> k -> a
Map.! Int
p Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Vector (Map Int Double)
emit Vector (Map Int Double) -> Int -> Map Int Double
forall a. Vector a -> Int -> a
V.! Int
i Map Int Double -> Int -> Double
forall k a. Ord k => Map k a -> k -> a
Map.! Int
p'
                                Double -> Double -> Double
forall a. Num a => a -> a -> a
- (if Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p' then Double
0 else Double
kaPentaLambda), Int
p )
                            | Int
p <- [Int
0 .. Int
11] ] ]
              in (((Double, Int) -> Double)
-> Map Int (Double, Int) -> Map Int Double
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Double, Int) -> Double
forall a b. (a, b) -> a
fst Map Int (Double, Int)
scores', Int
-> Map Int Int -> Map Int (Map Int Int) -> Map Int (Map Int Int)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
i (((Double, Int) -> Int) -> Map Int (Double, Int) -> Map Int Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Double, Int) -> Int
forall a b. (a, b) -> b
snd Map Int (Double, Int)
scores') Map Int (Map Int Int)
bps)
            init0 :: (Map Int Double, Map k a)
init0 = ( [(Int, Double)] -> Map Int Double
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                        [ (Int
p, if Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p0 then Vector (Map Int Double)
emit Vector (Map Int Double) -> Int -> Map Int Double
forall a. Vector a -> Int -> a
V.! Int
0 Map Int Double -> Int -> Double
forall k a. Ord k => Map k a -> k -> a
Map.! Int
p0 else -Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0)
                        | Int
p <- [Int
0 .. Int
11] ]
                    , Map k a
forall k a. Map k a
Map.empty )
            (Map Int Double
final, Map Int (Map Int Int)
paths) = ((Map Int Double, Map Int (Map Int Int))
 -> Int -> (Map Int Double, Map Int (Map Int Int)))
-> (Map Int Double, Map Int (Map Int Int))
-> [Int]
-> (Map Int Double, Map Int (Map Int Int))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map Int Double, Map Int (Map Int Int))
-> Int -> (Map Int Double, Map Int (Map Int Int))
step (Map Int Double, Map Int (Map Int Int))
forall {k} {a}. (Map Int Double, Map k a)
init0 [Int
1 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
            wrap :: Int -> Double
wrap Int
p = Map Int Double
final Map Int Double -> Int -> Double
forall k a. Ord k => Map k a -> k -> a
Map.! Int
p Double -> Double -> Double
forall a. Num a => a -> a -> a
- (if Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p0 then Double
0 else Double
kaPentaLambda)
            pLast :: Int
pLast  = (Int -> Int -> Ordering) -> [Int] -> Int
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((Int -> Double) -> Int -> Int -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Int -> Double
wrap) [Int
0 .. Int
11]
            walkBack :: Int -> Int -> [Int] -> [Int]
walkBack Int
i Int
p [Int]
acc
              | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = Int
p Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
acc
              | Bool
otherwise = Int -> Int -> [Int] -> [Int]
walkBack (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ((Map Int (Map Int Int)
paths Map Int (Map Int Int) -> Int -> Map Int Int
forall k a. Ord k => Map k a -> k -> a
Map.! Int
i) Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! Int
p) (Int
p Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
acc)
        in (Int -> Double
wrap Int
pLast, if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then [Int
p0] else Int -> Int -> [Int] -> [Int]
walkBack (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
pLast [])
      (Double
_, [Int]
best) = ((Double, [Int]) -> (Double, [Int]) -> Ordering)
-> [(Double, [Int])] -> (Double, [Int])
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Double, [Int]) -> Double)
-> (Double, [Int]) -> (Double, [Int]) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Double, [Int]) -> Double
forall a b. (a, b) -> a
fst) ((Int -> (Double, [Int])) -> [Int] -> [(Double, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (Double, [Int])
run [Int
0 .. Int
11])
  in [Int]
best

-------------------------------------------------------------------------------
-- Public analysis
-------------------------------------------------------------------------------

-- |Analyze a finished progression: one 'BarAnalysis' per bar. Pure and
-- deterministic; cyclic (the wrap edge counts, so rotating the bars
-- rotates the answers).
analyzeProgression :: Pr.Progression -> [BarAnalysis]
analyzeProgression :: Progression -> [BarAnalysis]
analyzeProgression Progression
prog =
  let bars :: [CadenceState]
bars = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Pr.unProgression Progression
prog)
      bfs :: [BarFacts]
bfs  = (CadenceState -> BarFacts) -> [CadenceState] -> [BarFacts]
forall a b. (a -> b) -> [a] -> [b]
map CadenceState -> BarFacts
barFacts [CadenceState]
bars
      keys :: [(KeyArea, KeyForm)]
keys = [BarFacts] -> [(KeyArea, KeyForm)]
bestKeyPath [BarFacts]
bfs
      mres :: [(Set Int, ModeTier)]
mres = [ BarFacts -> (KeyArea, KeyForm) -> (Set Int, ModeTier)
mSetFor BarFacts
bf (KeyArea, KeyForm)
ka | (BarFacts
bf, (KeyArea, KeyForm)
ka) <- [BarFacts]
-> [(KeyArea, KeyForm)] -> [(BarFacts, (KeyArea, KeyForm))]
forall a b. [a] -> [b] -> [(a, b)]
zip [BarFacts]
bfs [(KeyArea, KeyForm)]
keys ]
      ps :: [Int]
ps   = [BarFacts] -> [Set Int] -> [Int]
pentaPath [BarFacts]
bfs (((Set Int, ModeTier) -> Set Int)
-> [(Set Int, ModeTier)] -> [Set Int]
forall a b. (a -> b) -> [a] -> [b]
map (Set Int, ModeTier) -> Set Int
forall a b. (a, b) -> a
fst [(Set Int, ModeTier)]
mres)
      n :: Int
n    = [CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
bars
      keyAt :: Int -> KeyArea
keyAt Int
i = (KeyArea, KeyForm) -> KeyArea
forall a b. (a, b) -> a
fst ([(KeyArea, KeyForm)]
keys [(KeyArea, KeyForm)] -> Int -> (KeyArea, KeyForm)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n))
  in [ BarAnalysis
         { baKey :: KeyArea
baKey        = KeyArea
key
         , baForm :: KeyForm
baForm       = KeyForm
fm
         , baModeSet :: Set Int
baModeSet    = Set Int
mset
         , baMode :: Maybe Mode
baMode       = Int -> [PitchClass] -> Maybe Mode
Sc.classifyModeAt (BarFacts -> Int
bfRoot BarFacts
bf)
                            ((Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
Pt.mkPitchClass (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
mset))
         , baTier :: ModeTier
baTier       = ModeTier
tier
         , baPentaRoot :: Int
baPentaRoot  = Int
pr
         , baPentaInKey :: Bool
baPentaInKey = Int -> Set Int
pentaSet Int
pr Set Int -> Set Int -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Int
mset
         , baBoundary :: Bool
baBoundary   = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& KeyArea
key KeyArea -> KeyArea -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> KeyArea
keyAt (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
         }
     | (Int
i, BarFacts
bf, (KeyArea
key, KeyForm
fm), (Set Int
mset, ModeTier
tier), Int
pr)
         <- [Int]
-> [BarFacts]
-> [(KeyArea, KeyForm)]
-> [(Set Int, ModeTier)]
-> [Int]
-> [(Int, BarFacts, (KeyArea, KeyForm), (Set Int, ModeTier), Int)]
forall {a} {b} {c} {d} {e}.
[a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)]
zip5 [Int
0 ..] [BarFacts]
bfs [(KeyArea, KeyForm)]
keys [(Set Int, ModeTier)]
mres [Int]
ps
     ]
  where
    zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)]
zip5 (a
a:[a]
as) (b
b:[b]
bs) (c
c:[c]
cs) (d
d:[d]
ds) (e
e:[e]
es) = (a
a, b
b, c
c, d
d, e
e) (a, b, c, d, e) -> [(a, b, c, d, e)] -> [(a, b, c, d, e)]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)]
zip5 [a]
as [b]
bs [c]
cs [d]
ds [e]
es
    zip5 [a]
_ [b]
_ [c]
_ [d]
_ [e]
_ = []

-- |Per-bar 7-PC palettes for the walking bass — the M sets of
-- 'analyzeProgression', in the exact shape the walk consumes.
barPalettes :: Pr.Progression -> V.Vector (Set Int)
barPalettes :: Progression -> Vector (Set Int)
barPalettes = [Set Int] -> Vector (Set Int)
forall a. [a] -> Vector a
V.fromList ([Set Int] -> Vector (Set Int))
-> (Progression -> [Set Int]) -> Progression -> Vector (Set Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BarAnalysis -> Set Int) -> [BarAnalysis] -> [Set Int]
forall a b. (a -> b) -> [a] -> [b]
map BarAnalysis -> Set Int
baModeSet ([BarAnalysis] -> [Set Int])
-> (Progression -> [BarAnalysis]) -> Progression -> [Set Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Progression -> [BarAnalysis]
analyzeProgression

-------------------------------------------------------------------------------
-- Layer derivation
-------------------------------------------------------------------------------

-- |Fill the S (pentatonic) and M (mode) layers of a context from the
-- key-area analysis of its triad layer. Identity on 'PC.FStrata' and
-- 'PC.FPoly' contexts, whose layers are already meaningful. Layer bars are
-- built exactly like genP's aux layers ('H.Unison' movement, chroma
-- expressed as intervals from the bar root), so they voice through the
-- same chroma engine ('Harmonic.Interface.Tidal.Arranger.strataModeFlow')
-- and print as mode names via the
-- 7-PC display path. The M bar is rooted on the bar's harmonic root (the
-- mode OF the bar — every tier of the override ladder contains it); the S
-- bar is rooted on the PENTATONIC's own root — a pentatonic legitimately
-- excludes the chord root (the pent-on-the-fifth over a maj7 does so by
-- design), and the set is named from its own root. (Bar roots seed only
-- bar 0's lattice in the chroma engine; pattern indices then track their
-- lattice slot, not the bar root.)
-- Provenance stays 'Nothing' (provenance is strata-specific and gates
-- strata regen \/ scoring).
--
-- The derived bars are forced to normal form as part of the result's
-- WHNF: 'PC.ProgressionContext' fields are lazy, and the first thing to
-- inspect an unforced layer can be the derived 'Eq' inside an arrange \/
-- lineHarmony cache lookup — i.e. the audio thread. Generated contexts
-- are forced when the generator prints them, so their analysis always
-- lands at generation time; a hand-applied 'chordscale' evaluates at its
-- own first use — print it (or run
-- 'Harmonic.Interface.Tidal.ChordscaleT.chordscaleReport' on it) at build time to
-- keep the work off the performance path.
chordscale :: PC.ProgressionContext -> PC.ProgressionContext
chordscale :: ProgressionContext -> ProgressionContext
chordscale ProgressionContext
ctx
  | ProgressionContext -> Family
PC.pcFamily ProgressionContext
ctx Family -> [Family] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Family
PC.FStrata, Family
PC.FPoly] = ProgressionContext
ctx
  | Progression -> Int
Pr.progLength (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
ctx) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0        = ProgressionContext
ctx
  | Bool
otherwise =
      let bars :: [CadenceState]
bars = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Pr.unProgression (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
ctx))
          anns :: [BarAnalysis]
anns = Progression -> [BarAnalysis]
analyzeProgression (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
ctx)
          mk :: NoteName -> Set Int -> CadenceState
mk NoteName
rootN Set Int
set =
            let rootPC :: Int
rootPC = PitchClass -> Int
Pt.unPitchClass (NoteName -> PitchClass
Pt.pitchClass NoteName
rootN)
                ivs :: [Int]
ivs    = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [ (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
rootPC) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
p <- Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
set ])
            in NoteName -> Movement -> [Int] -> CadenceState
H.mkCadenceStatePCs NoteName
rootN Movement
H.Unison [Int]
ivs
          spellAs :: CadenceState -> Int -> NoteName
spellAs CadenceState
cs = case CadenceState -> EnharmonicSpelling
H.stateSpelling CadenceState
cs of
            EnharmonicSpelling
H.FlatSpelling -> PitchClass -> NoteName
Pt.flat (PitchClass -> NoteName) -> (Int -> PitchClass) -> Int -> NoteName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PitchClass
Pt.mkPitchClass
            EnharmonicSpelling
_              -> PitchClass -> NoteName
Pt.sharp (PitchClass -> NoteName) -> (Int -> PitchClass) -> Int -> NoteName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PitchClass
Pt.mkPitchClass
          -- The M bar roots on the harmonic root; when that root is not a
          -- member of the set (a silent bar's default root, never a real
          -- override tier), fall to the set's lowest member — the
          -- constructor force-inserts interval 0, so an outside root would
          -- silently grow the bar to 8 tones.
          mRootFor :: CadenceState -> BarAnalysis -> NoteName
mRootFor CadenceState
cs BarAnalysis
a
            | BarFacts -> Int
bfRoot BarFacts
facts Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` BarAnalysis -> Set Int
baModeSet BarAnalysis
a =
                Chord -> NoteName
H.chordNoteName (CadenceState -> Chord
H.fromCadenceState CadenceState
cs)
            | Bool
otherwise = CadenceState -> Int -> NoteName
spellAs CadenceState
cs (Set Int -> Int
forall a. Set a -> a
Set.findMin (BarAnalysis -> Set Int
baModeSet BarAnalysis
a))
            where facts :: BarFacts
facts = CadenceState -> BarFacts
barFacts CadenceState
cs
          sBars :: [CadenceState]
sBars = [ NoteName -> Set Int -> CadenceState
mk (CadenceState -> Int -> NoteName
spellAs CadenceState
cs (BarAnalysis -> Int
baPentaRoot BarAnalysis
a)) (Int -> Set Int
pentaSet (BarAnalysis -> Int
baPentaRoot BarAnalysis
a))
                  | (CadenceState
cs, BarAnalysis
a) <- [CadenceState] -> [BarAnalysis] -> [(CadenceState, BarAnalysis)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CadenceState]
bars [BarAnalysis]
anns ]
          mBars :: [CadenceState]
mBars = [ NoteName -> Set Int -> CadenceState
mk (CadenceState -> BarAnalysis -> NoteName
mRootFor CadenceState
cs BarAnalysis
a) (BarAnalysis -> Set Int
baModeSet BarAnalysis
a)
                  | (CadenceState
cs, BarAnalysis
a) <- [CadenceState] -> [BarAnalysis] -> [(CadenceState, BarAnalysis)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CadenceState]
bars [BarAnalysis]
anns ]
          forceBars :: [CadenceState] -> ()
forceBars = (CadenceState -> () -> ()) -> () -> [CadenceState] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\CadenceState
cs ()
acc -> CadenceState -> EnharmonicSpelling
forceCS CadenceState
cs EnharmonicSpelling -> () -> ()
forall a b. a -> b -> b
`seq` ()
acc) ()
          forceCS :: CadenceState -> EnharmonicSpelling
forceCS CadenceState
cs =
            let cad :: Cadence
cad = CadenceState -> Cadence
H.stateCadence CadenceState
cs
            in [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cadence -> [Char]
H.cadenceFunctionality Cadence
cad)
               Int -> EnharmonicSpelling -> EnharmonicSpelling
forall a b. a -> b -> b
`seq` (PitchClass -> () -> ()) -> () -> [PitchClass] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PitchClass -> () -> ()
forall a b. a -> b -> b
seq () (Cadence -> [PitchClass]
H.cadenceIntervals Cadence
cad)
               () -> EnharmonicSpelling -> EnharmonicSpelling
forall a b. a -> b -> b
`seq` CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs
               NoteName -> EnharmonicSpelling -> EnharmonicSpelling
forall a b. a -> b -> b
`seq` CadenceState -> EnharmonicSpelling
H.stateSpelling CadenceState
cs
          sLayer :: Progression
sLayer = [CadenceState] -> Progression
Pr.fromCadenceStates [CadenceState]
sBars
          mLayer :: Progression
mLayer = [CadenceState] -> Progression
Pr.fromCadenceStates [CadenceState]
mBars
      in [CadenceState] -> ()
forceBars [CadenceState]
sBars () -> ProgressionContext -> ProgressionContext
forall a b. a -> b -> b
`seq` [CadenceState] -> ()
forceBars [CadenceState]
mBars
         () -> ProgressionContext -> ProgressionContext
forall a b. a -> b -> b
`seq` Progression -> Int
Pr.progLength Progression
sLayer Int -> ProgressionContext -> ProgressionContext
forall a b. a -> b -> b
`seq` Progression -> Int
Pr.progLength Progression
mLayer
         Int -> ProgressionContext -> ProgressionContext
forall a b. a -> b -> b
`seq` ProgressionContext
ctx { PC.strataLayer = sLayer, PC.modeLayer = mLayer }