-- |
-- Module      : Harmonic.Framework.Builder.PolyGen
-- Description : The genE paradigm — polytonal three-layer generation
--
-- The foundation progression (T layer) is a plain 'Harmonic.Framework.Builder.gen'
-- walk, byte-identical to it: same chain builder, same R constraints, same
-- entropy dial. Two partner triad chains (S\/M layers) are then walked over
-- the finished foundation, one bar at a time. Each partner draws from a
-- fresh transition list fetched from ITS OWN previous state — every partner
-- bar is a corpus-valid continuation of its own layer history — filtered to
-- the polytonal overlap rules against that bar's foundation triad:
--
-- * each partner shares exactly 2 pitch classes with the foundation bar;
-- * the three triads union to exactly 5 pitch classes.
--
-- Those two rules admit exactly two geometries per bar, and the traversal
-- chooses freely between them: COMMON-DYAD (all three triads share one
-- dyad; every layer pair sounds 4 tones) and BASE-ANCHORED (the partners
-- share different dyads of the foundation; T+S and T+M sound 4 tones, S+M
-- sounds the full pentad). The hub-tone shape (three different dyads
-- through one tone) unions to 4 and is excluded.
--
-- Partners honour the harmonic-space constraints only — key, allowed
-- roots, overtones — through the same R predicate as the walk
-- ('Core.matchesContextWithTarget' with no bass target). Root-motion
-- direction specs, drift, pedal and inversion spacing bind the foundation
-- alone: the foundation owns the bass whenever it is present, and the
-- partner layers stay free to diverge.
--
-- Selection: jointly valid (S, M) pairs are ranked by summed own-list rank
-- and drawn with ONE entropy-scaled gamma draw over the pair pool (the
-- two-stage per-layer alternative saturates the entropy dial at the ~8-
-- candidate second pool; the joint pool sits at ~100-324 where the dial is
-- monotone — measured in archive\/analysis\/poly_seq.md). Supply relaxes
-- down tiers when a list runs dry: one side from the space-constrained
-- pure enumeration over all 220 absolute 3-PC sets, then both, then the
-- unconstrained enumeration — the last is total, so partner selection can
-- never fail (the study measured the list tier alone at 100% over 2,100
-- live steps; archive\/analysis\/poly_chain.md).
--
-- S\/M identity is assigned once, after generation: the chain with the
-- lower whole-layer dissonance total becomes S. Per-bar assignment would
-- swap chain membership at ~45% of bar boundaries and destroy the very
-- layer identity the chains provide.
module Harmonic.Framework.Builder.PolyGen
  ( runPolyGen
  , runPolyGenFrom
  ) where

import           Data.Bits ((.&.), (.|.), popCount, setBit, testBit)
import           Data.Foldable (toList)
import           Data.List (intercalate, sort, sortBy)
import qualified Data.Map.Strict as Map
import           Data.Ord (comparing)
import qualified Data.Text as T
import           Control.Monad (when)
import           System.Random.MWC (GenIO, createSystemRandom)

import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as P
import qualified Harmonic.Rules.Types.Progression as Prog
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import           Harmonic.Evaluation.Scoring.Dissonance (dissonanceScore)
import           Harmonic.Traversal.Probabilistic (gammaIndexScaledWith)

import           Harmonic.Framework.Builder.Types
import           Harmonic.Framework.Builder.Core
                   ( TransitionSource, sourceFor, buildChainWith, tonalStartCue
                   , chainToProgression, extractCadence
                   , matchesContextWithTarget )
import           Harmonic.Framework.Builder.StrataGen (mkStarterDiag)

-------------------------------------------------------------------------------
-- Pitch-class set machinery
-------------------------------------------------------------------------------

-- Absolute pitch classes of a bar as a 12-bit mask.
absMask :: H.CadenceState -> Int
absMask :: CadenceState -> Int
absMask CadenceState
cs =
  let r :: Int
r = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs))
  in (Int -> Int -> Int) -> Int -> [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' Int -> Int -> Int
forall a. Bits a => a -> Int -> a
setBit Int
0 [ (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PitchClass -> Int
P.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) ]

pcsOf :: Int -> [Int]
pcsOf :: Int -> [Int]
pcsOf Int
m = [ Int
p | Int
p <- [Int
0 .. Int
11], Int -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int
m Int
p ]

-- Every absolute 3-PC set — the total partner universe behind the
-- enumeration tiers.
allTriadMasks :: [Int]
allTriadMasks :: [Int]
allTriadMasks = [ Int
m | Int
m <- [Int
7 .. Int
4095], Int -> Int
forall a. Bits a => a -> Int
popCount Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 ]

-- Both admitted geometries in one predicate: each partner already shares
-- exactly 2 tones with the foundation, so union 5 admits common-dyad
-- (S∩M = 2, the shared dyad) and base-anchored (S∩M = 1, the hub tone)
-- while excluding hub-tone triples and coincident partners (union 4).
unionOK :: Int -> Int -> Int -> Bool
unionOK :: Int -> Int -> Int -> Bool
unionOK Int
t Int
s Int
m = Int -> Int
forall a. Bits a => a -> Int
popCount (Int
t Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
s Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
m) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5

-- Harmonic root of an unrooted PC set: build from the lowest tone and let
-- inversion detection name the true root (deterministic on rotation ties).
harmonicRoot :: Int -> Int
harmonicRoot :: Int -> Int
harmonicRoot Int
m =
  let pcs :: [Int]
pcs = Int -> [Int]
pcsOf Int
m
      low :: Int
low = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
pcs
      cs :: CadenceState
cs  = NoteName -> Movement -> [Int] -> CadenceState
H.mkCadenceStatePCs (PitchClass -> NoteName
P.flat (Int -> PitchClass
P.mkPitchClass Int
low)) Movement
H.Unison
              [ (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
low) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
p <- [Int]
pcs ]
  in PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (Chord -> NoteName
H.chordNoteName (CadenceState -> Chord
H.fromCadenceState CadenceState
cs)))

-------------------------------------------------------------------------------
-- Partner chain steps
-------------------------------------------------------------------------------

-- Advance a partner chain onto a candidate cadence: root moves by the
-- cadence's movement, spelling carries over (partner chains keep a stable
-- enharmonic side rather than re-inferring per bar).
advCand :: H.CadenceState -> H.Cadence -> H.CadenceState
advCand :: CadenceState -> Cadence -> CadenceState
advCand CadenceState
prev Cadence
cad =
  let r' :: PitchClass
r' = NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
prev) PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ Movement -> PitchClass
H.fromMovement (Cadence -> Movement
H.cadenceMovement Cadence
cad)
      sp :: EnharmonicSpelling
sp = CadenceState -> EnharmonicSpelling
H.stateSpelling CadenceState
prev
  in Cadence -> NoteName -> EnharmonicSpelling -> CadenceState
H.CadenceState Cadence
cad (EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
sp PitchClass
r') EnharmonicSpelling
sp

-- A ranked eligible continuation: rank in the (corpus-sorted) source it
-- came from, and the advanced state.
type Elig = (Int, (Int, H.CadenceState))   -- (mask, (rank, state))

-- Eligible continuations from a partner's own transition list: advanced
-- set shares exactly 2 tones with the foundation bar, differs from it, and
-- passes the harmonic-space R predicate (no bass target — direction specs
-- never bind partners). Deduped by advanced set, best list rank kept.
listEligible :: ParsedContext -> Int -> H.CadenceState -> [(H.Cadence, Double)] -> [Elig]
listEligible :: ParsedContext
-> Int -> CadenceState -> [(Cadence, Double)] -> [Elig]
listEligible ParsedContext
pctx Int
tMask CadenceState
prev [(Cadence, Double)]
ts =
  Map Int (Int, CadenceState) -> [Elig]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Int (Int, CadenceState) -> [Elig])
-> Map Int (Int, CadenceState) -> [Elig]
forall a b. (a -> b) -> a -> b
$ ((Int, CadenceState) -> (Int, CadenceState) -> (Int, CadenceState))
-> [Elig] -> Map Int (Int, CadenceState)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\(Int, CadenceState)
a (Int, CadenceState)
b -> if (Int, CadenceState) -> Int
forall a b. (a, b) -> a
fst (Int, CadenceState)
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int, CadenceState) -> Int
forall a b. (a, b) -> a
fst (Int, CadenceState)
b then (Int, CadenceState)
a else (Int, CadenceState)
b)
    [ (Int
mk, (Int
rank, CadenceState
st))
    | (Int
rank, (Cadence
cad, Double
_)) <- [Int] -> [(Cadence, Double)] -> [(Int, (Cadence, Double))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [(Cadence, Double)]
ts
    , Maybe Int -> ParsedContext -> CadenceState -> Cadence -> Bool
matchesContextWithTarget Maybe Int
forall a. Maybe a
Nothing ParsedContext
pctx CadenceState
prev Cadence
cad
    , let st :: CadenceState
st = CadenceState -> Cadence -> CadenceState
advCand CadenceState
prev Cadence
cad
          mk :: Int
mk = CadenceState -> Int
absMask CadenceState
st
    , Int
mk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
tMask
    -- Each layer is a triad by the overlap algebra. The enumeration tiers
    -- are 3-PC by construction; the list tier inherits whatever the corpus
    -- holds, so the contract is asserted rather than assumed.
    , Int -> Int
forall a. Bits a => a -> Int
popCount Int
mk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
    , Int -> Int
forall a. Bits a => a -> Int
popCount (Int
mk Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
tMask) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 ]

-- Eligible continuations from the pure enumeration: every 3-PC set sharing
-- exactly 2 tones with the foundation bar, rooted on its own detected
-- harmonic root, reached by the real root movement from the partner's
-- previous bar. Ranked consonant-first AFTER any list candidates
-- (@baseRank@ = the list length), so list material always outranks
-- enumerated material at equal pool tier. The space flag applies the same
-- R predicate as the list tier; the unconstrained tier drops it and is
-- total — partner selection can never fail.
enumEligible :: Bool -> ParsedContext -> Int -> Int -> H.CadenceState -> [Elig]
enumEligible :: Bool -> ParsedContext -> Int -> Int -> CadenceState -> [Elig]
enumEligible Bool
space ParsedContext
pctx Int
baseRank Int
tMask CadenceState
prev =
  [ (Int
mk, (Int
baseRank Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i, CadenceState -> Cadence -> CadenceState
advCand CadenceState
prev Cadence
cad))
  | (Int
i, (Int
mk, Cadence
cad)) <- [Int] -> [(Int, Cadence)] -> [(Int, (Int, Cadence))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [(Int, Cadence)]
ranked
  , Bool -> Bool
not Bool
space Bool -> Bool -> Bool
|| Maybe Int -> ParsedContext -> CadenceState -> Cadence -> Bool
matchesContextWithTarget Maybe Int
forall a. Maybe a
Nothing ParsedContext
pctx CadenceState
prev Cadence
cad ]
  where
    prevRootPC :: PitchClass
prevRootPC = NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
prev)
    candOf :: Int -> (Int, Cadence)
candOf Int
mk =
      let root :: Int
root = Int -> Int
harmonicRoot Int
mk
          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
root) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
p <- Int -> [Int]
pcsOf Int
mk ]
          zfP :: [PitchClass]
zfP  = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P.mkPitchClass [Int]
zf
          mv :: Movement
mv   = PitchClass -> PitchClass -> Movement
H.toMovement PitchClass
prevRootPC (Int -> PitchClass
P.mkPitchClass Int
root)
      in (Int
mk, Functionality -> Movement -> [PitchClass] -> Cadence
H.Cadence ([PitchClass] -> Functionality
H.corpusFunctionality [PitchClass]
zfP) Movement
mv [PitchClass]
zfP)
    ranked :: [(Int, Cadence)]
ranked = ((Int, Cadence) -> (Int, Cadence) -> Ordering)
-> [(Int, Cadence)] -> [(Int, Cadence)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, Cadence) -> Integer)
-> (Int, Cadence) -> (Int, Cadence) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int -> Integer
dissOfMask (Int -> Integer)
-> ((Int, Cadence) -> Int) -> (Int, Cadence) -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Cadence) -> Int
forall a b. (a, b) -> a
fst))
               [ Int -> (Int, Cadence)
candOf Int
mk | Int
mk <- [Int]
allTriadMasks
                           , Int
mk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
tMask
                           , Int -> Int
forall a. Bits a => a -> Int
popCount (Int
mk Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
tMask) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 ]

-- Stored-zero-form dissonance of a set read from its detected root.
dissOfMask :: Int -> Integer
dissOfMask :: Int -> Integer
dissOfMask Int
m =
  let r :: Int
r = Int -> Int
harmonicRoot Int
m
  in [Int] -> Integer
dissonanceScore ([Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [ (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
p <- Int -> [Int]
pcsOf Int
m ])

-- Jointly valid (candidate-for-chain-1, candidate-for-chain-2) pairs,
-- ranked by summed rank so the corpus ordering shapes the pool the gamma
-- draw explores.
jointPairs :: Int -> [Elig] -> [Elig] -> [((Int, H.CadenceState), (Int, H.CadenceState))]
jointPairs :: Int
-> [Elig] -> [Elig] -> [((Int, CadenceState), (Int, CadenceState))]
jointPairs Int
tMask [Elig]
e1 [Elig]
e2 =
  (((Int, CadenceState), (Int, CadenceState))
 -> ((Int, CadenceState), (Int, CadenceState)) -> Ordering)
-> [((Int, CadenceState), (Int, CadenceState))]
-> [((Int, CadenceState), (Int, CadenceState))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((((Int, CadenceState), (Int, CadenceState)) -> Int)
-> ((Int, CadenceState), (Int, CadenceState))
-> ((Int, CadenceState), (Int, CadenceState))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\((Int
r1, CadenceState
_), (Int
r2, CadenceState
_)) -> Int
r1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r2))
    [ ((Int, CadenceState)
c1, (Int, CadenceState)
c2)
    | (Int
m1, (Int, CadenceState)
c1) <- [Elig]
e1, (Int
m2, (Int, CadenceState)
c2) <- [Elig]
e2
    , Int -> Int -> Int -> Bool
unionOK Int
tMask Int
m1 Int
m2 ]

-- Raw per-bar selection facts, chain-labelled (S\/M assignment happens at
-- the end); the renderers consume these through 'PolyDiag'.
data RawStep = RawStep
  { RawStep -> Functionality
rsTier  :: String
  , RawStep -> Int
rsPoolK :: Int
  , RawStep -> Maybe Int
rsRank1 :: Maybe Int   -- chain-1 candidate's own-list rank (Nothing = enumerated)
  , RawStep -> Maybe Int
rsRank2 :: Maybe Int
  }

-- One partner step: both chains fetch their own lists, tiers relax from
-- list×list through enumeration until a pool exists (the unconstrained
-- floor is total).
stepPartners :: GenIO -> TransitionSource -> ParsedContext -> Double
             -> H.CadenceState -> (H.CadenceState, H.CadenceState)
             -> IO (H.CadenceState, H.CadenceState, RawStep)
stepPartners :: GenIO
-> TransitionSource
-> ParsedContext
-> Double
-> CadenceState
-> (CadenceState, CadenceState)
-> IO (CadenceState, CadenceState, RawStep)
stepPartners GenIO
rng TransitionSource
source ParsedContext
pctx Double
ent CadenceState
tBar (CadenceState
prev1, CadenceState
prev2) = do
  ts1 <- TransitionSource
source (Functionality -> Text
T.pack (Cadence -> Functionality
forall a. Show a => a -> Functionality
show (CadenceState -> Cadence
H.stateCadence CadenceState
prev1)))
  ts2 <- source (T.pack (show (H.stateCadence prev2)))
  let tMask = CadenceState -> Int
absMask CadenceState
tBar
      l1 = ParsedContext
-> Int -> CadenceState -> [(Cadence, Double)] -> [Elig]
listEligible ParsedContext
pctx Int
tMask CadenceState
prev1 [(Cadence, Double)]
ts1
      l2 = ParsedContext
-> Int -> CadenceState -> [(Cadence, Double)] -> [Elig]
listEligible ParsedContext
pctx Int
tMask CadenceState
prev2 [(Cadence, Double)]
ts2
      e1 = Bool -> ParsedContext -> Int -> Int -> CadenceState -> [Elig]
enumEligible Bool
True  ParsedContext
pctx ([(Cadence, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Cadence, Double)]
ts1) Int
tMask CadenceState
prev1
      e2 = Bool -> ParsedContext -> Int -> Int -> CadenceState -> [Elig]
enumEligible Bool
True  ParsedContext
pctx ([(Cadence, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Cadence, Double)]
ts2) Int
tMask CadenceState
prev2
      u1 = Bool -> ParsedContext -> Int -> Int -> CadenceState -> [Elig]
enumEligible Bool
False ParsedContext
pctx ([(Cadence, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Cadence, Double)]
ts1) Int
tMask CadenceState
prev1
      u2 = Bool -> ParsedContext -> Int -> Int -> CadenceState -> [Elig]
enumEligible Bool
False ParsedContext
pctx ([(Cadence, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Cadence, Double)]
ts2) Int
tMask CadenceState
prev2
      ladder = [ (Functionality
"list",      Int
-> [Elig] -> [Elig] -> [((Int, CadenceState), (Int, CadenceState))]
jointPairs Int
tMask [Elig]
l1 [Elig]
l2)
               , (Functionality
"list+enum", Int
-> [Elig] -> [Elig] -> [((Int, CadenceState), (Int, CadenceState))]
jointPairs Int
tMask [Elig]
l1 [Elig]
e2)
               , (Functionality
"list+enum", Int
-> [Elig] -> [Elig] -> [((Int, CadenceState), (Int, CadenceState))]
jointPairs Int
tMask [Elig]
e1 [Elig]
l2)
               , (Functionality
"enum",      Int
-> [Elig] -> [Elig] -> [((Int, CadenceState), (Int, CadenceState))]
jointPairs Int
tMask [Elig]
e1 [Elig]
e2)
               , (Functionality
"free",      Int
-> [Elig] -> [Elig] -> [((Int, CadenceState), (Int, CadenceState))]
jointPairs Int
tMask [Elig]
u1 [Elig]
u2) ]
      listRank a
listed a
r = if a
r a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
listed then a -> Maybe a
forall a. a -> Maybe a
Just a
r else Maybe a
forall a. Maybe a
Nothing
  case filter (not . null . snd) ladder of
    ((Functionality
tier, [((Int, CadenceState), (Int, CadenceState))]
pool) : [(Functionality, [((Int, CadenceState), (Int, CadenceState))])]
_) -> do
      idx <- GenIO -> Double -> Int -> IO Int
gammaIndexScaledWith GenIO
rng Double
ent ([((Int, CadenceState), (Int, CadenceState))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((Int, CadenceState), (Int, CadenceState))]
pool)
      let ((r1, st1), (r2, st2)) = pool !! idx
      pure ( st1, st2
           , RawStep tier (length pool)
                     (listRank (length ts1) r1) (listRank (length ts2) r2) )
    [] -> Functionality -> IO (CadenceState, CadenceState, RawStep)
forall a. HasCallStack => Functionality -> a
error Functionality
"genE: partner pool empty at the unconstrained tier — unreachable (the enumeration is total)"

-- Walk both partner chains across the finished foundation. Bar 0 partners
-- come from the enumeration (a cue has no transition list), drawn from the
-- dissonance-ranked space-constrained pool.
partnerPass :: GenIO -> TransitionSource -> ParsedContext -> Double
            -> [H.CadenceState]
            -> IO ([H.CadenceState], [H.CadenceState], [RawStep])
partnerPass :: GenIO
-> TransitionSource
-> ParsedContext
-> Double
-> [CadenceState]
-> IO ([CadenceState], [CadenceState], [RawStep])
partnerPass GenIO
_ TransitionSource
_ ParsedContext
_ Double
_ [] = ([CadenceState], [CadenceState], [RawStep])
-> IO ([CadenceState], [CadenceState], [RawStep])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], [])
partnerPass GenIO
rng TransitionSource
source ParsedContext
pctx Double
ent (CadenceState
cueBar : [CadenceState]
rest) = do
  let tMask0 :: Int
tMask0 = CadenceState -> Int
absMask CadenceState
cueBar
      e0 :: [Elig]
e0     = Bool -> ParsedContext -> Int -> Int -> CadenceState -> [Elig]
enumEligible Bool
True ParsedContext
pctx Int
0 Int
tMask0 CadenceState
cueBar
      u0 :: [Elig]
u0     = Bool -> ParsedContext -> Int -> Int -> CadenceState -> [Elig]
enumEligible Bool
False ParsedContext
pctx Int
0 Int
tMask0 CadenceState
cueBar
      pool0 :: [((Int, CadenceState), (Int, CadenceState))]
pool0  = case Int
-> [Elig] -> [Elig] -> [((Int, CadenceState), (Int, CadenceState))]
jointPairs Int
tMask0 [Elig]
e0 [Elig]
e0 of
                 [] -> Int
-> [Elig] -> [Elig] -> [((Int, CadenceState), (Int, CadenceState))]
jointPairs Int
tMask0 [Elig]
u0 [Elig]
u0
                 [((Int, CadenceState), (Int, CadenceState))]
ps -> [((Int, CadenceState), (Int, CadenceState))]
ps
  idx <- GenIO -> Double -> Int -> IO Int
gammaIndexScaledWith GenIO
rng Double
ent ([((Int, CadenceState), (Int, CadenceState))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((Int, CadenceState), (Int, CadenceState))]
pool0)
  let ((_, s0), (_, m0)) = pool0 !! idx
      raw0 = Functionality -> Int -> Maybe Int -> Maybe Int -> RawStep
RawStep Functionality
"enum" ([((Int, CadenceState), (Int, CadenceState))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((Int, CadenceState), (Int, CadenceState))]
pool0) Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing
      go (CadenceState, CadenceState)
_ [] [(CadenceState, CadenceState, RawStep)]
acc = [(CadenceState, CadenceState, RawStep)]
-> IO [(CadenceState, CadenceState, RawStep)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(CadenceState, CadenceState, RawStep)]
-> [(CadenceState, CadenceState, RawStep)]
forall a. [a] -> [a]
reverse [(CadenceState, CadenceState, RawStep)]
acc)
      go (CadenceState, CadenceState)
prevs (CadenceState
tBar : [CadenceState]
more) [(CadenceState, CadenceState, RawStep)]
acc = do
        (st1, st2, raw) <- GenIO
-> TransitionSource
-> ParsedContext
-> Double
-> CadenceState
-> (CadenceState, CadenceState)
-> IO (CadenceState, CadenceState, RawStep)
stepPartners GenIO
rng TransitionSource
source ParsedContext
pctx Double
ent CadenceState
tBar (CadenceState, CadenceState)
prevs
        go (st1, st2) more ((st1, st2, raw) : acc)
  steps <- go (s0, m0) rest []
  pure ( s0 : [ a | (a, _, _) <- steps ]
       , m0 : [ b | (_, b, _) <- steps ]
       , raw0 : [ r | (_, _, r) <- steps ] )

-- Whole-layer ordering: the chain with the lower dissonance total becomes
-- S. Ties (0-2% of runs) break on canonical zero-forms, then roots —
-- deterministic, no musical claim. The flag reports whether the chains
-- swapped, so per-bar diagnostics can relabel their chain-bound fields.
orderChains :: [H.CadenceState] -> [H.CadenceState]
            -> ([H.CadenceState], [H.CadenceState], Bool)
orderChains :: [CadenceState]
-> [CadenceState] -> ([CadenceState], [CadenceState], Bool)
orderChains [CadenceState]
c1 [CadenceState]
c2 =
  if [CadenceState] -> (Integer, [[Int]], [Int])
keyOf [CadenceState]
c1 (Integer, [[Int]], [Int]) -> (Integer, [[Int]], [Int]) -> Bool
forall a. Ord a => a -> a -> Bool
<= [CadenceState] -> (Integer, [[Int]], [Int])
keyOf [CadenceState]
c2 then ([CadenceState]
c1, [CadenceState]
c2, Bool
False) else ([CadenceState]
c2, [CadenceState]
c1, Bool
True)
  where
    keyOf :: [CadenceState] -> (Integer, [[Int]], [Int])
keyOf [CadenceState]
ch = ( [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((CadenceState -> Integer) -> [CadenceState] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map CadenceState -> Integer
barDiss [CadenceState]
ch)
               , (CadenceState -> [Int]) -> [CadenceState] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Int]
canon (Int -> [Int]) -> (CadenceState -> Int) -> CadenceState -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> Int
absMask) [CadenceState]
ch
               , (CadenceState -> Int) -> [CadenceState] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (PitchClass -> Int
P.unPitchClass (PitchClass -> Int)
-> (CadenceState -> PitchClass) -> CadenceState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteName -> PitchClass
P.pitchClass (NoteName -> PitchClass)
-> (CadenceState -> NoteName) -> CadenceState -> PitchClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> NoteName
H.stateCadenceRoot) [CadenceState]
ch )
    barDiss :: CadenceState -> Integer
barDiss CadenceState
cs = [Int] -> Integer
dissonanceScore
      ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs)))
    canon :: Int -> [Int]
canon Int
m = [[Int]] -> [Int]
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [ (Int
p 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 | Int
p <- Int -> [Int]
pcsOf Int
m ] | Int
t <- Int -> [Int]
pcsOf Int
m ]

-------------------------------------------------------------------------------
-- Runner
-------------------------------------------------------------------------------

diagLevel :: Verbosity -> Maybe Int
diagLevel :: Verbosity -> Maybe Int
diagLevel Verbosity
Silent   = Maybe Int
forall a. Maybe a
Nothing
diagLevel Verbosity
Standard = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
diagLevel Verbosity
Verbose  = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2

-- |Execute a 'PolyMode' config: foundation walk (byte-identical to 'gen'),
-- then the partner pass, then S\/M assignment.
runPolyGen :: GenConfig -> IO (PC.ProgressionContext, GenerationDiagnostics)
runPolyGen :: GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
runPolyGen GenConfig
gc = do
  start <- if GenConfig -> Bool
_gcCueExplicit GenConfig
gc then GenConfig -> IO CadenceState
_gcCue GenConfig
gc else GenConfig -> IO CadenceState
tonalStartCue GenConfig
gc
  when (length (H.cadenceIntervals (H.stateCadence start)) /= 3) $
    error "genE cues are exactly 3 tones — each layer is a triad by the overlap algebra; richer structures come from combining layers (TS/TM/SM/TSM), not from the cue"
  let pctx = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
      n    = GenConfig -> Int
_gcLen GenConfig
gc
  rng    <- createSystemRandom
  source <- sourceFor (T.pack (_gcSeek gc))
  (chain, stepDiags) <- buildChainWith source rng
                          (diagLevel (_gcVerbosity gc)) (_gcEntropy gc)
                          (_gcTonal gc) (const pctx) start (n - 1)
  (p1, p2, raws) <- partnerPass rng source pctx (_gcEntropy gc) chain
  let (sChain, mChain, swapped) = orderChains p1 p2
      prog = [CadenceState] -> Progression
chainToProgression [CadenceState]
chain
      pcx = PC.ProgressionContext
        { triadLayer :: Progression
PC.triadLayer   = Progression
prog
        , strataLayer :: Progression
PC.strataLayer  = [CadenceState] -> Progression
Prog.fromCadenceStates [CadenceState]
sChain
        , modeLayer :: Progression
PC.modeLayer    = [CadenceState] -> Progression
Prog.fromCadenceStates [CadenceState]
mChain
        , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance = Maybe (Seq (Tristrata, StrataLabel))
forall a. Maybe a
Nothing
        , pcFamily :: Family
PC.pcFamily     = Family
PC.FPoly
        }
      -- Diagnostics carry one entry per bar (starter row for the cue),
      -- each with the bar's PolyDiag; the renderers relabel nothing —
      -- chain-bound fields are already S/M-ordered here.
      -- A one-bar walk takes no steps, so there is no step diagnostic to
      -- hang the bar's PolyDiag on and genE'' prints no per-bar table at
      -- len 1. Degenerate case — the grids still print.
      polySteps = case [StepDiagnostic]
stepDiags of
        [] -> []
        [StepDiagnostic]
_  -> [ StepDiagnostic
d { sdStepNumber = i, sdPoly = Just pd }
              | (Int
i, StepDiagnostic
d, PolyDiag
pd) <- [Int]
-> [StepDiagnostic]
-> [PolyDiag]
-> [(Int, StepDiagnostic, PolyDiag)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
1 ..] (CadenceState -> StepDiagnostic
mkStarterDiag CadenceState
start StepDiagnostic -> [StepDiagnostic] -> [StepDiagnostic]
forall a. a -> [a] -> [a]
: [StepDiagnostic]
stepDiags)
                                   (ProgressionContext -> Bool -> [RawStep] -> [PolyDiag]
polyDiagsFor ProgressionContext
pcx Bool
swapped [RawStep]
raws) ]
      diag = GenerationDiagnostics
        { gdStartCadence :: Functionality
gdStartCadence = Cadence -> Functionality
forall a. Show a => a -> Functionality
show (CadenceState -> Cadence
extractCadence CadenceState
start)
        , gdStartRoot :: Functionality
gdStartRoot    = NoteName -> Functionality
forall a. Show a => a -> Functionality
show (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
start)
        , gdRequestedLen :: Int
gdRequestedLen = Int
n
        , gdActualLen :: Int
gdActualLen    = Progression -> Int
Prog.progLength Progression
prog
        , gdEntropy :: Double
gdEntropy      = GenConfig -> Double
_gcEntropy GenConfig
gc
        , gdSteps :: [StepDiagnostic]
gdSteps        = [StepDiagnostic]
polySteps
        , gdProgression :: Progression
gdProgression  = Progression
prog
        , gdJazzTrace :: [Functionality]
gdJazzTrace    = []
        }
  pure (pcx, diag)

-- |Regenerate a contiguous range of bars within an existing polytonal
-- context. The foundation range regenerates exactly like a 'gen' regen
-- (cue = the bar before the range, inferred by 'genFrom'); both partner
-- chains regenerate over it, seeded from the KEPT partner bars before the
-- range, so every regenerated partner bar continues its own layer's
-- history. The source's S\/M labelling is preserved — a partial regen
-- never reorders chains (that would relabel the kept bars).
--
-- Seam: when the regen does not cover the whole progression, the final
-- regenerated bar's joint pool is additionally filtered to pairs whose
-- partner states can continue onto the kept next partner bars as real
-- graph edges — relaxed when empty (the study measured list-tier supply
-- at 100%, so the filter is a preference, not a wall).
runPolyGenFrom :: PC.ProgressionContext -> Int -> Int -> GenConfig
               -> IO (PC.ProgressionContext, GenerationDiagnostics)
runPolyGenFrom :: ProgressionContext
-> Int
-> Int
-> GenConfig
-> IO (ProgressionContext, GenerationDiagnostics)
runPolyGenFrom ProgressionContext
srcPC Int
s Int
_e GenConfig
gc = do
  start <- GenConfig -> IO CadenceState
_gcCue GenConfig
gc
  let pctx  = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
      srcN  = ProgressionContext -> Int
PC.pcLength ProgressionContext
srcPC
      rSize = GenConfig -> Int
_gcLen GenConfig
gc
      effE  = ((Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
srcN) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      cuePos = ((Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
srcN) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      barAt ProgressionContext -> Progression
lyr Int
i = case Progression -> Int -> Maybe CadenceState
Prog.getCadenceState (ProgressionContext -> Progression
lyr ProgressionContext
srcPC) Int
i of
        Just CadenceState
cs -> CadenceState
cs
        Maybe CadenceState
Nothing -> Functionality -> CadenceState
forall a. HasCallStack => Functionality -> a
error Functionality
"genFrom (poly): source bar out of range"
      sSeed = (ProgressionContext -> Progression) -> Int -> CadenceState
barAt ProgressionContext -> Progression
PC.strataLayer Int
cuePos
      mSeed = (ProgressionContext -> Progression) -> Int -> CadenceState
barAt ProgressionContext -> Progression
PC.modeLayer Int
cuePos
      -- Kept partner bars after the seam (Nothing on a full-cycle regen).
      keptNext
        | Int
rSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
srcN = Maybe (CadenceState, CadenceState)
forall a. Maybe a
Nothing
        | Bool
otherwise =
            let nextPos :: Int
nextPos = (Int
effE Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
srcN) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            in (CadenceState, CadenceState) -> Maybe (CadenceState, CadenceState)
forall a. a -> Maybe a
Just ((ProgressionContext -> Progression) -> Int -> CadenceState
barAt ProgressionContext -> Progression
PC.strataLayer Int
nextPos, (ProgressionContext -> Progression) -> Int -> CadenceState
barAt ProgressionContext -> Progression
PC.modeLayer Int
nextPos)
  rng    <- createSystemRandom
  source <- sourceFor (T.pack (_gcSeek gc))
  (chain, stepDiags) <- buildChainWith source rng
                          (diagLevel (_gcVerbosity gc)) (_gcEntropy gc)
                          (_gcTonal gc) (const pctx) start rSize
  let newFound = Int -> [CadenceState] -> [CadenceState]
forall a. Int -> [a] -> [a]
drop Int
1 [CadenceState]
chain
      -- Offline (empty list) can't verify continuity — accept rather than
      -- spin the retry budget on an unverifiable preference.
      canContinue CadenceState
next [(a, b)]
ts =
        [(a, b)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, b)]
ts Bool -> Bool -> Bool
|| Cadence -> Functionality
forall a. Show a => a -> Functionality
show (CadenceState -> Cadence
H.stateCadence CadenceState
next) Functionality -> [Functionality] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ a -> Functionality
forall a. Show a => a -> Functionality
show a
cad | (a
cad, b
_) <- [(a, b)]
ts ]
      go (CadenceState, CadenceState)
_ [] [(CadenceState, CadenceState, RawStep)]
acc = [(CadenceState, CadenceState, RawStep)]
-> IO [(CadenceState, CadenceState, RawStep)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(CadenceState, CadenceState, RawStep)]
-> [(CadenceState, CadenceState, RawStep)]
forall a. [a] -> [a]
reverse [(CadenceState, CadenceState, RawStep)]
acc)
      go (CadenceState, CadenceState)
prevs (CadenceState
tBar : [CadenceState]
more) [(CadenceState, CadenceState, RawStep)]
acc = do
        (st1, st2, raw) <- GenIO
-> TransitionSource
-> ParsedContext
-> Double
-> CadenceState
-> (CadenceState, CadenceState)
-> IO (CadenceState, CadenceState, RawStep)
stepPartners Gen RealWorld
GenIO
rng TransitionSource
source ParsedContext
pctx (GenConfig -> Double
_gcEntropy GenConfig
gc) CadenceState
tBar (CadenceState, CadenceState)
prevs
        -- Seam preference on the final regenerated bar: keep drawing pairs
        -- until one reaches the kept next partner bars, bounded by the
        -- pool-shaped retry budget; fall back to the unfiltered draw.
        (st1', st2', raw') <-
          case (more, keptNext) of
            ([], Just (CadenceState
sNext, CadenceState
mNext)) -> do
              let retry :: Int
-> (CadenceState, CadenceState, RawStep)
-> IO (CadenceState, CadenceState, RawStep)
retry Int
0 (CadenceState, CadenceState, RawStep)
best = (CadenceState, CadenceState, RawStep)
-> IO (CadenceState, CadenceState, RawStep)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CadenceState, CadenceState, RawStep)
best
                  retry Int
k best :: (CadenceState, CadenceState, RawStep)
best@(CadenceState
b1, CadenceState
b2, RawStep
_) = do
                    tsS <- TransitionSource
source (Functionality -> Text
T.pack (Cadence -> Functionality
forall a. Show a => a -> Functionality
show (CadenceState -> Cadence
H.stateCadence CadenceState
b1)))
                    tsM <- source (T.pack (show (H.stateCadence b2)))
                    if canContinue sNext tsS && canContinue mNext tsM
                      then pure best
                      else do
                        cand <- stepPartners rng source pctx (_gcEntropy gc) tBar prevs
                        retry (k - 1 :: Int) cand
              Int
-> (CadenceState, CadenceState, RawStep)
-> IO (CadenceState, CadenceState, RawStep)
retry Int
8 (CadenceState
st1, CadenceState
st2, RawStep
raw)
            ([CadenceState], Maybe (CadenceState, CadenceState))
_ -> (CadenceState, CadenceState, RawStep)
-> IO (CadenceState, CadenceState, RawStep)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CadenceState
st1, CadenceState
st2, RawStep
raw)
        go (st1', st2') more ((st1', st2', raw') : acc)
  steps <- go (sSeed, mSeed) newFound []
  let newS = [ CadenceState
a | (CadenceState
a, CadenceState
_, RawStep
_) <- [(CadenceState, CadenceState, RawStep)]
steps ]
      newM = [ CadenceState
b | (CadenceState
_, CadenceState
b, RawStep
_) <- [(CadenceState, CadenceState, RawStep)]
steps ]
      raws = Functionality -> Int -> Maybe Int -> Maybe Int -> RawStep
RawStep Functionality
"seed" Int
0 Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing RawStep -> [RawStep] -> [RawStep]
forall a. a -> [a] -> [a]
: [ RawStep
r | (CadenceState
_, CadenceState
_, RawStep
r) <- [(CadenceState, CadenceState, RawStep)]
steps ]
      triad'  = Progression -> Int -> Int -> [CadenceState] -> Progression
Prog.spliceProgression (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
srcPC)  Int
s Int
effE [CadenceState]
newFound
      strata' = Progression -> Int -> Int -> [CadenceState] -> Progression
Prog.spliceProgression (ProgressionContext -> Progression
PC.strataLayer ProgressionContext
srcPC) Int
s Int
effE [CadenceState]
newS
      mode'   = Progression -> Int -> Int -> [CadenceState] -> Progression
Prog.spliceProgression (ProgressionContext -> Progression
PC.modeLayer ProgressionContext
srcPC)   Int
s Int
effE [CadenceState]
newM
      pcx = Progression
-> Progression
-> Progression
-> Maybe (Seq (Tristrata, StrataLabel))
-> Family
-> ProgressionContext
PC.ProgressionContext Progression
triad' Progression
strata' Progression
mode' Maybe (Seq (Tristrata, StrataLabel))
forall a. Maybe a
Nothing Family
PC.FPoly
      -- Trace context: seed bar + regenerated bars, in walk order.
      insPC = PC.ProgressionContext
        { triadLayer :: Progression
PC.triadLayer   = [CadenceState] -> Progression
Prog.fromCadenceStates [CadenceState]
chain
        , strataLayer :: Progression
PC.strataLayer  = [CadenceState] -> Progression
Prog.fromCadenceStates (CadenceState
sSeed CadenceState -> [CadenceState] -> [CadenceState]
forall a. a -> [a] -> [a]
: [CadenceState]
newS)
        , modeLayer :: Progression
PC.modeLayer    = [CadenceState] -> Progression
Prog.fromCadenceStates (CadenceState
mSeed CadenceState -> [CadenceState] -> [CadenceState]
forall a. a -> [a] -> [a]
: [CadenceState]
newM)
        , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance = Maybe (Seq (Tristrata, StrataLabel))
forall a. Maybe a
Nothing
        , pcFamily :: Family
PC.pcFamily     = Family
PC.FPoly
        }
      polySteps = case [StepDiagnostic]
stepDiags of
        [] -> []
        [StepDiagnostic]
_  -> [ StepDiagnostic
d { sdStepNumber = i, sdPoly = Just pd }
              | (Int
i, StepDiagnostic
d, PolyDiag
pd) <- [Int]
-> [StepDiagnostic]
-> [PolyDiag]
-> [(Int, StepDiagnostic, PolyDiag)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
1 ..] (CadenceState -> StepDiagnostic
mkStarterDiag CadenceState
start StepDiagnostic -> [StepDiagnostic] -> [StepDiagnostic]
forall a. a -> [a] -> [a]
: [StepDiagnostic]
stepDiags)
                                   (ProgressionContext -> Bool -> [RawStep] -> [PolyDiag]
polyDiagsFor ProgressionContext
insPC Bool
False [RawStep]
raws) ]
      diag = GenerationDiagnostics
        { gdStartCadence :: Functionality
gdStartCadence = Cadence -> Functionality
forall a. Show a => a -> Functionality
show (CadenceState -> Cadence
extractCadence CadenceState
start)
        , gdStartRoot :: Functionality
gdStartRoot    = NoteName -> Functionality
forall a. Show a => a -> Functionality
show (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
start)
        , gdRequestedLen :: Int
gdRequestedLen = Int
rSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        , gdActualLen :: Int
gdActualLen    = [CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
chain
        , gdEntropy :: Double
gdEntropy      = GenConfig -> Double
_gcEntropy GenConfig
gc
        , gdSteps :: [StepDiagnostic]
gdSteps        = [StepDiagnostic]
polySteps
        , gdProgression :: Progression
gdProgression  = [CadenceState] -> Progression
Prog.fromCadenceStates [CadenceState]
chain
        , gdJazzTrace :: [Functionality]
gdJazzTrace    = []
        }
  pure (pcx, diag)

-- Per-bar 'PolyDiag' records for a finished polytonal context: names are
-- rendered with each bar's own spelling; chain-bound facts (list ranks)
-- follow the final S/M assignment.
polyDiagsFor :: PC.ProgressionContext -> Bool -> [RawStep] -> [PolyDiag]
polyDiagsFor :: ProgressionContext -> Bool -> [RawStep] -> [PolyDiag]
polyDiagsFor ProgressionContext
pcx Bool
swapped [RawStep]
raws =
  [ PolyDiag
      { pdGeometry :: Functionality
pdGeometry = case Int -> Int
forall a. Bits a => a -> Int
popCount (CadenceState -> Int
absMask CadenceState
sBar Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. CadenceState -> Int
absMask CadenceState
mBar) of
          Int
2 -> Functionality
"common-dyad"
          Int
_ -> Functionality
"base-anchored"
      , pdTier :: Functionality
pdTier  = RawStep -> Functionality
rsTier RawStep
raw
      , pdPoolK :: Int
pdPoolK = RawStep -> Int
rsPoolK RawStep
raw
      , pdSRank :: Maybe Int
pdSRank = if Bool
swapped then RawStep -> Maybe Int
rsRank2 RawStep
raw else RawStep -> Maybe Int
rsRank1 RawStep
raw
      , pdMRank :: Maybe Int
pdMRank = if Bool
swapped then RawStep -> Maybe Int
rsRank1 RawStep
raw else RawStep -> Maybe Int
rsRank2 RawStep
raw
      , pdSName :: Functionality
pdSName = CadenceState -> Functionality
nameBar CadenceState
sBar
      , pdMName :: Functionality
pdMName = CadenceState -> Functionality
nameBar CadenceState
mBar
      , pdDyad :: Functionality
pdDyad  = CadenceState -> Int -> Functionality
renderDyad CadenceState
tBar (CadenceState -> Int
absMask CadenceState
tBar Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. CadenceState -> Int
absMask CadenceState
sBar Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. CadenceState -> Int
absMask CadenceState
mBar)
      , pdPairTS :: Functionality
pdPairTS = CadenceState -> Functionality
nameBar CadenceState
tsBar
      , pdPairTM :: Functionality
pdPairTM = CadenceState -> Functionality
nameBar CadenceState
tmBar
      , pdPairSM :: Functionality
pdPairSM = CadenceState -> Functionality
nameBar CadenceState
smBar
      , pdPentad :: Functionality
pdPentad = CadenceState -> Functionality
nameBar CadenceState
tsmBar
      }
  | (CadenceState
tBar, CadenceState
sBar, CadenceState
mBar, CadenceState
tsBar, CadenceState
tmBar, CadenceState
smBar, CadenceState
tsmBar, RawStep
raw) <-
      [CadenceState]
-> [CadenceState]
-> [CadenceState]
-> [CadenceState]
-> [CadenceState]
-> [CadenceState]
-> [CadenceState]
-> [RawStep]
-> [(CadenceState, CadenceState, CadenceState, CadenceState,
     CadenceState, CadenceState, CadenceState, RawStep)]
forall {a} {b} {c} {d} {e} {f} {g} {h}.
[a]
-> [b]
-> [c]
-> [d]
-> [e]
-> [f]
-> [g]
-> [h]
-> [(a, b, c, d, e, f, g, h)]
zip8 (Layer -> [CadenceState]
bars Layer
PC.T) (Layer -> [CadenceState]
bars Layer
PC.S) (Layer -> [CadenceState]
bars Layer
PC.M)
           (Layer -> [CadenceState]
bars Layer
PC.TS) (Layer -> [CadenceState]
bars Layer
PC.TM) (Layer -> [CadenceState]
bars Layer
PC.SM) (Layer -> [CadenceState]
bars Layer
PC.TSM) [RawStep]
raws ]
  where
    bars :: Layer -> [CadenceState]
bars Layer
sel = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression (Layer -> ProgressionContext -> Progression
PC.layer Layer
sel ProgressionContext
pcx))
    nameBar :: CadenceState -> Functionality
nameBar CadenceState
cs = (PitchClass -> NoteName) -> CadenceState -> Functionality
Prog.showHarmony (EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc (CadenceState -> EnharmonicSpelling
H.stateSpelling CadenceState
cs)) CadenceState
cs
    renderDyad :: CadenceState -> Int -> Functionality
renderDyad CadenceState
tBar Int
m =
      Functionality -> [Functionality] -> Functionality
forall a. [a] -> [[a]] -> [a]
intercalate Functionality
"+" [ NoteName -> Functionality
forall a. Show a => a -> Functionality
show (EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc (CadenceState -> EnharmonicSpelling
H.stateSpelling CadenceState
tBar)
                                (Int -> PitchClass
P.mkPitchClass Int
p))
                      | Int
p <- Int -> [Int]
pcsOf Int
m ]
    zip8 :: [a]
-> [b]
-> [c]
-> [d]
-> [e]
-> [f]
-> [g]
-> [h]
-> [(a, b, c, d, e, f, g, h)]
zip8 (a
a:[a]
as) (b
b:[b]
bs) (c
c:[c]
cs) (d
d:[d]
ds) (e
e:[e]
es) (f
f:[f]
fs) (g
g:[g]
gs) (h
h:[h]
hs) =
      (a
a, b
b, c
c, d
d, e
e, f
f, g
g, h
h) (a, b, c, d, e, f, g, h)
-> [(a, b, c, d, e, f, g, h)] -> [(a, b, c, d, e, f, g, h)]
forall a. a -> [a] -> [a]
: [a]
-> [b]
-> [c]
-> [d]
-> [e]
-> [f]
-> [g]
-> [h]
-> [(a, b, c, d, e, f, g, h)]
zip8 [a]
as [b]
bs [c]
cs [d]
ds [e]
es [f]
fs [g]
gs [h]
hs
    zip8 [a]
_ [b]
_ [c]
_ [d]
_ [e]
_ [f]
_ [g]
_ [h]
_ = []