{-# LANGUAGE DeriveGeneric #-}

-- |
-- Module      : Harmonic.Evaluation.Scoring.VoiceLeading
-- Description : Cyclic DP voice leading optimization
-- 
-- Part of the Evaluation (E) component of the Creative Systems Framework:
-- voice-leading cost scores the quality of movement between sonorities. It
-- does not run in the per-step generation loop — it enters evaluation at the
-- whole-progression level ("Harmonic.Evaluation.Scoring.Progression", used
-- by @attempt@) and is applied by the Tidal Arranger when realising voicings.
--
-- KEY DESIGN DECISIONS:
--
-- 1. Cost Function Approach
--    Rather than hard constraints, voice leading quality is measured via
--    a cost function. This allows flexible optimization strategies.
--
-- 2. Cyclic Dynamic Programming
--    Uses DP to find globally optimal voicings for the entire cyclic 
--    progression, considering wrap-around from last to first chord.
--
-- 3. Register Constraints
--    Candidate pitches live in [7, 35] (pitchPlacements over [minPitch,
--    maxPitch] bounds; the effective ceiling is 35 = 11+24). First chord
--    starts in compact root position, and the whole result is shifted so
--    the first root lands in [-12, -1].
--
-- 4. Two DP Paradigms (plus extractors and the chroma engine):
--    * solveRoot (grid): smooth, compact voice leading, root always in bass
--    * solveFlow (flow): smooth, compact voice leading, any inversion

module Harmonic.Evaluation.Scoring.VoiceLeading
  ( -- * Cost Functions
    voiceLeadingCost
  , alignVoices
  , totalCost
  , cyclicCost
  
    -- * Voice Movement Calculation
  , voiceMovement
  , minimalMovement
  
    -- * Candidate Generation
  , allVoicings
  , pitchPlacements
  , initialCompact
  
    -- * Paradigm Solvers (Cyclic DP)
  , solveRoot
  , solveFlow
  , liteVoicing
  , bassVoicing
  
    -- * Post-processing
  , normalizeByFirstRoot
  ) where

import Data.List (sort, nub, minimumBy)
import qualified Data.List as List
import Data.Function (on)
import Data.Maybe (catMaybes)
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import qualified Data.Set as Set
import qualified Data.Vector as V
import GHC.Generics (Generic)

import Harmonic.Rules.Types.Pitch (PitchClass(..), mkPitchClass, unPitchClass, transpose)

-------------------------------------------------------------------------------
-- Constants
-------------------------------------------------------------------------------

-- | Minimum allowed pitch for exploration (exploration floor)
-- Allows bass to descend up to a 5th below target octave
minPitch :: Int
minPitch :: Int
minPitch = Int
7

-- | Maximum allowed pitch for exploration (exploration ceiling).
-- Note: never binds in practice — 'pitchPlacements' only generates
-- pc, pc+12, pc+24, so the effective ceiling is 35 (= 11 + 24).
maxPitch :: Int
maxPitch :: Int
maxPitch = Int
41

-- | Target octave lower bound: 'initialCompact' places bar 0's bass at
-- rootPC + this, i.e. in [12, 23].
targetOctaveMin :: Int
targetOctaveMin :: Int
targetOctaveMin = Int
12

-- | Post-normalization anchor: 'normalizeByFirstRoot' shifts the whole
-- progression so bar 0's bass lands at its pitch class + this, i.e. in
-- [-12, -1].
targetFirstRootMin :: Int
targetFirstRootMin :: Int
targetFirstRootMin = -Int
12

-------------------------------------------------------------------------------
-- Voice Movement Calculation
-------------------------------------------------------------------------------

-- |Calculate the movement for a single voice between two concrete pitches.
-- Movement is measured in absolute semitones (not mod 12 since we're
-- working with concrete pitches in the [0,36] range).
voiceMovement :: Int -> Int -> Int
voiceMovement :: Int -> Int -> Int
voiceMovement Int
from Int
to = Int -> Int
forall a. Num a => a -> a
abs (Int
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
from)
{-# INLINE voiceMovement #-}

-- |Calculate minimal movement between two pitch class values (mod 12).
-- Exported API; currently unused inside the engine (kept for REPL and
-- downstream use).
minimalMovement :: PitchClass -> PitchClass -> Int
minimalMovement :: PitchClass -> PitchClass -> Int
minimalMovement (P Int
from) (P Int
to) = 
  let up :: Int
up   = (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
      down :: Int
down = (Int
from Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
to) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
  in Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
up Int
down
{-# INLINE minimalMovement #-}

-------------------------------------------------------------------------------
-- Cost Functions
-------------------------------------------------------------------------------

-- |Calculate the voice leading cost between two chords.
--
-- Cost components:
--   * Base: sum of absolute MIDI movements per voice.
--   * Parallel penalty: +3 for each parallel perfect 5th \/ octave between
--     ANY voice pair (not just adjacent), when at least one voice moves.
--   * Large leap penalty: +2 per voice moving > 4 semitones.
--   * Register-exchange penalty: +4 per adjacent voice pair where both
--     voices move ≥5 semitones in opposite directions (split-leap pattern
--     producing register inversion). Note: not classical "voice crossing"
--     — sorted MIDI voicings have no voice identity to cross — but the
--     same musical effect of register-swapping leaps.
--   * Contrary motion bonus: −1 per voice pair (any pair) where both
--     voices move ≤4 semitones in opposite directions (modest divergence).
--   * Stepwise motion bonus: −1 per stepping voice (movement ∈ {1, 2})
--     when ≥2 voices step. Single-voice steps contribute 0.
--
-- Magnitudes calibrated to compose: contrary motion and register exchange
-- are deliberately disjoint by magnitude (≤4 vs ≥5 thresholds), aligning
-- with the leap-penalty trigger so the same motion is never both
-- rewarded and penalised. They also differ in pair scope by design:
-- register exchange scans ADJACENT pairs only (a register swap is a
-- neighbouring-voices phenomenon), while contrary motion rewards ANY pair.
--
-- The total is floored at 1 for any actual motion (from /= to): bonuses
-- could otherwise exceed base + penalties and drive a moving transition
-- below the held-chord cost of 0 — inverting the musical preference. A
-- held chord ("available static movement") is always strictly cheapest;
-- bonuses still discriminate among positive-cost alternatives. The floor
-- applies to the TOTAL only — component bonuses stay un-clamped inside
-- the sum (e.g. [0,4,7]→[-1,2,7] = base 3 + stepwise −1 = 2).
-- Cross-cardinality transitions (mixed-set seams: lead' cues, hand-built
-- fromChords material) are costed by optimal monotone padding: the smaller
-- sorted voicing is expanded by duplicating tones per the minimal-distance
-- non-crossing alignment in which every voice of BOTH chords participates
-- ('alignVoices'), then the full cost above runs verbatim on the aligned
-- pair. An extra voice pays exactly its distance to the tone it splits
-- from (a literal unison doubling is free); no voice can appear or vanish
-- unpenalised. Historical note: this branch was a flat 999 sentinel,
-- which in the DP acted as "ignore this edge" — seam registers were
-- decided by downstream edges alone and the cyclic wrap objective was
-- silently disabled on mixed material.
voiceLeadingCost :: [Int] -> [Int] -> Int
voiceLeadingCost :: [Int] -> [Int] -> Int
voiceLeadingCost [Int]
from [Int]
to
  | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
from Bool -> Bool -> Bool
|| [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
to = Int
0        -- Empty bar: neutral edge
  | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
from Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
to =
      let ([Int]
from', [Int]
to') = [Int] -> [Int] -> ([Int], [Int])
alignVoices [Int]
from [Int]
to
      in [Int] -> [Int] -> Int
voiceLeadingCost [Int]
from' [Int]
to'
  | [Int]
from [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
to = Int
0                  -- Identical voicings have zero cost
  | Bool
otherwise =
      Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
baseCost Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
parallelPenalty Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
leapPenalty
               Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
registerExchangePenalty Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
contraryBonus Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stepwiseBonus)
  where
    movements :: [Int]
movements   = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
voiceMovement [Int]
from [Int]
to
    signedMoves :: [Int]
signedMoves = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) [Int]
to [Int]
from

    -- Per-voice tuples traversed once; pair scans use tails\/zip rather
    -- than repeated list indexing (the old `!!`-based loops made each
    -- call effectively O(n³) — a real cost at 36–432 DP candidates\/bar).
    voiceData :: [(Int, Int, Int)]
voiceData   = [Int] -> [Int] -> [Int] -> [(Int, Int, Int)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int]
from [Int]
to [Int]
signedMoves
    pairsAll :: [((Int, Int, Int), (Int, Int, Int))]
pairsAll    = [ ((Int, Int, Int)
a, (Int, Int, Int)
b) | ((Int, Int, Int)
a : [(Int, Int, Int)]
rest) <- [(Int, Int, Int)] -> [[(Int, Int, Int)]]
forall a. [a] -> [[a]]
List.tails [(Int, Int, Int)]
voiceData, (Int, Int, Int)
b <- [(Int, Int, Int)]
rest ]
    pairsAdj :: [((Int, Int, Int), (Int, Int, Int))]
pairsAdj    = [(Int, Int, Int)]
-> [(Int, Int, Int)] -> [((Int, Int, Int), (Int, Int, Int))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int, Int, Int)]
voiceData (Int -> [(Int, Int, Int)] -> [(Int, Int, Int)]
forall a. Int -> [a] -> [a]
drop Int
1 [(Int, Int, Int)]
voiceData)

    baseCost :: Int
baseCost = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
movements

    -- Parallel perfect intervals (P5 = 7, P8 = 0) between ANY voice pair.
    -- The interval is preserved across the transition AND at least one
    -- voice moves (purely held intervals don't count).
    isPerfect :: a -> Bool
isPerfect a
ivl = a
ivl a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
7 Bool -> Bool -> Bool
|| a
ivl a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
    isParallelPerfect :: ((a, a, a), (a, a, a)) -> Bool
isParallelPerfect ((a
f1, a
t1, a
s1), (a
f2, a
t2, a
s2)) =
      let fromInt :: a
fromInt = (a
f2 a -> a -> a
forall a. Num a => a -> a -> a
- a
f1) a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
12
          toInt :: a
toInt   = (a
t2 a -> a -> a
forall a. Num a => a -> a -> a
- a
t1) a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
12
      in a -> Bool
forall {a}. (Eq a, Num a) => a -> Bool
isPerfect a
fromInt Bool -> Bool -> Bool
&& a
fromInt a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
toInt Bool -> Bool -> Bool
&& (a
s1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
|| a
s2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0)
    parallelPenalty :: Int
parallelPenalty = Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [((Int, Int, Int), (Int, Int, Int))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((((Int, Int, Int), (Int, Int, Int)) -> Bool)
-> [((Int, Int, Int), (Int, Int, Int))]
-> [((Int, Int, Int), (Int, Int, Int))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int, Int, Int), (Int, Int, Int)) -> Bool
forall {a} {a} {a}.
(Integral a, Num a, Num a, Eq a, Eq a) =>
((a, a, a), (a, a, a)) -> Bool
isParallelPerfect [((Int, Int, Int), (Int, Int, Int))]
pairsAll)

    -- Per-voice penalty for movements > 4 semitones (anything above a P4).
    leapPenalty :: Int
leapPenalty = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4) [Int]
movements)

    -- Adjacent split-leap detection: both voices leap ≥5 in opposite directions.
    isExchange :: ((a, b, a), (a, b, a)) -> Bool
isExchange ((a
_, b
_, a
s1), (a
_, b
_, a
s2)) =
      a
s1 a -> a -> a
forall a. Num a => a -> a -> a
* a
s2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
&& a -> a
forall a. Num a => a -> a
abs a
s1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
5 Bool -> Bool -> Bool
&& a -> a
forall a. Num a => a -> a
abs a
s2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
5
    registerExchangePenalty :: Int
registerExchangePenalty = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [((Int, Int, Int), (Int, Int, Int))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((((Int, Int, Int), (Int, Int, Int)) -> Bool)
-> [((Int, Int, Int), (Int, Int, Int))]
-> [((Int, Int, Int), (Int, Int, Int))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int, Int, Int), (Int, Int, Int)) -> Bool
forall {a} {a} {b} {a} {b}.
(Ord a, Num a) =>
((a, b, a), (a, b, a)) -> Bool
isExchange [((Int, Int, Int), (Int, Int, Int))]
pairsAdj)

    -- Contrary motion: any voice pair, both moving ≤4 in opposite directions
    -- (smooth divergence). Disjoint from register exchange by magnitude.
    isContrary :: ((a, b, a), (a, b, a)) -> Bool
isContrary ((a
_, b
_, a
s1), (a
_, b
_, a
s2)) =
      a
s1 a -> a -> a
forall a. Num a => a -> a -> a
* a
s2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
&& a -> a
forall a. Num a => a -> a
abs a
s1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
4 Bool -> Bool -> Bool
&& a -> a
forall a. Num a => a -> a
abs a
s2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
4
    contraryBonus :: Int
contraryBonus = (-Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* [((Int, Int, Int), (Int, Int, Int))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((((Int, Int, Int), (Int, Int, Int)) -> Bool)
-> [((Int, Int, Int), (Int, Int, Int))]
-> [((Int, Int, Int), (Int, Int, Int))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int, Int, Int), (Int, Int, Int)) -> Bool
forall {a} {a} {b} {a} {b}.
(Ord a, Num a) =>
((a, b, a), (a, b, a)) -> Bool
isContrary [((Int, Int, Int), (Int, Int, Int))]
pairsAll)

    -- Stepwise: per voice with movement of 1 or 2 semitones, bonus only
    -- when ≥2 voices step (preserves >=1 floor for single-voice steps).
    stepwiseBonus :: Int
stepwiseBonus =
      let stepCount :: Int
stepCount = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Int
m -> Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) [Int]
movements)
      in if Int
stepCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 then -(Int
stepCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) else Int
0

-- |Optimal monotone padding for cross-cardinality voice leading.
-- Given two SORTED voicings of different lengths, expands the smaller by
-- duplicating tones so both have the larger's length, choosing the
-- duplication per the minimal-total-|distance| monotone (non-crossing)
-- alignment in which every voice of BOTH chords participates: each voice
-- of the larger maps to exactly one voice of the smaller, the mapping is
-- non-decreasing, and every smaller voice is used at least once. This is
-- the "lowest \/ middle \/ highest voices of the larger lead the smaller"
-- intuition: a 5-note chord resolves into a triad through its outer and
-- inner voices, and the doubled tones pay exactly their split distance.
-- O(m·n) DP (≤ 49 cells at max cardinality 7). Symmetric in its result
-- (roles of from\/to only decide which side gets padded). Equal-length
-- input is returned unchanged.
alignVoices :: [Int] -> [Int] -> ([Int], [Int])
alignVoices :: [Int] -> [Int] -> ([Int], [Int])
alignVoices [Int]
from [Int]
to
  | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
from Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
to = ([Int]
from, [Int]
to)
  | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
from Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
to = ([Int] -> [Int] -> [Int]
forall {b}. (Num b, Ord b) => [b] -> [b] -> [b]
padTo [Int]
from [Int]
to, [Int]
to)
  | Bool
otherwise                = ([Int]
from, [Int] -> [Int] -> [Int]
forall {b}. (Num b, Ord b) => [b] -> [b] -> [b]
padTo [Int]
to [Int]
from)
  where
    -- Expand @small@ (length m) to @big@'s length n by optimal monotone
    -- assignment big!!j -> small!!(a j), a non-decreasing surjection.
    padTo :: [b] -> [b] -> [b]
padTo [b]
small [b]
big =
      let m :: Int
m    = [b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
small
          n :: Int
n    = [b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
big
          s :: Vector b
s    = [b] -> Vector b
forall a. [a] -> Vector a
V.fromList [b]
small
          b :: Vector b
b    = [b] -> Vector b
forall a. [a] -> Vector a
V.fromList [b]
big
          huge :: b
huge = b
10 b -> Int -> b
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
9 :: Int)
          dist :: Int -> Int -> b
dist Int
j Int
i = b -> b
forall a. Num a => a -> a
abs (Vector b
b Vector b -> Int -> b
forall a. Vector a -> Int -> a
V.! Int
j b -> b -> b
forall a. Num a => a -> a -> a
- Vector b
s Vector b -> Int -> b
forall a. Vector a -> Int -> a
V.! Int
i)
          -- rows !! j: at each small-index i, (min cost with big j -> small i,
          -- predecessor small-index at big (j-1))
          row0 :: Vector (b, Int)
row0 = Int -> (Int -> (b, Int)) -> Vector (b, Int)
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
m (\Int
i -> if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then (Int -> Int -> b
dist Int
0 Int
0, Int
0) else (b
huge, Int
i))
          step :: Vector (b, b) -> Int -> Vector (b, Int)
step Vector (b, b)
prev Int
j = Int -> (Int -> (b, Int)) -> Vector (b, Int)
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
m ((Int -> (b, Int)) -> Vector (b, Int))
-> (Int -> (b, Int)) -> Vector (b, Int)
forall a b. (a -> b) -> a -> b
$ \Int
i ->
            let stayC :: b
stayC = (b, b) -> b
forall a b. (a, b) -> a
fst (Vector (b, b)
prev Vector (b, b) -> Int -> (b, b)
forall a. Vector a -> Int -> a
V.! Int
i)
                diagC :: b
diagC = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then (b, b) -> b
forall a b. (a, b) -> a
fst (Vector (b, b)
prev Vector (b, b) -> Int -> (b, b)
forall a. Vector a -> Int -> a
V.! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) else b
huge
                best :: b
best  = b -> b -> b
forall a. Ord a => a -> a -> a
min b
stayC b
diagC
                prevI :: Int
prevI = if b
diagC b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
stayC then Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Int
i
            in if b
best b -> b -> Bool
forall a. Ord a => a -> a -> Bool
>= b
huge then (b
huge, Int
i) else (Int -> Int -> b
dist Int
j Int
i b -> b -> b
forall a. Num a => a -> a -> a
+ b
best, Int
prevI)
          rows :: [Vector (b, Int)]
rows = (Vector (b, Int) -> Int -> Vector (b, Int))
-> Vector (b, Int) -> [Int] -> [Vector (b, Int)]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Vector (b, Int) -> Int -> Vector (b, Int)
forall {b}. Vector (b, b) -> Int -> Vector (b, Int)
step Vector (b, Int)
row0 [Int
1 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
          backtrack :: Int -> Int -> [Int] -> [Int]
backtrack Int
j Int
i [Int]
acc
            | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
acc
            | Bool
otherwise = let (b
_, Int
prevI) = ([Vector (b, Int)]
rows [Vector (b, Int)] -> Int -> Vector (b, Int)
forall a. HasCallStack => [a] -> Int -> a
!! Int
j) Vector (b, Int) -> Int -> (b, Int)
forall a. Vector a -> Int -> a
V.! Int
i
                          in Int -> Int -> [Int] -> [Int]
backtrack (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
prevI (Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
acc)
          assignment :: [Int]
assignment = Int -> Int -> [Int] -> [Int]
backtrack (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) []
      in (Int -> b) -> [Int] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Vector b
s Vector b -> Int -> b
forall a. Vector a -> Int -> a
V.!) [Int]
assignment

-- |Calculate total voice leading cost for a sequence of chords
totalCost :: [[Int]] -> Int
totalCost :: [[Int]] -> Int
totalCost [] = Int
0
totalCost [[Int]
_] = Int
0
totalCost [[Int]]
chords = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ([Int] -> [Int] -> Int) -> [[Int]] -> [[Int]] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Int] -> [Int] -> Int
voiceLeadingCost [[Int]]
chords ([[Int]] -> [[Int]]
forall a. HasCallStack => [a] -> [a]
tail [[Int]]
chords)

-- |Calculate cyclic cost: total cost including wrap-around from last to first.
-- This is essential for loop-aware optimization.
--
-- From the evaluation document:
--   "Adding wrap-around cost to the voice leading solver solves the @drift@
--    issue elegantly. It forces the algorithm to find a path that is not
--    just locally optimal, but topologically closed."
cyclicCost :: [[Int]] -> Int
cyclicCost :: [[Int]] -> Int
cyclicCost [] = Int
0
cyclicCost [[Int]
x] = Int
0
cyclicCost [[Int]]
chords = [[Int]] -> Int
totalCost [[Int]]
chords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> [Int] -> Int
voiceLeadingCost ([[Int]] -> [Int]
forall a. HasCallStack => [a] -> a
last [[Int]]
chords) ([[Int]] -> [Int]
forall a. HasCallStack => [a] -> a
head [[Int]]
chords)

-------------------------------------------------------------------------------
-- Candidate Generation
-------------------------------------------------------------------------------

-- |Get all valid octave placements for a pitch class within [minPitch, maxPitch]
-- Generates placements at base, +12, and +24 semitones (3 octaves)
pitchPlacements :: Int -> [Int]
pitchPlacements :: Int -> [Int]
pitchPlacements Int
pc = 
  let pcMod :: Int
pcMod = Int
pc Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
  in (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Int
p -> Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minPitch Bool -> Bool -> Bool
&& Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxPitch) 
       [Int
pcMod, Int
pcMod Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
12, Int
pcMod Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
24]

-- |Generate all valid voicings for a pitch-class set of any cardinality.
-- Each pitch class is placed at its 'pitchPlacements' octaves (PCs 0-6
-- get 2 placements in [12, 30]; PCs 7-11 get 3 in [7, 35]) — candidate
-- count is the per-PC placement product (2^a·3^b: typically 12 for a
-- triad, 36 for a tetrad, 72 for a 5-PC set), NOT 3^N. The key-dependent
-- window asymmetry is a known calibration; widening it changes every
-- solved voicing globally and is deferred behind a before\/after
-- listening protocol.
-- Results are sorted low-to-high and deduplicated.
--
-- Historical note: this was hard-coded to 3 notes, with non-triads falling
-- back to the single candidate @[sort pcs]@ pinned in octave [0,11] — which
-- collapsed bars 2..n of any multi-bar 4+-note progression ~2 octaves below
-- bar 1 under 'Harmonic.Interface.Tidal.Arranger.flow'/'Harmonic.Interface.Tidal.Arranger.grid' (bar 1 goes through 'initialCompact', the rest
-- through here, then 'normalizeByFirstRoot' applies one uniform shift).
allVoicings :: [Int] -> [[Int]]
allVoicings :: [Int] -> [[Int]]
allVoicings [Int]
pcs
  | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
pcs = [[]]
  | Bool
otherwise =
    let placements :: [[Int]]
placements = (Int -> [Int]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Int]
pitchPlacements (Int -> [Int]) -> (Int -> Int) -> Int -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)) [Int]
pcs
        -- Cartesian product of per-note octave placements
        allCombos :: [[Int]]
allCombos = [[Int]] -> [[Int]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [[Int]]
placements
        -- Sort each voicing low-to-high, deduplicate via Set (O(n log n) vs nub's O(n²))
        sorted :: [[Int]]
sorted = ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [[Int]]
allCombos
    in Set [Int] -> [[Int]]
forall a. Set a -> [a]
Set.toList ([[Int]] -> Set [Int]
forall a. Ord a => [a] -> Set a
Set.fromList [[Int]]
sorted)

-- |Create initial compact voicing: root in bass in target octave (12-23),
-- upper voices stacked compactly above.
initialCompact :: Int -> [Int] -> [Int]
initialCompact :: Int -> [Int] -> [Int]
initialCompact Int
_ [] = []
initialCompact Int
rootPC [Int]
pcs =
  let rootMod :: Int
rootMod = Int
rootPC Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
      -- Place root in target octave (12-23)
      bassPos :: Int
bassPos = Int
rootMod Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
targetOctaveMin
      -- Get other pitch classes
      otherPCs :: [Int]
otherPCs = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Int
p -> Int
p Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
rootMod) ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
pcs)
      -- Stack each above bass: find lowest placement > bass.
      -- `filter (> bass)` is never empty: bass <= 23 < 24 <= pc+24, and
      -- pc+24 is always in pitchPlacements' output.
      stackAbove :: Int -> Int -> Int
stackAbove Int
bass Int
pc = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
bass) (Int -> [Int]
pitchPlacements Int
pc))
      uppers :: [Int]
uppers = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
stackAbove Int
bassPos) [Int]
otherPCs
  in [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort (Int
bassPos Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
uppers)

-------------------------------------------------------------------------------
-- Cyclic Dynamic Programming Solver
-------------------------------------------------------------------------------

-- |DP state: maps candidate index to (min cost to reach, previous index)
type DPState = Map Int (Int, Int)

-- |Solve voice leading using cyclic DP.
-- Finds globally optimal voicings minimizing total cyclic cost — the
-- wrap edge (last bar -> bar 0) is part of the objective, so loops
-- close smoothly.
--
-- Bar 0 is DELIBERATELY pinned to 'initialCompact' (compact root
-- position): the published contract is a predictable starting register,
-- so the optimum is conditional on that anchor rather than searched
-- over bar-0 voicings.
--
-- Tie-breaking: 'minimumBy' keeps the first minimum and candidates are
-- in ascending (lowest-register-first) order, so exact ties resolve to
-- the lowest-register choice.
--
-- Parameters:
--   * filterCandidates: function to filter candidates (e.g., root-only for solveRoot)
--   * rootPCs: root pitch class for each chord (extracted from bass of input)
--   * chords: input chords (pitch classes)
solveCyclicDP :: (Int -> [[Int]] -> [[Int]]) -> [Int] -> [[Int]] -> [[Int]]
solveCyclicDP :: (Int -> [[Int]] -> [[Int]]) -> [Int] -> [[Int]] -> [[Int]]
solveCyclicDP Int -> [[Int]] -> [[Int]]
_ [Int]
_ [] = []
solveCyclicDP Int -> [[Int]] -> [[Int]]
_ [Int]
_ [[Int]
x] = [Int -> [Int] -> [Int]
initialCompact ([Int] -> Int
bassPC [Int]
x) ([Int] -> [Int]
dedupPCs [Int]
x)]
solveCyclicDP Int -> [[Int]] -> [[Int]]
filterCandidates [Int]
rootPCs [[Int]]
rawChords =
  let -- Canonical dedup: pitch-class sets carry no duplicates. Keeps the
      -- first occurrence so the root stays at head, and keeps
      -- 'initialCompact' (which drops duplicate roots) and 'allVoicings'
      -- (which would keep them) at the same cardinality — a duplicated
      -- root PC previously guaranteed a cross-cardinality edge out of
      -- bar 0.
      chords :: [[Int]]
chords = ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
dedupPCs [[Int]]
rawChords
      n :: Int
n = [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
chords
      rootPCsV :: Vector Int
rootPCsV = [Int] -> Vector Int
forall a. [a] -> Vector a
V.fromList [Int]
rootPCs
      chordsV :: Vector [Int]
chordsV = [[Int]] -> Vector [Int]
forall a. [a] -> Vector a
V.fromList [[Int]]
chords

      -- Generate candidates for each position
      -- Position 0 is fixed to initial compact voicing
      firstRootPC :: Int
firstRootPC = Vector Int -> Int
forall a. Vector a -> a
V.head Vector Int
rootPCsV
      firstVoicing :: [Int]
firstVoicing = Int -> [Int] -> [Int]
initialCompact Int
firstRootPC (Vector [Int] -> [Int]
forall a. Vector a -> a
V.head Vector [Int]
chordsV)

      -- For positions 1..n-1, generate all candidates filtered appropriately
      -- Vector of Vectors for O(1) indexing
      candidatesPerPos :: V.Vector (V.Vector [Int])
      candidatesPerPos :: Vector (Vector [Int])
candidatesPerPos = Int -> (Int -> Vector [Int]) -> Vector (Vector [Int])
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
n ((Int -> Vector [Int]) -> Vector (Vector [Int]))
-> (Int -> Vector [Int]) -> Vector (Vector [Int])
forall a b. (a -> b) -> a -> b
$ \Int
i ->
        if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then [Int] -> Vector [Int]
forall a. a -> Vector a
V.singleton [Int]
firstVoicing
        else [[Int]] -> Vector [Int]
forall a. [a] -> Vector a
V.fromList ([[Int]] -> Vector [Int]) -> [[Int]] -> Vector [Int]
forall a b. (a -> b) -> a -> b
$ Int -> [[Int]] -> [[Int]]
filterCandidates (Vector Int
rootPCsV Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i) ([Int] -> [[Int]]
allVoicings (Vector [Int]
chordsV Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
i))

      getCandidates :: Int -> V.Vector [Int]
      getCandidates :: Int -> Vector [Int]
getCandidates Int
i = Vector (Vector [Int])
candidatesPerPos Vector (Vector [Int]) -> Int -> Vector [Int]
forall a. Vector a -> Int -> a
V.! Int
i

      -- Initial state: position 0, only candidate 0 (the fixed first voicing)
      initialDP :: DPState
      initialDP :: DPState
initialDP = Int -> (Int, Int) -> DPState
forall k a. k -> a -> Map k a
Map.singleton Int
0 (Int
0, -Int
1)

      -- Forward pass: for each position, compute min cost to reach each candidate
      forwardPass :: V.Vector DPState
      forwardPass :: Vector DPState
forwardPass = [DPState] -> Vector DPState
forall a. [a] -> Vector a
V.fromList ([DPState] -> Vector DPState) -> [DPState] -> Vector DPState
forall a b. (a -> b) -> a -> b
$ (DPState -> Int -> DPState) -> DPState -> [Int] -> [DPState]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl DPState -> Int -> DPState
stepDP DPState
initialDP [Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
        where
          stepDP :: DPState -> Int -> DPState
          stepDP :: DPState -> Int -> DPState
stepDP DPState
prevState Int
pos =
            let prevCands :: Vector [Int]
prevCands = Int -> Vector [Int]
getCandidates (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                currCands :: Vector [Int]
currCands = Int -> Vector [Int]
getCandidates Int
pos
                -- For each current candidate, find best predecessor
                computeBest :: Int -> Maybe (Int, (Int, Int))
                computeBest :: Int -> Maybe (Int, (Int, Int))
computeBest Int
currIdx =
                  let currVoicing :: [Int]
currVoicing = Vector [Int]
currCands Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
currIdx
                      -- Try each predecessor
                      costs :: [(Int, Int, Int)]
costs = [(Int
prevIdx, Int
cost Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> [Int] -> Int
voiceLeadingCost [Int]
prevVoicing [Int]
currVoicing, Int
prevIdx)
                              | (Int
prevIdx, (Int
cost, Int
_)) <- DPState -> [(Int, (Int, Int))]
forall k a. Map k a -> [(k, a)]
Map.toList DPState
prevState
                              , let prevVoicing :: [Int]
prevVoicing = Vector [Int]
prevCands Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
prevIdx]
                  in if [(Int, Int, Int)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int, Int)]
costs
                     then Maybe (Int, (Int, Int))
forall a. Maybe a
Nothing
                     else let (Int
_, Int
minCost, Int
backPtr) = ((Int, Int, Int) -> (Int, Int, Int) -> Ordering)
-> [(Int, Int, Int)] -> (Int, Int, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, Int, Int) -> Int)
-> (Int, Int, Int)
-> (Int, Int, Int)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Int
_,Int
c,Int
_) -> Int
c)) [(Int, Int, Int)]
costs
                          in (Int, (Int, Int)) -> Maybe (Int, (Int, Int))
forall a. a -> Maybe a
Just (Int
currIdx, (Int
minCost, Int
backPtr))
            in [(Int, (Int, Int))] -> DPState
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Int, (Int, Int))] -> DPState) -> [(Int, (Int, Int))] -> DPState
forall a b. (a -> b) -> a -> b
$ [Maybe (Int, (Int, Int))] -> [(Int, (Int, Int))]
forall a. [Maybe a] -> [a]
catMaybes [Int -> Maybe (Int, (Int, Int))
computeBest Int
j | Int
j <- [Int
0 .. Vector [Int] -> Int
forall a. Vector a -> Int
V.length Vector [Int]
currCands Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

      -- Get final DP state
      finalState :: DPState
      finalState :: DPState
finalState = Vector DPState -> DPState
forall a. Vector a -> a
V.last Vector DPState
forwardPass

      -- Add wrap-around cost and find best ending
      lastCands :: Vector [Int]
lastCands = Int -> Vector [Int]
getCandidates (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      bestEnding :: (Int, Int)  -- (candidate index, total cyclic cost)
      bestEnding :: (Int, Int)
bestEnding = ((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> (Int, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, Int) -> Int
forall a b. (a, b) -> b
snd)
        [(Int
lastIdx, Int
cost Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> [Int] -> Int
voiceLeadingCost (Vector [Int]
lastCands Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
lastIdx) [Int]
firstVoicing)
        | (Int
lastIdx, (Int
cost, Int
_)) <- DPState -> [(Int, (Int, Int))]
forall k a. Map k a -> [(k, a)]
Map.toList DPState
finalState]

      -- Backtrack to reconstruct path (accumulator-passing, O(n))
      backtrack :: Int -> Int -> [Int] -> [Int]
      backtrack :: Int -> Int -> [Int] -> [Int]
backtrack Int
pos Int
candIdx [Int]
acc
        | Int
pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int
candIdx Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
acc
        | Bool
otherwise =
          let (Int
_, Int
backPtr) = (Vector DPState
forwardPass Vector DPState -> Int -> DPState
forall a. Vector a -> Int -> a
V.! Int
pos) DPState -> Int -> (Int, Int)
forall k a. Ord k => Map k a -> k -> a
Map.! Int
candIdx
          in Int -> Int -> [Int] -> [Int]
backtrack (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
backPtr (Int
candIdx Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
acc)

      path :: Vector Int
path = [Int] -> Vector Int
forall a. [a] -> Vector a
V.fromList ([Int] -> Vector Int) -> [Int] -> Vector Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [Int] -> [Int]
backtrack (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ((Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
bestEnding) []

      -- Convert path to voicings
      result :: [[Int]]
result = [Int -> Vector [Int]
getCandidates Int
i Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! (Vector Int
path Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i) | Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]

  in [[Int]]
result

-- |Solve with root always in bass (root paradigm).
-- Filters candidates at each position to only those where bass note mod 12 == root PC.
-- Result is normalized so first chord's root is in [-12,-1].
solveRoot :: [[Int]] -> [[Int]]
solveRoot :: [[Int]] -> [[Int]]
solveRoot [] = []
solveRoot [[Int]]
chords =
  let rootPCs :: [Int]
rootPCs = ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
bassPC [[Int]]
chords
      -- The fallback below is provably unreachable for non-empty chords: a
      -- root-in-bass candidate always exists, because every non-root PC
      -- has a placement at pc+24 >= 24, above any minimum root placement
      -- (<= 23). Kept as free defense rather than a crash surface.
      filterByRoot :: Int -> [[Int]] -> [[Int]]
filterByRoot Int
rootPC [[Int]]
cands =
        let valid :: [[Int]]
valid = ([Int] -> Bool) -> [[Int]] -> [[Int]]
forall a. (a -> Bool) -> [a] -> [a]
filter (\[Int]
v -> [Int] -> Int
bassPC [Int]
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rootPC) [[Int]]
cands
        in if [[Int]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Int]]
valid then [[Int]]
cands else [[Int]]
valid
      solved :: [[Int]]
solved = (Int -> [[Int]] -> [[Int]]) -> [Int] -> [[Int]] -> [[Int]]
solveCyclicDP Int -> [[Int]] -> [[Int]]
filterByRoot [Int]
rootPCs [[Int]]
chords
  in [[Int]] -> [[Int]]
normalizeByFirstRoot [[Int]]
solved

-------------------------------------------------------------------------------
-- Paradigm Solvers
-------------------------------------------------------------------------------

-- |Solve FLOW paradigm using cyclic DP:
-- Smoothest voice leading with any inversion allowed for bars 1..n-1.
-- Bar 0 is anchored to the compact root-position voicing
-- ('initialCompact') so the progression's starting register is
-- predictable and 'normalizeByFirstRoot' has a stable anchor.
-- Voice crossings permitted in subsequent bars for optimal smoothness.
-- Result is normalized so first chord's root is in [-12, -1].
solveFlow :: [[Int]] -> [[Int]]
solveFlow :: [[Int]] -> [[Int]]
solveFlow [] = []
solveFlow [[Int]]
chords =
  let rootPCs :: [Int]
rootPCs = ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
bassPC [[Int]]
chords
      noFilter :: p -> p -> p
noFilter p
_ p
cands = p
cands  -- No filtering, all inversions allowed
      solved :: [[Int]]
solved = (Int -> [[Int]] -> [[Int]]) -> [Int] -> [[Int]] -> [[Int]]
solveCyclicDP Int -> [[Int]] -> [[Int]]
forall {p} {p}. p -> p -> p
noFilter [Int]
rootPCs [[Int]]
chords
  in [[Int]] -> [[Int]]
normalizeByFirstRoot [[Int]]
solved

-- |LITE paradigm: Literal voicing with no optimization.
-- Takes raw pitch class lists and normalizes them.
-- Normalized so first chord's root is in [-12,-1].
-- Use this for comparing raw pitch classes against optimized voicings.
liteVoicing :: [[Int]] -> [[Int]]
liteVoicing :: [[Int]] -> [[Int]]
liteVoicing [] = []
liteVoicing [[Int]]
raw = [[Int]] -> [[Int]]
normalizeByFirstRoot [[Int]]
raw

-- |BASS paradigm: Bass note only (root pitch class per chord).
-- Extracts the root note (first element, mod 12) from each chord.
-- Returns as single-element lists in [0,11] range.
-- Use this for bass line extraction from voiced progressions.
bassVoicing :: [[Int]] -> [[Int]]
bassVoicing :: [[Int]] -> [[Int]]
bassVoicing [] = []
bassVoicing [[Int]]
chords = ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (\[Int]
chord -> if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
chord then [] else [[Int] -> Int
bassPC [Int]
chord]) [[Int]]
chords

-------------------------------------------------------------------------------
-- Post-processing
-------------------------------------------------------------------------------

-- |Normalize a progression by a single uniform shift placing the first
-- chord's root (bass note) at @firstRootPC + targetFirstRootMin@ — i.e.
-- into [-12, -1]. One constant transposition for the whole progression:
-- consistent output register regardless of key or where the solver
-- explored. (In practice the shift is always -24 after the DP solvers,
-- whose bar 0 is 'initialCompact' in [12, 23], and -12 for
-- 'liteVoicing', whose raw input has its root in [0, 11].)
normalizeByFirstRoot :: [[Int]] -> [[Int]]
normalizeByFirstRoot :: [[Int]] -> [[Int]]
normalizeByFirstRoot [] = []
normalizeByFirstRoot voicings :: [[Int]]
voicings@([Int]
firstChord : [[Int]]
_)
  | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
firstChord = [[Int]]
voicings  -- empty first bar: nothing to anchor on
  | Bool
otherwise =
      let firstRoot :: Int
firstRoot   = [Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
firstChord
          firstRootPC :: Int
firstRootPC = Int
firstRoot Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
          targetRoot :: Int
targetRoot  = Int
firstRootPC Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
targetFirstRootMin
          shift :: Int
shift       = Int
targetRoot Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstRoot
      in ([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. Num a => a -> a -> a
+ Int
shift)) [[Int]]
voicings

-- |Bass pitch class of a voicing (0 for an empty bar — degrades, never crashes).
bassPC :: [Int] -> Int
bassPC :: [Int] -> Int
bassPC []      = Int
0
bassPC (Int
p : [Int]
_) = Int
p Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12

-- |Duplicate-free pitch classes, first occurrence kept (root stays at head).
dedupPCs :: [Int] -> [Int]
dedupPCs :: [Int] -> [Int]
dedupPCs = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)