{-# LANGUAGE DeriveGeneric #-}

-- |
-- Module      : Harmonic.Evaluation.Scoring.Dissonance
-- Description : Hindemith-based dissonance evaluation
--
-- This module implements the Evaluation (E) component of the Creative Systems
-- Framework for consonance\/dissonance assessment.
--
-- == Academic Lineage
--
-- Paul Hindemith, /The Craft of Musical Composition/ (1937): the interval
-- class consonance ranking that underlies the @dissVect@ weighting vector.
--
-- /Data Science In The Creative Process/ (South, 2018): the computational
-- implementation as @dissVect = [16,8,4,2,1,24]@ (MusicData.hs lines 394-401).
--
-- == Weighting Vector
--
-- @dissVect = [16,8,4,2,1,24]@ maps interval classes to *dissonance*
-- weights — higher is more dissonant:
--
--   * Minor second\/major seventh (ic 1): 16
--   * Major second\/minor seventh (ic 2): 8
--   * Minor third\/major sixth (ic 3): 4
--   * Major third\/minor sixth (ic 4): 2
--   * Perfect fourth\/perfect fifth (ic 5): 1 (most consonant)
--   * Tritone (ic 6): 24 (most dissonant)
--
-- (Matches the authoritative table on 'hindemithVector' below; an earlier
-- version of this header had the interval names shifted one class up.)

module Harmonic.Evaluation.Scoring.Dissonance
  ( -- * Core Dissonance Calculation
    dissonanceLevel
  , dissonanceScore
  
    -- * Hindemith Vector
  , hindemithVector
  
    -- * Interval Analysis
  , intervalVector
  , intervalClass
  
    -- * Root Motion Scoring
  , rootMotionVector
  , rootMotionScore
  
    -- * Selection
  , mostConsonant
  , rankByConsonance
  ) where

import GHC.Generics (Generic)
import Data.Function (on)
import Data.List (sortBy, sort, nub)

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

-------------------------------------------------------------------------------
-- Hindemith Dissonance Model (VERBATIM from legacy MusicData.hs)
-------------------------------------------------------------------------------

-- |The Hindemith dissonance weighting vector.
-- Based on Paul Hindemith's ranking of interval classes.
-- 
-- Interval class mapping:
--   Index 0 → ic 1 (minor 2nd \/ major 7th) → weight 16
--   Index 1 → ic 2 (major 2nd \/ minor 7th) → weight 8
--   Index 2 → ic 3 (minor 3rd \/ major 6th) → weight 4
--   Index 3 → ic 4 (major 3rd \/ minor 6th) → weight 2
--   Index 4 → ic 5 (perfect 4th \/ perfect 5th) → weight 1
--   Index 5 → ic 6 (tritone) → weight 24
hindemithVector :: [Integer]
hindemithVector :: [Integer]
hindemithVector = [Integer
16, Integer
8, Integer
4, Integer
2, Integer
1, Integer
24]
{-# INLINE hindemithVector #-}

-- |Root motion scoring vector for fallback generation.
-- Ranks interval classes by smoothness (lower = smoother movement).
--
-- Interval class mapping:
--   Index 0 → ic 1 (m2\/M7) → weight 3 (stepwise)
--   Index 1 → ic 2 (M2\/m7) → weight 3 (stepwise)
--   Index 2 → ic 3 (m3\/M6) → weight 4 (moderate leap)
--   Index 3 → ic 4 (M3\/m6) → weight 4 (moderate leap)
--   Index 4 → ic 5 (P4\/P5) → weight 1 (strong harmonic motion)
--   Index 5 → ic 6 (TT)    → weight 6 (avoid)
--
-- Special cases:
--   ic 0 (Unison\/Pedal) → weight 2 (encourages harmonic rhythm)
rootMotionVector :: [Integer]
rootMotionVector :: [Integer]
rootMotionVector = [Integer
3, Integer
3, Integer
4, Integer
4, Integer
1, Integer
6]
{-# INLINE rootMotionVector #-}

-- |Score root motion interval by smoothness.
-- Returns smoothness penalty (lower = better movement).
--
-- Examples:
--   rootMotionScore 0  == 2 (pedal - slight penalty)
--   rootMotionScore 7  == 1 (P5 - strongest movement)
--   rootMotionScore 5  == 1 (P4 - strong movement)
--   rootMotionScore 1  == 3 (m2 - stepwise)
--   rootMotionScore 2  == 3 (M2 - stepwise)
--   rootMotionScore 6  == 6 (TT - avoid)
rootMotionScore :: Int -> Integer
rootMotionScore :: Int -> Integer
rootMotionScore Int
n
  | Int
ic Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0   = Integer
2  -- Pedal: slight penalty to encourage harmonic rhythm
  | Bool
otherwise = [Integer]
rootMotionVector [Integer] -> Int -> Integer
forall a. HasCallStack => [a] -> Int -> a
!! (Int
ic Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  where ic :: Int
ic = Int -> Int
intervalClass Int
n
{-# INLINE rootMotionScore #-}

-------------------------------------------------------------------------------
-- Interval Vector (Set Theory)
-------------------------------------------------------------------------------

-- |Calculate the interval class (0-6) for an interval in semitones.
-- Interval classes fold intervals larger than a tritone to their complement.
intervalClass :: Int -> Int
intervalClass :: Int -> Int
intervalClass Int
n
  | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6    = Int
m
  | Bool
otherwise = Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m
  where m :: Int
m = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
{-# INLINE intervalClass #-}

-- |Calculate the interval vector for a pitch class set.
-- Returns counts for interval classes [1..6].
-- 
-- The interval vector is the "fingerprint" of a pitch set, counting how many
-- times each interval class appears between all pairs of pitches.
--
-- Ported from legacy MusicData.hs (lines 349-358)
intervalVector :: [Int] -> [Integer]
intervalVector :: [Int] -> [Integer]
intervalVector [Int]
xs = [Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Int
vectCounts Int
ic) | Int
ic <- [Int
1..Int
6]]
  where
    pitches :: [Int]
pitches = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (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]
xs
    -- All pairs of pitches
    pairs :: [(Int, Int)]
pairs = [(Int
a, Int
b) | Int
a <- [Int]
pitches, Int
b <- [Int]
pitches, Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
b]
    -- Interval between each pair, folded to interval class
    intervals :: [Int]
intervals = [Int -> Int
intervalClass (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a) | (Int
a, Int
b) <- [(Int, Int)]
pairs]
    -- Count occurrences of each interval class
    vectCounts :: Int -> Int
vectCounts Int
ic = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ic) [Int]
intervals

-- |Alternative interval vector from pitch classes directly
intervalVectorPC :: [PitchClass] -> [Integer]
intervalVectorPC :: [PitchClass] -> [Integer]
intervalVectorPC [PitchClass]
pcs = [Int] -> [Integer]
intervalVector ([Int] -> [Integer]) -> [Int] -> [Integer]
forall a b. (a -> b) -> a -> b
$ (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
unPitchClass [PitchClass]
pcs

-------------------------------------------------------------------------------
-- Dissonance Calculation (VERBATIM PRINCIPLE from legacy MusicData.hs)
-------------------------------------------------------------------------------

-- |Calculate dissonance level for a pitch set.
-- Returns (dissonance score, original pitches) for sorting\/selection.
--
-- The calculation:
--   1. Compute interval vector [ic1, ic2, ic3, ic4, ic5, ic6]
--   2. Dot product with Hindemith weights [16, 8, 4, 2, 1, 24]
--   3. Special case: if only one interval class is present and it's the fifth,
--      subtract 1 (bonus for "pure" fifths)
--   4. Special case: if interval vector is all zeros except one slot,
--      return 27 (penalty for degenerate sets)
--
-- VERBATIM from legacy MusicData.hs (lines 394-401):
-- @
-- dissonanceLevel xs
--   | countElem iVect 0 == 5 = (27, xs)
--   | elem (7+head xs) xs    = (subtract 1 $ sum $ zipWith (*) dissVect iVect, xs)
--   | otherwise              = (sum $ zipWith (*) dissVect iVect, xs)
-- @
dissonanceLevel :: [Int] -> (Integer, [Int])
dissonanceLevel :: [Int] -> (Integer, [Int])
dissonanceLevel [Int]
xs
  | [Integer] -> Integer -> Int
forall a. Eq a => [a] -> a -> Int
countElem [Integer]
iVect Integer
0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 = (Integer
27, [Int]
xs)  -- Degenerate: only one interval class
  | [Int] -> Bool
hasPerfectFifth [Int]
xs     = (Integer
baseDiss Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1, [Int]
xs)  -- Bonus for containing P5
  | Bool
otherwise              = (Integer
baseDiss, [Int]
xs)
  where
    iVect :: [Integer]
iVect    = [Int] -> [Integer]
intervalVector [Int]
xs
    baseDiss :: Integer
baseDiss = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ (Integer -> Integer -> Integer)
-> [Integer] -> [Integer] -> [Integer]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) [Integer]
hindemithVector [Integer]
iVect

-- |Simplified dissonance score (just the number, not paired with input)
dissonanceScore :: [Int] -> Integer
dissonanceScore :: [Int] -> Integer
dissonanceScore = (Integer, [Int]) -> Integer
forall a b. (a, b) -> a
fst ((Integer, [Int]) -> Integer)
-> ([Int] -> (Integer, [Int])) -> [Int] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> (Integer, [Int])
dissonanceLevel

-- |Check if a pitch set contains a perfect fifth above the root
hasPerfectFifth :: [Int] -> Bool
hasPerfectFifth :: [Int] -> Bool
hasPerfectFifth [] = Bool
False
hasPerfectFifth (Int
root:[Int]
rest) = 
  let p5 :: Int
p5 = (Int
root Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
  in (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
x -> Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p5) [Int]
rest

-- |Count occurrences of an element in a list
countElem :: Eq a => [a] -> a -> Int
countElem :: forall a. Eq a => [a] -> a -> Int
countElem [a]
xs a
x = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x) [a]
xs

-------------------------------------------------------------------------------
-- Consonance Selection
-------------------------------------------------------------------------------

-- |Select the most consonant option from a list of pitch sets.
-- Used by triad generation to pick the "best" interpretation.
--
-- Ported from legacy MusicData.hs (lines 403-406):
-- @
-- mostConsonant xs = triadChoice . sortFst $ dissonanceLevel <$> xs
--   where triadChoice xs = (snd . head . sortFst) xs
--         sortFst xs     = List.sortBy (compare `on` fst) xs
-- @
mostConsonant :: [[Int]] -> [Int]
mostConsonant :: [[Int]] -> [Int]
mostConsonant [] = [Int
0, Int
4, Int
7]  -- Default to major triad if no options
mostConsonant [[Int]]
xs = (Integer, [Int]) -> [Int]
forall a b. (a, b) -> b
snd ((Integer, [Int]) -> [Int])
-> ([(Integer, [Int])] -> (Integer, [Int]))
-> [(Integer, [Int])]
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Integer, [Int])] -> (Integer, [Int])
forall a. HasCallStack => [a] -> a
head ([(Integer, [Int])] -> (Integer, [Int]))
-> ([(Integer, [Int])] -> [(Integer, [Int])])
-> [(Integer, [Int])]
-> (Integer, [Int])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Integer, [Int])] -> [(Integer, [Int])]
forall {b}. [(Integer, b)] -> [(Integer, b)]
sortByFst ([(Integer, [Int])] -> [Int]) -> [(Integer, [Int])] -> [Int]
forall a b. (a -> b) -> a -> b
$ ([Int] -> (Integer, [Int])) -> [[Int]] -> [(Integer, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> (Integer, [Int])
dissonanceLevel [[Int]]
xs
  where
    sortByFst :: [(Integer, b)] -> [(Integer, b)]
sortByFst = ((Integer, b) -> (Integer, b) -> Ordering)
-> [(Integer, b)] -> [(Integer, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Integer -> Ordering)
-> ((Integer, b) -> Integer)
-> (Integer, b)
-> (Integer, b)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Integer, b) -> Integer
forall a b. (a, b) -> a
fst)

-- |Rank a list of pitch sets by consonance (most consonant first)
rankByConsonance :: [[Int]] -> [[Int]]
rankByConsonance :: [[Int]] -> [[Int]]
rankByConsonance [[Int]]
xs = ((Integer, [Int]) -> [Int]) -> [(Integer, [Int])] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, [Int]) -> [Int]
forall a b. (a, b) -> b
snd ([(Integer, [Int])] -> [[Int]]) -> [(Integer, [Int])] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ ((Integer, [Int]) -> (Integer, [Int]) -> Ordering)
-> [(Integer, [Int])] -> [(Integer, [Int])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Integer -> Ordering)
-> ((Integer, [Int]) -> Integer)
-> (Integer, [Int])
-> (Integer, [Int])
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Integer, [Int]) -> Integer
forall a b. (a, b) -> a
fst) ([(Integer, [Int])] -> [(Integer, [Int])])
-> [(Integer, [Int])] -> [(Integer, [Int])]
forall a b. (a -> b) -> a -> b
$ ([Int] -> (Integer, [Int])) -> [[Int]] -> [(Integer, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> (Integer, [Int])
dissonanceLevel [[Int]]
xs

-- |Rank and return with scores for debugging\/inspection
rankByConsonanceWithScores :: [[Int]] -> [(Integer, [Int])]
rankByConsonanceWithScores :: [[Int]] -> [(Integer, [Int])]
rankByConsonanceWithScores [[Int]]
xs = ((Integer, [Int]) -> (Integer, [Int]) -> Ordering)
-> [(Integer, [Int])] -> [(Integer, [Int])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Integer -> Ordering)
-> ((Integer, [Int]) -> Integer)
-> (Integer, [Int])
-> (Integer, [Int])
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Integer, [Int]) -> Integer
forall a b. (a, b) -> a
fst) ([(Integer, [Int])] -> [(Integer, [Int])])
-> [(Integer, [Int])] -> [(Integer, [Int])]
forall a b. (a -> b) -> a -> b
$ ([Int] -> (Integer, [Int])) -> [[Int]] -> [(Integer, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> (Integer, [Int])
dissonanceLevel [[Int]]
xs