-- |
-- 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. The legacy 'Harmonic.Framework.Builder.gen' paradigm produces contexts where all three layers
-- duplicate the same triad progression and provenance is 'Nothing'; the new
-- 'Harmonic.Framework.Builder.genP' paradigm (introduced by the octatripentatonic framework) produces
-- contexts with distinct strata\/mode layers and 'Just' provenance.

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

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

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

-- |Layer tag selecting one of the three progression layers at a call site.
--
-- * 'T' — Triad layer (cadential harmony, the Rules.Types.Progression result).
-- * 'S' — Strata layer (5-note pentatonic chroma, one stratum per bar).
-- * 'M' — Mode layer (7-note diatonic chroma, the pair-union mode).
--
-- @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
  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)

-- |Three bar-aligned progression layers with optional per-bar provenance.
--
-- Invariant: @progLength triadLayer == progLength strataLayer == progLength modeLayer@,
-- and when @pcProvenance = Just seq@, @Seq.length seq == 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))
  } 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.
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

-- |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. Used by the legacy 'Harmonic.Framework.Builder.gen' paradigm
-- and by test fixtures migrating to the widened type.
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
  }

-- |Apply a 'Progression'-transforming function pointwise across all three
-- layers. Drops provenance — specific Class 1 combinators that preserve bar
-- alignment should permute provenance directly rather than going through
-- 'liftPC'.
liftPC :: (Progression -> Progression) -> ProgressionContext -> ProgressionContext
liftPC :: (Progression -> Progression)
-> ProgressionContext -> ProgressionContext
liftPC Progression -> Progression
f ProgressionContext
pc = 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
  }

instance Semigroup ProgressionContext where
  ProgressionContext
a <> :: ProgressionContext -> ProgressionContext -> ProgressionContext
<> ProgressionContext
b = 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
    }

instance Monoid ProgressionContext where
  mempty :: ProgressionContext
mempty = Progression
-> Progression
-> Progression
-> Maybe (Seq (Tristrata, StrataLabel))
-> 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

-- |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))
-> ProgressionContext
ProgressionContext Progression
triad' Progression
strata' Progression
mode' Maybe (Seq (Tristrata, StrataLabel))
prov'

-- |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
seq Int
start Int
end Seq a
ins =
  let n :: Int
n = Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
seq
  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
seq
           suffix :: Seq a
suffix = Int -> Seq a -> Seq a
forall a. Int -> Seq a -> Seq a
Seq.drop Int
end Seq a
seq
       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
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 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