-- |
-- Module      : Harmonic.Rules.Types.Scale
-- Description : Pentatonic, modal, and octatripentatonic vocabulary
--
-- Vocabulary for the octatripentatonic framework: pentatonic families,
-- the 28-mode taxonomy, the eleven canonical strata, and the twelve
-- curated tristrata. E-minor-base chroma throughout.

module Harmonic.Rules.Types.Scale
  ( -- * Pentatonic families
    PentaFamily(..)
  , familyChroma
  , Pentatonic(..)
  , pentaChroma
  , pentaFromChroma

    -- * Mode taxonomy
  , ModeQuality(..)
  , Mode(..)
  , modeChroma
  , classifyMode
  , classifyModeAt
  , ScaleFamily(..)
  , modeFamily
  , modeDegree
  , parentKey
  , showScaleFamily
  , showModeQuality
  , ModeResult(..)

    -- * Strata
  , StrataLabel(..)
  , strataChroma
  , strataDissonance
  , allStrataLabels

    -- * Tristrata
  , Tristrata(..)
  , validTristrata
  , tristrataIndex
  , tristrataStrataAt
  , tristrataDissonance
  , tristrataOf
  , tristrataModes

    -- * Parsers
  , parseTristrataList
  , parseRelStrata
  , parseAbsStrata
  ) where

import Data.List (nub, sort, find)
import Data.Maybe (listToMaybe, mapMaybe, fromMaybe)
import Data.Char (toUpper)

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

-------------------------------------------------------------------------------
-- Pentatonic families
-------------------------------------------------------------------------------

-- |Pentatonic family: the four ancestral pentatonic shapes recognised
-- throughout the legacy theory (major, Okinawan, Iwato, Kumoi).
data PentaFamily = MajorPenta | Okinawan | Iwato | Kumoi
  deriving (PentaFamily -> PentaFamily -> Bool
(PentaFamily -> PentaFamily -> Bool)
-> (PentaFamily -> PentaFamily -> Bool) -> Eq PentaFamily
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PentaFamily -> PentaFamily -> Bool
== :: PentaFamily -> PentaFamily -> Bool
$c/= :: PentaFamily -> PentaFamily -> Bool
/= :: PentaFamily -> PentaFamily -> Bool
Eq, Eq PentaFamily
Eq PentaFamily =>
(PentaFamily -> PentaFamily -> Ordering)
-> (PentaFamily -> PentaFamily -> Bool)
-> (PentaFamily -> PentaFamily -> Bool)
-> (PentaFamily -> PentaFamily -> Bool)
-> (PentaFamily -> PentaFamily -> Bool)
-> (PentaFamily -> PentaFamily -> PentaFamily)
-> (PentaFamily -> PentaFamily -> PentaFamily)
-> Ord PentaFamily
PentaFamily -> PentaFamily -> Bool
PentaFamily -> PentaFamily -> Ordering
PentaFamily -> PentaFamily -> PentaFamily
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 :: PentaFamily -> PentaFamily -> Ordering
compare :: PentaFamily -> PentaFamily -> Ordering
$c< :: PentaFamily -> PentaFamily -> Bool
< :: PentaFamily -> PentaFamily -> Bool
$c<= :: PentaFamily -> PentaFamily -> Bool
<= :: PentaFamily -> PentaFamily -> Bool
$c> :: PentaFamily -> PentaFamily -> Bool
> :: PentaFamily -> PentaFamily -> Bool
$c>= :: PentaFamily -> PentaFamily -> Bool
>= :: PentaFamily -> PentaFamily -> Bool
$cmax :: PentaFamily -> PentaFamily -> PentaFamily
max :: PentaFamily -> PentaFamily -> PentaFamily
$cmin :: PentaFamily -> PentaFamily -> PentaFamily
min :: PentaFamily -> PentaFamily -> PentaFamily
Ord, Int -> PentaFamily -> ShowS
[PentaFamily] -> ShowS
PentaFamily -> String
(Int -> PentaFamily -> ShowS)
-> (PentaFamily -> String)
-> ([PentaFamily] -> ShowS)
-> Show PentaFamily
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PentaFamily -> ShowS
showsPrec :: Int -> PentaFamily -> ShowS
$cshow :: PentaFamily -> String
show :: PentaFamily -> String
$cshowList :: [PentaFamily] -> ShowS
showList :: [PentaFamily] -> ShowS
Show, ReadPrec [PentaFamily]
ReadPrec PentaFamily
Int -> ReadS PentaFamily
ReadS [PentaFamily]
(Int -> ReadS PentaFamily)
-> ReadS [PentaFamily]
-> ReadPrec PentaFamily
-> ReadPrec [PentaFamily]
-> Read PentaFamily
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS PentaFamily
readsPrec :: Int -> ReadS PentaFamily
$creadList :: ReadS [PentaFamily]
readList :: ReadS [PentaFamily]
$creadPrec :: ReadPrec PentaFamily
readPrec :: ReadPrec PentaFamily
$creadListPrec :: ReadPrec [PentaFamily]
readListPrec :: ReadPrec [PentaFamily]
Read, Int -> PentaFamily
PentaFamily -> Int
PentaFamily -> [PentaFamily]
PentaFamily -> PentaFamily
PentaFamily -> PentaFamily -> [PentaFamily]
PentaFamily -> PentaFamily -> PentaFamily -> [PentaFamily]
(PentaFamily -> PentaFamily)
-> (PentaFamily -> PentaFamily)
-> (Int -> PentaFamily)
-> (PentaFamily -> Int)
-> (PentaFamily -> [PentaFamily])
-> (PentaFamily -> PentaFamily -> [PentaFamily])
-> (PentaFamily -> PentaFamily -> [PentaFamily])
-> (PentaFamily -> PentaFamily -> PentaFamily -> [PentaFamily])
-> Enum PentaFamily
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 :: PentaFamily -> PentaFamily
succ :: PentaFamily -> PentaFamily
$cpred :: PentaFamily -> PentaFamily
pred :: PentaFamily -> PentaFamily
$ctoEnum :: Int -> PentaFamily
toEnum :: Int -> PentaFamily
$cfromEnum :: PentaFamily -> Int
fromEnum :: PentaFamily -> Int
$cenumFrom :: PentaFamily -> [PentaFamily]
enumFrom :: PentaFamily -> [PentaFamily]
$cenumFromThen :: PentaFamily -> PentaFamily -> [PentaFamily]
enumFromThen :: PentaFamily -> PentaFamily -> [PentaFamily]
$cenumFromTo :: PentaFamily -> PentaFamily -> [PentaFamily]
enumFromTo :: PentaFamily -> PentaFamily -> [PentaFamily]
$cenumFromThenTo :: PentaFamily -> PentaFamily -> PentaFamily -> [PentaFamily]
enumFromThenTo :: PentaFamily -> PentaFamily -> PentaFamily -> [PentaFamily]
Enum, PentaFamily
PentaFamily -> PentaFamily -> Bounded PentaFamily
forall a. a -> a -> Bounded a
$cminBound :: PentaFamily
minBound :: PentaFamily
$cmaxBound :: PentaFamily
maxBound :: PentaFamily
Bounded)

-- |Chroma (pitch-class set) for a pentatonic family, rooted at 0.
familyChroma :: PentaFamily -> [PitchClass]
familyChroma :: PentaFamily -> [PitchClass]
familyChroma PentaFamily
MajorPenta = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
0, Int
2, Int
4, Int
7, Int
9]
familyChroma PentaFamily
Okinawan   = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
0, Int
4, Int
5, Int
7, Int
11]
familyChroma PentaFamily
Iwato      = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
0, Int
1, Int
5, Int
6, Int
10]
familyChroma PentaFamily
Kumoi      = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
0, Int
2, Int
3, Int
7, Int
9]

-- |A pentatonic scale is a family + a root pitch class.
data Pentatonic = Pentatonic
  { Pentatonic -> PentaFamily
pentaFamily :: PentaFamily
  , Pentatonic -> PitchClass
pentaRoot   :: PitchClass
  } deriving (Pentatonic -> Pentatonic -> Bool
(Pentatonic -> Pentatonic -> Bool)
-> (Pentatonic -> Pentatonic -> Bool) -> Eq Pentatonic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pentatonic -> Pentatonic -> Bool
== :: Pentatonic -> Pentatonic -> Bool
$c/= :: Pentatonic -> Pentatonic -> Bool
/= :: Pentatonic -> Pentatonic -> Bool
Eq, Eq Pentatonic
Eq Pentatonic =>
(Pentatonic -> Pentatonic -> Ordering)
-> (Pentatonic -> Pentatonic -> Bool)
-> (Pentatonic -> Pentatonic -> Bool)
-> (Pentatonic -> Pentatonic -> Bool)
-> (Pentatonic -> Pentatonic -> Bool)
-> (Pentatonic -> Pentatonic -> Pentatonic)
-> (Pentatonic -> Pentatonic -> Pentatonic)
-> Ord Pentatonic
Pentatonic -> Pentatonic -> Bool
Pentatonic -> Pentatonic -> Ordering
Pentatonic -> Pentatonic -> Pentatonic
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 :: Pentatonic -> Pentatonic -> Ordering
compare :: Pentatonic -> Pentatonic -> Ordering
$c< :: Pentatonic -> Pentatonic -> Bool
< :: Pentatonic -> Pentatonic -> Bool
$c<= :: Pentatonic -> Pentatonic -> Bool
<= :: Pentatonic -> Pentatonic -> Bool
$c> :: Pentatonic -> Pentatonic -> Bool
> :: Pentatonic -> Pentatonic -> Bool
$c>= :: Pentatonic -> Pentatonic -> Bool
>= :: Pentatonic -> Pentatonic -> Bool
$cmax :: Pentatonic -> Pentatonic -> Pentatonic
max :: Pentatonic -> Pentatonic -> Pentatonic
$cmin :: Pentatonic -> Pentatonic -> Pentatonic
min :: Pentatonic -> Pentatonic -> Pentatonic
Ord, Int -> Pentatonic -> ShowS
[Pentatonic] -> ShowS
Pentatonic -> String
(Int -> Pentatonic -> ShowS)
-> (Pentatonic -> String)
-> ([Pentatonic] -> ShowS)
-> Show Pentatonic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pentatonic -> ShowS
showsPrec :: Int -> Pentatonic -> ShowS
$cshow :: Pentatonic -> String
show :: Pentatonic -> String
$cshowList :: [Pentatonic] -> ShowS
showList :: [Pentatonic] -> ShowS
Show)

-- |Concrete chroma of a rooted pentatonic.
pentaChroma :: Pentatonic -> [PitchClass]
pentaChroma :: Pentatonic -> [PitchClass]
pentaChroma (Pentatonic PentaFamily
fam (P Int
r)) =
  [PitchClass] -> [PitchClass]
forall a. Ord a => [a] -> [a]
sort ([PitchClass] -> [PitchClass]) -> [PitchClass] -> [PitchClass]
forall a b. (a -> b) -> a -> b
$ [PitchClass] -> [PitchClass]
forall a. Eq a => [a] -> [a]
nub [ Int -> PitchClass
mkPitchClass (PitchClass -> Int
unPitchClass PitchClass
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r) | PitchClass
p <- PentaFamily -> [PitchClass]
familyChroma PentaFamily
fam ]

-- |Reverse lookup: given a 5-PC set, identify its family+root if any.
pentaFromChroma :: [PitchClass] -> Maybe Pentatonic
pentaFromChroma :: [PitchClass] -> Maybe Pentatonic
pentaFromChroma [PitchClass]
pcs
  | [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PitchClass]
uniq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
5 = Maybe Pentatonic
forall a. Maybe a
Nothing
  | Bool
otherwise = [Pentatonic] -> Maybe Pentatonic
forall a. [a] -> Maybe a
listToMaybe
      [ PentaFamily -> PitchClass -> Pentatonic
Pentatonic PentaFamily
fam (Int -> PitchClass
P Int
r)
      | PentaFamily
fam <- [PentaFamily
forall a. Bounded a => a
minBound .. PentaFamily
forall a. Bounded a => a
maxBound]
      , Int
r   <- [Int
0 .. Int
11]
      , [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
unPitchClass (Pentatonic -> [PitchClass]
pentaChroma (PentaFamily -> PitchClass -> Pentatonic
Pentatonic PentaFamily
fam (Int -> PitchClass
P Int
r))))
          [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
unPitchClass [PitchClass]
uniq)
      ]
  where
    uniq :: [PitchClass]
uniq = [PitchClass] -> [PitchClass]
forall a. Eq a => [a] -> [a]
nub [PitchClass]
pcs

-------------------------------------------------------------------------------
-- Mode taxonomy (28 modes)
-------------------------------------------------------------------------------

-- |28-mode taxonomy ported from the legacy @toMode@ function.
data ModeQuality
  -- Major modes (7)
  = Ionian | Dorian | Phrygian | Lydian | Mixolydian | Aeolian | Locrian
  -- Melodic minor modes (7)
  | MelMin | DorB2 | LydS5 | LydDom | MixoB6 | LocNat2 | AltDom
  -- Harmonic minor modes (7)
  | HarmMin | LocNat6 | IonS5 | DorS4 | PhryNat3 | LydS2 | AltBb7
  -- Harmonic major modes (7)
  | HarmMaj | DorB5 | PhryB4 | LydB3 | MixoB2 | LydAugS2 | LocBb7
  deriving (ModeQuality -> ModeQuality -> Bool
(ModeQuality -> ModeQuality -> Bool)
-> (ModeQuality -> ModeQuality -> Bool) -> Eq ModeQuality
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ModeQuality -> ModeQuality -> Bool
== :: ModeQuality -> ModeQuality -> Bool
$c/= :: ModeQuality -> ModeQuality -> Bool
/= :: ModeQuality -> ModeQuality -> Bool
Eq, Eq ModeQuality
Eq ModeQuality =>
(ModeQuality -> ModeQuality -> Ordering)
-> (ModeQuality -> ModeQuality -> Bool)
-> (ModeQuality -> ModeQuality -> Bool)
-> (ModeQuality -> ModeQuality -> Bool)
-> (ModeQuality -> ModeQuality -> Bool)
-> (ModeQuality -> ModeQuality -> ModeQuality)
-> (ModeQuality -> ModeQuality -> ModeQuality)
-> Ord ModeQuality
ModeQuality -> ModeQuality -> Bool
ModeQuality -> ModeQuality -> Ordering
ModeQuality -> ModeQuality -> ModeQuality
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 :: ModeQuality -> ModeQuality -> Ordering
compare :: ModeQuality -> ModeQuality -> Ordering
$c< :: ModeQuality -> ModeQuality -> Bool
< :: ModeQuality -> ModeQuality -> Bool
$c<= :: ModeQuality -> ModeQuality -> Bool
<= :: ModeQuality -> ModeQuality -> Bool
$c> :: ModeQuality -> ModeQuality -> Bool
> :: ModeQuality -> ModeQuality -> Bool
$c>= :: ModeQuality -> ModeQuality -> Bool
>= :: ModeQuality -> ModeQuality -> Bool
$cmax :: ModeQuality -> ModeQuality -> ModeQuality
max :: ModeQuality -> ModeQuality -> ModeQuality
$cmin :: ModeQuality -> ModeQuality -> ModeQuality
min :: ModeQuality -> ModeQuality -> ModeQuality
Ord, Int -> ModeQuality -> ShowS
[ModeQuality] -> ShowS
ModeQuality -> String
(Int -> ModeQuality -> ShowS)
-> (ModeQuality -> String)
-> ([ModeQuality] -> ShowS)
-> Show ModeQuality
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ModeQuality -> ShowS
showsPrec :: Int -> ModeQuality -> ShowS
$cshow :: ModeQuality -> String
show :: ModeQuality -> String
$cshowList :: [ModeQuality] -> ShowS
showList :: [ModeQuality] -> ShowS
Show, ReadPrec [ModeQuality]
ReadPrec ModeQuality
Int -> ReadS ModeQuality
ReadS [ModeQuality]
(Int -> ReadS ModeQuality)
-> ReadS [ModeQuality]
-> ReadPrec ModeQuality
-> ReadPrec [ModeQuality]
-> Read ModeQuality
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ModeQuality
readsPrec :: Int -> ReadS ModeQuality
$creadList :: ReadS [ModeQuality]
readList :: ReadS [ModeQuality]
$creadPrec :: ReadPrec ModeQuality
readPrec :: ReadPrec ModeQuality
$creadListPrec :: ReadPrec [ModeQuality]
readListPrec :: ReadPrec [ModeQuality]
Read, Int -> ModeQuality
ModeQuality -> Int
ModeQuality -> [ModeQuality]
ModeQuality -> ModeQuality
ModeQuality -> ModeQuality -> [ModeQuality]
ModeQuality -> ModeQuality -> ModeQuality -> [ModeQuality]
(ModeQuality -> ModeQuality)
-> (ModeQuality -> ModeQuality)
-> (Int -> ModeQuality)
-> (ModeQuality -> Int)
-> (ModeQuality -> [ModeQuality])
-> (ModeQuality -> ModeQuality -> [ModeQuality])
-> (ModeQuality -> ModeQuality -> [ModeQuality])
-> (ModeQuality -> ModeQuality -> ModeQuality -> [ModeQuality])
-> Enum ModeQuality
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 :: ModeQuality -> ModeQuality
succ :: ModeQuality -> ModeQuality
$cpred :: ModeQuality -> ModeQuality
pred :: ModeQuality -> ModeQuality
$ctoEnum :: Int -> ModeQuality
toEnum :: Int -> ModeQuality
$cfromEnum :: ModeQuality -> Int
fromEnum :: ModeQuality -> Int
$cenumFrom :: ModeQuality -> [ModeQuality]
enumFrom :: ModeQuality -> [ModeQuality]
$cenumFromThen :: ModeQuality -> ModeQuality -> [ModeQuality]
enumFromThen :: ModeQuality -> ModeQuality -> [ModeQuality]
$cenumFromTo :: ModeQuality -> ModeQuality -> [ModeQuality]
enumFromTo :: ModeQuality -> ModeQuality -> [ModeQuality]
$cenumFromThenTo :: ModeQuality -> ModeQuality -> ModeQuality -> [ModeQuality]
enumFromThenTo :: ModeQuality -> ModeQuality -> ModeQuality -> [ModeQuality]
Enum, ModeQuality
ModeQuality -> ModeQuality -> Bounded ModeQuality
forall a. a -> a -> Bounded a
$cminBound :: ModeQuality
minBound :: ModeQuality
$cmaxBound :: ModeQuality
maxBound :: ModeQuality
Bounded)

-- |Interval pattern (from the root) for each mode quality.
modeIntervals :: ModeQuality -> [Int]
-- Major
modeIntervals :: ModeQuality -> [Int]
modeIntervals ModeQuality
Ionian     = [Int
0,Int
2,Int
4,Int
5,Int
7,Int
9,Int
11]
modeIntervals ModeQuality
Dorian     = [Int
0,Int
2,Int
3,Int
5,Int
7,Int
9,Int
10]
modeIntervals ModeQuality
Phrygian   = [Int
0,Int
1,Int
3,Int
5,Int
7,Int
8,Int
10]
modeIntervals ModeQuality
Lydian     = [Int
0,Int
2,Int
4,Int
6,Int
7,Int
9,Int
11]
modeIntervals ModeQuality
Mixolydian = [Int
0,Int
2,Int
4,Int
5,Int
7,Int
9,Int
10]
modeIntervals ModeQuality
Aeolian    = [Int
0,Int
2,Int
3,Int
5,Int
7,Int
8,Int
10]
modeIntervals ModeQuality
Locrian    = [Int
0,Int
1,Int
3,Int
5,Int
6,Int
8,Int
10]
-- Melodic minor
modeIntervals ModeQuality
MelMin     = [Int
0,Int
2,Int
3,Int
5,Int
7,Int
9,Int
11]
modeIntervals ModeQuality
DorB2      = [Int
0,Int
1,Int
3,Int
5,Int
7,Int
9,Int
10]
modeIntervals ModeQuality
LydS5      = [Int
0,Int
2,Int
4,Int
6,Int
8,Int
9,Int
11]
modeIntervals ModeQuality
LydDom     = [Int
0,Int
2,Int
4,Int
6,Int
7,Int
9,Int
10]
modeIntervals ModeQuality
MixoB6     = [Int
0,Int
2,Int
4,Int
5,Int
7,Int
8,Int
10]
modeIntervals ModeQuality
LocNat2    = [Int
0,Int
2,Int
3,Int
5,Int
6,Int
8,Int
10]
modeIntervals ModeQuality
AltDom     = [Int
0,Int
1,Int
3,Int
4,Int
6,Int
8,Int
10]
-- Harmonic minor
modeIntervals ModeQuality
HarmMin    = [Int
0,Int
2,Int
3,Int
5,Int
7,Int
8,Int
11]
modeIntervals ModeQuality
LocNat6    = [Int
0,Int
1,Int
3,Int
5,Int
6,Int
9,Int
10]
modeIntervals ModeQuality
IonS5      = [Int
0,Int
2,Int
4,Int
5,Int
8,Int
9,Int
11]
modeIntervals ModeQuality
DorS4      = [Int
0,Int
2,Int
3,Int
6,Int
7,Int
9,Int
10]
modeIntervals ModeQuality
PhryNat3   = [Int
0,Int
1,Int
4,Int
5,Int
7,Int
8,Int
10]
modeIntervals ModeQuality
LydS2      = [Int
0,Int
3,Int
4,Int
6,Int
7,Int
9,Int
11]
modeIntervals ModeQuality
AltBb7     = [Int
0,Int
1,Int
3,Int
4,Int
6,Int
8,Int
9]
-- Harmonic major
modeIntervals ModeQuality
HarmMaj    = [Int
0,Int
2,Int
4,Int
5,Int
7,Int
8,Int
11]
modeIntervals ModeQuality
DorB5      = [Int
0,Int
2,Int
3,Int
5,Int
6,Int
9,Int
10]
modeIntervals ModeQuality
PhryB4     = [Int
0,Int
1,Int
3,Int
4,Int
7,Int
8,Int
10]
modeIntervals ModeQuality
LydB3      = [Int
0,Int
2,Int
3,Int
6,Int
7,Int
9,Int
11]
modeIntervals ModeQuality
MixoB2     = [Int
0,Int
1,Int
4,Int
5,Int
7,Int
9,Int
10]
modeIntervals ModeQuality
LydAugS2   = [Int
0,Int
3,Int
4,Int
6,Int
8,Int
9,Int
11]
modeIntervals ModeQuality
LocBb7     = [Int
0,Int
1,Int
3,Int
5,Int
6,Int
8,Int
9]

allModeQualities :: [ModeQuality]
allModeQualities :: [ModeQuality]
allModeQualities = [ModeQuality
forall a. Bounded a => a
minBound .. ModeQuality
forall a. Bounded a => a
maxBound]

-- |A mode is a quality rooted at a pitch class.
data Mode = Mode
  { Mode -> ModeQuality
modeQuality :: ModeQuality
  , Mode -> PitchClass
modeRoot    :: PitchClass
  } deriving (Mode -> Mode -> Bool
(Mode -> Mode -> Bool) -> (Mode -> Mode -> Bool) -> Eq Mode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
/= :: Mode -> Mode -> Bool
Eq, Eq Mode
Eq Mode =>
(Mode -> Mode -> Ordering)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Mode)
-> (Mode -> Mode -> Mode)
-> Ord Mode
Mode -> Mode -> Bool
Mode -> Mode -> Ordering
Mode -> Mode -> Mode
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 :: Mode -> Mode -> Ordering
compare :: Mode -> Mode -> Ordering
$c< :: Mode -> Mode -> Bool
< :: Mode -> Mode -> Bool
$c<= :: Mode -> Mode -> Bool
<= :: Mode -> Mode -> Bool
$c> :: Mode -> Mode -> Bool
> :: Mode -> Mode -> Bool
$c>= :: Mode -> Mode -> Bool
>= :: Mode -> Mode -> Bool
$cmax :: Mode -> Mode -> Mode
max :: Mode -> Mode -> Mode
$cmin :: Mode -> Mode -> Mode
min :: Mode -> Mode -> Mode
Ord, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mode -> ShowS
showsPrec :: Int -> Mode -> ShowS
$cshow :: Mode -> String
show :: Mode -> String
$cshowList :: [Mode] -> ShowS
showList :: [Mode] -> ShowS
Show)

-- |Concrete chroma of a rooted mode.
modeChroma :: Mode -> [PitchClass]
modeChroma :: Mode -> [PitchClass]
modeChroma (Mode ModeQuality
q (P Int
r)) =
  [PitchClass] -> [PitchClass]
forall a. Ord a => [a] -> [a]
sort [ Int -> PitchClass
mkPitchClass (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r) | Int
i <- ModeQuality -> [Int]
modeIntervals ModeQuality
q ]

-- |Identify a 7-PC set as a mode by trying each element as root
-- and pattern-matching against the 28 templates.
classifyMode :: [PitchClass] -> Maybe Mode
classifyMode :: [PitchClass] -> Maybe Mode
classifyMode [PitchClass]
pcs
  | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
uniq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
7 = Maybe Mode
forall a. Maybe a
Nothing
  | Bool
otherwise = [Mode] -> Maybe Mode
forall a. [a] -> Maybe a
listToMaybe ([Mode] -> Maybe Mode) -> [Mode] -> Maybe Mode
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe Mode) -> [Int] -> [Mode]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Int -> Maybe Mode
tryRoot [Int]
uniq
  where
    uniq :: [Int]
uniq = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
unPitchClass [PitchClass]
pcs
    tryRoot :: Int -> Maybe Mode
tryRoot Int
r =
      let shifted :: [Int]
shifted = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [ (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
p <- [Int]
uniq ]
      in (ModeQuality -> Mode) -> Maybe ModeQuality -> Maybe Mode
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ModeQuality
q -> ModeQuality -> PitchClass -> Mode
Mode ModeQuality
q (Int -> PitchClass
P Int
r)) ((ModeQuality -> Bool) -> [ModeQuality] -> Maybe ModeQuality
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ModeQuality
q -> ModeQuality -> [Int]
modeIntervals ModeQuality
q [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
shifted) [ModeQuality]
allModeQualities)

-- |Pinned-root classifier: identify a 7-PC set as a mode rooted on the
-- given pitch class, exhaustively checking the 28 mode quality patterns.
-- Mirrors legacy @toMode@ semantics (root explicit, not inferred).
-- Returns 'Nothing' when the set isn't 7 unique PCs or when no quality
-- matches the shifted interval pattern.
classifyModeAt :: Int -> [PitchClass] -> Maybe Mode
classifyModeAt :: Int -> [PitchClass] -> Maybe Mode
classifyModeAt Int
rootPC [PitchClass]
pcs
  | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
uniq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
7 = Maybe Mode
forall a. Maybe a
Nothing
  | Bool
otherwise =
      let shifted :: [Int]
shifted = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [ (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]
uniq ]
      in (ModeQuality -> Mode) -> Maybe ModeQuality -> Maybe Mode
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ModeQuality
q -> ModeQuality -> PitchClass -> Mode
Mode ModeQuality
q (Int -> PitchClass
P (Int
rootPC Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)))
              ((ModeQuality -> Bool) -> [ModeQuality] -> Maybe ModeQuality
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ModeQuality
q -> ModeQuality -> [Int]
modeIntervals ModeQuality
q [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
shifted) [ModeQuality]
allModeQualities)
  where
    uniq :: [Int]
uniq = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
unPitchClass [PitchClass]
pcs

-------------------------------------------------------------------------------
-- Scale families (parent-key partition of the 28-mode taxonomy)
-------------------------------------------------------------------------------

-- |Each of the 28 'ModeQuality' constructors belongs to exactly one of four
-- parent scale families.
data ScaleFamily = Major | MelodicMinor | HarmonicMinor | HarmonicMajor
  deriving (ScaleFamily -> ScaleFamily -> Bool
(ScaleFamily -> ScaleFamily -> Bool)
-> (ScaleFamily -> ScaleFamily -> Bool) -> Eq ScaleFamily
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScaleFamily -> ScaleFamily -> Bool
== :: ScaleFamily -> ScaleFamily -> Bool
$c/= :: ScaleFamily -> ScaleFamily -> Bool
/= :: ScaleFamily -> ScaleFamily -> Bool
Eq, Eq ScaleFamily
Eq ScaleFamily =>
(ScaleFamily -> ScaleFamily -> Ordering)
-> (ScaleFamily -> ScaleFamily -> Bool)
-> (ScaleFamily -> ScaleFamily -> Bool)
-> (ScaleFamily -> ScaleFamily -> Bool)
-> (ScaleFamily -> ScaleFamily -> Bool)
-> (ScaleFamily -> ScaleFamily -> ScaleFamily)
-> (ScaleFamily -> ScaleFamily -> ScaleFamily)
-> Ord ScaleFamily
ScaleFamily -> ScaleFamily -> Bool
ScaleFamily -> ScaleFamily -> Ordering
ScaleFamily -> ScaleFamily -> ScaleFamily
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 :: ScaleFamily -> ScaleFamily -> Ordering
compare :: ScaleFamily -> ScaleFamily -> Ordering
$c< :: ScaleFamily -> ScaleFamily -> Bool
< :: ScaleFamily -> ScaleFamily -> Bool
$c<= :: ScaleFamily -> ScaleFamily -> Bool
<= :: ScaleFamily -> ScaleFamily -> Bool
$c> :: ScaleFamily -> ScaleFamily -> Bool
> :: ScaleFamily -> ScaleFamily -> Bool
$c>= :: ScaleFamily -> ScaleFamily -> Bool
>= :: ScaleFamily -> ScaleFamily -> Bool
$cmax :: ScaleFamily -> ScaleFamily -> ScaleFamily
max :: ScaleFamily -> ScaleFamily -> ScaleFamily
$cmin :: ScaleFamily -> ScaleFamily -> ScaleFamily
min :: ScaleFamily -> ScaleFamily -> ScaleFamily
Ord, Int -> ScaleFamily -> ShowS
[ScaleFamily] -> ShowS
ScaleFamily -> String
(Int -> ScaleFamily -> ShowS)
-> (ScaleFamily -> String)
-> ([ScaleFamily] -> ShowS)
-> Show ScaleFamily
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScaleFamily -> ShowS
showsPrec :: Int -> ScaleFamily -> ShowS
$cshow :: ScaleFamily -> String
show :: ScaleFamily -> String
$cshowList :: [ScaleFamily] -> ShowS
showList :: [ScaleFamily] -> ShowS
Show, ReadPrec [ScaleFamily]
ReadPrec ScaleFamily
Int -> ReadS ScaleFamily
ReadS [ScaleFamily]
(Int -> ReadS ScaleFamily)
-> ReadS [ScaleFamily]
-> ReadPrec ScaleFamily
-> ReadPrec [ScaleFamily]
-> Read ScaleFamily
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ScaleFamily
readsPrec :: Int -> ReadS ScaleFamily
$creadList :: ReadS [ScaleFamily]
readList :: ReadS [ScaleFamily]
$creadPrec :: ReadPrec ScaleFamily
readPrec :: ReadPrec ScaleFamily
$creadListPrec :: ReadPrec [ScaleFamily]
readListPrec :: ReadPrec [ScaleFamily]
Read, Int -> ScaleFamily
ScaleFamily -> Int
ScaleFamily -> [ScaleFamily]
ScaleFamily -> ScaleFamily
ScaleFamily -> ScaleFamily -> [ScaleFamily]
ScaleFamily -> ScaleFamily -> ScaleFamily -> [ScaleFamily]
(ScaleFamily -> ScaleFamily)
-> (ScaleFamily -> ScaleFamily)
-> (Int -> ScaleFamily)
-> (ScaleFamily -> Int)
-> (ScaleFamily -> [ScaleFamily])
-> (ScaleFamily -> ScaleFamily -> [ScaleFamily])
-> (ScaleFamily -> ScaleFamily -> [ScaleFamily])
-> (ScaleFamily -> ScaleFamily -> ScaleFamily -> [ScaleFamily])
-> Enum ScaleFamily
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 :: ScaleFamily -> ScaleFamily
succ :: ScaleFamily -> ScaleFamily
$cpred :: ScaleFamily -> ScaleFamily
pred :: ScaleFamily -> ScaleFamily
$ctoEnum :: Int -> ScaleFamily
toEnum :: Int -> ScaleFamily
$cfromEnum :: ScaleFamily -> Int
fromEnum :: ScaleFamily -> Int
$cenumFrom :: ScaleFamily -> [ScaleFamily]
enumFrom :: ScaleFamily -> [ScaleFamily]
$cenumFromThen :: ScaleFamily -> ScaleFamily -> [ScaleFamily]
enumFromThen :: ScaleFamily -> ScaleFamily -> [ScaleFamily]
$cenumFromTo :: ScaleFamily -> ScaleFamily -> [ScaleFamily]
enumFromTo :: ScaleFamily -> ScaleFamily -> [ScaleFamily]
$cenumFromThenTo :: ScaleFamily -> ScaleFamily -> ScaleFamily -> [ScaleFamily]
enumFromThenTo :: ScaleFamily -> ScaleFamily -> ScaleFamily -> [ScaleFamily]
Enum, ScaleFamily
ScaleFamily -> ScaleFamily -> Bounded ScaleFamily
forall a. a -> a -> Bounded a
$cminBound :: ScaleFamily
minBound :: ScaleFamily
$cmaxBound :: ScaleFamily
maxBound :: ScaleFamily
Bounded)

-- |Map a 'ModeQuality' to its parent scale family.
modeFamily :: ModeQuality -> ScaleFamily
modeFamily :: ModeQuality -> ScaleFamily
modeFamily ModeQuality
q
  | ModeQuality
q ModeQuality -> [ModeQuality] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModeQuality
Ionian, ModeQuality
Dorian, ModeQuality
Phrygian, ModeQuality
Lydian, ModeQuality
Mixolydian, ModeQuality
Aeolian, ModeQuality
Locrian] = ScaleFamily
Major
  | ModeQuality
q ModeQuality -> [ModeQuality] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModeQuality
MelMin, ModeQuality
DorB2, ModeQuality
LydS5, ModeQuality
LydDom, ModeQuality
MixoB6, ModeQuality
LocNat2, ModeQuality
AltDom]          = ScaleFamily
MelodicMinor
  | ModeQuality
q ModeQuality -> [ModeQuality] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModeQuality
HarmMin, ModeQuality
LocNat6, ModeQuality
IonS5, ModeQuality
DorS4, ModeQuality
PhryNat3, ModeQuality
LydS2, ModeQuality
AltBb7]        = ScaleFamily
HarmonicMinor
  | Bool
otherwise                                                                  = ScaleFamily
HarmonicMajor

-- |Semitone offset of each mode's tonic from its parent scale's root.
-- E.g. Aeolian sits on the 6th degree of major → 9 semitones above the
-- parent root → @modeDegree Aeolian = 9@.
modeDegree :: ModeQuality -> Int
-- Major
modeDegree :: ModeQuality -> Int
modeDegree ModeQuality
Ionian     = Int
0
modeDegree ModeQuality
Dorian     = Int
2
modeDegree ModeQuality
Phrygian   = Int
4
modeDegree ModeQuality
Lydian     = Int
5
modeDegree ModeQuality
Mixolydian = Int
7
modeDegree ModeQuality
Aeolian    = Int
9
modeDegree ModeQuality
Locrian    = Int
11
-- Melodic minor
modeDegree ModeQuality
MelMin     = Int
0
modeDegree ModeQuality
DorB2      = Int
2
modeDegree ModeQuality
LydS5      = Int
3
modeDegree ModeQuality
LydDom     = Int
5
modeDegree ModeQuality
MixoB6     = Int
7
modeDegree ModeQuality
LocNat2    = Int
9
modeDegree ModeQuality
AltDom     = Int
11
-- Harmonic minor
modeDegree ModeQuality
HarmMin    = Int
0
modeDegree ModeQuality
LocNat6    = Int
2
modeDegree ModeQuality
IonS5      = Int
3
modeDegree ModeQuality
DorS4      = Int
5
modeDegree ModeQuality
PhryNat3   = Int
7
modeDegree ModeQuality
LydS2      = Int
8
modeDegree ModeQuality
AltBb7     = Int
11
-- Harmonic major
modeDegree ModeQuality
HarmMaj    = Int
0
modeDegree ModeQuality
DorB5      = Int
2
modeDegree ModeQuality
PhryB4     = Int
4
modeDegree ModeQuality
LydB3      = Int
5
modeDegree ModeQuality
MixoB2     = Int
7
modeDegree ModeQuality
LydAugS2   = Int
8
modeDegree ModeQuality
LocBb7     = Int
11

-- |Parent (root pitch class, family) for any mode. E.g.
-- @parentKey (Mode Aeolian (P 1)) == (P 4, Major)@ — C# Aeolian is a mode
-- of E Major.
parentKey :: Mode -> (PitchClass, ScaleFamily)
parentKey :: Mode -> (PitchClass, ScaleFamily)
parentKey (Mode ModeQuality
q (P Int
r)) =
  (Int -> PitchClass
mkPitchClass ((Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- ModeQuality -> Int
modeDegree ModeQuality
q) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12), ModeQuality -> ScaleFamily
modeFamily ModeQuality
q)

-- |Render a scale family as a human-readable string.
showScaleFamily :: ScaleFamily -> String
showScaleFamily :: ScaleFamily -> String
showScaleFamily ScaleFamily
Major          = String
"Major"
showScaleFamily ScaleFamily
MelodicMinor   = String
"Melodic Minor"
showScaleFamily ScaleFamily
HarmonicMinor  = String
"Harmonic Minor"
showScaleFamily ScaleFamily
HarmonicMajor  = String
"Harmonic Major"

-- |Legacy @toMode@ mode-quality strings from
-- @theHarmonicAlgorithmLegacy\/src\/MusicData.hs@. Preferred over the
-- derived 'Show' (which yields compact constructor names like
-- "IonS5") for musician-facing diagnostic output.
showModeQuality :: ModeQuality -> String
-- Major modes
showModeQuality :: ModeQuality -> String
showModeQuality ModeQuality
Ionian     = String
"Ionian"
showModeQuality ModeQuality
Dorian     = String
"Dorian"
showModeQuality ModeQuality
Phrygian   = String
"Phrygian"
showModeQuality ModeQuality
Lydian     = String
"Lydian"
showModeQuality ModeQuality
Mixolydian = String
"Mixolydian"
showModeQuality ModeQuality
Aeolian    = String
"Aeolian"
showModeQuality ModeQuality
Locrian    = String
"Locrian"
-- Melodic minor modes
showModeQuality ModeQuality
MelMin     = String
"Mel_Min"
showModeQuality ModeQuality
DorB2      = String
"Dor_b2"
showModeQuality ModeQuality
LydS5      = String
"Lyd_#5"
showModeQuality ModeQuality
LydDom     = String
"Lyd_Dom"
showModeQuality ModeQuality
MixoB6     = String
"Mixo_b6"
showModeQuality ModeQuality
LocNat2    = String
"Loc_nat.2"
showModeQuality ModeQuality
AltDom     = String
"Alt_Dom"
-- Harmonic minor modes
showModeQuality ModeQuality
HarmMin    = String
"Harm_Min"
showModeQuality ModeQuality
LocNat6    = String
"Loc_nat.6"
showModeQuality ModeQuality
IonS5      = String
"Ion_#5"
showModeQuality ModeQuality
DorS4      = String
"Dor_#4"
showModeQuality ModeQuality
PhryNat3   = String
"Phry_nat.3"
showModeQuality ModeQuality
LydS2      = String
"Lyd_#2"
showModeQuality ModeQuality
AltBb7     = String
"Alt_bb7"
-- Harmonic major modes
showModeQuality ModeQuality
HarmMaj    = String
"Harm_Maj"
showModeQuality ModeQuality
DorB5      = String
"Dor_b5"
showModeQuality ModeQuality
PhryB4     = String
"Phry_b4"
showModeQuality ModeQuality
LydB3      = String
"Lyd_b3"
showModeQuality ModeQuality
MixoB2     = String
"Mixo_b2"
showModeQuality ModeQuality
LydAugS2   = String
"Lyd_Aug_#2"
showModeQuality ModeQuality
LocBb7     = String
"Loc_bb7"

-- |Result of a triad-anchored mode classification. 'ModeOk' carries a
-- normally classified mode; 'ModeInvalid' carries the offending
-- pair-union pitch classes when the union doesn't have exactly 7 unique
-- PCs (only reachable under 'Harmonic.Framework.Builder.absStrata' overrides that violate
-- tristrata adjacency).
data ModeResult
  = ModeOk Mode
  | ModeInvalid [PitchClass]
  deriving (ModeResult -> ModeResult -> Bool
(ModeResult -> ModeResult -> Bool)
-> (ModeResult -> ModeResult -> Bool) -> Eq ModeResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ModeResult -> ModeResult -> Bool
== :: ModeResult -> ModeResult -> Bool
$c/= :: ModeResult -> ModeResult -> Bool
/= :: ModeResult -> ModeResult -> Bool
Eq, Int -> ModeResult -> ShowS
[ModeResult] -> ShowS
ModeResult -> String
(Int -> ModeResult -> ShowS)
-> (ModeResult -> String)
-> ([ModeResult] -> ShowS)
-> Show ModeResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ModeResult -> ShowS
showsPrec :: Int -> ModeResult -> ShowS
$cshow :: ModeResult -> String
show :: ModeResult -> String
$cshowList :: [ModeResult] -> ShowS
showList :: [ModeResult] -> ShowS
Show)

-------------------------------------------------------------------------------
-- Strata
-------------------------------------------------------------------------------

-- |The eleven canonical strata labels (Roman I–XI).
data StrataLabel
  = I | II | III | IV | V | VI | VII | VIII | IX | X | XI
  deriving (StrataLabel -> StrataLabel -> Bool
(StrataLabel -> StrataLabel -> Bool)
-> (StrataLabel -> StrataLabel -> Bool) -> Eq StrataLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StrataLabel -> StrataLabel -> Bool
== :: StrataLabel -> StrataLabel -> Bool
$c/= :: StrataLabel -> StrataLabel -> Bool
/= :: StrataLabel -> StrataLabel -> Bool
Eq, Eq StrataLabel
Eq StrataLabel =>
(StrataLabel -> StrataLabel -> Ordering)
-> (StrataLabel -> StrataLabel -> Bool)
-> (StrataLabel -> StrataLabel -> Bool)
-> (StrataLabel -> StrataLabel -> Bool)
-> (StrataLabel -> StrataLabel -> Bool)
-> (StrataLabel -> StrataLabel -> StrataLabel)
-> (StrataLabel -> StrataLabel -> StrataLabel)
-> Ord StrataLabel
StrataLabel -> StrataLabel -> Bool
StrataLabel -> StrataLabel -> Ordering
StrataLabel -> StrataLabel -> StrataLabel
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 :: StrataLabel -> StrataLabel -> Ordering
compare :: StrataLabel -> StrataLabel -> Ordering
$c< :: StrataLabel -> StrataLabel -> Bool
< :: StrataLabel -> StrataLabel -> Bool
$c<= :: StrataLabel -> StrataLabel -> Bool
<= :: StrataLabel -> StrataLabel -> Bool
$c> :: StrataLabel -> StrataLabel -> Bool
> :: StrataLabel -> StrataLabel -> Bool
$c>= :: StrataLabel -> StrataLabel -> Bool
>= :: StrataLabel -> StrataLabel -> Bool
$cmax :: StrataLabel -> StrataLabel -> StrataLabel
max :: StrataLabel -> StrataLabel -> StrataLabel
$cmin :: StrataLabel -> StrataLabel -> StrataLabel
min :: StrataLabel -> StrataLabel -> StrataLabel
Ord, Int -> StrataLabel -> ShowS
[StrataLabel] -> ShowS
StrataLabel -> String
(Int -> StrataLabel -> ShowS)
-> (StrataLabel -> String)
-> ([StrataLabel] -> ShowS)
-> Show StrataLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StrataLabel -> ShowS
showsPrec :: Int -> StrataLabel -> ShowS
$cshow :: StrataLabel -> String
show :: StrataLabel -> String
$cshowList :: [StrataLabel] -> ShowS
showList :: [StrataLabel] -> ShowS
Show, ReadPrec [StrataLabel]
ReadPrec StrataLabel
Int -> ReadS StrataLabel
ReadS [StrataLabel]
(Int -> ReadS StrataLabel)
-> ReadS [StrataLabel]
-> ReadPrec StrataLabel
-> ReadPrec [StrataLabel]
-> Read StrataLabel
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS StrataLabel
readsPrec :: Int -> ReadS StrataLabel
$creadList :: ReadS [StrataLabel]
readList :: ReadS [StrataLabel]
$creadPrec :: ReadPrec StrataLabel
readPrec :: ReadPrec StrataLabel
$creadListPrec :: ReadPrec [StrataLabel]
readListPrec :: ReadPrec [StrataLabel]
Read, Int -> StrataLabel
StrataLabel -> Int
StrataLabel -> [StrataLabel]
StrataLabel -> StrataLabel
StrataLabel -> StrataLabel -> [StrataLabel]
StrataLabel -> StrataLabel -> StrataLabel -> [StrataLabel]
(StrataLabel -> StrataLabel)
-> (StrataLabel -> StrataLabel)
-> (Int -> StrataLabel)
-> (StrataLabel -> Int)
-> (StrataLabel -> [StrataLabel])
-> (StrataLabel -> StrataLabel -> [StrataLabel])
-> (StrataLabel -> StrataLabel -> [StrataLabel])
-> (StrataLabel -> StrataLabel -> StrataLabel -> [StrataLabel])
-> Enum StrataLabel
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 :: StrataLabel -> StrataLabel
succ :: StrataLabel -> StrataLabel
$cpred :: StrataLabel -> StrataLabel
pred :: StrataLabel -> StrataLabel
$ctoEnum :: Int -> StrataLabel
toEnum :: Int -> StrataLabel
$cfromEnum :: StrataLabel -> Int
fromEnum :: StrataLabel -> Int
$cenumFrom :: StrataLabel -> [StrataLabel]
enumFrom :: StrataLabel -> [StrataLabel]
$cenumFromThen :: StrataLabel -> StrataLabel -> [StrataLabel]
enumFromThen :: StrataLabel -> StrataLabel -> [StrataLabel]
$cenumFromTo :: StrataLabel -> StrataLabel -> [StrataLabel]
enumFromTo :: StrataLabel -> StrataLabel -> [StrataLabel]
$cenumFromThenTo :: StrataLabel -> StrataLabel -> StrataLabel -> [StrataLabel]
enumFromThenTo :: StrataLabel -> StrataLabel -> StrataLabel -> [StrataLabel]
Enum, StrataLabel
StrataLabel -> StrataLabel -> Bounded StrataLabel
forall a. a -> a -> Bounded a
$cminBound :: StrataLabel
minBound :: StrataLabel
$cmaxBound :: StrataLabel
maxBound :: StrataLabel
Bounded)

-- |All strata labels in order.
allStrataLabels :: [StrataLabel]
allStrataLabels :: [StrataLabel]
allStrataLabels = [StrataLabel
forall a. Bounded a => a
minBound .. StrataLabel
forall a. Bounded a => a
maxBound]

-- |Chroma (E-minor base) of each strata.
strataChroma :: StrataLabel -> [PitchClass]
strataChroma :: StrataLabel -> [PitchClass]
strataChroma StrataLabel
I    = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
2, Int
4, Int
6, Int
7, Int
11]
strataChroma StrataLabel
II   = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
1, Int
2, Int
4, Int
6, Int
9]
strataChroma StrataLabel
III  = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
1, Int
2, Int
4, Int
6, Int
11]
strataChroma StrataLabel
IV   = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
2, Int
4, Int
6, Int
7, Int
9]
strataChroma StrataLabel
V    = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
1, Int
2, Int
4, Int
7, Int
9]
strataChroma StrataLabel
VI   = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
1, Int
2, Int
4, Int
7, Int
11]
strataChroma StrataLabel
VII  = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
2, Int
4, Int
6, Int
7, Int
10]
strataChroma StrataLabel
VIII = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
1, Int
2, Int
6, Int
7, Int
9]
strataChroma StrataLabel
IX   = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
1, Int
2, Int
6, Int
7, Int
11]
strataChroma StrataLabel
X    = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
1, Int
2, Int
6, Int
7, Int
10]
strataChroma StrataLabel
XI   = (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P [Int
1, Int
4, Int
6, Int
7, Int
10]

-- |Prime-form dissonance of each strata (from the octatripentatonic spec).
strataDissonance :: StrataLabel -> Int
strataDissonance :: StrataLabel -> Int
strataDissonance StrataLabel
I    = Int
47
strataDissonance StrataLabel
II   = Int
46
strataDissonance StrataLabel
III  = Int
53
strataDissonance StrataLabel
IV   = Int
52
strataDissonance StrataLabel
V    = Int
68
strataDissonance StrataLabel
VI   = Int
72
strataDissonance StrataLabel
VII  = Int
71
strataDissonance StrataLabel
VIII = Int
74
strataDissonance StrataLabel
IX   = Int
75
strataDissonance StrataLabel
X    = Int
72
strataDissonance StrataLabel
XI   = Int
91

-------------------------------------------------------------------------------
-- Tristrata
-------------------------------------------------------------------------------

-- |A tristrata is three strata whose pair-unions are diatonic 7-note sets
-- and whose three-way union is the canonical 8-note set @[1,2,4,6,7,9,10,11]@.
data Tristrata = Tristrata
  { Tristrata -> StrataLabel
ts1 :: StrataLabel
  , Tristrata -> StrataLabel
ts2 :: StrataLabel
  , Tristrata -> StrataLabel
ts3 :: StrataLabel
  } deriving (Tristrata -> Tristrata -> Bool
(Tristrata -> Tristrata -> Bool)
-> (Tristrata -> Tristrata -> Bool) -> Eq Tristrata
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tristrata -> Tristrata -> Bool
== :: Tristrata -> Tristrata -> Bool
$c/= :: Tristrata -> Tristrata -> Bool
/= :: Tristrata -> Tristrata -> Bool
Eq, Eq Tristrata
Eq Tristrata =>
(Tristrata -> Tristrata -> Ordering)
-> (Tristrata -> Tristrata -> Bool)
-> (Tristrata -> Tristrata -> Bool)
-> (Tristrata -> Tristrata -> Bool)
-> (Tristrata -> Tristrata -> Bool)
-> (Tristrata -> Tristrata -> Tristrata)
-> (Tristrata -> Tristrata -> Tristrata)
-> Ord Tristrata
Tristrata -> Tristrata -> Bool
Tristrata -> Tristrata -> Ordering
Tristrata -> Tristrata -> Tristrata
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 :: Tristrata -> Tristrata -> Ordering
compare :: Tristrata -> Tristrata -> Ordering
$c< :: Tristrata -> Tristrata -> Bool
< :: Tristrata -> Tristrata -> Bool
$c<= :: Tristrata -> Tristrata -> Bool
<= :: Tristrata -> Tristrata -> Bool
$c> :: Tristrata -> Tristrata -> Bool
> :: Tristrata -> Tristrata -> Bool
$c>= :: Tristrata -> Tristrata -> Bool
>= :: Tristrata -> Tristrata -> Bool
$cmax :: Tristrata -> Tristrata -> Tristrata
max :: Tristrata -> Tristrata -> Tristrata
$cmin :: Tristrata -> Tristrata -> Tristrata
min :: Tristrata -> Tristrata -> Tristrata
Ord, Int -> Tristrata -> ShowS
[Tristrata] -> ShowS
Tristrata -> String
(Int -> Tristrata -> ShowS)
-> (Tristrata -> String)
-> ([Tristrata] -> ShowS)
-> Show Tristrata
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tristrata -> ShowS
showsPrec :: Int -> Tristrata -> ShowS
$cshow :: Tristrata -> String
show :: Tristrata -> String
$cshowList :: [Tristrata] -> ShowS
showList :: [Tristrata] -> ShowS
Show)

-- |Twelve canonical tristrata (records 1..12 of the octatripentatonic corpus).
validTristrata :: [Tristrata]
validTristrata :: [Tristrata]
validTristrata =
  [ StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
I   StrataLabel
V    StrataLabel
X      --  1
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
II  StrataLabel
VI   StrataLabel
X      --  2
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
III StrataLabel
V    StrataLabel
VII    --  3
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
III StrataLabel
V    StrataLabel
X      --  4
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
IV  StrataLabel
VI   StrataLabel
X      --  5
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
I   StrataLabel
V    StrataLabel
XI     --  6
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
II  StrataLabel
VI   StrataLabel
XI     --  7
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
III StrataLabel
V    StrataLabel
XI     --  8
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
V   StrataLabel
VII  StrataLabel
IX     --  9
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
IV  StrataLabel
VI   StrataLabel
XI     -- 10
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
V   StrataLabel
IX   StrataLabel
XI     -- 11
  , StrataLabel -> StrataLabel -> StrataLabel -> Tristrata
Tristrata StrataLabel
VI  StrataLabel
VIII StrataLabel
XI     -- 12
  ]

-- |Index into 'validTristrata' using a 1-based ordinal.
tristrataIndex :: Int -> Tristrata
tristrataIndex :: Int -> Tristrata
tristrataIndex Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Tristrata] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tristrata]
validTristrata =
      String -> Tristrata
forall a. HasCallStack => String -> a
error (String -> Tristrata) -> String -> Tristrata
forall a b. (a -> b) -> a -> b
$ String
"tristrataIndex: out of range 1.." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Tristrata] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tristrata]
validTristrata) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
  | Bool
otherwise = [Tristrata]
validTristrata [Tristrata] -> Int -> Tristrata
forall a. HasCallStack => [a] -> Int -> a
!! (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- |Project a tristrata to its strata at position 1, 2, or 3.
tristrataStrataAt :: Tristrata -> Int -> StrataLabel
tristrataStrataAt :: Tristrata -> Int -> StrataLabel
tristrataStrataAt Tristrata
t Int
1 = Tristrata -> StrataLabel
ts1 Tristrata
t
tristrataStrataAt Tristrata
t Int
2 = Tristrata -> StrataLabel
ts2 Tristrata
t
tristrataStrataAt Tristrata
t Int
3 = Tristrata -> StrataLabel
ts3 Tristrata
t
tristrataStrataAt Tristrata
_ Int
p = String -> StrataLabel
forall a. HasCallStack => String -> a
error (String -> StrataLabel) -> String -> StrataLabel
forall a b. (a -> b) -> a -> b
$ String
"tristrataStrataAt: position must be 1..3, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
p

-- |Sum of prime-form dissonances of the tristrata's three strata.
tristrataDissonance :: Tristrata -> Int
tristrataDissonance :: Tristrata -> Int
tristrataDissonance (Tristrata StrataLabel
a StrataLabel
b StrataLabel
c) =
  StrataLabel -> Int
strataDissonance StrataLabel
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ StrataLabel -> Int
strataDissonance StrataLabel
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ StrataLabel -> Int
strataDissonance StrataLabel
c

-- |All (tristrata, position) pairs that contain a given strata.
tristrataOf :: StrataLabel -> [(Tristrata, Int)]
tristrataOf :: StrataLabel -> [(Tristrata, Int)]
tristrataOf StrataLabel
s =
  [ (Tristrata
t, Int
p)
  | Tristrata
t <- [Tristrata]
validTristrata
  , Int
p <- [Int
1, Int
2, Int
3]
  , Tristrata -> Int -> StrataLabel
tristrataStrataAt Tristrata
t Int
p StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
s
  ]

-- |Classify the three pair-unions of a tristrata as diatonic modes.
-- Returns @(mode(ts1∪ts2), mode(ts1∪ts3), mode(ts2∪ts3))@.
tristrataModes :: Tristrata -> (Maybe Mode, Maybe Mode, Maybe Mode)
tristrataModes :: Tristrata -> (Maybe Mode, Maybe Mode, Maybe Mode)
tristrataModes (Tristrata StrataLabel
a StrataLabel
b StrataLabel
c) =
  let union2 :: StrataLabel -> StrataLabel -> [PitchClass]
union2 StrataLabel
x StrataLabel
y = [PitchClass] -> [PitchClass]
forall a. Ord a => [a] -> [a]
sort ([PitchClass] -> [PitchClass]) -> [PitchClass] -> [PitchClass]
forall a b. (a -> b) -> a -> b
$ [PitchClass] -> [PitchClass]
forall a. Eq a => [a] -> [a]
nub (StrataLabel -> [PitchClass]
strataChroma StrataLabel
x [PitchClass] -> [PitchClass] -> [PitchClass]
forall a. [a] -> [a] -> [a]
++ StrataLabel -> [PitchClass]
strataChroma StrataLabel
y)
  in ( [PitchClass] -> Maybe Mode
classifyMode (StrataLabel -> StrataLabel -> [PitchClass]
union2 StrataLabel
a StrataLabel
b)
     , [PitchClass] -> Maybe Mode
classifyMode (StrataLabel -> StrataLabel -> [PitchClass]
union2 StrataLabel
a StrataLabel
c)
     , [PitchClass] -> Maybe Mode
classifyMode (StrataLabel -> StrataLabel -> [PitchClass]
union2 StrataLabel
b StrataLabel
c)
     )

-------------------------------------------------------------------------------
-- Parsers (string surface for live-coding modifiers)
-------------------------------------------------------------------------------

-- |Strip surrounding brackets, commas, and whitespace from a list literal.
-- Accepts @"5"@, @"1 2 5"@, @"[1 2 5]"@, @"[1,2,5]"@.
stripListLit :: String -> String
stripListLit :: ShowS
stripListLit = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replaceComma ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropBrackets ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trim
  where
    trim :: ShowS
trim = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse
    dropBrackets :: ShowS
dropBrackets (Char
'[':String
rest) = ShowS
forall a. [a] -> [a]
reverse (ShowS
dropBracketEnd (ShowS
forall a. [a] -> [a]
reverse String
rest))
    dropBrackets String
s          = String
s
    dropBracketEnd :: ShowS
dropBracketEnd (Char
']':String
r)  = String
r
    dropBracketEnd String
s        = String
s
    replaceComma :: Char -> Char
replaceComma Char
','        = Char
' '
    replaceComma Char
c          = Char
c

-- |Parse a tristrata allow-list string to a list of 1-based indices.
-- @""@ → empty (meaning "all allowed"); @"5"@ → @[5]@; @"1 2 5"@ → @[1,2,5]@.
parseTristrataList :: String -> [Int]
parseTristrataList :: String -> [Int]
parseTristrataList String
s =
  let toks :: [String]
toks = String -> [String]
words (ShowS
stripListLit String
s)
  in [ Int
n | String
t <- [String]
toks, Just Int
n <- [String -> Maybe Int
readMaybeInt String
t], Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1, Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [Tristrata] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tristrata]
validTristrata ]

-- |Parse a per-bar position sequence (elements ∈ {1,2,3}).
parseRelStrata :: String -> [Int]
parseRelStrata :: String -> [Int]
parseRelStrata String
s =
  let toks :: [String]
toks = String -> [String]
words (ShowS
stripListLit String
s)
  in [ Int
n | String
t <- [String]
toks, Just Int
n <- [String -> Maybe Int
readMaybeInt String
t], Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1, Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3 ]

-- |Parse a per-bar absolute strata sequence. Accepts @"I V X"@ or @"[I V X]"@.
parseAbsStrata :: String -> [StrataLabel]
parseAbsStrata :: String -> [StrataLabel]
parseAbsStrata String
s =
  let toks :: [String]
toks = String -> [String]
words (ShowS
stripListLit String
s)
  in (String -> Maybe StrataLabel) -> [String] -> [StrataLabel]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe StrataLabel
readStrata [String]
toks
  where
    readStrata :: String -> Maybe StrataLabel
readStrata String
t = case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
t of
      String
"I"    -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
I
      String
"II"   -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
II
      String
"III"  -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
III
      String
"IV"   -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
IV
      String
"V"    -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
V
      String
"VI"   -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
VI
      String
"VII"  -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
VII
      String
"VIII" -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
VIII
      String
"IX"   -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
IX
      String
"X"    -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
X
      String
"XI"   -> StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just StrataLabel
XI
      String
_      -> Maybe StrataLabel
forall a. Maybe a
Nothing

-- |Parse an integer, returning Nothing on failure.
readMaybeInt :: String -> Maybe Int
readMaybeInt :: String -> Maybe Int
readMaybeInt String
s = case ReadS Int
forall a. Read a => ReadS a
reads String
s of
  [(Int
n, String
"")] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
  [(Int, String)]
_         -> Maybe Int
forall a. Maybe a
Nothing