-- |
-- Module      : Harmonic.Rules.Import.Jazz
-- Description : Chord-symbol parser for the Bunks jazz corpus
--
-- Parses leadsheet chord symbols from the Jazz-Chord-Progressions-Corpus
-- (Bunks, Weyde, Dixon, Di Giorgi, ISMIR 2023) into absolute pitch-class
-- sets. Every symbol has the shape @root quality [\/bass]@ (or the bare
-- token @NC@ for silence); the parser honours the notation exactly:
--
-- * The written root and slash bass are never rewritten or dropped.
--   A slash bass is unioned into the pitch-class set and becomes the
--   chord's /anchor/ (the reference for zero-form and movement); without
--   a slash the root is the anchor.
-- * Qualities map to curated canonical tone sets ('qualityIntervals'):
--   the tones a jazz player reads from the symbol, not the full
--   theoretical extension stack. The conventions are documented on the
--   table itself.
-- * Symbols that fail to parse are returned as 'JazzRefusal' values —
--   recorded, never silently skipped.
--
-- Shared surface: the ingest run parses the corpus through it, genJ
-- names walked chords with 'jazzFunctionality', and @leadJ@ cues parse
-- through 'parseToken'.

module Harmonic.Rules.Import.Jazz (
    JazzToken(..),
    JazzChord(..),
    JazzRefusal(..),
    parseToken,
    JazzSong(..),
    parseSong,
    beatSlots,
    beatStream,
    jazzZeroForm,
    JazzCadence(..),
    jazzShow,
    songCadences,
    normalizeComposer,
    buildChangeEdges,
    qualityIntervals,
    qualityNames,
    qualityFrequency,
    canonicalQuality,
    jazzFunctionality,
    jazzFunctionalityR,
    parseSlashName,
    BassVocab(..),
    bassVocabFor,
) where

import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Read as TR
import Data.List (maximumBy, nub, sort)
import Data.Ord (comparing)
import Harmonic.Rules.Types.Pitch (PitchClass, mkPitchClass, unPitchClass)
import Harmonic.Rules.Types.Harmony (Movement, toMovement)

-- | One corpus chord token: sounding harmony or notated silence (@NC@).
data JazzToken
  = NoChord                -- ^ The @NC@ token: no harmony sounding.
  | Sounding JazzChord     -- ^ A parsed chord symbol.
  deriving (Int -> JazzToken -> ShowS
[JazzToken] -> ShowS
JazzToken -> String
(Int -> JazzToken -> ShowS)
-> (JazzToken -> String)
-> ([JazzToken] -> ShowS)
-> Show JazzToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JazzToken -> ShowS
showsPrec :: Int -> JazzToken -> ShowS
$cshow :: JazzToken -> String
show :: JazzToken -> String
$cshowList :: [JazzToken] -> ShowS
showList :: [JazzToken] -> ShowS
Show, JazzToken -> JazzToken -> Bool
(JazzToken -> JazzToken -> Bool)
-> (JazzToken -> JazzToken -> Bool) -> Eq JazzToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JazzToken -> JazzToken -> Bool
== :: JazzToken -> JazzToken -> Bool
$c/= :: JazzToken -> JazzToken -> Bool
/= :: JazzToken -> JazzToken -> Bool
Eq)

-- | A parsed chord symbol as pitch-class content.
data JazzChord = JazzChord
  { JazzChord -> PitchClass
jcRoot    :: PitchClass        -- ^ Notated chord root.
  , JazzChord -> Maybe PitchClass
jcBass    :: Maybe PitchClass  -- ^ Notated slash bass, when present.
  , JazzChord -> Text
jcQuality :: T.Text            -- ^ Quality string exactly as notated.
  , JazzChord -> [PitchClass]
jcTones   :: [PitchClass]      -- ^ Absolute pitch-class set: root,
                                   --   quality tones and slash bass,
                                   --   sorted and deduplicated.
  , JazzChord -> PitchClass
jcAnchor  :: PitchClass        -- ^ Slash bass when notated, else the
                                   --   root: the sounding fundamental,
                                   --   reference for zero-form/movement.
  } deriving (Int -> JazzChord -> ShowS
[JazzChord] -> ShowS
JazzChord -> String
(Int -> JazzChord -> ShowS)
-> (JazzChord -> String)
-> ([JazzChord] -> ShowS)
-> Show JazzChord
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JazzChord -> ShowS
showsPrec :: Int -> JazzChord -> ShowS
$cshow :: JazzChord -> String
show :: JazzChord -> String
$cshowList :: [JazzChord] -> ShowS
showList :: [JazzChord] -> ShowS
Show, JazzChord -> JazzChord -> Bool
(JazzChord -> JazzChord -> Bool)
-> (JazzChord -> JazzChord -> Bool) -> Eq JazzChord
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JazzChord -> JazzChord -> Bool
== :: JazzChord -> JazzChord -> Bool
$c/= :: JazzChord -> JazzChord -> Bool
/= :: JazzChord -> JazzChord -> Bool
Eq)

-- | A symbol the parser refused, with the reason. Refusals are
-- first-class data: aggregated and reported by the ingest run, never
-- silently dropped.
data JazzRefusal = JazzRefusal
  { JazzRefusal -> Text
refusalInput  :: T.Text  -- ^ The symbol as it appeared in the corpus.
  , JazzRefusal -> Text
refusalReason :: T.Text  -- ^ Why it failed to parse.
  } deriving (Int -> JazzRefusal -> ShowS
[JazzRefusal] -> ShowS
JazzRefusal -> String
(Int -> JazzRefusal -> ShowS)
-> (JazzRefusal -> String)
-> ([JazzRefusal] -> ShowS)
-> Show JazzRefusal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JazzRefusal -> ShowS
showsPrec :: Int -> JazzRefusal -> ShowS
$cshow :: JazzRefusal -> String
show :: JazzRefusal -> String
$cshowList :: [JazzRefusal] -> ShowS
showList :: [JazzRefusal] -> ShowS
Show, JazzRefusal -> JazzRefusal -> Bool
(JazzRefusal -> JazzRefusal -> Bool)
-> (JazzRefusal -> JazzRefusal -> Bool) -> Eq JazzRefusal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JazzRefusal -> JazzRefusal -> Bool
== :: JazzRefusal -> JazzRefusal -> Bool
$c/= :: JazzRefusal -> JazzRefusal -> Bool
/= :: JazzRefusal -> JazzRefusal -> Bool
Eq)

-- | Parse one whitespace-delimited corpus token.
--
-- >>> parseToken "Dm7/G"
-- Right (Sounding (JazzChord {jcRoot = P 2, jcBass = Just (P 7), ...}))
parseToken :: T.Text -> Either JazzRefusal JazzToken
parseToken :: Text -> Either JazzRefusal JazzToken
parseToken Text
t
  | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"NC" = JazzToken -> Either JazzRefusal JazzToken
forall a b. b -> Either a b
Right JazzToken
NoChord
  | Bool
otherwise = case Text -> Maybe (PitchClass, Text)
parseNote Text
t of
      Maybe (PitchClass, Text)
Nothing -> JazzRefusal -> Either JazzRefusal JazzToken
forall a b. a -> Either a b
Left (Text -> Text -> JazzRefusal
JazzRefusal Text
t Text
"no root note")
      Just (PitchClass
root, Text
rest) -> do
        let (Text
qual, Text
slash) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"/" Text
rest
        bass <- case Text -> Text -> Maybe Text
T.stripPrefix Text
"/" Text
slash of
          Maybe Text
Nothing -> Maybe PitchClass -> Either JazzRefusal (Maybe PitchClass)
forall a b. b -> Either a b
Right Maybe PitchClass
forall a. Maybe a
Nothing
          Just Text
b  -> case Text -> Maybe (PitchClass, Text)
parseNote Text
b of
            Just (PitchClass
bpc, Text
leftover) | Text -> Bool
T.null Text
leftover -> Maybe PitchClass -> Either JazzRefusal (Maybe PitchClass)
forall a b. b -> Either a b
Right (PitchClass -> Maybe PitchClass
forall a. a -> Maybe a
Just PitchClass
bpc)
            Maybe (PitchClass, Text)
_ -> JazzRefusal -> Either JazzRefusal (Maybe PitchClass)
forall a b. a -> Either a b
Left (Text -> Text -> JazzRefusal
JazzRefusal Text
t Text
"malformed slash bass")
        ivs <- case Map.lookup qual qualityIntervals of
          Just [Int]
ivs -> [Int] -> Either JazzRefusal [Int]
forall a b. b -> Either a b
Right [Int]
ivs
          Maybe [Int]
Nothing  -> JazzRefusal -> Either JazzRefusal [Int]
forall a b. a -> Either a b
Left (Text -> Text -> JazzRefusal
JazzRefusal Text
t (Text
"unknown quality: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qual))
        let quals = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> PitchClass
root PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ Int -> PitchClass
mkPitchClass Int
i) [Int]
ivs
            tones = [PitchClass] -> [PitchClass]
forall a. Ord a => [a] -> [a]
sort ([PitchClass] -> [PitchClass])
-> ([PitchClass] -> [PitchClass]) -> [PitchClass] -> [PitchClass]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PitchClass] -> [PitchClass]
forall a. Eq a => [a] -> [a]
nub ([PitchClass] -> [PitchClass]) -> [PitchClass] -> [PitchClass]
forall a b. (a -> b) -> a -> b
$ [PitchClass]
-> (PitchClass -> [PitchClass]) -> Maybe PitchClass -> [PitchClass]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [PitchClass]
quals (PitchClass -> [PitchClass] -> [PitchClass]
forall a. a -> [a] -> [a]
: [PitchClass]
quals) Maybe PitchClass
bass
        Right . Sounding $ JazzChord
          { jcRoot    = root
          , jcBass    = bass
          , jcQuality = qual
          , jcTones   = tones
          , jcAnchor  = maybe root id bass
          }

-- Note-name parse: letter plus optional accidental, consumed greedily
-- (no corpus quality begins with 'b' or '#', so greed is always right).
-- The mod-12 arithmetic IS the enharmonic fold: Cb -> 11, B# -> 0, etc.
parseNote :: T.Text -> Maybe (PitchClass, T.Text)
parseNote :: Text -> Maybe (PitchClass, Text)
parseNote Text
t = do
  (c, rest) <- Text -> Maybe (Char, Text)
T.uncons Text
t
  base <- lookup c [('C',0),('D',2),('E',4),('F',5),('G',7),('A',9),('B',11)]
  pure $ case T.uncons rest of
    Just (Char
'#', Text
r) -> (Int -> PitchClass
mkPitchClass (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1), Text
r)
    Just (Char
'b', Text
r) -> (Int -> PitchClass
mkPitchClass (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1), Text
r)
    Maybe (Char, Text)
_             -> (Int -> PitchClass
mkPitchClass Int
base, Text
rest)

-- | Every quality string the table covers (the corpus census: 122
-- qualities; @NC@ is handled at token level).
qualityNames :: [T.Text]
qualityNames :: [Text]
qualityNames = Map Text [Int] -> [Text]
forall k a. Map k a -> [k]
Map.keys Map Text [Int]
qualityIntervals

-- | Curated canonical tone set per quality, as semitone intervals from
-- the root. Covers all 122 quality strings in the corpus census.
--
-- Conventions (the tones a player reads from the symbol, kept
-- deterministic so equal sonorities land on equal graph nodes):
--
-- 1. Written alterations and additions are always present, exactly as
--    notated, and displace their natural counterpart (@#5@\/@b5@ replace
--    the 5th, @b9@\/@#9@ replace the natural 9th where one is implied).
-- 2. The natural 5th is included except where altered — and except in
--    13th chords, which take the working-voicing form 1-3-b7-9-13 (no
--    5th, no 11th).
-- 3. Dominant 11th chords omit the 3rd (1-5-b7-9-11): at pitch-class
--    level @11@ and @9sus4@ are deliberately the same sonority.
-- 4. @b13@ stacks over an unaltered 5th (that presence is what separates
--    it from @#5@ at set level); @b6@ likewise.
-- 5. @alt@ is rendered as the classic altered voicing 1-3-#5-b7-b9
--    (identical set to @7#5b9@).
-- 6. Spelling variants are separate keys mapping to identical sets:
--    @M7@\/@maj7@, @o@\/@dim@, @h7@\/@m7b5@, @7+@\/@7#5@\/@+7@,
--    @sus@\/@sus4@\/@4@, @2@\/@sus2@, @mi@\/@m@, and so on.
-- 7. Literal oddities stay literal: @5@ is the bare power-chord dyad,
--    @67@ is 6th plus b7, @M@ is an explicit major triad, @susb9@ is a
--    sus4 triad with b9 and no 7th.
qualityIntervals :: Map.Map T.Text [Int]
qualityIntervals :: Map Text [Int]
qualityIntervals = [(Text, [Int])] -> Map Text [Int]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ -- Triads, dyads and added-tone colours
    (Text
"",         [Int
0,Int
4,Int
7])         -- bare symbol: major triad
  , (Text
"M",        [Int
0,Int
4,Int
7])         -- explicit major triad
  , (Text
"m",        [Int
0,Int
3,Int
7])
  , (Text
"mi",       [Int
0,Int
3,Int
7])
  , (Text
"+",        [Int
0,Int
4,Int
8])
  , (Text
"m+",       [Int
0,Int
3,Int
8])         -- minor with raised 5th
  , (Text
"m#5",      [Int
0,Int
3,Int
8])
  , (Text
"o",        [Int
0,Int
3,Int
6])
  , (Text
"dim",      [Int
0,Int
3,Int
6])
  , (Text
"mb5",      [Int
0,Int
3,Int
6])
  , (Text
"Mb5",      [Int
0,Int
4,Int
6])
  , (Text
"5",        [Int
0,Int
7])           -- power chord: literal dyad
  , (Text
"sus4",     [Int
0,Int
5,Int
7])
  , (Text
"sus",      [Int
0,Int
5,Int
7])
  , (Text
"4",        [Int
0,Int
5,Int
7])
  , (Text
"sus2",     [Int
0,Int
2,Int
7])
  , (Text
"2",        [Int
0,Int
2,Int
7])
  , (Text
"sus24",    [Int
0,Int
2,Int
5,Int
7])       -- both suspensions, no 3rd
  , (Text
"susb9",    [Int
0,Int
1,Int
5,Int
7])       -- sus4 triad with b9, no 7th
  , (Text
"mb6",      [Int
0,Int
3,Int
7,Int
8])
  , (Text
"madd4",    [Int
0,Int
3,Int
5,Int
7])
  , (Text
"add9",     [Int
0,Int
2,Int
4,Int
7])
  , (Text
"madd9",    [Int
0,Int
2,Int
3,Int
7])
  , (Text
"addb9",    [Int
0,Int
1,Int
4,Int
7])
  , (Text
"add9no3",  [Int
0,Int
2,Int
7])
  , (Text
"+add9",    [Int
0,Int
2,Int
4,Int
8])
  , (Text
"+add#9",   [Int
0,Int
3,Int
4,Int
8])
  , (Text
"M#5add9",  [Int
0,Int
2,Int
4,Int
8])
    -- Sixths
  , (Text
"6",        [Int
0,Int
4,Int
7,Int
9])
  , (Text
"M6",       [Int
0,Int
4,Int
7,Int
9])
  , (Text
"m6",       [Int
0,Int
3,Int
7,Int
9])
  , (Text
"69",       [Int
0,Int
2,Int
4,Int
7,Int
9])
  , (Text
"M69",      [Int
0,Int
2,Int
4,Int
7,Int
9])
  , (Text
"m69",      [Int
0,Int
2,Int
3,Int
7,Int
9])
  , (Text
"6#11",     [Int
0,Int
4,Int
6,Int
7,Int
9])
  , (Text
"M69#11",   [Int
0,Int
2,Int
4,Int
6,Int
7,Int
9])
  , (Text
"6b5",      [Int
0,Int
4,Int
6,Int
9])
  , (Text
"67",       [Int
0,Int
4,Int
7,Int
9,Int
10])    -- literal oddity: 6th plus b7
    -- Sevenths
  , (Text
"7",        [Int
0,Int
4,Int
7,Int
10])
  , (Text
"M7",       [Int
0,Int
4,Int
7,Int
11])
  , (Text
"maj7",     [Int
0,Int
4,Int
7,Int
11])
  , (Text
"m7",       [Int
0,Int
3,Int
7,Int
10])
  , (Text
"m7b5",     [Int
0,Int
3,Int
6,Int
10])
  , (Text
"h7",       [Int
0,Int
3,Int
6,Int
10])
  , (Text
"o7",       [Int
0,Int
3,Int
6,Int
9])
  , (Text
"dim7",     [Int
0,Int
3,Int
6,Int
9])
  , (Text
"mM7",      [Int
0,Int
3,Int
7,Int
11])
  , (Text
"mMaj7",    [Int
0,Int
3,Int
7,Int
11])
  , (Text
"mM7b6",    [Int
0,Int
3,Int
7,Int
8,Int
11])
  , (Text
"oM7",      [Int
0,Int
3,Int
6,Int
11])      -- diminished triad, major 7th
  , (Text
"o7M7",     [Int
0,Int
3,Int
6,Int
9,Int
11])    -- full dim7 plus major 7th
  , (Text
"7+",       [Int
0,Int
4,Int
8,Int
10])
  , (Text
"7#5",      [Int
0,Int
4,Int
8,Int
10])
  , (Text
"+7",       [Int
0,Int
4,Int
8,Int
10])
  , (Text
"M7#5",     [Int
0,Int
4,Int
8,Int
11])
  , (Text
"maj7#5",   [Int
0,Int
4,Int
8,Int
11])
  , (Text
"M7+",      [Int
0,Int
4,Int
8,Int
11])
  , (Text
"m7#5",     [Int
0,Int
3,Int
8,Int
10])
  , (Text
"7b5",      [Int
0,Int
4,Int
6,Int
10])
  , (Text
"M7b5",     [Int
0,Int
4,Int
6,Int
11])
  , (Text
"7b6",      [Int
0,Int
4,Int
7,Int
8,Int
10])    -- b6 over unaltered 5th (convention 4)
  , (Text
"7#11",     [Int
0,Int
4,Int
6,Int
7,Int
10])
  , (Text
"M7#11",    [Int
0,Int
4,Int
6,Int
7,Int
11])
  , (Text
"7add6",    [Int
0,Int
4,Int
7,Int
9,Int
10])
  , (Text
"7add13",   [Int
0,Int
4,Int
7,Int
9,Int
10])
  , (Text
"M7add13",  [Int
0,Int
4,Int
7,Int
9,Int
11])
  , (Text
"7sus4",    [Int
0,Int
5,Int
7,Int
10])
  , (Text
"7sus",     [Int
0,Int
5,Int
7,Int
10])
  , (Text
"7sus4b9",  [Int
0,Int
1,Int
5,Int
7,Int
10])
  , (Text
"7b9sus4",  [Int
0,Int
1,Int
5,Int
7,Int
10])
  , (Text
"7susb9",   [Int
0,Int
1,Int
5,Int
7,Int
10])
  , (Text
"7sus4b9b13", [Int
0,Int
1,Int
5,Int
7,Int
8,Int
10])
  , (Text
"7alt",     [Int
0,Int
1,Int
4,Int
8,Int
10])    -- 1 3 #5 b7 b9 (convention 5)
  , (Text
"7b9",      [Int
0,Int
1,Int
4,Int
7,Int
10])
  , (Text
"7#9",      [Int
0,Int
3,Int
4,Int
7,Int
10])
  , (Text
"m7b9",     [Int
0,Int
1,Int
3,Int
7,Int
10])
  , (Text
"7#5b9",    [Int
0,Int
1,Int
4,Int
8,Int
10])
  , (Text
"7#5#9",    [Int
0,Int
3,Int
4,Int
8,Int
10])
  , (Text
"7b5b9",    [Int
0,Int
1,Int
4,Int
6,Int
10])
  , (Text
"7b9b5",    [Int
0,Int
1,Int
4,Int
6,Int
10])
  , (Text
"7b5#9",    [Int
0,Int
3,Int
4,Int
6,Int
10])
  , (Text
"7b9#11",   [Int
0,Int
1,Int
4,Int
6,Int
7,Int
10])
  , (Text
"7#9#11",   [Int
0,Int
3,Int
4,Int
6,Int
7,Int
10])
  , (Text
"7#5b9#11", [Int
0,Int
1,Int
4,Int
6,Int
8,Int
10])
  , (Text
"7b13",     [Int
0,Int
4,Int
7,Int
8,Int
10])
  , (Text
"7b9b13",   [Int
0,Int
1,Int
4,Int
7,Int
8,Int
10])
  , (Text
"7#9b13",   [Int
0,Int
3,Int
4,Int
7,Int
8,Int
10])
  , (Text
"M7#9b5",   [Int
0,Int
3,Int
4,Int
6,Int
11])
  , (Text
"M7#9#11",  [Int
0,Int
3,Int
4,Int
6,Int
7,Int
11])
  , (Text
"m7add11",  [Int
0,Int
3,Int
5,Int
7,Int
10])
  , (Text
"m7add4",   [Int
0,Int
3,Int
5,Int
7,Int
10])
    -- Ninths
  , (Text
"9",        [Int
0,Int
2,Int
4,Int
7,Int
10])
  , (Text
"M9",       [Int
0,Int
2,Int
4,Int
7,Int
11])
  , (Text
"maj9",     [Int
0,Int
2,Int
4,Int
7,Int
11])
  , (Text
"m9",       [Int
0,Int
2,Int
3,Int
7,Int
10])
  , (Text
"mM9",      [Int
0,Int
2,Int
3,Int
7,Int
11])
  , (Text
"9#5",      [Int
0,Int
2,Int
4,Int
8,Int
10])
  , (Text
"9+",       [Int
0,Int
2,Int
4,Int
8,Int
10])
  , (Text
"M9#5",     [Int
0,Int
2,Int
4,Int
8,Int
11])
  , (Text
"9b5",      [Int
0,Int
2,Int
4,Int
6,Int
10])
  , (Text
"m9b5",     [Int
0,Int
2,Int
3,Int
6,Int
10])
  , (Text
"9#11",     [Int
0,Int
2,Int
4,Int
6,Int
7,Int
10])
  , (Text
"M9#11",    [Int
0,Int
2,Int
4,Int
6,Int
7,Int
11])
  , (Text
"maj9#11",  [Int
0,Int
2,Int
4,Int
6,Int
7,Int
11])
  , (Text
"9b13",     [Int
0,Int
2,Int
4,Int
7,Int
8,Int
10])
  , (Text
"9sus4",    [Int
0,Int
2,Int
5,Int
7,Int
10])
  , (Text
"9sus",     [Int
0,Int
2,Int
5,Int
7,Int
10])
    -- Elevenths (dominant form omits the 3rd, convention 3)
  , (Text
"11",       [Int
0,Int
2,Int
5,Int
7,Int
10])
  , (Text
"m11",      [Int
0,Int
2,Int
3,Int
5,Int
7,Int
10])
  , (Text
"m11b5",    [Int
0,Int
2,Int
3,Int
5,Int
6,Int
10])
    -- Thirteenths (1-3-b7-9-13, no 5th or 11th, convention 2)
  , (Text
"13",       [Int
0,Int
2,Int
4,Int
9,Int
10])
  , (Text
"13b9",     [Int
0,Int
1,Int
4,Int
9,Int
10])
  , (Text
"13#9",     [Int
0,Int
3,Int
4,Int
9,Int
10])
  , (Text
"13#11",    [Int
0,Int
2,Int
4,Int
6,Int
9,Int
10])
  , (Text
"13b5",     [Int
0,Int
2,Int
4,Int
6,Int
9,Int
10])  -- b5 and #11 coincide at set level
  , (Text
"13b9#11",  [Int
0,Int
1,Int
4,Int
6,Int
9,Int
10])
  , (Text
"13sus4",   [Int
0,Int
2,Int
5,Int
9,Int
10])    -- 4th replaces 3rd, 13th-form otherwise
  , (Text
"13sus",    [Int
0,Int
2,Int
5,Int
9,Int
10])
  , (Text
"m13",      [Int
0,Int
2,Int
3,Int
9,Int
10])
  , (Text
"M13",      [Int
0,Int
2,Int
4,Int
9,Int
11])
  , (Text
"maj13",    [Int
0,Int
2,Int
4,Int
9,Int
11])
  , (Text
"M13#11",   [Int
0,Int
2,Int
4,Int
6,Int
9,Int
11])
  ]

-- | Corpus occurrence count per quality string (census of the 2,614-tune
-- Bunks corpus, 2026-08-25: 134,355 tokens). Drives the canonical-spelling
-- choice in 'canonicalQuality': where spelling variants share a tone set,
-- the spelling the corpus itself uses most is the one the graph shows.
qualityFrequency :: Map.Map T.Text Int
qualityFrequency :: Map Text Int
qualityFrequency = [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (Text
"7", Int
34679)
  , (Text
"m7", Int
28905)
  , (Text
"", Int
17308)
  , (Text
"M7", Int
13468)
  , (Text
"m", Int
6266)
  , (Text
"6", Int
4572)
  , (Text
"m7b5", Int
3701)
  , (Text
"7b9", Int
3060)
  , (Text
"o7", Int
2527)
  , (Text
"9", Int
2033)
  , (Text
"m6", Int
1452)
  , (Text
"7#9", Int
1197)
  , (Text
"7alt", Int
1095)
  , (Text
"7+", Int
1048)
  , (Text
"13", Int
1010)
  , (Text
"m9", Int
985)
  , (Text
"7#11", Int
906)
  , (Text
"7sus4", Int
822)
  , (Text
"7#5", Int
758)
  , (Text
"M7#11", Int
692)
  , (Text
"69", Int
548)
  , (Text
"7b5", Int
538)
  , (Text
"+", Int
536)
  , (Text
"m11", Int
417)
  , (Text
"M9", Int
371)
  , (Text
"mM7", Int
353)
  , (Text
"9sus4", Int
351)
  , (Text
"o", Int
335)
  , (Text
"7#5#9", Int
278)
  , (Text
"maj7", Int
239)
  , (Text
"7#5b9", Int
233)
  , (Text
"7sus", Int
228)
  , (Text
"9#11", Int
219)
  , (Text
"sus4", Int
158)
  , (Text
"M7b5", Int
151)
  , (Text
"13b9", Int
149)
  , (Text
"dim", Int
141)
  , (Text
"m69", Int
131)
  , (Text
"add9", Int
120)
  , (Text
"m+", Int
118)
  , (Text
"M7#5", Int
117)
  , (Text
"11", Int
117)
  , (Text
"13#11", Int
111)
  , (Text
"7b9#11", Int
99)
  , (Text
"9#5", Int
85)
  , (Text
"13sus4", Int
71)
  , (Text
"M6", Int
54)
  , (Text
"9b5", Int
50)
  , (Text
"9+", Int
47)
  , (Text
"7b9sus4", Int
47)
  , (Text
"maj9", Int
46)
  , (Text
"5", Int
43)
  , (Text
"mMaj7", Int
42)
  , (Text
"2", Int
41)
  , (Text
"7sus4b9", Int
40)
  , (Text
"9sus", Int
38)
  , (Text
"7b5b9", Int
31)
  , (Text
"madd9", Int
28)
  , (Text
"13#9", Int
28)
  , (Text
"sus", Int
24)
  , (Text
"m13", Int
24)
  , (Text
"7susb9", Int
24)
  , (Text
"m#5", Int
23)
  , (Text
"7b9b13", Int
23)
  , (Text
"13b9#11", Int
22)
  , (Text
"7#9#11", Int
20)
  , (Text
"13sus", Int
20)
  , (Text
"m9b5", Int
19)
  , (Text
"M", Int
19)
  , (Text
"sus24", Int
17)
  , (Text
"7b5#9", Int
17)
  , (Text
"m7b9", Int
15)
  , (Text
"M69", Int
15)
  , (Text
"h7", Int
15)
  , (Text
"13b5", Int
15)
  , (Text
"7b13", Int
14)
  , (Text
"M9#5", Int
12)
  , (Text
"maj13", Int
11)
  , (Text
"m7add11", Int
11)
  , (Text
"dim7", Int
11)
  , (Text
"m7add4", Int
9)
  , (Text
"sus2", Int
8)
  , (Text
"oM7", Int
8)
  , (Text
"m7#5", Int
8)
  , (Text
"M13#11", Int
8)
  , (Text
"7#9b13", Int
8)
  , (Text
"mM9", Int
7)
  , (Text
"mb6", Int
7)
  , (Text
"M#5add9", Int
6)
  , (Text
"addb9", Int
6)
  , (Text
"7add6", Int
6)
  , (Text
"+7", Int
6)
  , (Text
"maj7#5", Int
5)
  , (Text
"M9#11", Int
5)
  , (Text
"M7add13", Int
5)
  , (Text
"7b6", Int
5)
  , (Text
"Mb5", Int
4)
  , (Text
"mb5", Int
4)
  , (Text
"maj9#11", Int
4)
  , (Text
"M69#11", Int
4)
  , (Text
"7#5b9#11", Int
4)
  , (Text
"67", Int
4)
  , (Text
"6#11", Int
4)
  , (Text
"mM7b6", Int
3)
  , (Text
"M7+", Int
3)
  , (Text
"add9no3", Int
3)
  , (Text
"4", Int
3)
  , (Text
"+add9", Int
3)
  , (Text
"madd4", Int
2)
  , (Text
"M7#9b5", Int
2)
  , (Text
"7add13", Int
2)
  , (Text
"6b5", Int
2)
  , (Text
"susb9", Int
1)
  , (Text
"o7M7", Int
1)
  , (Text
"mi", Int
1)
  , (Text
"M7#9#11", Int
1)
  , (Text
"M13", Int
1)
  , (Text
"m11b5", Int
1)
  , (Text
"9b13", Int
1)
  , (Text
"7sus4b9b13", Int
1)
  , (Text
"7b9b5", Int
1)
  , (Text
"+add#9", Int
1)
  ]

-- | Canonical quality name per tone set: the reverse of
-- 'qualityIntervals', collapsing spelling variants (and pitch-class
-- coincidences such as @13b5@\/@13#11@) onto the corpus-preferred
-- spelling. 122 qualities reduce to 85 distinct sets.
canonicalQuality :: Map.Map [Int] T.Text
canonicalQuality :: Map [Int] Text
canonicalQuality =
  (Text -> Text -> Text) -> [([Int], Text)] -> Map [Int] Text
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Text -> Text -> Text
prefer [ ([Int]
ivs, Text
q) | (Text
q, [Int]
ivs) <- Map Text [Int] -> [(Text, [Int])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text [Int]
qualityIntervals ]
  where
    freq :: Text -> Int
freq Text
q = Int -> Text -> Map Text Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 Text
q Map Text Int
qualityFrequency
    prefer :: Text -> Text -> Text
prefer Text
a Text
b
      | Text -> Int
freq Text
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Text -> Int
freq Text
b = Text
a
      | Text -> Int
freq Text
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Text -> Int
freq Text
a = Text
b
      | Bool
otherwise       = Text -> Text -> Text
forall a. Ord a => a -> a -> a
min Text
a Text
b

-- | Name a zero-form pitch-class set (sorted, deduplicated, containing 0)
-- for the jazz graph: the pure set-to-name function that keeps node
-- identity and node label in lockstep.
--
-- A set matching a curated quality names directly (with the bare major
-- triad displayed as @maj@). Anything else is read as a slash shape: some
-- rotation of the set is a curated quality — guaranteed for every
-- corpus-derived set, whose rotation to the notated root is its quality
-- by construction — and the name is @quality\/bass-degree@
-- (@[0,5,9]@ is a major triad over its 5th: @maj\/5@). Candidate
-- rotations are ranked by corpus frequency of the quality, preferring the
-- reading whose bass is a chord member, then the smallest rotation.
-- 'Nothing' only for sets no rotation of which is a curated quality —
-- impossible for corpus data, reported (never invented) if it ever
-- happens downstream.
jazzFunctionality :: [Int] -> Maybe T.Text
jazzFunctionality :: [Int] -> Maybe Text
jazzFunctionality = ((Text, Int) -> Text) -> Maybe (Text, Int) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Int) -> Text
forall a b. (a, b) -> a
fst (Maybe (Text, Int) -> Maybe Text)
-> ([Int] -> Maybe (Text, Int)) -> [Int] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Maybe (Text, Int)
jazzFunctionalityR

-- | 'jazzFunctionality' with the rotation exposed: the second component
-- is the offset of the TRUE quality root above the anchor (0 when the
-- set names directly, the chosen rotation for slash shapes). The
-- structural authority for anchor-independent readings — e.g.
-- 'Harmonic.Interface.Tidal.Groove.fund' recovering the harmonic
-- fundamental of a slash bar.
jazzFunctionalityR :: [Int] -> Maybe (T.Text, Int)
jazzFunctionalityR :: [Int] -> Maybe (Text, Int)
jazzFunctionalityR [Int]
raw
  | case [Int]
set of { (Int
s0 : [Int]
_) -> Int
s0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0; [] -> Bool
True } = Maybe (Text, Int)
forall a. Maybe a
Nothing
  | Bool
otherwise = case [Int] -> Map [Int] Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Int]
set Map [Int] Text
canonicalQuality of
      Just Text
q  -> (Text, Int) -> Maybe (Text, Int)
forall a. a -> Maybe a
Just (Text -> Text
forall {a}. (Eq a, IsString a) => a -> a
display Text
q, Int
0)
      Maybe Text
Nothing -> case [(Int, Bool, Int, Text)]
candidates of
        [] -> Maybe (Text, Int)
forall a. Maybe a
Nothing
        [(Int, Bool, Int, Text)]
cs -> let (Int
_, Bool
_, Int
d, Text
q) = ((Int, Bool, Int, Text) -> (Int, Bool, Int, Text) -> Ordering)
-> [(Int, Bool, Int, Text)] -> (Int, Bool, Int, Text)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Int, Bool, Int, Text) -> (Int, Bool, Int))
-> (Int, Bool, Int, Text) -> (Int, Bool, Int, Text) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Bool, Int, Text) -> (Int, Bool, Int)
forall {c} {a} {b} {d}. Num c => (a, b, c, d) -> (a, b, c)
rank) [(Int, Bool, Int, Text)]
cs
              in (Text, Int) -> Maybe (Text, Int)
forall a. a -> Maybe a
Just (Text -> Text
forall {a}. (Eq a, IsString a) => a -> a
display Text
q Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
degreeLabel ((-Int
d) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12), Int
d)
  where
    set :: [Int]
set = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ((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]
raw))
    freq :: Text -> Int
freq Text
q = Int -> Text -> Map Text Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 Text
q Map Text Int
qualityFrequency
    rotate :: a -> [a] -> [a]
rotate a
d [a]
xs = [a] -> [a]
forall a. Ord a => [a] -> [a]
sort ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub ((a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
d) a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
12) [a]
xs))
    candidates :: [(Int, Bool, Int, Text)]
candidates =
      [ (Text -> Int
freq Text
q, Bool
member, Int
d, Text
q)
      | Int
d <- [Int]
set, Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
      , (Bool
member, [Int]
rotated) <- [ (Bool
True,  Int -> [Int] -> [Int]
forall {a}. Integral a => a -> [a] -> [a]
rotate Int
d [Int]
set)
                             , (Bool
False, Int -> [Int] -> [Int]
forall {a}. Integral a => a -> [a] -> [a]
rotate Int
d ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) [Int]
set)) ]
      , Just Text
q <- [[Int] -> Map [Int] Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Int]
rotated Map [Int] Text
canonicalQuality]
      ]
    rank :: (a, b, c, d) -> (a, b, c)
rank (a
f, b
member, c
d, d
_) = (a
f, b
member, c -> c
forall a. Num a => a -> a
negate c
d)
    display :: a -> a
display a
"" = a
"maj"
    display a
q  = a
q

-- | Exact inverse of the slash names 'jazzFunctionalityR' emits, over
-- the CLOSED corpus vocabulary: @quality\/degreeLabel@ where the quality
-- is a curated name and the label one of the eleven bass degrees.
-- Returns the quality and the true root's offset ABOVE the anchor (the
-- rotation the namer applied). Fails on anything else — classical names
-- that merely contain a slash (@sus2\/4no5@) fail the degree-label
-- membership, so a successful parse is proof the name came from the
-- jazz namer. The DISPLAY authority for chart-convention rendering:
-- parsing the stored name back can never disagree with the name the
-- walk stamped, where re-deriving from intervals could pick a
-- different rotation.
parseSlashName :: T.Text -> Maybe (T.Text, Int)
parseSlashName :: Text -> Maybe (Text, Int)
parseSlashName Text
nm = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"/" Text
nm of
  (Text
q, Text
rest) | Just Text
lbl <- Text -> Text -> Maybe Text
T.stripPrefix Text
"/" Text
rest
            , Text -> Bool
qualityOk Text
q
            , Just Int
off <- Text -> [(Text, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
lbl [(Text, Int)]
labelOffsets ->
      (Text, Int) -> Maybe (Text, Int)
forall a. a -> Maybe a
Just (Text
q, (Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
off) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
  (Text, Text)
_ -> Maybe (Text, Int)
forall a. Maybe a
Nothing
  where
    qualityOk :: Text -> Bool
qualityOk Text
q = Text
q Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"maj" Bool -> Bool -> Bool
|| Text -> Map Text [Int] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Text
q Map Text [Int]
qualityIntervals
    labelOffsets :: [(Text, Int)]
labelOffsets = [ (Int -> Text
degreeLabel Int
n, Int
n) | Int
n <- [Int
1 .. Int
11] ]

-- Bass-degree label for slash names: semitones above the upper root.
degreeLabel :: Int -> T.Text
degreeLabel :: Int -> Text
degreeLabel Int
n = case Int
n of
  Int
1 -> Text
"b2"; Int
2 -> Text
"2";  Int
3 -> Text
"b3"; Int
4 -> Text
"3";  Int
5 -> Text
"4";  Int
6 -> Text
"b5"
  Int
7 -> Text
"5";  Int
8 -> Text
"b6"; Int
9 -> Text
"6";  Int
10 -> Text
"b7"; Int
11 -> Text
"7"; Int
_ -> Text
"1"

-- | Walking-bass understanding of a jazz tone set: what the SYMBOL means
-- to a bass player rather than what the working voicing contains. Corpus
-- sets omit degrees a bassist still needs (13th chords carry no 5th and
-- no 11th) and notate colours a bassist must not land on strong beats
-- (b9, #9, #11, b13). Root-relative intervals throughout.
data BassVocab = BassVocab
  { BassVocab -> [Int]
bvTarget  :: [Int] -- ^ The triadic core — root, third (or sus 4) and
                       --   THE fifth: the tones a line aims AT. Primary
                       --   strong-beat targets; the rest of the chord is
                       --   colour that guides passing motion and scale
                       --   choice rather than serving as a destination.
  , BassVocab -> [Int]
bvStrong  :: [Int] -- ^ Strong-beat anchors: the target triad plus the
                       --   seventh (or true 6th) — legal to land on, with
                       --   the target tones preferred.
  , BassVocab -> [Int]
bvPassing :: [Int] -- ^ Favourable passing tones — weak-beat preferred,
                       --   modest strong-beat access: the 9 where natural,
                       --   and the 11 over the minor family only (over a
                       --   major third it is the classic avoid note).
  , BassVocab -> [Int]
bvAvoid   :: [Int] -- ^ Notated tones never to land on strong beats
                       --   (colour alterations); still reachable as
                       --   weak-beat tension through the connector pools.
  , BassVocab -> Int
bvFifth   :: Int   -- ^ THE fifth of the quality: 7 natural (restored
                       --   for the 13th family), 6 where b5 defines it,
                       --   8 where #5 replaces it.
  } deriving (Int -> BassVocab -> ShowS
[BassVocab] -> ShowS
BassVocab -> String
(Int -> BassVocab -> ShowS)
-> (BassVocab -> String)
-> ([BassVocab] -> ShowS)
-> Show BassVocab
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BassVocab -> ShowS
showsPrec :: Int -> BassVocab -> ShowS
$cshow :: BassVocab -> String
show :: BassVocab -> String
$cshowList :: [BassVocab] -> ShowS
showList :: [BassVocab] -> ShowS
Show, BassVocab -> BassVocab -> Bool
(BassVocab -> BassVocab -> Bool)
-> (BassVocab -> BassVocab -> Bool) -> Eq BassVocab
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BassVocab -> BassVocab -> Bool
== :: BassVocab -> BassVocab -> Bool
$c/= :: BassVocab -> BassVocab -> Bool
/= :: BassVocab -> BassVocab -> Bool
Eq, Eq BassVocab
Eq BassVocab =>
(BassVocab -> BassVocab -> Ordering)
-> (BassVocab -> BassVocab -> Bool)
-> (BassVocab -> BassVocab -> Bool)
-> (BassVocab -> BassVocab -> Bool)
-> (BassVocab -> BassVocab -> Bool)
-> (BassVocab -> BassVocab -> BassVocab)
-> (BassVocab -> BassVocab -> BassVocab)
-> Ord BassVocab
BassVocab -> BassVocab -> Bool
BassVocab -> BassVocab -> Ordering
BassVocab -> BassVocab -> BassVocab
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 :: BassVocab -> BassVocab -> Ordering
compare :: BassVocab -> BassVocab -> Ordering
$c< :: BassVocab -> BassVocab -> Bool
< :: BassVocab -> BassVocab -> Bool
$c<= :: BassVocab -> BassVocab -> Bool
<= :: BassVocab -> BassVocab -> Bool
$c> :: BassVocab -> BassVocab -> Bool
> :: BassVocab -> BassVocab -> Bool
$c>= :: BassVocab -> BassVocab -> Bool
>= :: BassVocab -> BassVocab -> Bool
$cmax :: BassVocab -> BassVocab -> BassVocab
max :: BassVocab -> BassVocab -> BassVocab
$cmin :: BassVocab -> BassVocab -> BassVocab
min :: BassVocab -> BassVocab -> BassVocab
Ord)

-- | Derive the walking-bass vocabulary from a zero-form tone set. The
-- rules codify the hand-inferred per-quality palettes of
-- notes\/walking_bass_theory.md (maj\/dom take the 9 and avoid the 11;
-- the minor family takes 9 and 11; defining tones reserved for strong
-- beats) plus the corpus table's own conventions (alterations displace
-- naturals; 13th chords omit 5th and 11th). Total over any zero-form
-- set, so hand-built and spliced material degrades gracefully.
--
-- Known limitation, deliberate: the same source supersedes per-QUALITY
-- palettes with per-FUNCTION ones (a iii chord takes the 11 but not the
-- 9, which is a b9 from the key; a IV takes the \#11). This signature
-- takes one bar's intervals and cannot see key or function, so it
-- implements the quality-level rule only. The walk does infer a key
-- centre, so the refinement is reachable later without changing callers.
bassVocabFor :: [Int] -> BassVocab
bassVocabFor :: [Int] -> BassVocab
bassVocabFor [Int]
raw = BassVocab
  { bvTarget :: [Int]
bvTarget  = [Int]
target
  , bvStrong :: [Int]
bvStrong  = [Int]
strong
  , bvPassing :: [Int]
bvPassing = [Int]
passing
  , bvAvoid :: [Int]
bvAvoid   = [Int]
avoid
  , bvFifth :: Int
bvFifth   = Int
fifth
  }
  where
    ivs :: [Int]
ivs = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ((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]
raw))
    has :: Int -> Bool
has = (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
ivs)
    -- The 13th family omits the 5th by convention, so a bare 6 there is
    -- the #11, not a b5. `13#11` and `13b5` share a tone set, so set-only
    -- inference must take the majority reading: #11-named 13ths outnumber
    -- `13b5` 141 to 15 in the corpus, and canonicalQuality already names
    -- that set `13#11`. The `has 4` term keeps o7M7's diminished fifth.
    thirteenish :: Bool
thirteenish = Int -> Bool
has Int
9 Bool -> Bool -> Bool
&& (Int -> Bool
has Int
10 Bool -> Bool -> Bool
|| Int -> Bool
has Int
11) Bool -> Bool -> Bool
&& Int -> Bool
has Int
4
    fifth :: Int
fifth
      | Int -> Bool
has Int
7                    = Int
7
      | Int -> Bool
has Int
6 Bool -> Bool -> Bool
&& Int -> Bool
has Int
8           = if Int -> Bool
has Int
4 then Int
8 else Int
6
      | Int -> Bool
has Int
6 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
thirteenish = Int
6
      | Int -> Bool
has Int
8                    = Int
8
      | Bool
otherwise                = Int
7   -- restored: the symbol implies a natural 5th
    third :: [Int]
third
      | Int -> Bool
has Int
4     = [Int
4]
      | Int -> Bool
has Int
3     = [Int
3]
      | Bool
otherwise = []
    sus4 :: Bool
sus4    = Int -> Bool
has Int
5 Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
has Int
3) Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
has Int
4)
    seventh :: [Int]
seventh
      | Int -> Bool
has Int
10    = [Int
10]
      | Int -> Bool
has Int
11    = [Int
11]
      | Bool
otherwise = []
    -- a 9-semitone tone is the chord's 6th when no 7th is present
    -- (6-chords, dim7), and a 13 colour when one is.
    sixthStrong :: Bool
sixthStrong = Int -> Bool
has Int
9 Bool -> Bool -> Bool
&& [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
seventh
    target :: [Int]
target = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int
0, Int
fifth] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
third [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
5 | Bool
sus4]
    strong :: [Int]
strong = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int]
target [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
seventh [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
9 | Bool
sixthStrong]
    minorThird :: Bool
minorThird  = Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
has Int
4)
    -- the natural 9 is only vocabulary when the symbol carries no b9/#9.
    naturalNine :: Bool
naturalNine = Bool -> Bool
not (Int -> Bool
has Int
1) Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Int -> Bool
has Int
4)
    -- The 11 belongs to the MINOR family only: over a major third it is a
    -- tritone above it — the classic avoid note (walking_bass_theory.md
    -- ch. 10). The 13th family's table entries omit it for that reason,
    -- not for voicing economy, so it is never restored the way the 5th is.
    passing :: [Int]
passing = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
strong) ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
avoid) ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
                 [Int
2 | Bool
naturalNine]
              [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
5 | Bool
minorThird]
    avoid :: [Int]
avoid = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int
1 | Int -> Bool
has Int
1]
               [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
3 | Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Int -> Bool
has Int
4]
               [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
6 | Int -> Bool
has Int
6 Bool -> Bool -> Bool
&& Int
fifth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
6]
               [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
8 | Int -> Bool
has Int
8 Bool -> Bool -> Bool
&& Int
fifth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
8]

-- | One corpus tune: identifying header fields and the bar-structured
-- token stream. @DBKeySig@ is deliberately not read — the graph is
-- zero-form, so key signatures carry no information it needs.
data JazzSong = JazzSong
  { JazzSong -> Text
jsTitle    :: T.Text          -- ^ Title header (filename stem when the header is corrupt).
  , JazzSong -> Text
jsComposer :: T.Text          -- ^ ComposedBy header, verbatim.
  , JazzSong -> (Int, Int)
jsTimeSig  :: (Int, Int)      -- ^ TimeSig header as (numerator, denominator).
  , JazzSong -> [[JazzToken]]
jsBars     :: [[JazzToken]]   -- ^ Parsed chord tokens, one list per bar.
  } deriving (Int -> JazzSong -> ShowS
[JazzSong] -> ShowS
JazzSong -> String
(Int -> JazzSong -> ShowS)
-> (JazzSong -> String) -> ([JazzSong] -> ShowS) -> Show JazzSong
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JazzSong -> ShowS
showsPrec :: Int -> JazzSong -> ShowS
$cshow :: JazzSong -> String
show :: JazzSong -> String
$cshowList :: [JazzSong] -> ShowS
showList :: [JazzSong] -> ShowS
Show, JazzSong -> JazzSong -> Bool
(JazzSong -> JazzSong -> Bool)
-> (JazzSong -> JazzSong -> Bool) -> Eq JazzSong
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JazzSong -> JazzSong -> Bool
== :: JazzSong -> JazzSong -> Bool
$c/= :: JazzSong -> JazzSong -> Bool
/= :: JazzSong -> JazzSong -> Bool
Eq)

-- | Parse one corpus song file. The first argument names the song in
-- refusals (and stands in for a corrupt @Title@ header); the second is
-- the file content. Header fields are matched by prefix so the two known
-- corrupt headers in the corpus degrade gracefully; the @Bars@ header is
-- ignored in favour of counting actual bar delimiters (it is wrong in
-- three corpus files). Any token refusal refuses the whole song, with
-- the song name attached.
parseSong :: T.Text -> T.Text -> Either JazzRefusal JazzSong
parseSong :: Text -> Text -> Either JazzRefusal JazzSong
parseSong Text
name Text
content =
  let ls :: [Text]
ls = Text -> [Text]
T.lines Text
content
      ([Text]
headerLs, [Text]
bodyLs) = Int -> [Text] -> ([Text], [Text])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
5 [Text]
ls
      field :: Text -> [Text]
field Text
key = [ Text -> Text
T.strip Text
v | Text
l <- [Text]
headerLs
                  , Just Text
v <- [Text -> Text -> Maybe Text
T.stripPrefix (Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" =") (Text -> Text
T.strip Text
l)] ]
      title :: Text
title = case Text -> [Text]
field Text
"Title" of { (Text
t:[Text]
_) -> Text
t; [] -> Text
name }
      composer :: Text
composer = case Text -> [Text]
field Text
"ComposedBy" of { (Text
c:[Text]
_) -> Text
c; [] -> Text
"" }
      timesig :: Maybe (Int, Int)
timesig = case Text -> [Text]
field Text
"TimeSig" of
        (Text
t:[Text]
_) | [Text
n, Text
d] <- Text -> [Text]
T.words Text
t
              , Just Int
n' <- Text -> Maybe Int
forall {a}. Integral a => Text -> Maybe a
readInt Text
n, Just Int
d' <- Text -> Maybe Int
forall {a}. Integral a => Text -> Maybe a
readInt Text
d -> (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
n', Int
d')
        [Text]
_ -> Maybe (Int, Int)
forall a. Maybe a
Nothing
      bars :: [[Text]]
bars = [ Text -> [Text]
T.words Text
b
             | Text
b <- (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"|") [Text]
bodyLs
             , Bool -> Bool
not (Text -> Bool
T.null (Text -> Text
T.strip Text
b)) ]
      parseBar :: t Text -> Either JazzRefusal (t JazzToken)
parseBar t Text
b = (Text -> Either JazzRefusal JazzToken)
-> t Text -> Either JazzRefusal (t JazzToken)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse (\Text
t -> (JazzRefusal -> Either JazzRefusal JazzToken)
-> (JazzToken -> Either JazzRefusal JazzToken)
-> Either JazzRefusal JazzToken
-> Either JazzRefusal JazzToken
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> JazzRefusal -> Either JazzRefusal JazzToken
forall {b}. Text -> JazzRefusal -> Either JazzRefusal b
refuseIn Text
name) JazzToken -> Either JazzRefusal JazzToken
forall a b. b -> Either a b
Right (Text -> Either JazzRefusal JazzToken
parseToken Text
t)) t Text
b
  in case Maybe (Int, Int)
timesig of
       Maybe (Int, Int)
Nothing -> JazzRefusal -> Either JazzRefusal JazzSong
forall a b. a -> Either a b
Left (Text -> Text -> JazzRefusal
JazzRefusal Text
name Text
"missing or malformed TimeSig header")
       Just (Int, Int)
ts -> do
         parsed <- ([Text] -> Either JazzRefusal [JazzToken])
-> [[Text]] -> Either JazzRefusal [[JazzToken]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [Text] -> Either JazzRefusal [JazzToken]
forall {t :: * -> *}.
Traversable t =>
t Text -> Either JazzRefusal (t JazzToken)
parseBar [[Text]]
bars
         Right (JazzSong title composer ts parsed)
  where
    readInt :: Text -> Maybe a
readInt Text
t = case Reader a
forall a. Integral a => Reader a
TR.decimal Text
t of { Right (a
n, Text
r) | Text -> Bool
T.null Text
r -> a -> Maybe a
forall a. a -> Maybe a
Just a
n; Either String (a, Text)
_ -> Maybe a
forall a. Maybe a
Nothing }
    refuseIn :: Text -> JazzRefusal -> Either JazzRefusal b
refuseIn Text
n (JazzRefusal Text
i Text
r) = JazzRefusal -> Either JazzRefusal b
forall a b. a -> Either a b
Left (Text -> Text -> JazzRefusal
JazzRefusal (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
i) Text
r)

-- | Beat slots per chord for one bar: how many one-beat cadence steps
-- each chord occupies. A bar's beats (the time-signature numerator;
-- numerator \`div\` 3 for compound x\/8 meters) are shared out with any
-- remainder going to the earliest chords — so 3 chords in 4\/4 hold
-- [2,1,1] beats. More chords than beats means sub-beat harmony: every
-- chord gets one slot. A chord holding n slots contributes n-1
-- self-cadences, mirroring the classical graph's sustained-harmony
-- self-edges.
beatSlots :: (Int, Int) -> Int -> [Int]
beatSlots :: (Int, Int) -> Int -> [Int]
beatSlots (Int
num, Int
den) Int
nChords
  | Int
nChords Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0      = []
  | Int
nChords Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
beats  = Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
nChords Int
1
  | Bool
otherwise         = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
nChords Int
q)
                                    (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
r Int
1 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
forall a. a -> [a]
repeat Int
0)
  where
    beats :: Int
beats = if Int
den Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 then Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
num Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3) else Int
num
    (Int
q, Int
r) = Int
beats Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
nChords

-- | Expand a song to its beat-level chord stream. Each chord repeats
-- once per beat slot; @NC@ beats vanish entirely, so the chords either
-- side of a silence become adjacent — the notated harmonic motion
-- bridges the gap, and silence never becomes a graph node.
beatStream :: JazzSong -> [JazzChord]
beatStream :: JazzSong -> [JazzChord]
beatStream JazzSong
song =
  [ JazzChord
c
  | [JazzToken]
bar <- JazzSong -> [[JazzToken]]
jsBars JazzSong
song
  , (JazzToken
tok, Int
slots) <- [JazzToken] -> [Int] -> [(JazzToken, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [JazzToken]
bar ((Int, Int) -> Int -> [Int]
beatSlots (JazzSong -> (Int, Int)
jsTimeSig JazzSong
song) ([JazzToken] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JazzToken]
bar))
  , Sounding JazzChord
c <- [JazzToken
tok]
  , Int
_ <- [Int
1 .. Int
slots]
  ]

-- | Anchor-relative zero form of a parsed chord: intervals above the
-- sounding fundamental, sorted, starting at 0. This is the jazz graph's
-- node identity (paired with the arrival movement).
jazzZeroForm :: JazzChord -> [Int]
jazzZeroForm :: JazzChord -> [Int]
jazzZeroForm JazzChord
c = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\PitchClass
p -> PitchClass -> Int
unPitchClass (PitchClass
p PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
- JazzChord -> PitchClass
jcAnchor JazzChord
c)) (JazzChord -> [PitchClass]
jcTones JazzChord
c)))

-- | One jazz cadence: how the anchor moved and what sounds above it.
-- The jazz-graph analogue of the classical 'Harmonic.Rules.Types.Harmony.Cadence'.
data JazzCadence = JazzCadence
  { JazzCadence -> Movement
jzMovement :: Movement  -- ^ Anchor motion arriving at this chord.
  , JazzCadence -> [Int]
jzSet      :: [Int]     -- ^ Anchor-relative zero-form tone set.
  , JazzCadence -> Text
jzName     :: T.Text    -- ^ Canonical functionality ('jazzFunctionality').
  } deriving (Int -> JazzCadence -> ShowS
[JazzCadence] -> ShowS
JazzCadence -> String
(Int -> JazzCadence -> ShowS)
-> (JazzCadence -> String)
-> ([JazzCadence] -> ShowS)
-> Show JazzCadence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JazzCadence -> ShowS
showsPrec :: Int -> JazzCadence -> ShowS
$cshow :: JazzCadence -> String
show :: JazzCadence -> String
$cshowList :: [JazzCadence] -> ShowS
showList :: [JazzCadence] -> ShowS
Show, JazzCadence -> JazzCadence -> Bool
(JazzCadence -> JazzCadence -> Bool)
-> (JazzCadence -> JazzCadence -> Bool) -> Eq JazzCadence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JazzCadence -> JazzCadence -> Bool
== :: JazzCadence -> JazzCadence -> Bool
$c/= :: JazzCadence -> JazzCadence -> Bool
/= :: JazzCadence -> JazzCadence -> Bool
Eq, Eq JazzCadence
Eq JazzCadence =>
(JazzCadence -> JazzCadence -> Ordering)
-> (JazzCadence -> JazzCadence -> Bool)
-> (JazzCadence -> JazzCadence -> Bool)
-> (JazzCadence -> JazzCadence -> Bool)
-> (JazzCadence -> JazzCadence -> Bool)
-> (JazzCadence -> JazzCadence -> JazzCadence)
-> (JazzCadence -> JazzCadence -> JazzCadence)
-> Ord JazzCadence
JazzCadence -> JazzCadence -> Bool
JazzCadence -> JazzCadence -> Ordering
JazzCadence -> JazzCadence -> JazzCadence
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 :: JazzCadence -> JazzCadence -> Ordering
compare :: JazzCadence -> JazzCadence -> Ordering
$c< :: JazzCadence -> JazzCadence -> Bool
< :: JazzCadence -> JazzCadence -> Bool
$c<= :: JazzCadence -> JazzCadence -> Bool
<= :: JazzCadence -> JazzCadence -> Bool
$c> :: JazzCadence -> JazzCadence -> Bool
> :: JazzCadence -> JazzCadence -> Bool
$c>= :: JazzCadence -> JazzCadence -> Bool
>= :: JazzCadence -> JazzCadence -> Bool
$cmax :: JazzCadence -> JazzCadence -> JazzCadence
max :: JazzCadence -> JazzCadence -> JazzCadence
$cmin :: JazzCadence -> JazzCadence -> JazzCadence
min :: JazzCadence -> JazzCadence -> JazzCadence
Ord)

-- | Graph node key for a jazz cadence, matching the classical key shape:
-- @( \<movement\> -> \<functionality\> )@.
jazzShow :: JazzCadence -> T.Text
jazzShow :: JazzCadence -> Text
jazzShow (JazzCadence Movement
mv [Int]
_ Text
nm) =
  Text
"( " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Movement -> String
forall a. Show a => a -> String
show Movement
mv) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" )"

-- | The cadence chain of one song: one cadence per beat-to-beat step
-- (n beats yield n-1 cadences; the opening beat has no arrival). A beat
-- sustaining the same harmony over the same anchor yields a pedal
-- self-cadence. Chains never cross song boundaries — the caller builds
-- edges from consecutive pairs within one song's chain only.
songCadences :: JazzSong -> [JazzCadence]
songCadences :: JazzSong -> [JazzCadence]
songCadences JazzSong
song =
  [ Movement -> [Int] -> Text -> JazzCadence
JazzCadence (PitchClass -> PitchClass -> Movement
toMovement (JazzChord -> PitchClass
jcAnchor JazzChord
prev) (JazzChord -> PitchClass
jcAnchor JazzChord
cur)) [Int]
zf Text
name
  | (JazzChord
prev, JazzChord
cur) <- [JazzChord] -> [JazzChord] -> [(JazzChord, JazzChord)]
forall a b. [a] -> [b] -> [(a, b)]
zip [JazzChord]
stream (Int -> [JazzChord] -> [JazzChord]
forall a. Int -> [a] -> [a]
drop Int
1 [JazzChord]
stream)
  , let zf :: [Int]
zf = JazzChord -> [Int]
jazzZeroForm JazzChord
cur
  , Just Text
name <- [[Int] -> Maybe Text
jazzFunctionality [Int]
zf]
  ]
  where stream :: [JazzChord]
stream = JazzSong -> [JazzChord]
beatStream JazzSong
song

-- | Composer name to weight key: lower-cased, alphanumerics only, with
-- the empty result mapped to @unknown@. The ONE normalisation applied at
-- every write and lookup, so a composer can never split across variant
-- spellings of the same name.
normalizeComposer :: T.Text -> T.Text
normalizeComposer :: Text -> Text
normalizeComposer Text
t =
  let slug :: Text
slug = (Char -> Bool) -> Text -> Text
T.filter (\Char
c -> Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char
'a'..Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'])) (Text -> Text
T.toLower Text
t)
  in if Text -> Bool
T.null Text
slug then Text
"unknown" else Text
slug

-- | Aggregate the whole corpus into weighted transition edges: every
-- consecutive cadence pair within one song contributes 1.0 to that
-- song's composer on the @from -> to@ edge. Chains never cross songs.
-- The result feeds 'Harmonic.Rules.Import.Graph.writeChangeEdges'.
buildChangeEdges :: [JazzSong]
                 -> [((JazzCadence, JazzCadence), Map.Map T.Text Double)]
buildChangeEdges :: [JazzSong] -> [((JazzCadence, JazzCadence), Map Text Double)]
buildChangeEdges [JazzSong]
songs = Map (JazzCadence, JazzCadence) (Map Text Double)
-> [((JazzCadence, JazzCadence), Map Text Double)]
forall k a. Map k a -> [(k, a)]
Map.toList ((Map Text Double -> Map Text Double -> Map Text Double)
-> [((JazzCadence, JazzCadence), Map Text Double)]
-> Map (JazzCadence, JazzCadence) (Map Text Double)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ((Double -> Double -> Double)
-> Map Text Double -> Map Text Double -> Map Text Double
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+))
  [ ((JazzCadence
a, JazzCadence
b), Text -> Double -> Map Text Double
forall k a. k -> a -> Map k a
Map.singleton (Text -> Text
normalizeComposer (JazzSong -> Text
jsComposer JazzSong
song)) Double
1.0)
  | JazzSong
song <- [JazzSong]
songs
  , let chain :: [JazzCadence]
chain = JazzSong -> [JazzCadence]
songCadences JazzSong
song
  , (JazzCadence
a, JazzCadence
b) <- [JazzCadence] -> [JazzCadence] -> [(JazzCadence, JazzCadence)]
forall a b. [a] -> [b] -> [(a, b)]
zip [JazzCadence]
chain (Int -> [JazzCadence] -> [JazzCadence]
forall a. Int -> [a] -> [a]
drop Int
1 [JazzCadence]
chain)
  ])