{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE InstanceSigs #-}

-- |
-- 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
  , excerptProgression
  , insertProgression
  , fuseProgression
  , 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.Maybe (fromMaybe)
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, transpose, 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(..), fromMovement, toMovement, EnharmonicSpelling(..), zeroFormPC, enharmonicFunc, inferSpelling, toFunctionalityChord)
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 -> String
show (Progression Seq CadenceState
seq) 
    | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
seq = String
"[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
seq
          -- 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 :: [String]
showChords = ((PitchClass -> NoteName) -> CadenceState -> String)
-> [PitchClass -> NoteName] -> [CadenceState] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (PitchClass -> NoteName) -> CadenceState -> String
showHarmony [PitchClass -> NoteName]
enharms [CadenceState]
cadenceStates
          -- Pad each chord string to fixed width (14 chars) and add separator
          paddedChords :: [String]
paddedChords = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> ShowS
forall a. [a] -> [a] -> [a]
++String
"|   ") ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
padTo Int
14) [String]
showChords
          -- Group into lines of 4 chords with bar labels (consistent 3-space indent)
          barLabels :: [String]
barLabels = [String
"\n   1   ||   ", String
"\n   5    |   ", String
"\n   9    |   ", String
"\n   13   |   ",
                       String
"\n   17   |   ", String
"\n   21   |   ", String
"\n   25   |   ", String
"\n   29   |   ",
                       String
"\n   33   |   ", String
"\n   37   |   ", String
"\n   41   |   ", String
"\n   45   |   ",
                       String
"\n   49   |   ", String
"\n   53   |   ", String
"\n   57   |   ", String
"\n   61   |   "]
          groupedChords :: [[String]]
groupedChords = Int -> [String] -> [[String]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
4 [String]
paddedChords
          -- Format each 4-bar group (remove trailing separator)
          formattedGroups :: [String]
formattedGroups = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS
forall a. HasCallStack => [a] -> [a]
init ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. HasCallStack => [a] -> [a]
init ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. HasCallStack => [a] -> [a]
init ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) [[String]]
groupedChords
          -- Combine with labels
          result :: String
result = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> ShowS) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> ShowS
forall a. [a] -> [a] -> [a]
(++) [String]
barLabels [String]
formattedGroups
      in String
result String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|\n"
    where
      padTo :: Int -> ShowS
padTo Int
n String
s = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
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 ([ChordState] -> [ChordState]
forall a. HasCallStack => [a] -> [a]
tail [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 fromChord :: Chord
fromChord = ChordState -> Chord
stateChord ChordState
from
      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 = String -> Movement -> [PitchClass] -> Cadence
Cadence (Chord -> String
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
from) (P Int
to) = 
      let diff :: Int
diff = (Int
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
from) 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
seq) = (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
seq)

-- |Extract all cadences from a progression
progCadences :: Progression -> [Cadence]
progCadences :: Progression -> [Cadence]
progCadences (Progression Seq CadenceState
seq) = (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
seq)

-- |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
seq) 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
seq

-- |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
  CadenceState
cs <- Progression -> Int -> Maybe CadenceState
getCadenceState Progression
prog Int
idx
  let chord :: Chord
chord = CadenceState -> Chord
fromCadenceState CadenceState
cs
  ChordState -> Maybe ChordState
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChordState -> Maybe ChordState) -> ChordState -> Maybe ChordState
forall a b. (a -> b) -> a -> b
$ Chord -> NoteName -> ChordState
ChordState Chord
chord (CadenceState -> NoteName
stateCadenceRoot CadenceState
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
seq)
  | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
seq = Seq CadenceState -> Progression
Progression Seq CadenceState
seq
  | Bool
otherwise = 
    let len :: Int
len = Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
seq
        n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len
        (Seq CadenceState
front, Seq CadenceState
back) = Int -> Seq CadenceState -> (Seq CadenceState, Seq CadenceState)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
n' Seq CadenceState
seq
    in Seq CadenceState -> Progression
Progression (Seq CadenceState
back Seq CadenceState -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a -> Seq a
>< Seq CadenceState
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
seq) =
  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 Seq CadenceState -> Progression
Progression (Seq CadenceState -> Progression)
-> Seq CadenceState -> Progression
forall a b. (a -> b) -> a -> b
$ Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.take Int
len (Seq CadenceState -> Seq CadenceState)
-> Seq CadenceState -> Seq CadenceState
forall a b. (a -> b) -> a -> b
$ Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.drop Int
start' Seq CadenceState
seq

-- |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 -> Progression)
-> Seq CadenceState -> Progression
forall a b. (a -> b) -> a -> b
$ [CadenceState] -> Seq CadenceState
forall a. [a] -> Seq a
Seq.fromList ([CadenceState] -> Seq CadenceState)
-> [CadenceState] -> Seq CadenceState
forall a b. (a -> b) -> a -> b
$ [CadenceState] -> [CadenceState] -> [CadenceState]
forall a. [a] -> [a] -> [a]
interleave (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq CadenceState
a) (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq CadenceState
b)
  where
    interleave :: [a] -> [a] -> [a]
interleave [] [a]
ys = [a]
ys
    interleave [a]
xs [] = [a]
xs
    interleave (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]
interleave [a]
xs [a]
ys

-- |Transpose a progression by n semitones
transposeProgression :: Int -> Progression -> Progression
transposeProgression :: Int -> Progression -> Progression
transposeProgression Int
n (Progression Seq CadenceState
seq) =
  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
seq

-- |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
seq) Int
start Int
end [CadenceState]
newChords =
  let n :: Int
n = Seq CadenceState -> Int
forall a. Seq a -> Int
Seq.length Seq CadenceState
seq
      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
seq
        suffix :: Seq CadenceState
suffix = Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.drop Int
end Seq CadenceState
seq
        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
seq)
        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
seq)
  | Seq CadenceState -> Bool
forall a. Seq a -> Bool
Seq.null Seq CadenceState
seq 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
seq = Seq CadenceState -> Progression
Progression Seq CadenceState
seq
  | Bool
otherwise =
    let prevCS :: CadenceState
prevCS = Seq CadenceState -> Int -> CadenceState
forall a. Seq a -> Int -> a
Seq.index Seq CadenceState
seq (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
seq 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
seq)

-------------------------------------------------------------------------------
-- 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
seq) = 
  (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
seq)

-- |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 -> String
showTriad PitchClass -> NoteName
f (Chord NoteName
noteName String
functionality [Integer]
_)
    -- Root position sus4
    | String
"sus4" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
functionality Bool -> Bool -> Bool
&& Bool -> Bool
not ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
functionality) [String
"_1stInv", String
"_2ndInv"]) =
      NoteName -> String
forall a. Show a => a -> String
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
functionality
    -- 1st inversion major: C maj\/E (3rd in bass = root + 4 semitones)
    | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
functionality) [String
"_1stInv", String
"maj"] =
      NoteName -> String
forall a. Show a => a -> String
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum String
functionality
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> String
forall a. Show a => a -> String
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)
    | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
functionality) [String
"_1stInv", String
"min"] =
      NoteName -> String
forall a. Show a => a -> String
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum String
functionality
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> String
forall a. Show a => a -> String
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)
    | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
functionality) [String
"_1stInv", String
"dim"] =
      NoteName -> String
forall a. Show a => a -> String
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum String
functionality String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> String
forall a. Show a => a -> String
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)
    | String
"_2ndInv" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
functionality Bool -> Bool -> Bool
&& (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
functionality) [String
"maj", String
"min"] =
      NoteName -> String
forall a. Show a => a -> String
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++
      (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum String
functionality String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> String
forall a. Show a => a -> String
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)
    | String
"_2ndInv" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
functionality Bool -> Bool -> Bool
&& String
"dim" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
functionality =
      NoteName -> String
forall a. Show a => a -> String
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++
      (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum String
functionality String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NoteName -> String
forall a. Show a => a -> String
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 -> String
forall a. Show a => a -> String
show (PitchClass -> NoteName
f (PitchClass -> NoteName) -> PitchClass -> NoteName
forall a b. (a -> b) -> a -> b
$ NoteName -> PitchClass
pitchClass NoteName
noteName) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 -> String
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 -> String
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 -> String
forall a. Show a => a -> String
show (PitchClass -> NoteName
f (Int -> PitchClass
mkPitchClass Int
r)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ModeQuality -> String
Sc.showModeQuality ModeQuality
q
        Maybe Mode
Nothing -> String
chordName
  | Bool
otherwise = String
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 :: String
storedF = Cadence -> String
cadenceFunctionality Cadence
cad
    fn :: String
fn | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
storedF = [PitchClass] -> String
toFunctionalityChord [PitchClass]
ivs
       | Bool
otherwise    = String
storedF
    chordName :: String
chordName = NoteName -> String
forall a. Show a => a -> String
show (PitchClass -> NoteName
f (NoteName -> PitchClass
pitchClass NoteName
root)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fn