-- |
-- Module      : Harmonic.Interface.Tidal.Arranger
-- Description : Performance-oriented progression manipulation
-- 
-- Shorthand for manipulating progressions in a TidalCycles performance
-- context. All functions are designed for live-coding ergonomics: short
-- names, intuitive parameter order, and no @IO@.
--
-- Two families, both wrapping the more verbose
-- "Harmonic.Rules.Types.Progression" functions:
--
-- [Rearranging] 'rotate', 'excerpt', 'insert', 'switch', 'clone', 'extract',
-- 'transposeP', 'reverse', 'fuse', 'fuse2', 'interleave', 'expandP',
-- 'progOverlap', 'progOverlapF', 'progOverlapB'.
--
-- [Voicing] five strategies that turn a progression into concrete pitches —
-- 'grid', 'flow', 'lite', 'literal' and 'root'. 'grid' and 'flow' solve a
-- cyclic DP for smooth voice leading; the others are literal or bass-only.
--
-- Rearranging composes on the progression before it reaches a voicing:
--
-- @
-- s  \<- seek \"*\" $ len 8 $ entropy 0.4 $ gen
-- s' = fuse (excerpt 0 4 s) (rotate 2 s)
-- @
--
-- The voicing is then chosen per instrument at the point of play, so two
-- lines can read the same progression differently:
--
-- @
-- , cello      T (0,1) k vl flow Tenor8vb
-- , contrabass T (0,1) k vl grid Bass8vb
-- @

module Harmonic.Interface.Tidal.Arranger
  ( -- * Position/Range Operations
    rotate
  , excerpt
  , insert
  , switch
  , clone
  , extract

    -- * Transformation Operations
  , transposeP
  , Harmonic.Interface.Tidal.Arranger.reverse
  , fuse
  , fuse2
  , interleave
  , expandP

    -- * Overlap Operations (Progression-level)
  , progOverlap
  , progOverlapF
  , progOverlapB

    -- * Voicing Extractors (Voicing paradigms)
  , grid   -- Root locked in bass, smooth compact voice leading (cyclic DP)
  , flow   -- Any inversion allowed for smoothest voice leading (cyclic DP)
  , lite   -- Literal, no transformation
  , literal -- Alias for lite
  , root   -- Root note only (root pitch class per chord)
  , strataModeFlow  -- Bar-0-grounded pitch lattice for non-triad chroma layers

    -- * Explicit Progression Construction
  , fromChords      -- Construct Progression from pitch-class lists
  , prog            -- Legacy alias for fromChords

    -- * Scale Source (Switch Mechanism)
  , ScaleSource(..)
  , melodyStateFrom

    -- * Starting State Construction
  , lead
  , lead'
  , leadJ
  , parseLeadTokens
  , LeadToken(..)
  ) where

import qualified Data.Sequence as Seq
import Data.Sequence ((><))
import Data.Foldable (toList)
import Data.List (sort, nub, sortBy)
import Data.Maybe (listToMaybe)
import Data.Char (toLower)
import Data.Ord (comparing)
import qualified Data.Map.Strict as Map
import System.Random.MWC (createSystemRandom, uniformRM, GenIO)

import Harmonic.Rules.Types.Progression
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import Harmonic.Rules.Types.ProgressionContext (ProgressionContext, liftPC)
import Harmonic.Rules.Types.Harmony (Cadence(..), CadenceState(..), EnharmonicSpelling(..), toFunctionality, toFunctionalityChord, Movement(..), enharmonicFunc, inferSpelling, isAmbiguousPattern, initCadenceState, mkCadenceStatePCs, toMovement)
import qualified Harmonic.Rules.Constraints.Filter as Filter
import qualified Harmonic.Rules.Import.Jazz as J
import qualified Data.Text as T
import Harmonic.Traversal.Probabilistic (gammaIndexScaledWith)
import Harmonic.Evaluation.Scoring.Dissonance (dissonanceScore)
import Harmonic.Rules.Types.Pitch (PitchClass(..), NoteName(..), pitchClass, mkPitchClass, unPitchClass, flat, sharp)
import Harmonic.Evaluation.Scoring.VoiceLeading (solveRoot, solveFlow, bassVoicing, normalizeByFirstRoot, initialCompact, alignVoices)
import Data.Function (on)
import Data.List (minimumBy)

-------------------------------------------------------------------------------
-- Position\/Range Operations
-------------------------------------------------------------------------------

-- |Rotate a progression by n bars (positive = left, negative = right).
-- Bar-aligned: provenance and family travel with the bars.
rotate :: Int -> ProgressionContext -> ProgressionContext
rotate :: Int -> ProgressionContext -> ProgressionContext
rotate Int
n = (forall a. Seq a -> Seq a)
-> ProgressionContext -> ProgressionContext
PC.liftPCAligned (Int -> Seq a -> Seq a
forall a. Int -> Seq a -> Seq a
rotateSeq Int
n)

-- |Extract bars start to end (1-indexed, inclusive).
-- Bar-aligned: provenance and family travel with the bars.
excerpt :: Int -> Int -> ProgressionContext -> ProgressionContext
excerpt :: Int -> Int -> ProgressionContext -> ProgressionContext
excerpt Int
s Int
e = (forall a. Seq a -> Seq a)
-> ProgressionContext -> ProgressionContext
PC.liftPCAligned (Int -> Int -> Seq a -> Seq a
forall a. Int -> Int -> Seq a -> Seq a
excerptSeq Int
s Int
e)

-- |Insert a CadenceState at position (1-indexed), replacing the existing one.
-- Bar substitution: the foreign bar breaks strata\/polytonal invariants, so
-- provenance drops and those families downgrade.
insert :: CadenceState -> Int -> ProgressionContext -> ProgressionContext
insert :: CadenceState -> Int -> ProgressionContext -> ProgressionContext
insert CadenceState
cs Int
pos = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
PC.liftPCSubst (CadenceState -> Int -> Progression -> Progression
insertProg CadenceState
cs Int
pos)
  where
    insertProg :: CadenceState -> Int -> Progression -> Progression
    insertProg :: CadenceState -> Int -> Progression -> Progression
insertProg CadenceState
c Int
p (Progression Seq CadenceState
s)
      | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
s = CadenceState -> Progression
singleton CadenceState
c
      | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = Seq CadenceState -> Progression
Progression (CadenceState
c CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. a -> Seq a -> Seq a
Seq.<| Seq CadenceState
s)
      | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
s = Seq CadenceState -> Progression
Progression (Seq CadenceState
s Seq CadenceState -> CadenceState -> Seq CadenceState
forall a. Seq a -> a -> Seq a
Seq.|> CadenceState
c)
      | Bool
otherwise =
        let (Seq CadenceState
before, Seq CadenceState
rest) = Int -> Seq CadenceState -> (Seq CadenceState, Seq CadenceState)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Seq CadenceState
s
        in case Seq CadenceState -> ViewL CadenceState
forall a. Seq a -> ViewL a
Seq.viewl Seq CadenceState
rest of
             ViewL CadenceState
Seq.EmptyL -> Seq CadenceState -> Progression
Progression (Seq CadenceState
before Seq CadenceState -> CadenceState -> Seq CadenceState
forall a. Seq a -> a -> Seq a
Seq.|> CadenceState
c)
             CadenceState
_ Seq.:< Seq CadenceState
after -> Seq CadenceState -> Progression
Progression (Seq CadenceState
before Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
>< (CadenceState
c CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. a -> Seq a -> Seq a
Seq.<| Seq CadenceState
after))

-- |Switch two bars at positions m and n (1-indexed).
-- Treated as substitution (drops provenance, downgrades strata\/polytonal
-- families); promotable to the aligned tier via a lockstep 'Seq.update'
-- pair if per-bar identity is ever wanted here.
switch :: Int -> Int -> ProgressionContext -> ProgressionContext
switch :: Int -> Int -> ProgressionContext -> ProgressionContext
switch Int
m Int
n = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
PC.liftPCSubst (Int -> Int -> Progression -> Progression
switchProg Int
m Int
n)
  where
    switchProg :: Int -> Int -> Progression -> Progression
    switchProg :: Int -> Int -> Progression -> Progression
switchProg Int
a Int
b progIn :: Progression
progIn@(Progression Seq CadenceState
s)
      | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b = Progression
progIn
      | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
s = Progression
progIn
      | Bool
otherwise =
        let len :: Int
len = Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
s
            m' :: Int
m' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
            n' :: Int
n' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
            csM :: CadenceState
csM = Seq CadenceState -> Int -> CadenceState
forall a. Seq a -> Int -> a
Seq.index Seq CadenceState
s Int
m'
            csN :: CadenceState
csN = Seq CadenceState -> Int -> CadenceState
forall a. Seq a -> Int -> a
Seq.index Seq CadenceState
s Int
n'
            s' :: Seq CadenceState
s'  = Int -> CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Int -> a -> Seq a -> Seq a
Seq.update Int
m' CadenceState
csN (Seq CadenceState -> Seq CadenceState)
-> Seq CadenceState -> Seq CadenceState
forall a b. (a -> b) -> a -> b
$ Int -> CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Int -> a -> Seq a -> Seq a
Seq.update Int
n' CadenceState
csM Seq CadenceState
s
        in Seq CadenceState -> Progression
Progression Seq CadenceState
s'

-- |Clone bar m to position n (overwrites n with contents of m).
-- Treated as substitution — see 'switch'.
clone :: Int -> Int -> ProgressionContext -> ProgressionContext
clone :: Int -> Int -> ProgressionContext -> ProgressionContext
clone Int
m Int
n = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
PC.liftPCSubst (Int -> Int -> Progression -> Progression
cloneProg Int
m Int
n)
  where
    cloneProg :: Int -> Int -> Progression -> Progression
    cloneProg :: Int -> Int -> Progression -> Progression
cloneProg Int
a Int
b progIn :: Progression
progIn@(Progression Seq CadenceState
s)
      | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b = Progression
progIn
      | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
s = Progression
progIn
      | Bool
otherwise =
        let len :: Int
len = Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
s
            m' :: Int
m' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
            n' :: Int
n' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
            csM :: CadenceState
csM = Seq CadenceState -> Int -> CadenceState
forall a. Seq a -> Int -> a
Seq.index Seq CadenceState
s Int
m'
            s' :: Seq CadenceState
s'  = Int -> CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Int -> a -> Seq a -> Seq a
Seq.update Int
n' CadenceState
csM Seq CadenceState
s
        in Seq CadenceState -> Progression
Progression Seq CadenceState
s'

-- |Extract a single CadenceState at index (1-indexed, modulo wrap) from the triad layer
extract :: Int -> ProgressionContext -> CadenceState
extract :: Int -> ProgressionContext -> CadenceState
extract Int
n ProgressionContext
pc
  | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0  = String -> CadenceState
forall a. HasCallStack => String -> a
error String
"extract: empty progression"
  | Bool
otherwise = case Progression -> Int -> Maybe CadenceState
getCadenceState Progression
progArg Int
idx of
      Just CadenceState
cs -> CadenceState
cs
      Maybe CadenceState
Nothing -> String -> CadenceState
forall a. HasCallStack => String -> a
error String
"extract: internal error"
  where
    progArg :: Progression
progArg = ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc
    len :: Int
len  = Progression -> Int
progLength Progression
progArg
    idx :: Int
idx  = ((Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1  -- 1-indexed with modulo wrap

-------------------------------------------------------------------------------
-- Transformation Operations
-------------------------------------------------------------------------------

-- |Transpose a progression by n semitones. Strata provenance is anchored
-- to ABSOLUTE pitch classes (the octatripentatonic universe has no
-- transposition closure), so provenance and family survive only octave
-- shifts; any other interval drops them.
transposeP :: Int -> ProgressionContext -> ProgressionContext
transposeP :: Int -> ProgressionContext -> ProgressionContext
transposeP Int
n ProgressionContext
pc
  | Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
      ((Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC (Int -> Progression -> Progression
transposeProgression Int
n) ProgressionContext
pc)
        { PC.pcProvenance = PC.pcProvenance pc
        , PC.pcFamily     = PC.pcFamily pc }
  | Bool
otherwise = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC (Int -> Progression -> Progression
transposeProgression Int
n) ProgressionContext
pc

-- |Reverse a progression. Bar-aligned: provenance and family travel.
reverse :: ProgressionContext -> ProgressionContext
reverse :: ProgressionContext -> ProgressionContext
reverse = (forall a. Seq a -> Seq a)
-> ProgressionContext -> ProgressionContext
PC.liftPCAligned Seq a -> Seq a
forall a. Seq a -> Seq a
Seq.reverse

-- |Fuse multiple progressions into one (concatenation)
fuse :: [ProgressionContext] -> ProgressionContext
fuse :: [ProgressionContext] -> ProgressionContext
fuse = [ProgressionContext] -> ProgressionContext
forall a. Monoid a => [a] -> a
mconcat

-- |Binary fuse for convenience in live coding
fuse2 :: ProgressionContext -> ProgressionContext -> ProgressionContext
fuse2 :: ProgressionContext -> ProgressionContext -> ProgressionContext
fuse2 ProgressionContext
a ProgressionContext
b = ProgressionContext
a ProgressionContext -> ProgressionContext -> ProgressionContext
forall a. Semigroup a => a -> a -> a
<> ProgressionContext
b

-- |Interleave two progressions (alternating chords)
-- Example: interleave [A,B,C] [X,Y,Z] = [A,X,B,Y,C,Z]
interleave :: ProgressionContext -> ProgressionContext -> ProgressionContext
interleave :: ProgressionContext -> ProgressionContext -> ProgressionContext
interleave ProgressionContext
a ProgressionContext
b = ProgressionContext -> ProgressionContext
PC.normalizeFamily PC.ProgressionContext
  { triadLayer :: Progression
PC.triadLayer   = Progression -> Progression -> Progression
fuseProgression (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
a)  (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
b)
  , strataLayer :: Progression
PC.strataLayer  = Progression -> Progression -> Progression
fuseProgression (ProgressionContext -> Progression
PC.strataLayer ProgressionContext
a) (ProgressionContext -> Progression
PC.strataLayer ProgressionContext
b)
  , modeLayer :: Progression
PC.modeLayer    = Progression -> Progression -> Progression
fuseProgression (ProgressionContext -> Progression
PC.modeLayer ProgressionContext
a)   (ProgressionContext -> Progression
PC.modeLayer ProgressionContext
b)
  , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance = Seq (Tristrata, StrataLabel)
-> Seq (Tristrata, StrataLabel) -> Seq (Tristrata, StrataLabel)
forall a. Seq a -> Seq a -> Seq a
interleaveSeq (Seq (Tristrata, StrataLabel)
 -> Seq (Tristrata, StrataLabel) -> Seq (Tristrata, StrataLabel))
-> Maybe (Seq (Tristrata, StrataLabel))
-> Maybe
     (Seq (Tristrata, StrataLabel) -> Seq (Tristrata, StrataLabel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance ProgressionContext
a Maybe
  (Seq (Tristrata, StrataLabel) -> Seq (Tristrata, StrataLabel))
-> Maybe (Seq (Tristrata, StrataLabel))
-> Maybe (Seq (Tristrata, StrataLabel))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance ProgressionContext
b
  , pcFamily :: Family
PC.pcFamily     = if ProgressionContext -> Family
PC.pcFamily ProgressionContext
a Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== ProgressionContext -> Family
PC.pcFamily ProgressionContext
b then ProgressionContext -> Family
PC.pcFamily ProgressionContext
a else Family
PC.FTriad
  }

-- |Expand a progression by repeating the WHOLE progression n times
-- (@expandP 2@ on C F G A yields C F G A C F G A).
-- Bar-aligned replication: provenance and family travel.
expandP :: Int -> ProgressionContext -> ProgressionContext
expandP :: Int -> ProgressionContext -> ProgressionContext
expandP Int
n = (forall a. Seq a -> Seq a)
-> ProgressionContext -> ProgressionContext
PC.liftPCAligned (\Seq a
sq -> if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then Seq a
forall a. Seq a
Seq.empty else [Seq a] -> Seq a
forall a. Monoid a => [a] -> a
mconcat (Int -> Seq a -> [Seq a]
forall a. Int -> a -> [a]
replicate Int
n Seq a
sq))

-------------------------------------------------------------------------------
-- Overlap Operations
-- These create sustain\/legato effects by merging pitches from adjacent chords
-------------------------------------------------------------------------------

-- Shared overlap core: for every bar, union the ABSOLUTE pitch classes
-- of the bars inside the window, then store them relative to that bar's
-- own root. Pitch content is read straight from 'cadenceIntervals' — no
-- 'fromCadenceState'\/'toTriad' round trip. The old round trip stored
-- each bar's ABSOLUTE pitch classes back into 'cadenceIntervals', which
-- the voicing layer then transposed by the root a second time (every
-- non-C-rooted bar sounded shifted up by its own root), and 'toTriad'
-- reduced >3-note bars to a triad before merging (extended material lost its
-- fourth voice).
progOverlapWith :: (Int -> (Int, Int)) -> Progression -> Progression
progOverlapWith :: (Int -> (Int, Int)) -> Progression -> Progression
progOverlapWith Int -> (Int, Int)
window (Progression Seq CadenceState
sq)
  | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
sq = Seq CadenceState -> Progression
Progression Seq CadenceState
sq
  | Bool
otherwise =
      let states :: [CadenceState]
states = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq CadenceState
sq
          len :: Int
len    = [CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
states
          absAt :: Int -> [Int]
absAt Int
j =
            let cs :: CadenceState
cs     = [CadenceState]
states [CadenceState] -> Int -> CadenceState
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                rootPC :: Int
rootPC = PitchClass -> Int
unPitchClass (NoteName -> PitchClass
pitchClass (CadenceState -> NoteName
stateCadenceRoot CadenceState
cs))
            in [ (PitchClass -> Int
unPitchClass PitchClass
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
               | PitchClass
p <- Cadence -> [PitchClass]
cadenceIntervals (CadenceState -> Cadence
stateCadence CadenceState
cs) ]
          rebuilt :: Int -> CadenceState -> CadenceState
rebuilt Int
i CadenceState
cs =
            let (Int
lo, Int
hi)  = Int -> (Int, Int)
window Int
i
                rootPC :: Int
rootPC    = PitchClass -> Int
unPitchClass (NoteName -> PitchClass
pitchClass (CadenceState -> NoteName
stateCadenceRoot CadenceState
cs))
                absUnion :: [Int]
absUnion  = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ((Int -> [Int]) -> [Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [Int]
absAt [Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
lo .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
hi])
                rels :: [Int]
rels      = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [ (Int
a 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
a <- [Int]
absUnion ])
            in Cadence -> NoteName -> [Integer] -> CadenceState
rebuildCadenceState (CadenceState -> Cadence
stateCadence CadenceState
cs) (CadenceState -> NoteName
stateCadenceRoot CadenceState
cs)
                                   ((Int -> Integer) -> [Int] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int]
rels)
      in Seq CadenceState -> Progression
Progression ([CadenceState] -> Seq CadenceState
forall a. [a] -> Seq a
Seq.fromList ((Int -> CadenceState -> CadenceState)
-> [Int] -> [CadenceState] -> [CadenceState]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> CadenceState -> CadenceState
rebuilt [Int
0 ..] [CadenceState]
states))

-- |Bidirectional overlap: merge pitches from n bars in both directions
progOverlap :: Int -> Progression -> Progression
progOverlap :: Int -> Progression -> Progression
progOverlap Int
range Progression
progArg
  | Int
range Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Progression
progArg
  | Bool
otherwise  = (Int -> (Int, Int)) -> Progression -> Progression
progOverlapWith (\Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
range, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
range)) Progression
progArg

-- |Forward-only overlap: merge pitches from n bars ahead
progOverlapF :: Int -> Progression -> Progression
progOverlapF :: Int -> Progression -> Progression
progOverlapF Int
range Progression
progArg
  | Int
range Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Progression
progArg
  | Bool
otherwise  = (Int -> (Int, Int)) -> Progression -> Progression
progOverlapWith (\Int
i -> (Int
i, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
range)) Progression
progArg

-- |Backward-only overlap: merge pitches from n bars behind
progOverlapB :: Int -> Progression -> Progression
progOverlapB :: Int -> Progression -> Progression
progOverlapB Int
range Progression
progArg
  | Int
range Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Progression
progArg
  | Bool
otherwise  = (Int -> (Int, Int)) -> Progression -> Progression
progOverlapWith (\Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
range, Int
i)) Progression
progArg

-- Helper: rebuild a CadenceState with new intervals
rebuildCadenceState :: Cadence -> NoteName -> [Integer] -> CadenceState
rebuildCadenceState :: Cadence -> NoteName -> [Integer] -> CadenceState
rebuildCadenceState Cadence
cad NoteName
rootName [Integer]
newIntervals =
  let -- Create a modified cadence with the new intervals (as PitchClasses)
      newPCs :: [PitchClass]
newPCs = (Integer -> PitchClass) -> [Integer] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
i -> Int -> PitchClass
mkPitchClass (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)) [Integer]
newIntervals
      -- Rename from the merged set: an overlapped bar sounds the union,
      -- so its displayed functionality must describe the union rather
      -- than the pre-merge chord.
      newName :: String
newName
        | [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PitchClass]
newPCs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3 = [PitchClass] -> String
toFunctionality [PitchClass]
newPCs
        | Bool
otherwise          = [PitchClass] -> String
toFunctionalityChord [PitchClass]
newPCs
      newCad :: Cadence
newCad = Cadence
cad { cadenceIntervals = newPCs, cadenceFunctionality = newName }
      -- Infer spelling from the new absolute pitches
      rootPC :: PitchClass
rootPC = NoteName -> PitchClass
pitchClass NoteName
rootName
      absolutePitches :: [Int]
absolutePitches = (Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
i -> (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PitchClass -> Int
unPitchClass PitchClass
rootPC) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Integer]
newIntervals
      spelling :: EnharmonicSpelling
spelling = [Int] -> EnharmonicSpelling
inferSpelling [Int]
absolutePitches
  in Cadence -> NoteName -> EnharmonicSpelling -> CadenceState
CadenceState Cadence
newCad NoteName
rootName EnharmonicSpelling
spelling

-------------------------------------------------------------------------------
-- Voicing Extractors (Voicing paradigms)
-------------------------------------------------------------------------------

-- |GRID paradigm: Root locked in bass with smooth compact voice leading.
-- Uses cyclic DP to find globally optimal voicings.
-- First chord starts compact with root in bass; all subsequent chords
-- maintain root in bass with minimal voice movement.
grid :: Progression -> [[Int]]
grid :: Progression -> [[Int]]
grid Progression
progArg
  | Progression -> Bool
hasBigChroma Progression
progArg = Progression -> [[Int]]
strataModeFlow Progression
progArg
  | Bool
otherwise =
      let intVoicings :: [[Int]]
intVoicings = ([Integer] -> [Int]) -> [[Integer]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([[Integer]] -> [[Int]]) -> [[Integer]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ Progression -> [[Integer]]
literalVoicing' Progression
progArg
      in [[Int]] -> [[Int]]
solveRoot [[Int]]
intVoicings

-- |FLOW paradigm: Smoothest voice leading with any inversion allowed.
-- Uses cyclic DP to find globally optimal voicings.
-- Voice crossings permitted for optimal smoothness; bass doesn't need
-- to be the root if an inversion provides smoother voice leading.
flow :: Progression -> [[Int]]
flow :: Progression -> [[Int]]
flow Progression
progArg
  | Progression -> Bool
hasBigChroma Progression
progArg = Progression -> [[Int]]
strataModeFlow Progression
progArg
  | Bool
otherwise =
      let intVoicings :: [[Int]]
intVoicings = ([Integer] -> [Int]) -> [[Integer]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([[Integer]] -> [[Int]]) -> [[Integer]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ Progression -> [[Integer]]
literalVoicing' Progression
progArg
      in [[Int]] -> [[Int]]
solveFlow [[Int]]
intVoicings

-- |LITE paradigm: Literal voicings with first-root normalization.
-- Returns pitches as stored, but normalized so first chord's root is in [-12,-1].
-- No voice leading optimization applied (only octave normalization).
lite :: Progression -> [[Int]]
lite :: Progression -> [[Int]]
lite Progression
progArg = 
  let raw :: [[Int]]
raw = ([Integer] -> [Int]) -> [[Integer]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([[Integer]] -> [[Int]]) -> [[Integer]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ Progression -> [[Integer]]
literalVoicing' Progression
progArg
  in [[Int]] -> [[Int]]
normalizeByFirstRoot [[Int]]
raw

-- |ROOT paradigm: Root note only (root pitch class per chord).
-- Extracts the root note (first element, mod 12) from each chord.
-- Returns as single-element lists in [0,11] range.
root :: Progression -> [[Int]]
root :: Progression -> [[Int]]
root Progression
progArg =
  let raw :: [[Int]]
raw = ([Integer] -> [Int]) -> [[Integer]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([[Integer]] -> [[Int]]) -> [[Integer]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ Progression -> [[Integer]]
literalVoicing' Progression
progArg
  in [[Int]] -> [[Int]]
bassVoicing [[Int]]
raw

-- |Alias for lite (legacy compatibility)
literal :: Progression -> [[Int]]
literal :: Progression -> [[Int]]
literal = Progression -> [[Int]]
lite

-- |STRATA-MODE-FLOW paradigm: a fixed pitch LATTICE grounded on bar 0.
-- Bar 0's chroma builds a compressed-ascending stack from its root
-- ('initialCompact' + 'normalizeByFirstRoot', root anchored in [-12, -1]);
-- every later bar keeps that lattice's slots in place and inflects each
-- slot to the current bar's chroma — the key signature changes, the hand
-- position does not. Pattern index @i@ addresses the i-th lattice slot,
-- so a held index pedals its pitch across key areas (inflecting by
-- accidental where the new set demands it) instead of transposing with
-- each bar's root, and increments of 1 still ascend by one set member.
--
-- Bar n (equal cardinality — the normal case: S layers uniformly 5-PC,
-- M layers uniformly 7-PC): the minimum-cost cyclic-monotone bijection
-- from the anchor lattice onto the bar's PC set. Each of the n cyclic
-- rotations of the bar's sorted PCs is realised monotonically against
-- the anchor (slot 0 nearest bar 0's slot 0, each later slot the
-- smallest pitch above its predecessor); the rotation minimising total
-- @|placed_MIDI - anchor_MIDI|@ wins (tie-break: smaller net signed
-- displacement). A bijection — not per-slot nearest-tone, which can
-- collapse two slots onto one pitch — so every bar stays distinct,
-- ascending, and surjective onto its chroma, and the octave-wrap
-- identity in "Harmonic.Interface.Tidal.Bridge" (index n = slot 0 + 12)
-- keeps working.
--
-- Anchoring every bar to bar 0 (rather than chaining to the previous
-- bar) bounds drift: each slot stays within a tritone of its anchor
-- pitch, the pattern wrap (bar N-1 → bar 0) returns home, and a bar
-- whose chroma equals bar 0's lands on bar 0's exact MIDI.
--
-- Bars whose cardinality differs from the anchor's (silent bars, 6-PC
-- override edges, hand-built mixed material arriving via @hasBigChroma@)
-- fall back to @shiftBar@ — slot identity is undefined across a
-- slot-count change. O(n²) per bar, n ≤ 7; eager forcing in
-- "Harmonic.Interface.Tidal.Bridge" hoists the work to REPL evaluation
-- time.
strataModeFlow :: Progression -> [[Int]]
strataModeFlow :: Progression -> [[Int]]
strataModeFlow Progression
progArg =
  case Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
unProgression Progression
progArg) of
    []                  -> []
    (CadenceState
firstCS : [CadenceState]
restCSs) ->
      let firstPCs :: [Int]
firstPCs    = CadenceState -> [Int]
cadencePCs CadenceState
firstCS
          firstRootPC :: Int
firstRootPC = case [Int]
firstPCs of (Int
p:[Int]
_) -> Int
p; [] -> Int
0
          v0 :: [Int]
v0          = Int -> [Int] -> [Int]
initialCompact Int
firstRootPC [Int]
firstPCs
          voicings :: [[Int]]
voicings    = [Int]
v0 [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: (CadenceState -> [Int]) -> [CadenceState] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> CadenceState -> [Int]
latticeBar [Int]
v0) [CadenceState]
restCSs
      in [[Int]] -> [[Int]]
normalizeByFirstRoot [[Int]]
voicings

-- |Inflect the bar-0 lattice @v0@ onto one bar's chroma: the minimum-cost
-- cyclic-monotone bijection described at 'strataModeFlow'. Falls back to
-- @shiftBar@ when the bar's distinct-PC count differs from the lattice's.
latticeBar :: [Int] -> CadenceState -> [Int]
latticeBar :: [Int] -> CadenceState -> [Int]
latticeBar [Int]
v0 CadenceState
cs =
  let tgt :: [Int]
tgt = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort (CadenceState -> [Int]
cadencePCs CadenceState
cs))
      n :: Int
n   = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
v0
  in if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
v0 Bool -> Bool -> Bool
|| [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
tgt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n
       then [Int] -> CadenceState -> [Int]
shiftBar [Int]
v0 CadenceState
cs
       else
         let rotations :: [[Int]]
rotations  = [ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
n (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
k ([Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
cycle [Int]
tgt)) | Int
k <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
             candidates :: [[Int]]
candidates = ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Int] -> [Int]
realizeAgainst [Int]
v0) [[Int]]
rotations
             cost :: [Int] -> Int
cost [Int]
v     = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
y Int
a -> Int -> Int
forall a. Num a => a -> a
abs (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a)) [Int]
v [Int]
v0)
             net :: [Int] -> Int
net [Int]
v      = Int -> Int
forall a. Num a => a -> a
abs ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) [Int]
v [Int]
v0))
             score :: [Int] -> (Int, Int)
score [Int]
v    = ([Int] -> Int
cost [Int]
v, [Int] -> Int
net [Int]
v)
         in ([Int] -> [Int] -> Ordering) -> [[Int]] -> [Int]
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int, Int) -> (Int, Int) -> Ordering)
-> ([Int] -> (Int, Int)) -> [Int] -> [Int] -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` [Int] -> (Int, Int)
score) [[Int]]
candidates

-- |Monotone realisation of an assigned PC sequence against the anchor:
-- slot 0 takes the pitch with its PC nearest the anchor's slot 0 (ties
-- resolve upward); each later slot takes the smallest pitch above its
-- predecessor carrying its PC. Output is strictly ascending and spans
-- less than an octave, like the anchor itself.
realizeAgainst :: [Int] -> [Int] -> [Int]
realizeAgainst :: [Int] -> [Int] -> [Int]
realizeAgainst [Int]
v0 [Int]
pcs = case ([Int]
v0, [Int]
pcs) of
  (Int
a0 : [Int]
_, Int
p0 : [Int]
ps) ->
    let d :: Int
d  = (Int
p0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a0) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
        y0 :: Int
y0 = if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 then Int
a0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d else Int
a0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
12
        step :: a -> a -> a
step a
prev a
p = a
prev a -> a -> a
forall a. Num a => a -> a -> a
+ a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
p a -> a -> a
forall a. Num a => a -> a -> a
- (a
prev a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)) a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
12)
    in (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Integral a => a -> a -> a
step Int
y0 [Int]
ps
  ([Int], [Int])
_ -> []

-- |Build a bar's natural compressed-ascending voicing rooted on its own
-- harmonic root, then choose the uniform octave shift that maximises
-- exact-MIDI common tones with (then minimises distance to) the bar 0
-- anchor @v0@. The fallback path for bars whose cardinality differs from
-- the lattice's; @latticeBar@ handles the normal case.
shiftBar :: [Int] -> CadenceState -> [Int]
shiftBar :: [Int] -> CadenceState -> [Int]
shiftBar [Int]
v0 CadenceState
cs =
  let nextPCs :: [Int]
nextPCs    = CadenceState -> [Int]
cadencePCs CadenceState
cs
      nextRootPC :: Int
nextRootPC = case [Int]
nextPCs of (Int
p:[Int]
_) -> Int
p; [] -> Int
0
      natural :: [Int]
natural    = Int -> [Int] -> [Int]
initialCompact Int
nextRootPC [Int]
nextPCs
      candidates :: [[Int]]
candidates = [ (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
12)) [Int]
natural | Int
k <- [-Int
3 .. Int
3] ]
      -- Primary metric: exact-MIDI common tones with the anchor — the
      -- pedal property (tones shared between bars hold their register,
      -- chosen rather than lucky under root motion). Tie-break: minimal
      -- aligned distance; 'alignVoices' handles bars whose cardinality
      -- differs from the anchor's (the old zipWith silently truncated).
      overlap :: [Int] -> Int
overlap [Int]
v  = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
v0) [Int]
v)
      dist :: [Int] -> Int
dist [Int]
v     = let ([Int]
a, [Int]
b) = [Int] -> [Int] -> ([Int], [Int])
alignVoices [Int]
v [Int]
v0
                   in [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
x Int
y -> Int -> Int
forall a. Num a => a -> a
abs (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y)) [Int]
a [Int]
b)
      score :: [Int] -> (Int, Int)
score [Int]
v    = (Int -> Int
forall a. Num a => a -> a
negate ([Int] -> Int
overlap [Int]
v), [Int] -> Int
dist [Int]
v)
  in ([Int] -> [Int] -> Ordering) -> [[Int]] -> [Int]
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int, Int) -> (Int, Int) -> Ordering)
-> ([Int] -> (Int, Int)) -> [Int] -> [Int] -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` [Int] -> (Int, Int)
score) [[Int]]
candidates

-- |Scale-cluster routing guard for the cyclic DP. The cost driver is the
-- DENSITY of big bars, not their presence — the DP's per-edge work is the
-- product of adjacent bars' voicing candidates. Measured (bytecode,
-- 16 bars): uniform 5-PC 2.3 s (always allowed); two 6-PC bars among
-- 4-note harmony 1.85 s — CHEAPER than the allowed baseline, so a jazz
-- progression is no longer re-routed by one 13th chord; adjacent 7-PC
-- pair 10.3 s; uniform 6-PC 15.9 s; uniform 7-PC ≈ 107 s. Routing rule:
-- any 7-PC bar (a full mode — lattice semantics are the right tool for it
-- musically as well as computationally), or 6-PC bars exceeding a quarter
-- of the progression (cluster-dominant material). genP chroma layers
-- route by provenance in Bridge before reaching here.
hasBigChroma :: Progression -> Bool
hasBigChroma :: Progression -> Bool
hasBigChroma Progression
progArg =
  let sizes :: [Int]
sizes = (CadenceState -> Int) -> [CadenceState] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PitchClass] -> Int)
-> (CadenceState -> [PitchClass]) -> CadenceState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cadence -> [PitchClass]
cadenceIntervals (Cadence -> [PitchClass])
-> (CadenceState -> Cadence) -> CadenceState -> [PitchClass]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> Cadence
stateCadence)
                  (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
unProgression Progression
progArg))
  in (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
7) [Int]
sizes Bool -> Bool -> Bool
|| Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6) [Int]
sizes) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
sizes

-- |Read a CadenceState's absolute PCs in cadence-interval order (NOT sorted).
-- For genP strata\/mode layers (intervals start at 0 from harmonic root), this
-- yields [root, root+2nd, root+3rd, ...]. Head = the bar's root, which seeds
-- bar 0's lattice in 'strataModeFlow'; later bars sort and inflect, so a
-- pattern index tracks its lattice slot, not the bar root.
cadencePCs :: CadenceState -> [Int]
cadencePCs :: CadenceState -> [Int]
cadencePCs CadenceState
cs =
  let r :: Int
r    = PitchClass -> Int
unPitchClass (NoteName -> PitchClass
pitchClass (CadenceState -> NoteName
stateCadenceRoot CadenceState
cs))
      ints :: [Int]
ints = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
unPitchClass (Cadence -> [PitchClass]
cadenceIntervals (CadenceState -> Cadence
stateCadence CadenceState
cs))
  in [ (Int
i 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
i <- [Int]
ints ]

-- Helper to get literal voicings as Integer lists (internal use).
-- Reads cadence intervals directly so non-triad CadenceStates (5-PC strata,
-- 7-PC mode in genP-derived ProgressionContexts) survive without toTriad
-- reduction. For 3-PC triad cadences this produces the same PCs as the
-- legacy chordIntervals path.
literalVoicing' :: Progression -> [[Integer]]
literalVoicing' :: Progression -> [[Integer]]
literalVoicing' (Progression Seq CadenceState
sq) =
  (CadenceState -> [Integer]) -> [CadenceState] -> [[Integer]]
forall a b. (a -> b) -> [a] -> [b]
map CadenceState -> [Integer]
forall {b}. Num b => CadenceState -> [b]
cadenceVoicing (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq CadenceState
sq)
  where
    cadenceVoicing :: CadenceState -> [b]
cadenceVoicing CadenceState
cs =
      let rootPC :: Int
rootPC = PitchClass -> Int
unPitchClass (NoteName -> PitchClass
pitchClass (CadenceState -> NoteName
stateCadenceRoot CadenceState
cs))
          tones :: [PitchClass]
tones = Cadence -> [PitchClass]
cadenceIntervals (CadenceState -> Cadence
stateCadence CadenceState
cs)
          pcs :: [Int]
pcs   = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\PitchClass
t -> (PitchClass -> Int
unPitchClass PitchClass
t 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) [PitchClass]
tones
      in (Int -> b) -> [Int] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int]
pcs

-------------------------------------------------------------------------------
-- Explicit Progression Construction
-------------------------------------------------------------------------------

-- |Name a chord from its zero-form intervals.
-- Uses legacy chord naming logic (toFunctionality for 3-note chords,
-- toFunctionalityChord for extended harmonies).
nameChord :: [Int] -> String
nameChord :: [Int] -> String
nameChord [Int]
intervals
  | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
intervals Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 =
      [PitchClass] -> String
toFunctionality ((Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
mkPitchClass [Int]
intervals)
  | Bool
otherwise =
      [PitchClass] -> String
toFunctionalityChord ((Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
mkPitchClass [Int]
intervals)

-- |Construct a Progression from explicit pitch-class sets.
-- This is the main function for composing\/arranging workflow (not generation).
-- Takes an enharmonic spelling and a list of chord pitch-class sets,
-- returns a Progression ready for 'Harmonic.Interface.Tidal.Bridge.arrange'.
--
-- Example:
-- @
-- fromChords [[0,4,7], [5,9,0], [7,11,2]]
--   --> C major → F major → G major
-- @
fromChords :: [[Int]] -> ProgressionContext
fromChords :: [[Int]] -> ProgressionContext
fromChords = Progression -> ProgressionContext
PC.fromProgression (Progression -> ProgressionContext)
-> ([[Int]] -> Progression) -> [[Int]] -> ProgressionContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Int]] -> Progression
fromChordsRaw

fromChordsRaw :: [[Int]] -> Progression
fromChordsRaw :: [[Int]] -> Progression
fromChordsRaw [] = Progression
forall a. Monoid a => a
mempty
fromChordsRaw [[Int]]
chordSets = Seq CadenceState -> Progression
Progression ([CadenceState] -> Seq CadenceState
forall a. [a] -> Seq a
Seq.fromList [CadenceState]
cadenceStates)
  where
    -- Spelling continuity: while the root pitch class stands still, the
    -- spelling stands still. Per-bar inference alone can flip enharmonic
    -- side between bars that share a root when an upper tone changes;
    -- holding the side over a stationary root keeps one region of a
    -- progression on one accidental system. The first bar infers freely;
    -- later bars adopt the previous spelling when the root is unchanged
    -- or the pitch content is enharmonically ambiguous.
    cadenceStates :: [CadenceState]
cadenceStates = Maybe (Int, EnharmonicSpelling) -> [[Int]] -> [CadenceState]
go Maybe (Int, EnharmonicSpelling)
forall a. Maybe a
Nothing [[Int]]
chordSets
      where
        go :: Maybe (Int, EnharmonicSpelling) -> [[Int]] -> [CadenceState]
go Maybe (Int, EnharmonicSpelling)
_ [] = []
        go Maybe (Int, EnharmonicSpelling)
prev ([Int]
pcs : [[Int]]
rest) =
          let cs :: CadenceState
cs = Maybe (Int, EnharmonicSpelling) -> [Int] -> CadenceState
toCadenceState Maybe (Int, EnharmonicSpelling)
prev [Int]
pcs
              rootPC :: Int
rootPC = (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) (case [Int]
pcs of { [] -> Int
0; (Int
p : [Int]
_) -> Int
p })
          in CadenceState
cs CadenceState -> [CadenceState] -> [CadenceState]
forall a. a -> [a] -> [a]
: Maybe (Int, EnharmonicSpelling) -> [[Int]] -> [CadenceState]
go ((Int, EnharmonicSpelling) -> Maybe (Int, EnharmonicSpelling)
forall a. a -> Maybe a
Just (Int
rootPC, CadenceState -> EnharmonicSpelling
stateSpelling CadenceState
cs)) [[Int]]
rest

    toCadenceState :: Maybe (Int, EnharmonicSpelling) -> [Int] -> CadenceState
    toCadenceState :: Maybe (Int, EnharmonicSpelling) -> [Int] -> CadenceState
toCadenceState Maybe (Int, EnharmonicSpelling)
prev [Int]
pcs =
      let rootInt :: Int
rootInt = case [Int]
pcs of { [] -> Int
0; (Int
p : [Int]
_) -> Int
p }
          rootPC :: PitchClass
rootPC = Int -> PitchClass
mkPitchClass Int
rootInt
          -- Dedup: pitch-class sets carry no duplicates (matches
          -- mkCadenceStatePCs; a duplicated PC would otherwise reach the
          -- voicing paths as a phantom voice).
          intervals :: [Int]
intervals = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
p -> (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
rootInt) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
pcs
          intervalPCs :: [PitchClass]
intervalPCs = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
mkPitchClass [Int]
intervals
          chordName :: String
chordName = [Int] -> String
nameChord [Int]
intervals
          -- Create Cadence with record syntax
          cadence :: Cadence
cadence = Cadence
            { cadenceFunctionality :: String
cadenceFunctionality = String
chordName
            , cadenceMovement :: Movement
cadenceMovement = Movement
Unison  -- Placeholder (no prior context)
            , cadenceIntervals :: [PitchClass]
cadenceIntervals = [PitchClass]
intervalPCs
            }
          absPCs :: [Int]
absPCs = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
pcs
          spelling :: EnharmonicSpelling
spelling = case Maybe (Int, EnharmonicSpelling)
prev of
            Just (Int
prevRoot, EnharmonicSpelling
prevSpelling)
              | Int
prevRoot Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rootInt Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12       -> EnharmonicSpelling
prevSpelling
              | [Int] -> Bool
isAmbiguousPattern [Int]
absPCs          -> EnharmonicSpelling
prevSpelling
            Maybe (Int, EnharmonicSpelling)
_                                      -> [Int] -> EnharmonicSpelling
inferSpelling [Int]
absPCs
          rootNote :: NoteName
rootNote = EnharmonicSpelling -> PitchClass -> NoteName
enharmonicFunc EnharmonicSpelling
spelling PitchClass
rootPC
       in Cadence -> NoteName -> EnharmonicSpelling -> CadenceState
CadenceState Cadence
cadence NoteName
rootNote EnharmonicSpelling
spelling

-- |Legacy alias for fromChords (matches legacy prog function)
prog :: [[Int]] -> ProgressionContext
prog :: [[Int]] -> ProgressionContext
prog = [[Int]] -> ProgressionContext
fromChords

-------------------------------------------------------------------------------
-- Scale Source (Switch Mechanism)
-------------------------------------------------------------------------------

-- |Scale source for melody mapping.
-- Enables flexible melody construction by allowing harmony (with optional
-- overlap) to serve as the scale source instead of explicit scale definitions.
data ScaleSource
  = ExplicitScale [[Int]]           -- ^ User-defined scale per chord
  | HarmonyAsScale Progression      -- ^ Use harmony chords as scales
  | HarmonyWithOverlap Progression (Int -> Progression -> Progression)
    -- ^ Use harmony with overlap function applied

-- |Create melody state from scale source.
-- Converts a ScaleSource into a Progression suitable for melody arrangement.
melodyStateFrom :: ScaleSource -> Progression
melodyStateFrom :: ScaleSource -> Progression
melodyStateFrom (ExplicitScale [[Int]]
scales) = [[Int]] -> Progression
fromChordsRaw [[Int]]
scales
melodyStateFrom (HarmonyAsScale Progression
progArg) = Progression
progArg  -- Direct passthrough
melodyStateFrom (HarmonyWithOverlap Progression
progArg Int -> Progression -> Progression
overlapFn) = Int -> Progression -> Progression
overlapFn Int
1 Progression
progArg

-------------------------------------------------------------------------------
-- Starting State Construction
-------------------------------------------------------------------------------

-- All unique 3-note zero-form sets: [0, a, b] with 1 ≤ a < b ≤ 11 (55 total)
allTriadZeroForms :: [[Int]]
allTriadZeroForms :: [[Int]]
allTriadZeroForms = [[Int
0, Int
a, Int
b] | Int
a <- [Int
1..Int
10], Int
b <- [Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1..Int
11]]

-- Map from quality name → all sets producing that name, sorted by dissonance
qualityMap :: Map.Map String [[Int]]
qualityMap :: Map String [[Int]]
qualityMap =
  ([[Int]] -> [[Int]]) -> Map String [[Int]] -> Map String [[Int]]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (([Int] -> [Int] -> Ordering) -> [[Int]] -> [[Int]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (([Int] -> Integer) -> [Int] -> [Int] -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing [Int] -> Integer
dissonanceScore))
  (Map String [[Int]] -> Map String [[Int]])
-> Map String [[Int]] -> Map String [[Int]]
forall a b. (a -> b) -> a -> b
$ ([[Int]] -> [[Int]] -> [[Int]])
-> [(String, [[Int]])] -> Map String [[Int]]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
(++)
    [ (String
name, [[Int]
zf])
    | [Int]
zf <- [[Int]]
allTriadZeroForms
    , let name :: String
name = [PitchClass] -> String
toFunctionality ((Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
mkPitchClass [Int]
zf)
    , Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name)
    ]

-- User-friendly alias table: shorthand → interval set variants (most consonant first)
qualityAliases :: Map.Map String [[Int]]
qualityAliases :: Map String [[Int]]
qualityAliases = [(String, [[Int]])] -> Map String [[Int]]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (String
"maj",  [[Int
0,Int
4,Int
7]])
  , (String
"min",  [[Int
0,Int
3,Int
7]])
  , (String
"dim",  [[Int
0,Int
3,Int
6]])
  , (String
"aug",  [[Int
0,Int
4,Int
8]])
  , (String
"7",    ([Int] -> [Int] -> Ordering) -> [[Int]] -> [[Int]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (([Int] -> Integer) -> [Int] -> [Int] -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing [Int] -> Integer
dissonanceScore) [[Int
0,Int
4,Int
10], [Int
0,Int
7,Int
10]])
  , (String
"dom7", ([Int] -> [Int] -> Ordering) -> [[Int]] -> [[Int]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (([Int] -> Integer) -> [Int] -> [Int] -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing [Int] -> Integer
dissonanceScore) [[Int
0,Int
4,Int
10], [Int
0,Int
7,Int
10]])
  , (String
"maj7", ([Int] -> [Int] -> Ordering) -> [[Int]] -> [[Int]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (([Int] -> Integer) -> [Int] -> [Int] -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing [Int] -> Integer
dissonanceScore) [[Int
0,Int
4,Int
11], [Int
0,Int
7,Int
11]])
  , (String
"min7", [[Int
0,Int
3,Int
10]])
  , (String
"m7",   [[Int
0,Int
3,Int
10]])
  , (String
"dim7", [[Int
0,Int
3,Int
6]])
  , (String
"hdim", ([Int] -> [Int] -> Ordering) -> [[Int]] -> [[Int]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (([Int] -> Integer) -> [Int] -> [Int] -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing [Int] -> Integer
dissonanceScore) [[Int
0,Int
3,Int
6], [Int
0,Int
3,Int
10]])
  , (String
"sus2", [[Int
0,Int
2,Int
7]])
  , (String
"sus4", [[Int
0,Int
5,Int
7]])
  , (String
"6",    [[Int
0,Int
4,Int
9]])
  , (String
"m6",   [[Int
0,Int
3,Int
9]])
  ]

-- Note name parsing table: lowercase → canonical
noteNameTable :: [(String, String)]
noteNameTable :: [(String, String)]
noteNameTable =
  [ (String
"c",String
"C"), (String
"db",String
"Db"), (String
"c#",String
"C#"), (String
"d",String
"D")
  , (String
"eb",String
"Eb"), (String
"d#",String
"D#"), (String
"e",String
"E"), (String
"f",String
"F")
  , (String
"gb",String
"Gb"), (String
"f#",String
"F#"), (String
"g",String
"G"), (String
"ab",String
"Ab")
  , (String
"g#",String
"G#"), (String
"a",String
"A"), (String
"bb",String
"Bb"), (String
"a#",String
"A#")
  , (String
"b",String
"B")
  ]

-- |Token type for 'parseLeadTokens'
data LeadToken = RootTok String | QualTok String | MoveTok Int
  deriving (Int -> LeadToken -> String -> String
[LeadToken] -> String -> String
LeadToken -> String
(Int -> LeadToken -> String -> String)
-> (LeadToken -> String)
-> ([LeadToken] -> String -> String)
-> Show LeadToken
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LeadToken -> String -> String
showsPrec :: Int -> LeadToken -> String -> String
$cshow :: LeadToken -> String
show :: LeadToken -> String
$cshowList :: [LeadToken] -> String -> String
showList :: [LeadToken] -> String -> String
Show, LeadToken -> LeadToken -> Bool
(LeadToken -> LeadToken -> Bool)
-> (LeadToken -> LeadToken -> Bool) -> Eq LeadToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeadToken -> LeadToken -> Bool
== :: LeadToken -> LeadToken -> Bool
$c/= :: LeadToken -> LeadToken -> Bool
/= :: LeadToken -> LeadToken -> Bool
Eq)

-- Parse a movement token: "(N)" or "(-N)" → Just N
parseMovement :: String -> Maybe Int
parseMovement :: String -> Maybe Int
parseMovement (Char
'(':String
rest) =
  case String -> String
forall a. [a] -> [a]
Prelude.reverse String
rest of
    (Char
')':String
inner) -> case ReadS Int
forall a. Read a => ReadS a
reads (String -> String
forall a. [a] -> [a]
Prelude.reverse String
inner) :: [(Int, String)] of
      [(Int
n, String
"")] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
      [(Int, String)]
_ -> Maybe Int
forall a. Maybe a
Nothing
    String
_ -> Maybe Int
forall a. Maybe a
Nothing
parseMovement String
_ = Maybe Int
forall a. Maybe a
Nothing

-- Classify a single token as root, movement, or quality
classifyToken :: String -> LeadToken
classifyToken :: String -> LeadToken
classifyToken String
tok
  | Just String
canonical <- String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
tok) [(String, String)]
noteNameTable = String -> LeadToken
RootTok String
canonical
  | Just Int
n         <- String -> Maybe Int
parseMovement String
tok                       = Int -> LeadToken
MoveTok Int
n
  | Bool
otherwise                                                 = String -> LeadToken
QualTok String
tok

-- |Parse a lead string into a list of typed tokens.
-- Each space-separated token is independently classified as root, quality, or movement.
parseLeadTokens :: String -> [LeadToken]
parseLeadTokens :: String -> [LeadToken]
parseLeadTokens = (String -> LeadToken) -> [String] -> [LeadToken]
forall a b. (a -> b) -> [a] -> [b]
map String -> LeadToken
classifyToken ([String] -> [LeadToken])
-> (String -> [String]) -> String -> [LeadToken]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words

-- Pick a variant from a sorted list, biased toward the most consonant
pickVariant :: GenIO -> String -> [[Int]] -> IO (String, [Int])
pickVariant :: GenIO -> String -> [[Int]] -> IO (String, [Int])
pickVariant GenIO
gen String
label [[Int]]
variants = do
  idx <- GenIO -> Double -> Int -> IO Int
gammaIndexScaledWith GenIO
gen Double
0.05 ([[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
variants)
  pure (label, variants !! idx)

-- Resolve a quality string to (label, intervals), or fall through to random
resolveQuality :: GenIO -> Maybe String -> IO (String, [Int])
resolveQuality :: GenIO -> Maybe String -> IO (String, [Int])
resolveQuality GenIO
gen Maybe String
Nothing  = GenIO -> IO (String, [Int])
randomQuality GenIO
gen
resolveQuality GenIO
gen (Just String
q) = do
  let qLower :: String
qLower = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
q
  case String -> Map String [[Int]] -> Maybe [[Int]]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
qLower Map String [[Int]]
qualityAliases of
    Just [[Int]]
vs -> GenIO -> String -> [[Int]] -> IO (String, [Int])
pickVariant GenIO
gen String
q [[Int]]
vs
    Maybe [[Int]]
Nothing -> case String -> Map String [[Int]] -> Maybe [[Int]]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
qLower Map String [[Int]]
qualityMap of
      Just [[Int]]
vs -> GenIO -> String -> [[Int]] -> IO (String, [Int])
pickVariant GenIO
gen String
q [[Int]]
vs
      Maybe [[Int]]
Nothing -> GenIO -> IO (String, [Int])
randomQuality GenIO
gen

-- Select a random quality, biased toward consonant (low entropy gamma)
randomQuality :: GenIO -> IO (String, [Int])
randomQuality :: GenIO -> IO (String, [Int])
randomQuality GenIO
gen = do
  let entries :: [(String, [[Int]])]
entries = ((String, [[Int]]) -> (String, [[Int]]) -> Ordering)
-> [(String, [[Int]])] -> [(String, [[Int]])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((String, [[Int]]) -> Integer)
-> (String, [[Int]]) -> (String, [[Int]]) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(String
_, [[Int]]
vs) -> [Int] -> Integer
dissonanceScore (case [[Int]]
vs of { ([Int]
v : [[Int]]
_) -> [Int]
v; [] -> [] }))) (Map String [[Int]] -> [(String, [[Int]])]
forall k a. Map k a -> [(k, a)]
Map.toList Map String [[Int]]
qualityMap)
  idx <- GenIO -> Double -> Int -> IO Int
gammaIndexScaledWith GenIO
gen Double
0.2 ([(String, [[Int]])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, [[Int]])]
entries)
  let (name, variants) = entries !! idx
  pickVariant gen name variants

-- Select a random root from the 12 chromatic notes (uniform)
randomRoot :: GenIO -> IO String
randomRoot :: GenIO -> IO String
randomRoot GenIO
gen = do
  let roots :: [String]
roots = [String
"C",String
"C#",String
"D",String
"Eb",String
"E",String
"F",String
"F#",String
"G",String
"Ab",String
"A",String
"Bb",String
"B"]
  idx <- (Int, Int) -> Gen RealWorld -> IO Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
uniformRM (Int
0, [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
roots Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Gen RealWorld
GenIO
gen
  pure (roots !! idx)

-- |Construct a 'CadenceState' from a human-readable string.
--
-- Parses root, quality, and movement from space-separated tokens.
-- Unspecified components fall through to randomness.
-- Prints "root quality" to the console after construction.
--
-- Examples:
-- @
-- start <- lead "E min (5)"  -- E minor, ascending 5th
-- start <- lead "E min"      -- E minor, random movement
-- start <- lead "min"        -- random root, minor quality, random movement
-- start <- lead "E"          -- E, random quality, random movement
-- start <- lead ""           -- fully random
-- start <- lead "(5)"        -- random root and quality, fixed movement 5
-- @
lead :: String -> IO CadenceState
lead :: String -> IO CadenceState
lead String
input = do
  rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  let toks = String -> [LeadToken]
parseLeadTokens String
input
      mRoot = [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe [String
r | RootTok String
r <- [LeadToken]
toks]
      mQual = [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe [String
q | QualTok String
q <- [LeadToken]
toks]
      mMove = [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe [Int
m | MoveTok Int
m <- [LeadToken]
toks]
  rootStr          <- maybe (randomRoot rng) pure mRoot
  (qualLabel, ivs) <- resolveQuality rng mQual
  movement         <- maybe (uniformRM (-5, 6) rng) pure mMove
  let cs = Int -> String -> [Int] -> CadenceState
initCadenceState Int
movement String
rootStr [Int]
ivs
  putStrLn $ rootStr ++ " " ++ qualLabel
  pure cs

-- |Construct a 'CadenceState' from an explicit list of note names —
-- the arbitrary-cardinality counterpart to 'lead'. The first note is the
-- root\/bass; the rest become root-relative intervals (any count, so
-- hand-built 4-note cues and beyond are first-class). Never truncates:
-- builds via 'mkCadenceStatePCs', so all pitch content survives into the
-- cue. Enharmonics follow the typed accidentals ("Eb" spells flat,
-- "D#" sharp; double accidentals accepted and resolved). An optional
-- @(N)@ token fixes the approach movement, otherwise it is randomized
-- exactly like 'lead'. Unrecognized tokens are reported and skipped;
-- with no valid notes at all, falls back to fully random 'lead'.
--
-- Examples:
-- @
-- start <- lead' "Eb Gb Bb Db"      -- Eb m7, random movement
-- start <- lead' "A C E G (5)"      -- A m7, ascending 5th approach
-- start <- lead' "C E G"            -- plain triad, same as lead "C maj"
-- @
lead' :: String -> IO CadenceState
lead' :: String -> IO CadenceState
lead' String
input = do
  rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  let toks       = String -> [String]
words String
input
      mMove      = [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe [ Int
n | String
t <- [String]
toks, Just Int
n <- [String -> Maybe Int
parseMovement String
t] ]
      noteToks   = [ String
t | String
t <- [String]
toks, String -> Maybe Int
parseMovement String
t Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
forall a. Maybe a
Nothing ]
      parsed     = [ (String
t, Text -> Maybe Int
Filter.noteNameToPitchClass (String -> Text
T.pack String
t)) | String
t <- [String]
noteToks ]
      badToks    = [ String
t | (String
t, Maybe Int
Nothing) <- [(String, Maybe Int)]
parsed ]
      notes      = [ (String
t, Int
p) | (String
t, Just Int
p) <- [(String, Maybe Int)]
parsed ]
  mapM_ (\String
t -> String -> IO ()
putStrLn (String
"lead': unrecognized note name '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' (skipped)")) badToks
  case notes of
    [] -> String -> IO CadenceState
lead String
""
    ((String
rootTok, Int
rootPC) : [(String, Int)]
_) -> do
      movement <- IO Int -> (Int -> IO Int) -> Maybe Int -> IO Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Int, Int) -> Gen RealWorld -> IO Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
uniformRM (-Int
5, Int
6) Gen RealWorld
rng) Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
mMove
      let rootInt   = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rootPC :: Int
          -- typed accidental drives the root's enharmonic identity
          rootName  = if Char
'b' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
rootTok)
                        then PitchClass -> NoteName
flat (Int -> PitchClass
mkPitchClass Int
rootInt) else PitchClass -> NoteName
sharp (Int -> PitchClass
mkPitchClass Int
rootInt)
          intervals = [ (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
rootInt) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | (String
_, Int
p) <- [(String, Int)]
notes ]
          cs        = NoteName -> Movement -> [Int] -> CadenceState
mkCadenceStatePCs NoteName
rootName
                        (PitchClass -> PitchClass -> Movement
toMovement (Int -> PitchClass
P Int
0) (Int -> PitchClass
mkPitchClass Int
movement)) [Int]
intervals
      putStrLn $ show rootName ++ " " ++ cadenceFunctionality (stateCadence cs)
      pure cs

-- |Construct a 'CadenceState' from a leadsheet chord symbol — the jazz
-- counterpart to 'lead', for cueing 'Harmonic.Framework.Builder.genJ'.
-- Accepts the Bunks corpus grammar: root, quality, optional slash bass
-- ("Cm7", "EbM7", "G7b9#11", "Dm7\/G"). Qualities occupy the jazz
-- namespace ('Harmonic.Rules.Import.Jazz.qualityIntervals'), entirely
-- separate from 'lead''s triadic quality table, so triadic behaviour is
-- untouched. A notated slash bass is honoured exactly: unioned into the
-- pitch-class set and made the anchor, so "Dm7\/G" cues from G with the
-- full Dm7 sounding above it. An optional @(N)@ token fixes the approach
-- movement, otherwise it is randomized exactly like 'lead'; either way
-- the movement shapes bar 1's stored metadata only — a fresh walk
-- departs from the functionality's hub node regardless. An
-- unparseable symbol is reported and falls back to the corpus workhorse
-- C m7.
--
-- Examples:
-- @
-- start <- leadJ "Cm7"        -- C m7, random movement
-- start <- leadJ "Dm7\/G"     -- G anchor, Dm7 above (a 9sus4 set)
-- start <- leadJ "EbM7 (5)"   -- Eb maj7, ascending 5th approach
-- @
leadJ :: String -> IO CadenceState
leadJ :: String -> IO CadenceState
leadJ String
input = do
  rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  let toks    = String -> [String]
words String
input
      mMove   = [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe [ Int
n | String
t <- [String]
toks, Just Int
n <- [String -> Maybe Int
parseMovement String
t] ]
      syms    = [ String
t | String
t <- [String]
toks, String -> Maybe Int
parseMovement String
t Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
forall a. Maybe a
Nothing ]
      moveTok = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" | Just Int
n <- [Maybe Int
mMove] ]
  case syms of
    (String
sym : [String]
_) | Right (J.Sounding JazzChord
jc) <- Text -> Either JazzRefusal JazzToken
J.parseToken (String -> Text
T.pack String
sym) -> do
      movement <- IO Int -> (Int -> IO Int) -> Maybe Int -> IO Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Int, Int) -> Gen RealWorld -> IO Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
uniformRM (-Int
5, Int
6) Gen RealWorld
rng) Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
mMove
      -- the typed accidental of the anchor segment drives its spelling
      let anchorTok  = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') String
sym of
            (String
_, Char
'/' : String
b) -> String
b
            (String
r, String
_)       -> (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"ABCDEFG#b" :: String)) (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
2 String
r)
          anchorName = if Char
'b' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
anchorTok
                         then PitchClass -> NoteName
flat (JazzChord -> PitchClass
J.jcAnchor JazzChord
jc) else PitchClass -> NoteName
sharp (JazzChord -> PitchClass
J.jcAnchor JazzChord
jc)
          intervals  = JazzChord -> [Int]
J.jazzZeroForm JazzChord
jc
          cs0        = NoteName -> Movement -> [Int] -> CadenceState
mkCadenceStatePCs NoteName
anchorName
                         (PitchClass -> PitchClass -> Movement
toMovement (Int -> PitchClass
P Int
0) (Int -> PitchClass
mkPitchClass Int
movement)) [Int]
intervals
          name       = String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Cadence -> String
cadenceFunctionality (CadenceState -> Cadence
stateCadence CadenceState
cs0)) Text -> String
T.unpack
                         ([Int] -> Maybe Text
J.jazzFunctionality [Int]
intervals)
          cs         = CadenceState
cs0 { stateCadence =
                               (stateCadence cs0) { cadenceFunctionality = name } }
      putStrLn $ show anchorName ++ " " ++ name
      pure cs
    [String]
_ -> do
      let reason :: String
reason = case [String]
syms of
            []       -> String
"no chord symbol"
            (String
s0 : [String]
_) -> case Text -> Either JazzRefusal JazzToken
J.parseToken (String -> Text
T.pack String
s0) of
              Left JazzRefusal
r  -> Text -> String
T.unpack (JazzRefusal -> Text
J.refusalReason JazzRefusal
r) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
              Right JazzToken
_ -> String
"NC is silence, not a chord"
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"leadJ: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" — cueing C m7"
      String -> IO CadenceState
leadJ (String
"Cm7" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
moveTok)