-- |
-- Module      : Harmonic.Rules.Types.ProgressionContext
-- Description : Three-layer progression value (triad \/ strata \/ mode) for the genP paradigm
--
-- A 'ProgressionContext' bundles three bar-aligned 'Progression' layers —
-- triads, pentatonic strata, and diatonic modes — together with optional
-- per-bar provenance tracking which tristrata and strata each bar was drawn
-- from. Every family fills the layers: 'Harmonic.Framework.Builder.genP' walks curated strata\/mode
-- chroma and carries 'Just' provenance; 'Harmonic.Framework.Builder.genE' fills partner triads; plain
-- 'Harmonic.Framework.Builder.gen' and 'Harmonic.Framework.Builder.genJ' derive a pentatonic S and a mode M by chordscale
-- key-area analysis ('Harmonic.Evaluation.Analysis.KeyArea.chordscale'),
-- provenance 'Nothing'. Only raw 'fromProgression' output (hand-built
-- material not passed through @chordscale@) still duplicates one
-- progression across all three layers.

module Harmonic.Rules.Types.ProgressionContext
  ( Layer(..)
  , Family(..)
  , ProgressionContext(..)
  , layer
  , pcLength
  , fromProgression
  , liftPC
  , liftPCAligned
  , liftPCSubst
  , normalizeFamily
  , pcSplice
  ) where

import Data.Sequence (Seq, (><))
import qualified Data.Sequence as Seq
import Data.Foldable (toList)
import Data.List (transpose)

import qualified Harmonic.Rules.Types.Progression as Prog
import Harmonic.Rules.Types.Progression (Progression(..), progLength)
import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as P
import Harmonic.Rules.Types.Scale (Tristrata, StrataLabel)

-- |Layer tag selecting one of the three progression layers — or a combination
-- of them — at a call site.
--
-- Single layers:
--
-- * 'T' — Triad layer (cadential harmony, the Rules.Types.Progression result).
-- * 'S' — Strata layer (genP: 5-note pentatonic chroma; genE: the less
--   dissonant partner triad).
-- * 'M' — Mode layer (genP: 7-note diatonic chroma; genE: the more dissonant
--   partner triad).
--
-- Combinations (synthesized per bar by 'layer'):
--
-- * 'TS' \/ 'TM' \/ 'SM' — pointwise pitch-class union of two layers.
-- * 'TSM' — union of all three.
-- * 'PT' — pivot tones: the pitch classes common to ALL three layers.
--
-- A merged bar is rooted on its LOWEST constituent layer's bar root
-- (T before S before M) — the foundation owns the bass whenever it is
-- present. On a polytonal (genE) context TS\/TM always union to 4 tones,
-- TSM to 5, and PT holds 2 tones on common-dyad bars or the single hub
-- tone on base-anchored bars. On a chordscale-derived gen\/genJ context
-- S is the bar's pentatonic, M its mode, and PT the chord tones the
-- pentatonic keeps. On contexts whose layers still duplicate one
-- progression (hand-built material without
-- 'Harmonic.Evaluation.Analysis.KeyArea.chordscale') every combination
-- degrades to that progression.
--
-- @M@ replaces the plan's @D@ to avoid clashing with 'Harmonic.Rules.Types.Pitch.NoteName'
-- (@D@ natural), which is re-exported via 'Harmonic.Lib' for live-coding use.
data Layer = T | S | M | TS | TM | SM | TSM | PT
  deriving (Layer -> Layer -> Bool
(Layer -> Layer -> Bool) -> (Layer -> Layer -> Bool) -> Eq Layer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Layer -> Layer -> Bool
== :: Layer -> Layer -> Bool
$c/= :: Layer -> Layer -> Bool
/= :: Layer -> Layer -> Bool
Eq, Eq Layer
Eq Layer =>
(Layer -> Layer -> Ordering)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Layer)
-> (Layer -> Layer -> Layer)
-> Ord Layer
Layer -> Layer -> Bool
Layer -> Layer -> Ordering
Layer -> Layer -> Layer
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Layer -> Layer -> Ordering
compare :: Layer -> Layer -> Ordering
$c< :: Layer -> Layer -> Bool
< :: Layer -> Layer -> Bool
$c<= :: Layer -> Layer -> Bool
<= :: Layer -> Layer -> Bool
$c> :: Layer -> Layer -> Bool
> :: Layer -> Layer -> Bool
$c>= :: Layer -> Layer -> Bool
>= :: Layer -> Layer -> Bool
$cmax :: Layer -> Layer -> Layer
max :: Layer -> Layer -> Layer
$cmin :: Layer -> Layer -> Layer
min :: Layer -> Layer -> Layer
Ord, Int -> Layer -> ShowS
[Layer] -> ShowS
Layer -> String
(Int -> Layer -> ShowS)
-> (Layer -> String) -> ([Layer] -> ShowS) -> Show Layer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Layer -> ShowS
showsPrec :: Int -> Layer -> ShowS
$cshow :: Layer -> String
show :: Layer -> String
$cshowList :: [Layer] -> ShowS
showList :: [Layer] -> ShowS
Show, ReadPrec [Layer]
ReadPrec Layer
Int -> ReadS Layer
ReadS [Layer]
(Int -> ReadS Layer)
-> ReadS [Layer]
-> ReadPrec Layer
-> ReadPrec [Layer]
-> Read Layer
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Layer
readsPrec :: Int -> ReadS Layer
$creadList :: ReadS [Layer]
readList :: ReadS [Layer]
$creadPrec :: ReadPrec Layer
readPrec :: ReadPrec Layer
$creadListPrec :: ReadPrec [Layer]
readListPrec :: ReadPrec [Layer]
Read, Int -> Layer
Layer -> Int
Layer -> [Layer]
Layer -> Layer
Layer -> Layer -> [Layer]
Layer -> Layer -> Layer -> [Layer]
(Layer -> Layer)
-> (Layer -> Layer)
-> (Int -> Layer)
-> (Layer -> Int)
-> (Layer -> [Layer])
-> (Layer -> Layer -> [Layer])
-> (Layer -> Layer -> [Layer])
-> (Layer -> Layer -> Layer -> [Layer])
-> Enum Layer
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Layer -> Layer
succ :: Layer -> Layer
$cpred :: Layer -> Layer
pred :: Layer -> Layer
$ctoEnum :: Int -> Layer
toEnum :: Int -> Layer
$cfromEnum :: Layer -> Int
fromEnum :: Layer -> Int
$cenumFrom :: Layer -> [Layer]
enumFrom :: Layer -> [Layer]
$cenumFromThen :: Layer -> Layer -> [Layer]
enumFromThen :: Layer -> Layer -> [Layer]
$cenumFromTo :: Layer -> Layer -> [Layer]
enumFromTo :: Layer -> Layer -> [Layer]
$cenumFromThenTo :: Layer -> Layer -> Layer -> [Layer]
enumFromThenTo :: Layer -> Layer -> Layer -> [Layer]
Enum, Layer
Layer -> Layer -> Bounded Layer
forall a. a -> a -> Bounded a
$cminBound :: Layer
minBound :: Layer
$cmaxBound :: Layer
maxBound :: Layer
Bounded)

-- |Generation family a progression belongs to. Families never mix:
-- regeneration ('Harmonic.Framework.Builder.genFrom') always reproduces
-- the source's family, and @fuse@ of differing families downgrades to
-- 'FTriad'. Family drives dispatch in @genFrom@ and in the walking-bass
-- interface: 'FJazz' contexts walk with a per-bar bass vocabulary
-- (restored fifths, passing extensions, avoid-tone protection), 'FStrata'
-- walks via provenance chroma, and everything else — including
-- downgraded mixes — walks the plain per-bar tone sets at whatever
-- cardinality each bar carries.
--
-- * 'FTriad'    — plain triadic walk ('Harmonic.Framework.Builder.gen').
-- * 'FExtended' — uniform 4-note hand-built material ('Harmonic.Interface.Tidal.Arranger.lead'' cues,
--   hand-spliced progressions); arrives only by inference, never stamped.
-- * 'FStrata'   — strata-first family ('Harmonic.Framework.Builder.genP'\/@genI@; carries provenance).
-- * 'FJazz'     — jazz Change-graph walk ('Harmonic.Framework.Builder.genJ'; variable arity 3-6).
-- * 'FPoly'     — polytonal three-triad family ('Harmonic.Framework.Builder.genE'):
--   T carries the foundation walk, S\/M carry partner triad chains sharing
--   tones with it per bar. Stamped explicitly by the producer; inference
--   never yields it.
data Family = FTriad | FExtended | FStrata | FJazz | FPoly
  deriving (Family -> Family -> Bool
(Family -> Family -> Bool)
-> (Family -> Family -> Bool) -> Eq Family
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Family -> Family -> Bool
== :: Family -> Family -> Bool
$c/= :: Family -> Family -> Bool
/= :: Family -> Family -> Bool
Eq, Eq Family
Eq Family =>
(Family -> Family -> Ordering)
-> (Family -> Family -> Bool)
-> (Family -> Family -> Bool)
-> (Family -> Family -> Bool)
-> (Family -> Family -> Bool)
-> (Family -> Family -> Family)
-> (Family -> Family -> Family)
-> Ord Family
Family -> Family -> Bool
Family -> Family -> Ordering
Family -> Family -> Family
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Family -> Family -> Ordering
compare :: Family -> Family -> Ordering
$c< :: Family -> Family -> Bool
< :: Family -> Family -> Bool
$c<= :: Family -> Family -> Bool
<= :: Family -> Family -> Bool
$c> :: Family -> Family -> Bool
> :: Family -> Family -> Bool
$c>= :: Family -> Family -> Bool
>= :: Family -> Family -> Bool
$cmax :: Family -> Family -> Family
max :: Family -> Family -> Family
$cmin :: Family -> Family -> Family
min :: Family -> Family -> Family
Ord, Int -> Family -> ShowS
[Family] -> ShowS
Family -> String
(Int -> Family -> ShowS)
-> (Family -> String) -> ([Family] -> ShowS) -> Show Family
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Family -> ShowS
showsPrec :: Int -> Family -> ShowS
$cshow :: Family -> String
show :: Family -> String
$cshowList :: [Family] -> ShowS
showList :: [Family] -> ShowS
Show, ReadPrec [Family]
ReadPrec Family
Int -> ReadS Family
ReadS [Family]
(Int -> ReadS Family)
-> ReadS [Family]
-> ReadPrec Family
-> ReadPrec [Family]
-> Read Family
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Family
readsPrec :: Int -> ReadS Family
$creadList :: ReadS [Family]
readList :: ReadS [Family]
$creadPrec :: ReadPrec Family
readPrec :: ReadPrec Family
$creadListPrec :: ReadPrec [Family]
readListPrec :: ReadPrec [Family]
Read, Int -> Family
Family -> Int
Family -> [Family]
Family -> Family
Family -> Family -> [Family]
Family -> Family -> Family -> [Family]
(Family -> Family)
-> (Family -> Family)
-> (Int -> Family)
-> (Family -> Int)
-> (Family -> [Family])
-> (Family -> Family -> [Family])
-> (Family -> Family -> [Family])
-> (Family -> Family -> Family -> [Family])
-> Enum Family
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Family -> Family
succ :: Family -> Family
$cpred :: Family -> Family
pred :: Family -> Family
$ctoEnum :: Int -> Family
toEnum :: Int -> Family
$cfromEnum :: Family -> Int
fromEnum :: Family -> Int
$cenumFrom :: Family -> [Family]
enumFrom :: Family -> [Family]
$cenumFromThen :: Family -> Family -> [Family]
enumFromThen :: Family -> Family -> [Family]
$cenumFromTo :: Family -> Family -> [Family]
enumFromTo :: Family -> Family -> [Family]
$cenumFromThenTo :: Family -> Family -> Family -> [Family]
enumFromThenTo :: Family -> Family -> Family -> [Family]
Enum, Family
Family -> Family -> Bounded Family
forall a. a -> a -> Bounded a
$cminBound :: Family
minBound :: Family
$cmaxBound :: Family
maxBound :: Family
Bounded)

-- |Three bar-aligned progression layers with optional per-bar provenance.
--
-- Invariant: @progLength triadLayer == progLength strataLayer == progLength modeLayer@,
-- and when @pcProvenance = Just sq@, @Seq.length sq == progLength triadLayer@.
data ProgressionContext = ProgressionContext
  { ProgressionContext -> Progression
triadLayer   :: Progression
  , ProgressionContext -> Progression
strataLayer  :: Progression
  , ProgressionContext -> Progression
modeLayer    :: Progression
  , ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
  , ProgressionContext -> Family
pcFamily     :: Family
  } deriving (ProgressionContext -> ProgressionContext -> Bool
(ProgressionContext -> ProgressionContext -> Bool)
-> (ProgressionContext -> ProgressionContext -> Bool)
-> Eq ProgressionContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProgressionContext -> ProgressionContext -> Bool
== :: ProgressionContext -> ProgressionContext -> Bool
$c/= :: ProgressionContext -> ProgressionContext -> Bool
/= :: ProgressionContext -> ProgressionContext -> Bool
Eq)

-- Source-compatible with the legacy 'Progression' display; verbose triadic layout only.
instance Show ProgressionContext where
  show :: ProgressionContext -> String
show = Progression -> String
forall a. Show a => a -> String
show (Progression -> String)
-> (ProgressionContext -> Progression)
-> ProgressionContext
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgressionContext -> Progression
triadLayer

-- |Project a 'ProgressionContext' to a single 'Progression' by layer tag.
-- Single tags project a stored layer; combination tags synthesize per-bar
-- unions (rooted on the lowest constituent layer's bar — T before S before
-- M, so the foundation owns the merged bass whenever present); 'PT'
-- synthesizes the per-bar intersection of all three layers. Total for every
-- family; on duplicated-layer contexts (the raw 'fromProgression' fallback)
-- every combination collapses to the stored progression.
layer :: Layer -> ProgressionContext -> Progression
layer :: Layer -> ProgressionContext -> Progression
layer Layer
T   = ProgressionContext -> Progression
triadLayer
layer Layer
S   = ProgressionContext -> Progression
strataLayer
layer Layer
M   = ProgressionContext -> Progression
modeLayer
layer Layer
TS  = [ProgressionContext -> Progression]
-> ProgressionContext -> Progression
mergeLayers [ProgressionContext -> Progression
triadLayer, ProgressionContext -> Progression
strataLayer]
layer Layer
TM  = [ProgressionContext -> Progression]
-> ProgressionContext -> Progression
mergeLayers [ProgressionContext -> Progression
triadLayer, ProgressionContext -> Progression
modeLayer]
layer Layer
SM  = [ProgressionContext -> Progression]
-> ProgressionContext -> Progression
mergeLayers [ProgressionContext -> Progression
strataLayer, ProgressionContext -> Progression
modeLayer]
layer Layer
TSM = [ProgressionContext -> Progression]
-> ProgressionContext -> Progression
mergeLayers [ProgressionContext -> Progression
triadLayer, ProgressionContext -> Progression
strataLayer, ProgressionContext -> Progression
modeLayer]
layer Layer
PT  = ProgressionContext -> Progression
pivotLayer

-- Absolute pitch classes sounded by one bar.
barAbsPCs :: H.CadenceState -> [Int]
barAbsPCs :: CadenceState -> [Int]
barAbsPCs CadenceState
cs =
  let r :: Int
r = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs))
  in [ (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PitchClass -> Int
P.unPitchClass PitchClass
iv) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
     | PitchClass
iv <- Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs) ]

-- Rebuild a bar over a given anchor bar's root, movement and spelling from
-- an absolute pitch-class set. 'H.mkCadenceStatePCs' keeps the zero-form
-- invariant (sorted, deduped, 0 re-inserted) at any cardinality.
barFromPCs :: H.CadenceState -> [Int] -> H.CadenceState
barFromPCs :: CadenceState -> [Int] -> CadenceState
barFromPCs CadenceState
anchor [Int]
pcs =
  let rootPC :: Int
rootPC = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
anchor))
      ivs :: [Int]
ivs    = [ (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
rootPC) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
p <- [Int]
pcs ]
      built :: CadenceState
built  = NoteName -> Movement -> [Int] -> CadenceState
H.mkCadenceStatePCs (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
anchor)
                 (Cadence -> Movement
H.cadenceMovement (CadenceState -> Cadence
H.stateCadence CadenceState
anchor)) [Int]
ivs
  in CadenceState
built { H.stateSpelling = H.stateSpelling anchor }

-- Pointwise union of the selected layers; the first selector is the lowest
-- layer and anchors each merged bar.
mergeLayers :: [ProgressionContext -> Progression] -> ProgressionContext -> Progression
mergeLayers :: [ProgressionContext -> Progression]
-> ProgressionContext -> Progression
mergeLayers [ProgressionContext -> Progression]
sels ProgressionContext
pc =
  let cols :: [[CadenceState]]
cols = [ Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
sel ProgressionContext
pc)) | ProgressionContext -> Progression
sel <- [ProgressionContext -> Progression]
sels ]
      mergeBar :: [CadenceState] -> CadenceState
mergeBar [CadenceState]
bars = case [CadenceState]
bars of
        (CadenceState
anchor : [CadenceState]
_) -> CadenceState -> [Int] -> CadenceState
barFromPCs CadenceState
anchor ((CadenceState -> [Int] -> [Int])
-> [Int] -> [CadenceState] -> [Int]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Int] -> [Int] -> [Int]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> [a] -> [a]
unionPCs ([Int] -> [Int] -> [Int])
-> (CadenceState -> [Int]) -> CadenceState -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> [Int]
barAbsPCs) [] [CadenceState]
bars)
        []           -> String -> CadenceState
forall a. HasCallStack => String -> a
error String
"mergeLayers: empty bar column"
      unionPCs :: t a -> [a] -> [a]
unionPCs t a
xs [a]
ys = (a -> [a] -> [a]) -> [a] -> t a -> [a]
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
acc -> if a
x a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
acc then [a]
acc else a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc) [a]
ys t a
xs
  in [CadenceState] -> Progression
Prog.fromCadenceStates (([CadenceState] -> CadenceState)
-> [[CadenceState]] -> [CadenceState]
forall a b. (a -> b) -> [a] -> [b]
map [CadenceState] -> CadenceState
mergeBar ([[CadenceState]] -> [[CadenceState]]
forall a. [[a]] -> [[a]]
transpose [[CadenceState]]
cols))

-- Per-bar intersection of all three layers. Bars whose intersection equals
-- the T bar's own set pass the T bar through unchanged (the duplicated-layer
-- degrade); on chordscale-derived gen\/genJ bars the intersection is the
-- chord tones the pentatonic keeps — an anchor-tone selection. Otherwise
-- the surviving tones are rooted by fifth orientation —
-- a dyad roots on the tone whose partner sits within a tritone above it, a
-- single hub tone roots on itself.
pivotLayer :: ProgressionContext -> Progression
pivotLayer :: ProgressionContext -> Progression
pivotLayer ProgressionContext
pc =
  let ts :: Seq CadenceState
ts = Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
triadLayer ProgressionContext
pc)
      ss :: Seq CadenceState
ss = Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
strataLayer ProgressionContext
pc)
      ms :: Seq CadenceState
ms = Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
modeLayer ProgressionContext
pc)
      pivotBar :: CadenceState -> CadenceState -> CadenceState -> CadenceState
pivotBar CadenceState
tBar CadenceState
sBar CadenceState
mBar =
        let common :: [Int]
common = [ Int
p | Int
p <- CadenceState -> [Int]
barAbsPCs CadenceState
tBar
                         , Int
p Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CadenceState -> [Int]
barAbsPCs CadenceState
sBar, Int
p Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CadenceState -> [Int]
barAbsPCs CadenceState
mBar ]
        in if [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
common 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 (CadenceState -> [Int]
barAbsPCs CadenceState
tBar)
             then CadenceState
tBar
             else CadenceState -> [Int] -> CadenceState
barFromPCs (CadenceState -> [Int] -> CadenceState
anchorOn CadenceState
tBar [Int]
common) [Int]
common
      anchorOn :: CadenceState -> [Int] -> CadenceState
anchorOn CadenceState
tBar [Int]
common =
        let root :: Int
root = case [Int]
common of
              [Int
a, Int
b] -> if (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 then Int
a else Int
b
              [Int
a]    -> Int
a
              [Int]
_      -> PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
tBar))
        in CadenceState
tBar { H.stateCadenceRoot =
                    H.enharmonicFunc (H.stateSpelling tBar) (P.mkPitchClass root) }
  in Seq CadenceState -> Progression
Progression ((CadenceState -> CadenceState -> CadenceState -> CadenceState)
-> Seq CadenceState
-> Seq CadenceState
-> Seq CadenceState
-> Seq CadenceState
forall a b c d.
(a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
Seq.zipWith3 CadenceState -> CadenceState -> CadenceState -> CadenceState
pivotBar Seq CadenceState
ts Seq CadenceState
ss Seq CadenceState
ms)

-- |Bar count — equal across all three layers by invariant.
pcLength :: ProgressionContext -> Int
pcLength :: ProgressionContext -> Int
pcLength = Progression -> Int
progLength (Progression -> Int)
-> (ProgressionContext -> Progression) -> ProgressionContext -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgressionContext -> Progression
triadLayer

-- |Wrap a single 'Progression' as a 'ProgressionContext' by duplicating it
-- into all three layers with no provenance — the RAW constructor. The gen
-- and genJ producers post-process the result with
-- 'Harmonic.Evaluation.Analysis.KeyArea.chordscale' to derive real S\/M
-- layers; hand-built material stays duplicated until passed through the
-- same combinator.
fromProgression :: Progression -> ProgressionContext
fromProgression :: Progression -> ProgressionContext
fromProgression Progression
p = ProgressionContext
  { triadLayer :: Progression
triadLayer   = Progression
p
  , strataLayer :: Progression
strataLayer  = Progression
p
  , modeLayer :: Progression
modeLayer    = Progression
p
  , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
pcProvenance = Maybe (Seq (Tristrata, StrataLabel))
forall a. Maybe a
Nothing
  , pcFamily :: Family
pcFamily     = Progression -> Family
inferFamilyFromProgression Progression
p
  }

-- |Cardinality-based family inference for progressions arriving without
-- an explicit stamp (hand-built, deserialised, or legacy callers):
-- uniformly extended bars (every bar 4+ tones) are 'FExtended';
-- anything else 'FTriad'. Strata
-- and jazz producers stamp 'pcFamily' explicitly instead.
inferFamilyFromProgression :: Progression -> Family
inferFamilyFromProgression :: Progression -> Family
inferFamilyFromProgression Progression
p =
  let sizes :: [Int]
sizes = [ [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs))
              | CadenceState
cs <- Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression Progression
p) ]
  in if Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
sizes) Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4) [Int]
sizes then Family
FExtended else Family
FTriad

-- |Apply a 'Progression'-transforming function pointwise across all three
-- layers. Drops provenance, and with it any 'FStrata' claim — a strata
-- context without provenance is no longer strata material, so the family
-- normalizes in step. Bar-alignment-preserving combinators should use
-- 'liftPCAligned' instead, which carries provenance (and the family)
-- through.
liftPC :: (Progression -> Progression) -> ProgressionContext -> ProgressionContext
liftPC :: (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC Progression -> Progression
f ProgressionContext
pc = ProgressionContext -> ProgressionContext
normalizeFamily ProgressionContext
  { triadLayer :: Progression
triadLayer   = Progression -> Progression
f (ProgressionContext -> Progression
triadLayer ProgressionContext
pc)
  , strataLayer :: Progression
strataLayer  = Progression -> Progression
f (ProgressionContext -> Progression
strataLayer ProgressionContext
pc)
  , modeLayer :: Progression
modeLayer    = Progression -> Progression
f (ProgressionContext -> Progression
modeLayer ProgressionContext
pc)
  , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
pcProvenance = Maybe (Seq (Tristrata, StrataLabel))
forall a. Maybe a
Nothing
  , pcFamily :: Family
pcFamily     = ProgressionContext -> Family
pcFamily ProgressionContext
pc
  }

-- |Class 1 combinator support: apply ONE bar-order permutation\/replication
-- to all three layers AND the provenance sequence in lockstep. The rank-2
-- argument cannot inspect elements (parametricity), so it can only
-- rearrange or duplicate whole bars — per-bar pairings (bar ↔ provenance,
-- foundation ↔ partners) survive intact and the family stamp stays true.
-- Chordscale-derived S\/M layers (gen \/ genJ) permute with their bars, so
-- each bar keeps its own mode\/pentatonic; the key BOUNDARIES they encode
-- reflect the pre-permutation whole-progression analysis — re-apply
-- 'Harmonic.Evaluation.Analysis.KeyArea.chordscale' for a fresh reading.
liftPCAligned :: (forall a. Seq a -> Seq a) -> ProgressionContext -> ProgressionContext
liftPCAligned :: (forall a. Seq a -> Seq a)
-> ProgressionContext -> ProgressionContext
liftPCAligned forall a. Seq a -> Seq a
f ProgressionContext
pc = ProgressionContext
  { triadLayer :: Progression
triadLayer   = Progression -> Progression
onProg (ProgressionContext -> Progression
triadLayer ProgressionContext
pc)
  , strataLayer :: Progression
strataLayer  = Progression -> Progression
onProg (ProgressionContext -> Progression
strataLayer ProgressionContext
pc)
  , modeLayer :: Progression
modeLayer    = Progression -> Progression
onProg (ProgressionContext -> Progression
modeLayer ProgressionContext
pc)
  , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
pcProvenance = (Seq (Tristrata, StrataLabel) -> Seq (Tristrata, StrataLabel))
-> Maybe (Seq (Tristrata, StrataLabel))
-> Maybe (Seq (Tristrata, StrataLabel))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Seq (Tristrata, StrataLabel) -> Seq (Tristrata, StrataLabel)
forall a. Seq a -> Seq a
f (ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
pcProvenance ProgressionContext
pc)
  , pcFamily :: Family
pcFamily     = ProgressionContext -> Family
pcFamily ProgressionContext
pc
  }
  where onProg :: Progression -> Progression
onProg = Seq CadenceState -> Progression
Progression (Seq CadenceState -> Progression)
-> (Progression -> Seq CadenceState) -> Progression -> Progression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Seq a
f (Seq CadenceState -> Seq CadenceState)
-> (Progression -> Seq CadenceState)
-> Progression
-> Seq CadenceState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Progression -> Seq CadenceState
Prog.unProgression

-- |Bar substitution breaks both the provenance-backed ('FStrata') and the
-- structural ('FPoly') family invariants — the result walks and voices as
-- plain material, and the tag must not claim otherwise. Chordscale-derived
-- S\/M layers are mapped like any other bars and go stale the same way —
-- re-apply 'Harmonic.Evaluation.Analysis.KeyArea.chordscale' after
-- bar-substituting edits.
liftPCSubst :: (Progression -> Progression) -> ProgressionContext -> ProgressionContext
liftPCSubst :: (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPCSubst Progression -> Progression
f ProgressionContext
pc =
  let out :: ProgressionContext
out = (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC Progression -> Progression
f ProgressionContext
pc   -- already normalized (provenance-less FStrata → FTriad)
  in ProgressionContext
out { pcFamily = case pcFamily out of
                        Family
FPoly -> Family
FTriad
                        Family
fam   -> Family
fam }

-- |'FStrata' is meaningless without the provenance that defines it; the
-- normalized form keeps 'Harmonic.Framework.Builder.genFrom' dispatch and
-- voicing routing honest. Invariant established type-wide:
-- @pcFamily == FStrata ⟹ pcProvenance == Just _@.
normalizeFamily :: ProgressionContext -> ProgressionContext
normalizeFamily :: ProgressionContext -> ProgressionContext
normalizeFamily ProgressionContext
pc
  | ProgressionContext -> Family
pcFamily ProgressionContext
pc Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
FStrata, Maybe (Seq (Tristrata, StrataLabel))
Nothing <- ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
pcProvenance ProgressionContext
pc = ProgressionContext
pc { pcFamily = FTriad }
  | Bool
otherwise = ProgressionContext
pc

instance Semigroup ProgressionContext where
  ProgressionContext
a <> :: ProgressionContext -> ProgressionContext -> ProgressionContext
<> ProgressionContext
b
    -- The empty context is a true identity: fuse of a singleton or pair
    -- must not meet-downgrade against mempty (Monoid law; Seq's Eq
    -- rejects on length in O(1) so the check is cheap).
    | ProgressionContext
a ProgressionContext -> ProgressionContext -> Bool
forall a. Eq a => a -> a -> Bool
== ProgressionContext
forall a. Monoid a => a
mempty = ProgressionContext
b
    | ProgressionContext
b ProgressionContext -> ProgressionContext -> Bool
forall a. Eq a => a -> a -> Bool
== ProgressionContext
forall a. Monoid a => a
mempty = ProgressionContext
a
    | Bool
otherwise = ProgressionContext -> ProgressionContext
normalizeFamily ProgressionContext
        { triadLayer :: Progression
triadLayer   = ProgressionContext -> Progression
triadLayer  ProgressionContext
a Progression -> Progression -> Progression
forall a. Semigroup a => a -> a -> a
<> ProgressionContext -> Progression
triadLayer  ProgressionContext
b
        , strataLayer :: Progression
strataLayer  = ProgressionContext -> Progression
strataLayer ProgressionContext
a Progression -> Progression -> Progression
forall a. Semigroup a => a -> a -> a
<> ProgressionContext -> Progression
strataLayer ProgressionContext
b
        , modeLayer :: Progression
modeLayer    = ProgressionContext -> Progression
modeLayer   ProgressionContext
a Progression -> Progression -> Progression
forall a. Semigroup a => a -> a -> a
<> ProgressionContext -> Progression
modeLayer   ProgressionContext
b
        , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
pcProvenance = case (ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
pcProvenance ProgressionContext
a, ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
pcProvenance ProgressionContext
b) of
                           (Just Seq (Tristrata, StrataLabel)
sa, Just Seq (Tristrata, StrataLabel)
sb) -> Seq (Tristrata, StrataLabel)
-> Maybe (Seq (Tristrata, StrataLabel))
forall a. a -> Maybe a
Just (Seq (Tristrata, StrataLabel)
sa Seq (Tristrata, StrataLabel)
-> Seq (Tristrata, StrataLabel) -> Seq (Tristrata, StrataLabel)
forall a. Seq a -> Seq a -> Seq a
Seq.>< Seq (Tristrata, StrataLabel)
sb)
                           (Maybe (Seq (Tristrata, StrataLabel)),
 Maybe (Seq (Tristrata, StrataLabel)))
_                  -> Maybe (Seq (Tristrata, StrataLabel))
forall a. Maybe a
Nothing
        , pcFamily :: Family
pcFamily     = if ProgressionContext -> Family
pcFamily ProgressionContext
a Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== ProgressionContext -> Family
pcFamily ProgressionContext
b then ProgressionContext -> Family
pcFamily ProgressionContext
a else Family
FTriad
        }

instance Monoid ProgressionContext where
  mempty :: ProgressionContext
mempty = Progression
-> Progression
-> Progression
-> Maybe (Seq (Tristrata, StrataLabel))
-> Family
-> ProgressionContext
ProgressionContext Progression
forall a. Monoid a => a
mempty Progression
forall a. Monoid a => a
mempty Progression
forall a. Monoid a => a
mempty Maybe (Seq (Tristrata, StrataLabel))
forall a. Maybe a
Nothing Family
FTriad

-- |Splice a range of bars within a 'ProgressionContext', replacing the
-- triad \/ strata \/ mode layers and the 'pcProvenance' sequence in lockstep.
--
-- Range is 1-indexed and wrap-aware (mirrors 'Prog.spliceProgression'):
--
-- * Non-wrapping (@start <= end@): replaces positions @start..end@.
-- * Wrapping (@start > end@): replaces @start..N@ and @1..end@.
--
-- The triad layer's movement seam is fixed via 'Prog.spliceProgression';
-- strata \/ mode layers don't carry meaningful Movement state (their
-- 'Harmonic.Rules.Types.Harmony.Cadence' is built with @Movement = Unison@ — see @mkChromaCS@ in
-- 'Harmonic.Framework.Builder') so they use a plain sequence splice.
--
-- Provenance follows the same geometry. When either side has
-- @pcProvenance = Nothing@, the result is 'Nothing' (the splice can't
-- reconstruct provenance from a layer-only source).
--
-- Caller is responsible for ensuring the inserted 'ProgressionContext'
-- has length equal to the range size.
pcSplice :: ProgressionContext -> Int -> Int -> ProgressionContext -> ProgressionContext
pcSplice :: ProgressionContext
-> Int -> Int -> ProgressionContext -> ProgressionContext
pcSplice ProgressionContext
src Int
start Int
end ProgressionContext
ins =
  let triad' :: Progression
triad' = Progression -> Int -> Int -> [CadenceState] -> Progression
Prog.spliceProgression
                 (ProgressionContext -> Progression
triadLayer ProgressionContext
src) Int
start Int
end
                 (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
triadLayer ProgressionContext
ins)))
      strata' :: Progression
strata' = Seq CadenceState -> Progression
Progression
                  (Seq CadenceState
-> Int -> Int -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Int -> Int -> Seq a -> Seq a
spliceSeq (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
strataLayer ProgressionContext
src))
                             Int
start Int
end
                             (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
strataLayer ProgressionContext
ins)))
      mode' :: Progression
mode'   = Seq CadenceState -> Progression
Progression
                  (Seq CadenceState
-> Int -> Int -> Seq CadenceState -> Seq CadenceState
forall a. Seq a -> Int -> Int -> Seq a -> Seq a
spliceSeq (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
modeLayer ProgressionContext
src))
                             Int
start Int
end
                             (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
modeLayer ProgressionContext
ins)))
      prov' :: Maybe (Seq (Tristrata, StrataLabel))
prov'   = case (ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
pcProvenance ProgressionContext
src, ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
pcProvenance ProgressionContext
ins) of
                  (Just Seq (Tristrata, StrataLabel)
s, Just Seq (Tristrata, StrataLabel)
i) -> Seq (Tristrata, StrataLabel)
-> Maybe (Seq (Tristrata, StrataLabel))
forall a. a -> Maybe a
Just (Seq (Tristrata, StrataLabel)
-> Int
-> Int
-> Seq (Tristrata, StrataLabel)
-> Seq (Tristrata, StrataLabel)
forall a. Seq a -> Int -> Int -> Seq a -> Seq a
spliceSeq Seq (Tristrata, StrataLabel)
s Int
start Int
end Seq (Tristrata, StrataLabel)
i)
                  (Maybe (Seq (Tristrata, StrataLabel)),
 Maybe (Seq (Tristrata, StrataLabel)))
_                -> Maybe (Seq (Tristrata, StrataLabel))
forall a. Maybe a
Nothing
  in Progression
-> Progression
-> Progression
-> Maybe (Seq (Tristrata, StrataLabel))
-> Family
-> ProgressionContext
ProgressionContext Progression
triad' Progression
strata' Progression
mode' Maybe (Seq (Tristrata, StrataLabel))
prov' (ProgressionContext -> Family
pcFamily ProgressionContext
src)

-- |Plain sequence splice with 1-indexed wrap-aware semantics. Mirrors the
-- geometry of 'Prog.spliceProgression' but without movement-fix
-- (used for non-cadence layers and the provenance sequence).
spliceSeq :: Seq a -> Int -> Int -> Seq a -> Seq a
spliceSeq :: forall a. Seq a -> Int -> Int -> Seq a -> Seq a
spliceSeq Seq a
sq Int
start Int
end Seq a
ins =
  let n :: Int
n = Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
sq
  in if Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
end then
       -- Non-wrapping
       let prefix :: Seq a
prefix = Int -> Seq a -> Seq a
forall a. Int -> Seq a -> Seq a
Seq.take (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Seq a
sq
           suffix :: Seq a
suffix = Int -> Seq a -> Seq a
forall a. Int -> Seq a -> Seq a
Seq.drop Int
end Seq a
sq
       in Seq a
prefix Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
>< Seq a
ins Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
>< Seq a
suffix
     else
       -- Wrapping: replaced = [start..N] ++ [1..end], kept = [end+1..start-1]
       let kept :: Seq a
kept       = Int -> Seq a -> Seq a
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 a -> Seq a
forall a. Int -> Seq a -> Seq a
Seq.drop Int
end Seq a
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 a
newAtEnd   = Int -> Seq a -> Seq a
forall a. Int -> Seq a -> Seq a
Seq.take Int
headCount Seq a
ins
           newAtStart :: Seq a
newAtStart = Int -> Seq a -> Seq a
forall a. Int -> Seq a -> Seq a
Seq.drop Int
headCount Seq a
ins
       in Seq a
newAtStart Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
>< Seq a
kept Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
>< Seq a
newAtEnd