{-# LANGUAGE BangPatterns #-}

-- |
-- 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  -- Per-voice tracking for non-triad chroma layers (key-signature semantic)

    -- * 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'
  , parseLeadTokens
  , LeadToken(..)
  ) where

import qualified Data.Sequence as Seq
import Data.Sequence (Seq, (><))
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 (Chord(..), Cadence(..), CadenceState(..), fromCadenceState, ChordState(..), EnharmonicSpelling(..), toFunctionality, toFunctionalityChord, Movement(..), enharmonicFunc, inferSpelling, isAmbiguousPattern, initCadenceState, mkCadenceStatePCs, toMovement)
import qualified Harmonic.Rules.Constraints.Filter as Filter
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, liteVoicing, 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)
rotate :: Int -> ProgressionContext -> ProgressionContext
rotate :: Int -> ProgressionContext -> ProgressionContext
rotate Int
n = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC (Int -> Progression -> Progression
rotateProgression Int
n)

-- |Extract bars start to end (1-indexed, inclusive)
excerpt :: Int -> Int -> ProgressionContext -> ProgressionContext
excerpt :: Int -> Int -> ProgressionContext -> ProgressionContext
excerpt Int
s Int
e = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC (Int -> Int -> Progression -> Progression
excerptProgression Int
s Int
e)

-- |Insert a CadenceState at position (1-indexed), replacing the existing one
insert :: CadenceState -> Int -> ProgressionContext -> ProgressionContext
insert :: CadenceState -> Int -> ProgressionContext -> ProgressionContext
insert CadenceState
cs Int
pos = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC (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)
switch :: Int -> Int -> ProgressionContext -> ProgressionContext
switch :: Int -> Int -> ProgressionContext -> ProgressionContext
switch Int
m Int
n = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC (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)
clone :: Int -> Int -> ProgressionContext -> ProgressionContext
clone :: Int -> Int -> ProgressionContext -> ProgressionContext
clone Int
m Int
n = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC (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  = [Char] -> CadenceState
forall a. HasCallStack => [Char] -> a
error [Char]
"extract: empty progression"
  | Bool
otherwise = case Progression -> Int -> Maybe CadenceState
getCadenceState Progression
prog Int
idx of
      Just CadenceState
cs -> CadenceState
cs
      Maybe CadenceState
Nothing -> [Char] -> CadenceState
forall a. HasCallStack => [Char] -> a
error [Char]
"extract: internal error"
  where
    prog :: Progression
prog = ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc
    len :: Int
len  = Progression -> Int
progLength Progression
prog
    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
transposeP :: Int -> ProgressionContext -> ProgressionContext
transposeP :: Int -> ProgressionContext -> ProgressionContext
transposeP Int
n = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC (Int -> Progression -> Progression
transposeProgression Int
n)

-- |Reverse a progression
reverse :: ProgressionContext -> ProgressionContext
reverse :: ProgressionContext -> ProgressionContext
reverse = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC (\(Progression Seq CadenceState
s) -> Seq CadenceState -> Progression
Progression (Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a
Seq.reverse Seq CadenceState
s))

-- |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 = 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 = Maybe (Seq (Tristrata, StrataLabel))
forall a. Maybe a
Nothing
  }

-- |Expand a progression by repeating each chord n times
expandP :: Int -> ProgressionContext -> ProgressionContext
expandP :: Int -> ProgressionContext -> ProgressionContext
expandP Int
n = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC (Int -> Progression -> Progression
expandProgression Int
n)

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

-- |Bidirectional overlap: merge pitches from n bars in both directions
progOverlap :: Int -> Progression -> Progression
progOverlap :: Int -> Progression -> Progression
progOverlap Int
range prog :: Progression
prog@(Progression Seq CadenceState
seq)
  | Int
range Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Progression
prog
  | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
seq = Progression
prog
  | Bool
otherwise = 
    let chords :: [Chord]
chords = Seq Chord -> [Chord]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Chord -> [Chord]) -> Seq Chord -> [Chord]
forall a b. (a -> b) -> a -> b
$ (CadenceState -> Chord) -> Seq CadenceState -> Seq Chord
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CadenceState -> Chord
fromCadenceState Seq CadenceState
seq
        cadences :: [Cadence]
cadences = Seq Cadence -> [Cadence]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Cadence -> [Cadence]) -> Seq Cadence -> [Cadence]
forall a b. (a -> b) -> a -> b
$ (CadenceState -> Cadence) -> Seq CadenceState -> Seq Cadence
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CadenceState -> Cadence
stateCadence Seq CadenceState
seq
        roots :: [NoteName]
roots = Seq NoteName -> [NoteName]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq NoteName -> [NoteName]) -> Seq NoteName -> [NoteName]
forall a b. (a -> b) -> a -> b
$ (CadenceState -> NoteName) -> Seq CadenceState -> Seq NoteName
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CadenceState -> NoteName
stateCadenceRoot Seq CadenceState
seq
        len :: Int
len = [Chord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Chord]
chords
        
        -- For each position, gather pitches from range bars before and after
        overlappedChords :: [[Integer]]
overlappedChords = 
          [ Int -> [Chord] -> Int -> [Integer]
overlapAt Int
i [Chord]
chords Int
range | Int
i <- [Int
0..Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]
        
        -- Rebuild CadenceStates with original cadences but new chord intervals
        newSeq :: Seq CadenceState
newSeq = [CadenceState] -> Seq CadenceState
forall a. [a] -> Seq a
Seq.fromList ([CadenceState] -> Seq CadenceState)
-> [CadenceState] -> Seq CadenceState
forall a b. (a -> b) -> a -> b
$ (Cadence -> NoteName -> [Integer] -> CadenceState)
-> [Cadence] -> [NoteName] -> [[Integer]] -> [CadenceState]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Cadence -> NoteName -> [Integer] -> CadenceState
rebuildCadenceState [Cadence]
cadences [NoteName]
roots [[Integer]]
overlappedChords
    in Seq CadenceState -> Progression
Progression Seq CadenceState
newSeq

-- |Forward-only overlap: merge pitches from n bars ahead
progOverlapF :: Int -> Progression -> Progression
progOverlapF :: Int -> Progression -> Progression
progOverlapF Int
range prog :: Progression
prog@(Progression Seq CadenceState
seq)
  | Int
range Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Progression
prog
  | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
seq = Progression
prog
  | Bool
otherwise = 
    let chords :: [Chord]
chords = Seq Chord -> [Chord]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Chord -> [Chord]) -> Seq Chord -> [Chord]
forall a b. (a -> b) -> a -> b
$ (CadenceState -> Chord) -> Seq CadenceState -> Seq Chord
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CadenceState -> Chord
fromCadenceState Seq CadenceState
seq
        cadences :: [Cadence]
cadences = Seq Cadence -> [Cadence]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Cadence -> [Cadence]) -> Seq Cadence -> [Cadence]
forall a b. (a -> b) -> a -> b
$ (CadenceState -> Cadence) -> Seq CadenceState -> Seq Cadence
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CadenceState -> Cadence
stateCadence Seq CadenceState
seq
        roots :: [NoteName]
roots = Seq NoteName -> [NoteName]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq NoteName -> [NoteName]) -> Seq NoteName -> [NoteName]
forall a b. (a -> b) -> a -> b
$ (CadenceState -> NoteName) -> Seq CadenceState -> Seq NoteName
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CadenceState -> NoteName
stateCadenceRoot Seq CadenceState
seq
        len :: Int
len = [Chord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Chord]
chords
        
        overlappedChords :: [[Integer]]
overlappedChords = 
          [ Int -> [Chord] -> Int -> [Integer]
overlapForwardAt Int
i [Chord]
chords Int
range | Int
i <- [Int
0..Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]
        
        newSeq :: Seq CadenceState
newSeq = [CadenceState] -> Seq CadenceState
forall a. [a] -> Seq a
Seq.fromList ([CadenceState] -> Seq CadenceState)
-> [CadenceState] -> Seq CadenceState
forall a b. (a -> b) -> a -> b
$ (Cadence -> NoteName -> [Integer] -> CadenceState)
-> [Cadence] -> [NoteName] -> [[Integer]] -> [CadenceState]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Cadence -> NoteName -> [Integer] -> CadenceState
rebuildCadenceState [Cadence]
cadences [NoteName]
roots [[Integer]]
overlappedChords
    in Seq CadenceState -> Progression
Progression Seq CadenceState
newSeq

-- |Backward-only overlap: merge pitches from n bars behind  
progOverlapB :: Int -> Progression -> Progression
progOverlapB :: Int -> Progression -> Progression
progOverlapB Int
range prog :: Progression
prog@(Progression Seq CadenceState
seq)
  | Int
range Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Progression
prog
  | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
seq = Progression
prog
  | Bool
otherwise = 
    let chords :: [Chord]
chords = Seq Chord -> [Chord]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Chord -> [Chord]) -> Seq Chord -> [Chord]
forall a b. (a -> b) -> a -> b
$ (CadenceState -> Chord) -> Seq CadenceState -> Seq Chord
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CadenceState -> Chord
fromCadenceState Seq CadenceState
seq
        cadences :: [Cadence]
cadences = Seq Cadence -> [Cadence]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Cadence -> [Cadence]) -> Seq Cadence -> [Cadence]
forall a b. (a -> b) -> a -> b
$ (CadenceState -> Cadence) -> Seq CadenceState -> Seq Cadence
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CadenceState -> Cadence
stateCadence Seq CadenceState
seq
        roots :: [NoteName]
roots = Seq NoteName -> [NoteName]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq NoteName -> [NoteName]) -> Seq NoteName -> [NoteName]
forall a b. (a -> b) -> a -> b
$ (CadenceState -> NoteName) -> Seq CadenceState -> Seq NoteName
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CadenceState -> NoteName
stateCadenceRoot Seq CadenceState
seq
        len :: Int
len = [Chord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Chord]
chords
        
        overlappedChords :: [[Integer]]
overlappedChords = 
          [ Int -> [Chord] -> Int -> [Integer]
overlapBackwardAt Int
i [Chord]
chords Int
range | Int
i <- [Int
0..Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]
        
        newSeq :: Seq CadenceState
newSeq = [CadenceState] -> Seq CadenceState
forall a. [a] -> Seq a
Seq.fromList ([CadenceState] -> Seq CadenceState)
-> [CadenceState] -> Seq CadenceState
forall a b. (a -> b) -> a -> b
$ (Cadence -> NoteName -> [Integer] -> CadenceState)
-> [Cadence] -> [NoteName] -> [[Integer]] -> [CadenceState]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Cadence -> NoteName -> [Integer] -> CadenceState
rebuildCadenceState [Cadence]
cadences [NoteName]
roots [[Integer]]
overlappedChords
    in Seq CadenceState -> Progression
Progression Seq CadenceState
newSeq

-- Helper: get overlapped pitches for position i (bidirectional)
overlapAt :: Int -> [Chord] -> Int -> [Integer]
overlapAt :: Int -> [Chord] -> Int -> [Integer]
overlapAt Int
i [Chord]
chords Int
range =
  let len :: Int
len = [Chord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Chord]
chords
      indices :: [Int]
indices = [Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
range) .. 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
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
range)]
      allPitches :: [Integer]
allPitches = (Int -> [Integer]) -> [Int] -> [Integer]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Chord -> [Integer]
chordIntervals (Chord -> [Integer]) -> (Int -> Chord) -> Int -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Chord]
chords [Chord] -> Int -> Chord
forall a. HasCallStack => [a] -> Int -> a
!!)) [Int]
indices
  in [Integer] -> [Integer]
forall a. Eq a => [a] -> [a]
nub [Integer]
allPitches

-- Helper: get overlapped pitches for position i (forward only)
overlapForwardAt :: Int -> [Chord] -> Int -> [Integer]
overlapForwardAt :: Int -> [Chord] -> Int -> [Integer]
overlapForwardAt Int
i [Chord]
chords Int
range =
  let len :: Int
len = [Chord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Chord]
chords
      indices :: [Int]
indices = [Int
i .. 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
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
range)]
      allPitches :: [Integer]
allPitches = (Int -> [Integer]) -> [Int] -> [Integer]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Chord -> [Integer]
chordIntervals (Chord -> [Integer]) -> (Int -> Chord) -> Int -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Chord]
chords [Chord] -> Int -> Chord
forall a. HasCallStack => [a] -> Int -> a
!!)) [Int]
indices
  in [Integer] -> [Integer]
forall a. Eq a => [a] -> [a]
nub [Integer]
allPitches

-- Helper: get overlapped pitches for position i (backward only)
overlapBackwardAt :: Int -> [Chord] -> Int -> [Integer]
overlapBackwardAt :: Int -> [Chord] -> Int -> [Integer]
overlapBackwardAt Int
i [Chord]
chords Int
range =
  let indices :: [Int]
indices = [Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
range) .. Int
i]
      allPitches :: [Integer]
allPitches = (Int -> [Integer]) -> [Int] -> [Integer]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Chord -> [Integer]
chordIntervals (Chord -> [Integer]) -> (Int -> Chord) -> Int -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Chord]
chords [Chord] -> Int -> Chord
forall a. HasCallStack => [a] -> Int -> a
!!)) [Int]
indices
  in [Integer] -> [Integer]
forall a. Eq a => [a] -> [a]
nub [Integer]
allPitches

-- Helper: rebuild a CadenceState with new intervals
rebuildCadenceState :: Cadence -> NoteName -> [Integer] -> CadenceState
rebuildCadenceState :: Cadence -> NoteName -> [Integer] -> CadenceState
rebuildCadenceState Cadence
cad NoteName
root [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
      newCad :: Cadence
newCad = Cadence
cad { cadenceIntervals = newPCs }
      -- Infer spelling from the new absolute pitches
      rootPC :: PitchClass
rootPC = NoteName -> PitchClass
pitchClass NoteName
root
      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
root 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
prog
  | Progression -> Bool
hasBigChroma Progression
prog = Progression -> [[Int]]
strataModeFlow Progression
prog
  | 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
prog
      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
prog
  | Progression -> Bool
hasBigChroma Progression
prog = Progression -> [[Int]]
strataModeFlow Progression
prog
  | 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
prog
      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
prog = 
  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
prog
  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
prog =
  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
prog
  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: each bar is the bar's chroma in
-- sorted-ascending compressed form rooted on its harmonic root, with the
-- whole voicing octave-shifted to minimise voice movement against the bar 0
-- anchor. Functions as a "key signature": pattern index @i@ in any bar plays
-- the i-th scale degree of that bar's strata \/ mode, so pattern increments
-- of 1 always ascend by one set member and decrements descend by one.
--
-- Bar 0: 'initialCompact' + 'normalizeByFirstRoot' anchors the harmonic
-- root in the standard window ([-12, -1] note range). Span ≤ 12 semitones
-- from root upward.
--
-- Bar n+1: 'initialCompact' rooted on bar n+1's harmonic root produces a
-- "natural" compressed-ascending voicing; the whole voicing is then shifted
-- by the octave (k·12 for @k ∈ [-3..3]@) that minimises total
-- @|placed_MIDI - anchor_MIDI|@ across voices, where @anchor@ is bar 0's
-- voicing. The root is allowed to migrate octaves freely if that makes the
-- line closer to the anchor. Voicing remains sorted ascending after the
-- shift (uniform shift preserves order), so "ascend by 1 with idx+1" holds.
--
-- Anchoring to bar 0 (rather than the previous bar) guarantees:
--   * No drift over long walks — every bar stays within ~6 semitones of the
--     anchor.
--   * Cyclic return to anchor at the pattern wrap (bar N-1 → bar 0).
--   * When chroma cycles back to bar 0's chroma (e.g. tristrata II-VI-X
--     repeating), the bar lands on bar 0's exact MIDI (shift = 0).
--
-- O(n × k) per bar where n = chroma cardinality and k = number of octave
-- candidates (~7). Sub-microsecond per bar; eager forcing in 'Bridge.arrange'
-- still hoists the work to REPL evaluation time.
strataModeFlow :: Progression -> [[Int]]
strataModeFlow :: Progression -> [[Int]]
strataModeFlow Progression
prog =
  case Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
unProgression Progression
prog) 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]
shiftBar [Int]
v0) [CadenceState]
restCSs
      in [[Int]] -> [[Int]]
normalizeByFirstRoot [[Int]]
voicings

-- |Build a bar's natural compressed-ascending voicing, then choose the
-- uniform octave shift that minimises total absolute MIDI distance to the
-- bar 0 anchor @v0@. Each bar is independently anchored so drift is bounded.
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

-- |True iff any bar carries >= 6 pitch classes — scale-cluster territory
-- (hand-built mode sets; genP chroma layers route by provenance in Bridge
-- before reaching here). The cyclic DP on 6\/7-voice sets is both
-- prohibitively slow live (16-bar 7-PC ≈ 107 s interpreted) and musically
-- the wrong tool ("voice leading" between scale-clusters); such material
-- gets the chroma engine's degree semantics as a safety fallback, not a
-- contract. Harmony-sized bars (<= 5 voices, mixed or uniform) always get
-- the real DP.
hasBigChroma :: Progression -> Bool
hasBigChroma :: Progression -> Bool
hasBigChroma Progression
prog =
  (CadenceState -> Bool) -> [CadenceState] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\CadenceState
cs -> [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cadence -> [PitchClass]
cadenceIntervals (CadenceState -> Cadence
stateCadence CadenceState
cs)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6)
      (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
unProgression Progression
prog))

-- |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, ...] — i.e. degree-ordered. Pattern idx 0
-- therefore tracks the 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
seq) =
  (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
seq)
  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] -> [Char]
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] -> [Char]
toFunctionality ((Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
mkPitchClass [Int]
intervals)
  | Bool
otherwise =
      [PitchClass] -> [Char]
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) (if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
pcs then Int
0 else [Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
pcs)
          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 root :: Int
root = if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
pcs then Int
0 else [Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
pcs
          rootPC :: PitchClass
rootPC = Int -> PitchClass
mkPitchClass Int
root
          -- 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
root) 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 :: [Char]
chordName = [Int] -> [Char]
nameChord [Int]
intervals
          -- Create Cadence with record syntax
          cadence :: Cadence
cadence = Cadence
            { cadenceFunctionality :: [Char]
cadenceFunctionality = [Char]
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
root 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
prog) = Progression
prog  -- Direct passthrough
melodyStateFrom (HarmonyWithOverlap Progression
prog Int -> Progression -> Progression
overlapFn) = Int -> Progression -> Progression
overlapFn Int
1 Progression
prog

-------------------------------------------------------------------------------
-- 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 [Char] [[Int]]
qualityMap =
  ([[Int]] -> [[Int]]) -> Map [Char] [[Int]] -> Map [Char] [[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 [Char] [[Int]] -> Map [Char] [[Int]])
-> Map [Char] [[Int]] -> Map [Char] [[Int]]
forall a b. (a -> b) -> a -> b
$ ([[Int]] -> [[Int]] -> [[Int]])
-> [([Char], [[Int]])] -> Map [Char] [[Int]]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
(++)
    [ ([Char]
name, [[Int]
zf])
    | [Int]
zf <- [[Int]]
allTriadZeroForms
    , let name :: [Char]
name = [PitchClass] -> [Char]
toFunctionality ((Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
mkPitchClass [Int]
zf)
    , Bool -> Bool
not ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
name)
    ]

-- User-friendly alias table: shorthand → interval set variants (most consonant first)
qualityAliases :: Map.Map String [[Int]]
qualityAliases :: Map [Char] [[Int]]
qualityAliases = [([Char], [[Int]])] -> Map [Char] [[Int]]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ ([Char]
"maj",  [[Int
0,Int
4,Int
7]])
  , ([Char]
"min",  [[Int
0,Int
3,Int
7]])
  , ([Char]
"dim",  [[Int
0,Int
3,Int
6]])
  , ([Char]
"aug",  [[Int
0,Int
4,Int
8]])
  , ([Char]
"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]])
  , ([Char]
"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]])
  , ([Char]
"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]])
  , ([Char]
"min7", [[Int
0,Int
3,Int
10]])
  , ([Char]
"m7",   [[Int
0,Int
3,Int
10]])
  , ([Char]
"dim7", [[Int
0,Int
3,Int
6]])
  , ([Char]
"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]])
  , ([Char]
"sus2", [[Int
0,Int
2,Int
7]])
  , ([Char]
"sus4", [[Int
0,Int
5,Int
7]])
  , ([Char]
"6",    [[Int
0,Int
4,Int
9]])
  , ([Char]
"m6",   [[Int
0,Int
3,Int
9]])
  ]

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

-- |Token type for 'parseLeadTokens'
data LeadToken = RootTok String | QualTok String | MoveTok Int
  deriving (Int -> LeadToken -> ShowS
[LeadToken] -> ShowS
LeadToken -> [Char]
(Int -> LeadToken -> ShowS)
-> (LeadToken -> [Char])
-> ([LeadToken] -> ShowS)
-> Show LeadToken
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeadToken -> ShowS
showsPrec :: Int -> LeadToken -> ShowS
$cshow :: LeadToken -> [Char]
show :: LeadToken -> [Char]
$cshowList :: [LeadToken] -> ShowS
showList :: [LeadToken] -> ShowS
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 :: [Char] -> Maybe Int
parseMovement (Char
'(':[Char]
rest) =
  case ShowS
forall a. [a] -> [a]
Prelude.reverse [Char]
rest of
    (Char
')':[Char]
inner) -> case ReadS Int
forall a. Read a => ReadS a
reads (ShowS
forall a. [a] -> [a]
Prelude.reverse [Char]
inner) :: [(Int, String)] of
      [(Int
n, [Char]
"")] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
      [(Int, [Char])]
_ -> Maybe Int
forall a. Maybe a
Nothing
    [Char]
_ -> Maybe Int
forall a. Maybe a
Nothing
parseMovement [Char]
_ = Maybe Int
forall a. Maybe a
Nothing

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

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

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

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

-- Select a random root from the 12 chromatic notes (uniform)
randomRoot :: GenIO -> IO String
randomRoot :: GenIO -> IO [Char]
randomRoot GenIO
gen = do
  let roots :: [[Char]]
roots = [[Char]
"C",[Char]
"C#",[Char]
"D",[Char]
"Eb",[Char]
"E",[Char]
"F",[Char]
"F#",[Char]
"G",[Char]
"Ab",[Char]
"A",[Char]
"Bb",[Char]
"B"]
  Int
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, [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
roots Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Gen RealWorld
GenIO
gen
  [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]]
roots [[Char]] -> Int -> [Char]
forall a. HasCallStack => [a] -> Int -> a
!! Int
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 :: [Char] -> IO CadenceState
lead [Char]
input = do
  Gen RealWorld
rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  let toks :: [LeadToken]
toks = [Char] -> [LeadToken]
parseLeadTokens [Char]
input
      mRoot :: Maybe [Char]
mRoot = [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
listToMaybe [[Char]
r | RootTok [Char]
r <- [LeadToken]
toks]
      mQual :: Maybe [Char]
mQual = [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
listToMaybe [[Char]
q | QualTok [Char]
q <- [LeadToken]
toks]
      mMove :: Maybe Int
mMove = [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe [Int
m | MoveTok Int
m <- [LeadToken]
toks]
  [Char]
rootStr          <- IO [Char] -> ([Char] -> IO [Char]) -> Maybe [Char] -> IO [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GenIO -> IO [Char]
randomRoot Gen RealWorld
GenIO
rng) [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
mRoot
  ([Char]
qualLabel, [Int]
ivs) <- GenIO -> Maybe [Char] -> IO ([Char], [Int])
resolveQuality Gen RealWorld
GenIO
rng Maybe [Char]
mQual
  Int
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 cs :: CadenceState
cs = Int -> [Char] -> [Int] -> CadenceState
initCadenceState Int
movement [Char]
rootStr [Int]
ivs
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
rootStr [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
qualLabel
  CadenceState -> IO CadenceState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CadenceState
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
-- 4-note cues for @gen4@ 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' :: [Char] -> IO CadenceState
lead' [Char]
input = do
  Gen RealWorld
rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  let toks :: [[Char]]
toks       = [Char] -> [[Char]]
words [Char]
input
      mMove :: Maybe Int
mMove      = [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe [ Int
n | [Char]
t <- [[Char]]
toks, Just Int
n <- [[Char] -> Maybe Int
parseMovement [Char]
t] ]
      noteToks :: [[Char]]
noteToks   = [ [Char]
t | [Char]
t <- [[Char]]
toks, [Char] -> Maybe Int
parseMovement [Char]
t Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
forall a. Maybe a
Nothing ]
      parsed :: [([Char], Maybe Int)]
parsed     = [ ([Char]
t, Text -> Maybe Int
Filter.noteNameToPitchClass ([Char] -> Text
T.pack [Char]
t)) | [Char]
t <- [[Char]]
noteToks ]
      badToks :: [[Char]]
badToks    = [ [Char]
t | ([Char]
t, Maybe Int
Nothing) <- [([Char], Maybe Int)]
parsed ]
      notes :: [([Char], Int)]
notes      = [ ([Char]
t, Int
p) | ([Char]
t, Just Int
p) <- [([Char], Maybe Int)]
parsed ]
  ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\[Char]
t -> [Char] -> IO ()
putStrLn ([Char]
"lead': unrecognized note name '" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
t [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"' (skipped)")) [[Char]]
badToks
  case [([Char], Int)]
notes of
    [] -> [Char] -> IO CadenceState
lead [Char]
""
    (([Char]
rootTok, Int
rootPC) : [([Char], Int)]
_) -> do
      Int
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
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 :: NoteName
rootName  = if Char
'b' Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
rootTok)
                        then PitchClass -> NoteName
flat (Int -> PitchClass
mkPitchClass Int
rootInt) else PitchClass -> NoteName
sharp (Int -> PitchClass
mkPitchClass Int
rootInt)
          intervals :: [Int]
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 | ([Char]
_, Int
p) <- [([Char], Int)]
notes ]
          cs :: CadenceState
cs        = NoteName -> Movement -> [Int] -> CadenceState
mkCadenceStatePCs NoteName
rootName
                        (PitchClass -> PitchClass -> Movement
toMovement (Int -> PitchClass
P Int
0) (Int -> PitchClass
mkPitchClass Int
movement)) [Int]
intervals
      [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ NoteName -> [Char]
forall a. Show a => a -> [Char]
show NoteName
rootName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Cadence -> [Char]
cadenceFunctionality (CadenceState -> Cadence
stateCadence CadenceState
cs)
      CadenceState -> IO CadenceState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CadenceState
cs