-- |
-- Module      : Harmonic.Rules.Types.Progression
-- Description : Progression type with Monoid structure and manipulation functions
-- 
-- This module defines 'Progression' as a sequence of 'CadenceState' values
-- with Monoid structure for composability.
--
-- DESIGN DECISION (from evaluation):
--   "Stick to the Strict interpretation for the data structure (Seq CadenceState).
--    Let the VoiceLeading module handle the cost calculation separately.
--    Don't over-complicate the data type itself."
--
-- Therefore:
--   * 'mempty' = empty progression
--   * '(<>)' = simple concatenation (seam smoothing is handled externally)
--
-- The manipulation functions (rotate, excerpt, insert, etc.) are ported
-- from legacy Arranger.hs to enable macro-level musical operations.

module Harmonic.Rules.Types.Progression
  ( -- * Core Type
    Progression(..)
  
    -- * Construction
  , singleton
  , fromCadenceStates
  , fromChordStates
  
    -- * Queries
  , progLength
  , progChords
  , progCadences
  , getCadenceState
  , getChordState
  
    -- * Manipulation (ported from legacy Arranger.hs)
  , rotateProgression
  , rotateSeq
  , excerptProgression
  , excerptSeq
  , insertProgression
  , fuseProgression
  , interleaveSeq
  , transposeProgression
  , overlapProgression
  , expandProgression
  
    -- * Splice Operations
  , spliceProgression
  , fixMovementAt

    -- * Voicing Extractors
  , literalVoicing
  , harmonyVoicing
  , closeVoicing
  , wideVoicing
  
    -- * Display Helpers
  , showTriad
  , showHarmony
  ) where

import GHC.Generics (Generic)
import Data.List (sort)
import Data.Sequence (Seq, (><))
import qualified Data.Sequence as Seq
import Data.Foldable (toList)
import Data.List.Split (chunksOf)
import qualified Data.List as List
import qualified Data.Char as Char

import Harmonic.Rules.Types.Pitch (PitchClass(..), mkPitchClass, unPitchClass, NoteName(..), pitchClass)
-- |Import zeroFormPC for zero-form normalization in toCadenceStateFromPair to match DB convention
import Harmonic.Rules.Types.Harmony (Chord(..), Cadence(..), ChordState(..), CadenceState(..), fromCadenceState, Movement(..), toMovement, zeroFormPC, enharmonicFunc, inferSpelling, toFunctionalityChord)
import qualified Harmonic.Rules.Import.Jazz as J
import qualified Data.Text as T
import qualified Harmonic.Rules.Types.Scale as Sc

-------------------------------------------------------------------------------
-- Progression Type
-------------------------------------------------------------------------------

-- |A Progression is a sequence of CadenceStates.
-- Using 'Seq' for O(1) access to both ends and O(log n) concatenation.
--
-- Note: This is the "strict interpretation" - the sequence holds concrete
-- states, and voice leading costs are computed externally when needed.
newtype Progression = Progression { Progression -> Seq CadenceState
unProgression :: Seq CadenceState }
  deriving (Progression -> Progression -> Bool
(Progression -> Progression -> Bool)
-> (Progression -> Progression -> Bool) -> Eq Progression
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Progression -> Progression -> Bool
== :: Progression -> Progression -> Bool
$c/= :: Progression -> Progression -> Bool
/= :: Progression -> Progression -> Bool
Eq, (forall x. Progression -> Rep Progression x)
-> (forall x. Rep Progression x -> Progression)
-> Generic Progression
forall x. Rep Progression x -> Progression
forall x. Progression -> Rep Progression x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Progression -> Rep Progression x
from :: forall x. Progression -> Rep Progression x
$cto :: forall x. Rep Progression x -> Progression
to :: forall x. Rep Progression x -> Progression
Generic)

-- |Visual Show instance for Progression (ported from legacy MusicData.hs).
-- Displays progressions in a 4-column grid with bar number labels.
-- Each chord is rendered using the enharmonic spelling stored in its CadenceState root.
-- The final grid shows consistent note names throughout the progression.
instance Show Progression where
  show :: Progression -> [Char]
show (Progression Seq CadenceState
sq) 
    | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
sq = [Char]
"[empty progression]"
    | Bool
otherwise = 
      let cadenceStates :: [CadenceState]
cadenceStates = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq CadenceState
sq
          -- Get enharmonic function from each cadence's stored spelling
          enharms :: [PitchClass -> NoteName]
enharms = (CadenceState -> PitchClass -> NoteName)
-> [CadenceState] -> [PitchClass -> NoteName]
forall a b. (a -> b) -> [a] -> [b]
map (EnharmonicSpelling -> PitchClass -> NoteName
enharmonicFunc (EnharmonicSpelling -> PitchClass -> NoteName)
-> (CadenceState -> EnharmonicSpelling)
-> CadenceState
-> PitchClass
-> NoteName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> EnharmonicSpelling
stateSpelling) [CadenceState]
cadenceStates
          -- Name each state via the cardinality dispatch (triads keep the
          -- historical showTriad path; 4+ note states are never reduced)
          showChords :: [[Char]]
showChords = ((PitchClass -> NoteName) -> CadenceState -> [Char])
-> [PitchClass -> NoteName] -> [CadenceState] -> [[Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (PitchClass -> NoteName) -> CadenceState -> [Char]
showHarmony [PitchClass -> NoteName]
enharms [CadenceState]
cadenceStates
          -- Pad each chord string to fixed width (14 chars) and add separator
          paddedChords :: [[Char]]
paddedChords = ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
"|   ") ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
padTo Int
14) [[Char]]
showChords
          -- Group into lines of 4 chords with bar labels (consistent 3-space indent)
          barLabels :: [[Char]]
barLabels = [[Char]
"\n   1   ||   ", [Char]
"\n   5    |   ", [Char]
"\n   9    |   ", [Char]
"\n   13   |   ",
                       [Char]
"\n   17   |   ", [Char]
"\n   21   |   ", [Char]
"\n   25   |   ", [Char]
"\n   29   |   ",
                       [Char]
"\n   33   |   ", [Char]
"\n   37   |   ", [Char]
"\n   41   |   ", [Char]
"\n   45   |   ",
                       [Char]
"\n   49   |   ", [Char]
"\n   53   |   ", [Char]
"\n   57   |   ", [Char]
"\n   61   |   "]
          groupedChords :: [[[Char]]]
groupedChords = Int -> [[Char]] -> [[[Char]]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
4 [[Char]]
paddedChords
          -- Format each 4-bar group (remove trailing separator)
          formattedGroups :: [[Char]]
formattedGroups = ([[Char]] -> [Char]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS
forall a. HasCallStack => [a] -> [a]
init ShowS -> ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. HasCallStack => [a] -> [a]
init ShowS -> ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. HasCallStack => [a] -> [a]
init ShowS -> ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) [[[Char]]]
groupedChords
          -- Combine with labels
          result :: [Char]
result = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ([Char] -> ShowS) -> [[Char]] -> [[Char]] -> [[Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Char] -> ShowS
forall a. [a] -> [a] -> [a]
(++) [[Char]]
barLabels [[Char]]
formattedGroups
      in [Char]
result [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"|\n"
    where
      padTo :: Int -> ShowS
padTo Int
n [Char]
s = [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
' '

-- |Monoid instance: empty progression as identity, concatenation as operation.
-- The "seam" between concatenated progressions is NOT automatically smoothed;
-- that responsibility lies with the VoiceLeading module.
instance Semigroup Progression where
  (<>) :: Progression -> Progression -> Progression
  (Progression Seq CadenceState
a) <> :: Progression -> Progression -> Progression
<> (Progression Seq CadenceState
b) = Seq CadenceState -> Progression
Progression (Seq CadenceState
a Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
>< Seq CadenceState
b)

instance Monoid Progression where
  mempty :: Progression
  mempty :: Progression
mempty = Seq CadenceState -> Progression
Progression Seq CadenceState
forall a. Seq a
Seq.empty

-------------------------------------------------------------------------------
-- Construction
-------------------------------------------------------------------------------

-- |Create a progression from a single CadenceState
singleton :: CadenceState -> Progression
singleton :: CadenceState -> Progression
singleton CadenceState
cs = Seq CadenceState -> Progression
Progression (CadenceState -> Seq CadenceState
forall a. a -> Seq a
Seq.singleton CadenceState
cs)

-- |Create a progression from a list of CadenceStates
fromCadenceStates :: [CadenceState] -> Progression
fromCadenceStates :: [CadenceState] -> Progression
fromCadenceStates = Seq CadenceState -> Progression
Progression (Seq CadenceState -> Progression)
-> ([CadenceState] -> Seq CadenceState)
-> [CadenceState]
-> Progression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CadenceState] -> Seq CadenceState
forall a. [a] -> Seq a
Seq.fromList

-- |Create a progression from a list of ChordStates (inferring cadences)
-- Each consecutive pair forms a cadence.
fromChordStates :: [ChordState] -> Progression
fromChordStates :: [ChordState] -> Progression
fromChordStates [] = Progression
forall a. Monoid a => a
mempty
fromChordStates [ChordState
_] = Progression
forall a. Monoid a => a
mempty  -- Need at least 2 chords for a cadence
fromChordStates [ChordState]
states =
  let pairs :: [(ChordState, ChordState)]
pairs = [ChordState] -> [ChordState] -> [(ChordState, ChordState)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ChordState]
states (Int -> [ChordState] -> [ChordState]
forall a. Int -> [a] -> [a]
drop Int
1 [ChordState]
states)
      cadenceStates :: [CadenceState]
cadenceStates = ((ChordState, ChordState) -> CadenceState)
-> [(ChordState, ChordState)] -> [CadenceState]
forall a b. (a -> b) -> [a] -> [b]
map (ChordState, ChordState) -> CadenceState
toCadenceStateFromPair [(ChordState, ChordState)]
pairs
  in [CadenceState] -> Progression
fromCadenceStates [CadenceState]
cadenceStates

-- |Helper: create CadenceState from a pair of ChordStates
-- Enharmonic spelling is inferred from the chord's absolute pitch content.
toCadenceStateFromPair :: (ChordState, ChordState) -> CadenceState
toCadenceStateFromPair :: (ChordState, ChordState) -> CadenceState
toCadenceStateFromPair (ChordState
from, ChordState
to) =
  let toChord :: Chord
toChord = ChordState -> Chord
stateChord ChordState
to
      -- Calculate movement
      fromRoot :: PitchClass
fromRoot = NoteName -> PitchClass
pitchClass (ChordState -> NoteName
stateRoot ChordState
from)
      toRoot :: PitchClass
toRoot = NoteName -> PitchClass
pitchClass (ChordState -> NoteName
stateRoot ChordState
to)
      mvmt :: Movement
mvmt = PitchClass -> PitchClass -> Movement
calculateMovement PitchClass
fromRoot PitchClass
toRoot
      -- Build cadence with zero-form intervals
      cad :: Cadence
cad = [Char] -> Movement -> [PitchClass] -> Cadence
Cadence (Chord -> [Char]
chordFunctionality Chord
toChord) Movement
mvmt ([PitchClass] -> [PitchClass]
zeroFormPC ([PitchClass] -> [PitchClass]) -> [PitchClass] -> [PitchClass]
forall a b. (a -> b) -> a -> b
$ (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
mkPitchClass ([Int] -> [PitchClass]) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
3 ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Chord -> [Integer]
chordIntervals Chord
toChord))
      -- Infer enharmonic spelling from absolute pitches
      tones :: [Int]
tones = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
unPitchClass ([PitchClass] -> [Int]) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> a -> b
$ Cadence -> [PitchClass]
cadenceIntervals Cadence
cad
      absolutePitches :: [Int]
absolutePitches = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
t -> (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PitchClass -> Int
unPitchClass PitchClass
toRoot) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
tones
      spelling :: EnharmonicSpelling
spelling = [Int] -> EnharmonicSpelling
inferSpelling [Int]
absolutePitches
  in Cadence -> NoteName -> EnharmonicSpelling -> CadenceState
CadenceState Cadence
cad (ChordState -> NoteName
stateRoot ChordState
to) EnharmonicSpelling
spelling
  where
    calculateMovement :: PitchClass -> PitchClass -> Movement
    calculateMovement :: PitchClass -> PitchClass -> Movement
calculateMovement (P Int
pcF) (P Int
pcT) =
      let diff :: Int
diff = (Int
pcT Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pcF) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
      in if Int
diff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 
         then if Int
diff Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Movement
Unison
              else if Int
diff Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 then Movement
Tritone
              else PitchClass -> Movement
Asc (Int -> PitchClass
P Int
diff)
         else PitchClass -> Movement
Desc (Int -> PitchClass
P (Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
diff))

-------------------------------------------------------------------------------
-- Queries
-------------------------------------------------------------------------------

-- |Get the length of a progression
progLength :: Progression -> Int
progLength :: Progression -> Int
progLength = Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length (Seq CadenceState -> Int)
-> (Progression -> Seq CadenceState) -> Progression -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Progression -> Seq CadenceState
unProgression

-- |Extract all chords from a progression
progChords :: Progression -> [Chord]
progChords :: Progression -> [Chord]
progChords (Progression Seq CadenceState
sq) = (CadenceState -> Chord) -> [CadenceState] -> [Chord]
forall a b. (a -> b) -> [a] -> [b]
map CadenceState -> Chord
fromCadenceState (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq CadenceState
sq)

-- |Extract all cadences from a progression
progCadences :: Progression -> [Cadence]
progCadences :: Progression -> [Cadence]
progCadences (Progression Seq CadenceState
sq) = (CadenceState -> Cadence) -> [CadenceState] -> [Cadence]
forall a b. (a -> b) -> [a] -> [b]
map CadenceState -> Cadence
stateCadence (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq CadenceState
sq)

-- |Get a CadenceState at a specific index (1-indexed for user friendliness)
getCadenceState :: Progression -> Int -> Maybe CadenceState
getCadenceState :: Progression -> Int -> Maybe CadenceState
getCadenceState (Progression Seq CadenceState
sq) Int
idx = Int -> Seq CadenceState -> Maybe CadenceState
forall a. Int -> Seq a -> Maybe a
Seq.lookup (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Seq CadenceState
sq

-- |Get a ChordState at a specific index (derived from CadenceState)
getChordState :: Progression -> Int -> Maybe ChordState
getChordState :: Progression -> Int -> Maybe ChordState
getChordState Progression
prog Int
idx = do
  cs <- Progression -> Int -> Maybe CadenceState
getCadenceState Progression
prog Int
idx
  let chord = CadenceState -> Chord
fromCadenceState CadenceState
cs
  return $ ChordState chord (stateCadenceRoot cs)

-------------------------------------------------------------------------------
-- Manipulation Functions (Ported from legacy Arranger.hs)
-------------------------------------------------------------------------------

-- |Rotate a progression by n positions
-- Positive n rotates left (first elements move to end)
-- Negative n rotates right (last elements move to front)
rotateProgression :: Int -> Progression -> Progression
rotateProgression :: Int -> Progression -> Progression
rotateProgression Int
n (Progression Seq CadenceState
sq) = Seq CadenceState -> Progression
Progression (Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
rotateSeq Int
n Seq CadenceState
sq)

-- |Element-agnostic core of 'rotateProgression', shared with the
-- provenance sequence so layers and provenance permute in lockstep.
rotateSeq :: Int -> Seq.Seq a -> Seq.Seq a
rotateSeq :: forall a. Int -> Seq a -> Seq a
rotateSeq Int
n Seq a
sq
  | Seq a -> Bool
forall a. Seq a -> Bool
Seq.null Seq a
sq = Seq a
sq
  | Bool
otherwise =
    let len :: Int
len = Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
sq
        n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len
        (Seq a
front, Seq a
back) = Int -> Seq a -> (Seq a, Seq a)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
n' Seq a
sq
    in Seq a
back Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
>< Seq a
front

-- |Extract a subsequence from a progression
-- Start and end are 1-indexed, inclusive
excerptProgression :: Int -> Int -> Progression -> Progression
excerptProgression :: Int -> Int -> Progression -> Progression
excerptProgression Int
start Int
end (Progression Seq CadenceState
sq) =
  Seq CadenceState -> Progression
Progression (Int -> Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Int -> Seq a -> Seq a
excerptSeq Int
start Int
end Seq CadenceState
sq)

-- |Element-agnostic core of 'excerptProgression' (1-indexed inclusive,
-- clamped, no wrap), shared with the provenance sequence.
excerptSeq :: Int -> Int -> Seq.Seq a -> Seq.Seq a
excerptSeq :: forall a. Int -> Int -> Seq a -> Seq a
excerptSeq Int
start Int
end Seq a
sq =
  let start' :: Int
start' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      len :: Int
len = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  in Int -> Seq a -> Seq a
forall a. Int -> Seq a -> Seq a
Seq.take Int
len (Int -> Seq a -> Seq a
forall a. Int -> Seq a -> Seq a
Seq.drop Int
start' Seq a
sq)

-- |Insert a progression at a specific position (1-indexed)
insertProgression :: Int -> Progression -> Progression -> Progression
insertProgression :: Int -> Progression -> Progression -> Progression
insertProgression Int
pos Progression
insert (Progression Seq CadenceState
target) =
  let pos' :: Int
pos' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      (Seq CadenceState
before, Seq CadenceState
after) = Int -> Seq CadenceState -> (Seq CadenceState, Seq CadenceState)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
pos' Seq CadenceState
target
  in Seq CadenceState -> Progression
Progression (Seq CadenceState
before Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
>< Progression -> Seq CadenceState
unProgression Progression
insert Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
>< Seq CadenceState
after)

-- |Fuse (interleave) two progressions
fuseProgression :: Progression -> Progression -> Progression
fuseProgression :: Progression -> Progression -> Progression
fuseProgression (Progression Seq CadenceState
a) (Progression Seq CadenceState
b) =
  Seq CadenceState -> Progression
Progression (Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
interleaveSeq Seq CadenceState
a Seq CadenceState
b)

-- |Element-agnostic core of 'fuseProgression' (alternating merge, longer
-- tail appended), shared with the provenance sequence.
interleaveSeq :: Seq.Seq a -> Seq.Seq a -> Seq.Seq a
interleaveSeq :: forall a. Seq a -> Seq a -> Seq a
interleaveSeq Seq a
a Seq a
b = [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList ([a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
go (Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq a
a) (Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq a
b))
  where
    go :: [a] -> [a] -> [a]
go [] [a]
ys = [a]
ys
    go [a]
xs [] = [a]
xs
    go (a
x:[a]
xs) (a
y:[a]
ys) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
go [a]
xs [a]
ys

-- |Transpose a progression by n semitones
transposeProgression :: Int -> Progression -> Progression
transposeProgression :: Int -> Progression -> Progression
transposeProgression Int
n (Progression Seq CadenceState
sq) =
  Seq CadenceState -> Progression
Progression (Seq CadenceState -> Progression)
-> Seq CadenceState -> Progression
forall a b. (a -> b) -> a -> b
$ (CadenceState -> CadenceState)
-> Seq CadenceState -> Seq CadenceState
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> CadenceState -> CadenceState
transposeCadenceState Int
n) Seq CadenceState
sq

-- |Helper: transpose a CadenceState, re-inferring spelling from new pitches
transposeCadenceState :: Int -> CadenceState -> CadenceState
transposeCadenceState :: Int -> CadenceState -> CadenceState
transposeCadenceState Int
n (CadenceState Cadence
cad NoteName
root EnharmonicSpelling
_oldSpelling) =
  let pc :: PitchClass
pc = NoteName -> PitchClass
pitchClass NoteName
root
      newRootPC :: PitchClass
newRootPC = PitchClass
pc PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ Int -> PitchClass
mkPitchClass Int
n
      tones :: [Int]
tones = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
unPitchClass ([PitchClass] -> [Int]) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> a -> b
$ Cadence -> [PitchClass]
cadenceIntervals Cadence
cad
      absolutePitches :: [Int]
absolutePitches = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
t -> (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PitchClass -> Int
unPitchClass PitchClass
newRootPC) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
tones
      newSpelling :: EnharmonicSpelling
newSpelling = [Int] -> EnharmonicSpelling
inferSpelling [Int]
absolutePitches
      newRoot :: NoteName
newRoot = EnharmonicSpelling -> PitchClass -> NoteName
enharmonicFunc EnharmonicSpelling
newSpelling PitchClass
newRootPC
  in Cadence -> NoteName -> EnharmonicSpelling -> CadenceState
CadenceState Cadence
cad NoteName
newRoot EnharmonicSpelling
newSpelling

-- |Overlap two progressions (start second before first ends)
overlapProgression :: Int -> Progression -> Progression -> Progression
overlapProgression :: Int -> Progression -> Progression -> Progression
overlapProgression Int
overlap (Progression Seq CadenceState
a) (Progression Seq CadenceState
b)
  | Int
overlap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
a = Seq CadenceState -> Progression
Progression Seq CadenceState
b
  | Bool
otherwise =
    let aLen :: Int
aLen = Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
a
        aTruncated :: Seq CadenceState
aTruncated = Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.take (Int
aLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
overlap) Seq CadenceState
a
    in Seq CadenceState -> Progression
Progression (Seq CadenceState
aTruncated Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
>< Seq CadenceState
b)

-- |Expand a progression by repeating it n times
expandProgression :: Int -> Progression -> Progression
expandProgression :: Int -> Progression -> Progression
expandProgression Int
n Progression
prog
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Progression
forall a. Monoid a => a
mempty
  | Bool
otherwise = [Progression] -> Progression
forall a. Monoid a => [a] -> a
mconcat (Int -> Progression -> [Progression]
forall a. Int -> a -> [a]
replicate Int
n Progression
prog)

-------------------------------------------------------------------------------
-- Splice Operations
-------------------------------------------------------------------------------

-- |Splice new chords into a progression, replacing a range (1-indexed, wrapping).
--
-- Non-wrapping (start <= end): replaces positions start..end.
-- Wrapping (start > end): replaces start..N and 1..end.
-- Fixes the movement at the seam where new chords meet kept chords.
spliceProgression :: Progression -> Int -> Int -> [CadenceState] -> Progression
spliceProgression :: Progression -> Int -> Int -> [CadenceState] -> Progression
spliceProgression (Progression Seq CadenceState
sq) Int
start Int
end [CadenceState]
newChords =
  let n :: Int
n = Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
sq
      newSeq :: Seq CadenceState
newSeq = [CadenceState] -> Seq CadenceState
forall a. [a] -> Seq a
Seq.fromList [CadenceState]
newChords
  in if Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
end then
    -- Non-wrapping
    let prefix :: Seq CadenceState
prefix = Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.take (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Seq CadenceState
sq
        suffix :: Seq CadenceState
suffix = Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.drop Int
end Seq CadenceState
sq
        result :: Seq CadenceState
result = Seq CadenceState
prefix Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
>< Seq CadenceState
newSeq Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
>< Seq CadenceState
suffix
        jIdx :: Int
jIdx = Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
prefix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
newSeq  -- 0-indexed position of first suffix chord
    in if Int
jIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
result Bool -> Bool -> Bool
&& Int
jIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
suffix)
       then Int -> Progression -> Progression
fixMovementAt0 Int
jIdx (Seq CadenceState -> Progression
Progression Seq CadenceState
result)
       else Seq CadenceState -> Progression
Progression Seq CadenceState
result
  else
    -- Wrapping: replaced = [start..N] ++ [1..end], kept = [end+1..start-1]
    let kept :: Seq CadenceState
kept = Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.take (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.drop Int
end Seq CadenceState
sq)
        headCount :: Int
headCount = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        newAtEnd :: Seq CadenceState
newAtEnd = Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.take Int
headCount Seq CadenceState
newSeq
        newAtStart :: Seq CadenceState
newAtStart = Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.drop Int
headCount Seq CadenceState
newSeq
        result :: Seq CadenceState
result = Seq CadenceState
newAtStart Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
>< Seq CadenceState
kept Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
>< Seq CadenceState
newAtEnd
        jIdx :: Int
jIdx = Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
newAtStart  -- 0-indexed position of first kept chord
    in if Int
jIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
result Bool -> Bool -> Bool
&& Int
jIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
kept)
       then Int -> Progression -> Progression
fixMovementAt0 Int
jIdx (Seq CadenceState -> Progression
Progression Seq CadenceState
result)
       else Seq CadenceState -> Progression
Progression Seq CadenceState
result

-- |Fix the movement at a 1-indexed position by recomputing from predecessor's root.
fixMovementAt :: Int -> Progression -> Progression
fixMovementAt :: Int -> Progression -> Progression
fixMovementAt Int
pos = Int -> Progression -> Progression
fixMovementAt0 (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- |Internal: fix movement at 0-indexed position.
fixMovementAt0 :: Int -> Progression -> Progression
fixMovementAt0 :: Int -> Progression -> Progression
fixMovementAt0 Int
idx (Progression Seq CadenceState
sq)
  | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
sq Bool -> Bool -> Bool
|| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
sq = Seq CadenceState -> Progression
Progression Seq CadenceState
sq
  | Bool
otherwise =
    let prevCS :: CadenceState
prevCS = Seq CadenceState -> Int -> CadenceState
forall a. Seq a -> Int -> a
Seq.index Seq CadenceState
sq (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        currCS :: CadenceState
currCS = Seq CadenceState -> Int -> CadenceState
forall a. Seq a -> Int -> a
Seq.index Seq CadenceState
sq Int
idx
        prevRootPC :: PitchClass
prevRootPC = NoteName -> PitchClass
pitchClass (CadenceState -> NoteName
stateCadenceRoot CadenceState
prevCS)
        currRootPC :: PitchClass
currRootPC = NoteName -> PitchClass
pitchClass (CadenceState -> NoteName
stateCadenceRoot CadenceState
currCS)
        newMovement :: Movement
newMovement = PitchClass -> PitchClass -> Movement
toMovement PitchClass
prevRootPC PitchClass
currRootPC
        oldCadence :: Cadence
oldCadence = CadenceState -> Cadence
stateCadence CadenceState
currCS
        newCadence :: Cadence
newCadence = Cadence
oldCadence { cadenceMovement = newMovement }
        fixed :: CadenceState
fixed = CadenceState
currCS { stateCadence = newCadence }
    in Seq CadenceState -> Progression
Progression (Int -> CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Int -> a -> Seq a -> Seq a
Seq.update Int
idx CadenceState
fixed Seq CadenceState
sq)

-------------------------------------------------------------------------------
-- Voicing Extractors
-- These convert progressions to integer pitch lists for performance
-------------------------------------------------------------------------------

-- |Extract literal voicings (pitch integers as stored)
literalVoicing :: Progression -> [[Int]]
literalVoicing :: Progression -> [[Int]]
literalVoicing (Progression Seq CadenceState
sq) = 
  (CadenceState -> [Int]) -> [CadenceState] -> [[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])
-> (CadenceState -> [Integer]) -> CadenceState -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chord -> [Integer]
chordIntervals (Chord -> [Integer])
-> (CadenceState -> Chord) -> CadenceState -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> Chord
fromCadenceState) (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq CadenceState
sq)

-- |Extract harmony voicings (pitch classes only, 0-11)
harmonyVoicing :: Progression -> [[Int]]
harmonyVoicing :: Progression -> [[Int]]
harmonyVoicing Progression
prog = ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((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)) (Progression -> [[Int]]
literalVoicing Progression
prog)

-- |Extract close voicings (smallest possible span)
closeVoicing :: Progression -> [[Int]]
closeVoicing :: Progression -> [[Int]]
closeVoicing Progression
prog = ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall {a}. Integral a => [a] -> [a]
toCloseVoicing (Progression -> [[Int]]
literalVoicing Progression
prog)
  where
    toCloseVoicing :: [a] -> [a]
toCloseVoicing [a]
xs = 
      let sorted :: [a]
sorted = [a] -> [a]
forall a. Ord a => [a] -> [a]
sort ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
12) [a]
xs
      in [a]
sorted

-- |Extract wide voicings (spread across octaves)
wideVoicing :: Progression -> [[Int]]
wideVoicing :: Progression -> [[Int]]
wideVoicing Progression
prog = ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall {a}. Num a => [a] -> [a]
toWideVoicing (Progression -> [[Int]]
literalVoicing Progression
prog)
  where
    toWideVoicing :: [a] -> [a]
toWideVoicing [] = []
    toWideVoicing (a
bass:[a]
rest) = 
      let bassOctave :: a
bassOctave = a
bass
          -- Spread upper voices across higher octaves
          spread :: [a]
spread = (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(+) [a]
rest [a
12, a
24, a
36, a
48]
      in a
bassOctave a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
rest) [a]
spread

-------------------------------------------------------------------------------
-- Display Helpers
-------------------------------------------------------------------------------

-- |Show a chord using the given enharmonic function.
-- Ported from legacy MusicData.hs showTriad
-- Maps the chord to a human-readable string representation with
-- proper enharmonic spelling (e.g., "C maj" or "F# min\/A")
showTriad :: (PitchClass -> NoteName) -> Chord -> String
showTriad :: (PitchClass -> NoteName) -> Chord -> [Char]
showTriad PitchClass -> NoteName
f (Chord NoteName
noteName [Char]
functionality [Integer]
_)
    -- Root position sus4
    | [Char]
"sus4" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` [Char]
functionality Bool -> Bool -> Bool
&& Bool -> Bool
not (([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` [Char]
functionality) [[Char]
"_1stInv", [Char]
"_2ndInv"]) =
      NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
functionality
    -- 1st inversion major: C maj\/E (3rd in bass = root + 4 semitones)
    | ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` [Char]
functionality) [[Char]
"_1stInv", [Char]
"maj"] =
      NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum [Char]
functionality
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (NoteName -> PitchClass
pitchClass NoteName
noteName PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ Int -> PitchClass
P Int
4))
    -- 1st inversion minor: A min\/C (3rd in bass = root + 3 semitones)
    | ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` [Char]
functionality) [[Char]
"_1stInv", [Char]
"min"] =
      NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum [Char]
functionality
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (NoteName -> PitchClass
pitchClass NoteName
noteName PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ Int -> PitchClass
P Int
3))
    -- 1st inversion dim (3rd in bass = root + 3 semitones)
    | ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` [Char]
functionality) [[Char]
"_1stInv", [Char]
"dim"] =
      NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum [Char]
functionality [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
      [Char]
"/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (NoteName -> PitchClass
pitchClass NoteName
noteName PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ Int -> PitchClass
P Int
3))
    -- 2nd inversion maj\/min (5th in bass = root + 7 semitones)
    | [Char]
"_2ndInv" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` [Char]
functionality Bool -> Bool -> Bool
&& ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` [Char]
functionality) [[Char]
"maj", [Char]
"min"] =
      NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
      (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum [Char]
functionality [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (NoteName -> PitchClass
pitchClass NoteName
noteName PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ Int -> PitchClass
P Int
7))
    -- 2nd inversion dim (5th in bass = root + 6 semitones for diminished)
    | [Char]
"_2ndInv" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` [Char]
functionality Bool -> Bool -> Bool
&& [Char]
"dim" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` [Char]
functionality =
      NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
      (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum [Char]
functionality [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (NoteName -> PitchClass
pitchClass NoteName
noteName PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ Int -> PitchClass
P Int
6))
    -- Root position (default)
    | Bool
otherwise = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
functionality

-- |Cardinality-dispatching display for a 'CadenceState'. The display seam
-- for every printed chord name (grid, scoreboard, traces, cue messages):
--
--   * <= 3 intervals — the triad path ('fromCadenceState' \/ 'showTriad'),
--     byte-identical to the historical behaviour, including inversion
--     detection and slash-chord rendering. All corpus-generated cadences
--     have exactly 3 intervals, so this arm covers all `gen`/`genP` output.
--   * 4-6 intervals — root name + the stored 'cadenceFunctionality'
--     (populated by 'toFunctionalityChord' at construction). Recomputed
--     only when the stored name is empty (legacy chroma states). No
--     inversion vocabulary exists for extended harmonies.
--   * 7 intervals — mode classification pinned at the state's root
--     ('Harmonic.Rules.Types.Scale.classifyModeAt'), falling back to the chord namer when the set
--     doesn't classify.
--
-- Never reduces pitch content: replaces the old path that forced every
-- state through @toTriad'@s most-consonant reduction before naming.
showHarmony :: (PitchClass -> NoteName) -> CadenceState -> String
showHarmony :: (PitchClass -> NoteName) -> CadenceState -> [Char]
showHarmony PitchClass -> NoteName
f cs :: CadenceState
cs@(CadenceState Cadence
cad NoteName
root EnharmonicSpelling
_)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3 = (PitchClass -> NoteName) -> Chord -> [Char]
showTriad PitchClass -> NoteName
f (CadenceState -> Chord
fromCadenceState CadenceState
cs)
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7 =
      case Int -> [PitchClass] -> Maybe Mode
Sc.classifyModeAt Int
rootInt [PitchClass]
absPCs of
        Just (Sc.Mode ModeQuality
q (P Int
r)) ->
          NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (Int -> PitchClass
mkPitchClass Int
r)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ModeQuality -> [Char]
Sc.showModeQuality ModeQuality
q
        Maybe Mode
Nothing -> [Char]
chordName
  | Bool
otherwise = [Char]
chordName
  where
    ivs :: [PitchClass]
ivs     = Cadence -> [PitchClass]
cadenceIntervals Cadence
cad
    n :: Int
n       = [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PitchClass]
ivs
    rootInt :: Int
rootInt = PitchClass -> Int
unPitchClass (NoteName -> PitchClass
pitchClass NoteName
root)
    absPCs :: [PitchClass]
absPCs  = (PitchClass -> PitchClass) -> [PitchClass] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map (PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ NoteName -> PitchClass
pitchClass NoteName
root) [PitchClass]
ivs
    storedF :: [Char]
storedF = Cadence -> [Char]
cadenceFunctionality Cadence
cad
    fn :: [Char]
fn | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
storedF = [PitchClass] -> [Char]
toFunctionalityChord [PitchClass]
ivs
       | Bool
otherwise    = [Char]
storedF
    -- Jazz slash structures render in CHART convention: true root name +
    -- quality, slash + bass note name ("Bb 7/Ab", not "Ab 7/b7" — the
    -- stored anchor convention stays in the graph keys and traces, where
    -- it IS the address). 'J.parseSlashName' is the exact inverse over
    -- the closed corpus vocabulary, so only names the jazz namer wrote
    -- can rewrite — a classical "sus2/4no5" fails its degree-label
    -- membership and prints as stored. Both note names go through the
    -- caller's enharmonic function, so key spelling holds.
    chordName :: [Char]
chordName = case Text -> Maybe (Text, Int)
J.parseSlashName ([Char] -> Text
T.pack [Char]
fn) of
      Just (Text
quality, Int
d) | Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 ->
        NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (NoteName -> PitchClass
pitchClass NoteName
root PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ Int -> PitchClass
P Int
d)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
quality
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (NoteName -> PitchClass
pitchClass NoteName
root))
      Maybe (Text, Int)
_ -> NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (NoteName -> PitchClass
pitchClass NoteName
root)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
fn