module Harmonic.Framework.Builder.Strata
( adjacentInTristrata
, allowedNext
, initialPlacement
, modeForTriad
, pickPartner
, positionalPartner
, selectNext
, selectNextSeeded
) where
import Data.List (find, nub, sortBy)
import Data.Ord (comparing)
import Data.Maybe (listToMaybe)
import qualified Harmonic.Rules.Types.Scale as Sc
import Harmonic.Rules.Types.Scale
( StrataLabel, Tristrata(..), Mode(..), ModeQuality(..), ModeResult(..)
, tristrataStrataAt, tristrataOf, tristrataDissonance
, strataDissonance, strataChroma, classifyModeAt
)
import Harmonic.Rules.Types.Pitch (PitchClass(..), mkPitchClass)
positionOf :: Tristrata -> StrataLabel -> Maybe Int
positionOf :: Tristrata -> StrataLabel -> Maybe Int
positionOf Tristrata
t StrataLabel
s
| Tristrata -> StrataLabel
ts1 Tristrata
t StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
s = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
| Tristrata -> StrataLabel
ts2 Tristrata
t StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
s = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2
| Tristrata -> StrataLabel
ts3 Tristrata
t StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
s = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3
| Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
adjacentInTristrata :: Tristrata -> StrataLabel -> [StrataLabel]
adjacentInTristrata :: Tristrata -> StrataLabel -> [StrataLabel]
adjacentInTristrata Tristrata
t StrataLabel
s = case Tristrata -> StrataLabel -> Maybe Int
positionOf Tristrata
t StrataLabel
s of
Maybe Int
Nothing -> []
Just Int
p ->
let positions :: [Int]
positions = [ ((Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
, Int
p
, (Int
p Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
]
in (Int -> StrataLabel) -> [Int] -> [StrataLabel]
forall a b. (a -> b) -> [a] -> [b]
map (Tristrata -> Int -> StrataLabel
tristrataStrataAt Tristrata
t) [Int]
positions
allowedNext :: [Tristrata] -> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
allowedNext :: [Tristrata]
-> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
allowedNext [Tristrata]
allowed (StrataLabel
s, Tristrata
_t) =
[ (StrataLabel
s', Tristrata
t')
| (Tristrata
t', Int
_p') <- StrataLabel -> [(Tristrata, Int)]
tristrataOf StrataLabel
s
, Tristrata
t' Tristrata -> [Tristrata] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tristrata]
allowed
, StrataLabel
s' <- Tristrata -> StrataLabel -> [StrataLabel]
adjacentInTristrata Tristrata
t' StrataLabel
s
]
initialPlacement :: [Tristrata] -> StrataLabel -> (StrataLabel, Tristrata)
initialPlacement :: [Tristrata] -> StrataLabel -> (StrataLabel, Tristrata)
initialPlacement [Tristrata]
allowed StrataLabel
s =
case (Tristrata -> Tristrata -> Ordering) -> [Tristrata] -> [Tristrata]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Tristrata -> Int) -> Tristrata -> Tristrata -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Tristrata -> Int
tristrataDissonance)
[ Tristrata
t | (Tristrata
t, Int
_) <- StrataLabel -> [(Tristrata, Int)]
tristrataOf StrataLabel
s, Tristrata
t Tristrata -> [Tristrata] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tristrata]
allowed ] of
(Tristrata
t:[Tristrata]
_) -> (StrataLabel
s, Tristrata
t)
[] -> case [Tristrata]
allowed of
(Tristrata
t:[Tristrata]
_) -> (StrataLabel
s, Tristrata
t)
[] -> (StrataLabel
s, Int -> Tristrata
Sc.tristrataIndex Int
1)
positionalPartner :: Tristrata -> StrataLabel -> StrataLabel
positionalPartner :: Tristrata -> StrataLabel -> StrataLabel
positionalPartner Tristrata
t StrataLabel
s = case Tristrata -> StrataLabel -> Maybe Int
positionOf Tristrata
t StrataLabel
s of
Just Int
1 -> Tristrata -> StrataLabel
ts2 Tristrata
t
Just Int
2 -> Tristrata -> StrataLabel
ts1 Tristrata
t
Just Int
3 -> Tristrata -> StrataLabel
ts1 Tristrata
t
Maybe Int
_ -> Tristrata -> StrataLabel
ts2 Tristrata
t
pickPartner :: [(StrataLabel, Tristrata)]
-> Int
-> StrataLabel
-> Tristrata
-> StrataLabel
pickPartner :: [(StrataLabel, Tristrata)]
-> Int -> StrataLabel -> Tristrata -> StrataLabel
pickPartner [(StrataLabel, Tristrata)]
barSeq Int
i StrataLabel
sCurr Tristrata
tCurr =
case Maybe StrataLabel
lastDifferent of
Just StrataLabel
sLast -> StrataLabel
sLast
Maybe StrataLabel
Nothing -> case Maybe StrataLabel
firstForwardDifferent of
Just StrataLabel
sNext -> StrataLabel
sNext
Maybe StrataLabel
Nothing -> Tristrata -> StrataLabel -> StrataLabel
positionalPartner Tristrata
tCurr StrataLabel
sCurr
where
lastDifferent :: Maybe StrataLabel
lastDifferent =
[StrataLabel] -> Maybe StrataLabel
forall a. [a] -> Maybe a
listToMaybe
[ StrataLabel
s
| Int
j <- [Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 .. Int
0]
, Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
, let (StrataLabel
s, Tristrata
_) = [(StrataLabel, Tristrata)]
barSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
, StrataLabel
s StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
/= StrataLabel
sCurr
]
firstForwardDifferent :: Maybe StrataLabel
firstForwardDifferent =
[StrataLabel] -> Maybe StrataLabel
forall a. [a] -> Maybe a
listToMaybe
[ StrataLabel
s
| Int
j <- [Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 .. [(StrataLabel, Tristrata)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(StrataLabel, Tristrata)]
barSeq Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
, let (StrataLabel
s, Tristrata
_) = [(StrataLabel, Tristrata)]
barSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
, StrataLabel
s StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
/= StrataLabel
sCurr
]
modeForTriad :: [(StrataLabel, Tristrata)]
-> Int
-> Int
-> ModeResult
modeForTriad :: [(StrataLabel, Tristrata)] -> Int -> Int -> ModeResult
modeForTriad [(StrataLabel, Tristrata)]
barSeq Int
i Int
triadRootPC
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [(StrataLabel, Tristrata)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(StrataLabel, Tristrata)]
barSeq = [PitchClass] -> ModeResult
ModeInvalid []
| Bool
otherwise =
let (StrataLabel
sCurr, Tristrata
tCurr) = [(StrataLabel, Tristrata)]
barSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
partnerStrata :: StrataLabel
partnerStrata = [(StrataLabel, Tristrata)]
-> Int -> StrataLabel -> Tristrata -> StrataLabel
pickPartner [(StrataLabel, Tristrata)]
barSeq Int
i StrataLabel
sCurr Tristrata
tCurr
unionPCs :: [PitchClass]
unionPCs = [PitchClass] -> [PitchClass]
forall a. Eq a => [a] -> [a]
nub (StrataLabel -> [PitchClass]
strataChroma StrataLabel
sCurr [PitchClass] -> [PitchClass] -> [PitchClass]
forall a. [a] -> [a] -> [a]
++ StrataLabel -> [PitchClass]
strataChroma StrataLabel
partnerStrata)
in if [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PitchClass]
unionPCs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
7
then [PitchClass] -> ModeResult
ModeInvalid [PitchClass]
unionPCs
else case Int -> [PitchClass] -> Maybe Mode
classifyModeAt Int
triadRootPC [PitchClass]
unionPCs of
Just Mode
m -> Mode -> ModeResult
ModeOk Mode
m
Maybe Mode
Nothing -> Mode -> ModeResult
ModeOk (ModeQuality -> PitchClass -> Mode
Mode ModeQuality
Aeolian (Int -> PitchClass
mkPitchClass Int
triadRootPC))
selectNext :: (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)]
-> Maybe (StrataLabel, Tristrata)
selectNext :: (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)] -> Maybe (StrataLabel, Tristrata)
selectNext (StrataLabel, Tristrata)
_ [] = Maybe (StrataLabel, Tristrata)
forall a. Maybe a
Nothing
selectNext (StrataLabel
sPrev, Tristrata
tPrev) [(StrataLabel, Tristrata)]
pool =
let sameStrata :: [(StrataLabel, Tristrata)]
sameStrata = ((StrataLabel, Tristrata) -> Bool)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(StrataLabel
s, Tristrata
_) -> StrataLabel
s StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
sPrev) [(StrataLabel, Tristrata)]
pool
sameTristrata :: [(StrataLabel, Tristrata)]
sameTristrata = ((StrataLabel, Tristrata) -> Bool)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(StrataLabel
_, Tristrata
t) -> Tristrata
t Tristrata -> Tristrata -> Bool
forall a. Eq a => a -> a -> Bool
== Tristrata
tPrev) [(StrataLabel, Tristrata)]
pool
byDissonance :: [(StrataLabel, Tristrata)]
byDissonance = ((StrataLabel, Tristrata) -> (StrataLabel, Tristrata) -> Ordering)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((StrataLabel, Tristrata) -> (Int, Int))
-> (StrataLabel, Tristrata) -> (StrataLabel, Tristrata) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (StrataLabel, Tristrata) -> (Int, Int)
keyDiss) [(StrataLabel, Tristrata)]
pool
keyDiss :: (StrataLabel, Tristrata) -> (Int, Int)
keyDiss (StrataLabel
s, Tristrata
t) = (StrataLabel -> Int
strataDissonance StrataLabel
s, Tristrata -> Int
tristrataDissonance Tristrata
t)
in case [(StrataLabel, Tristrata)]
sameStrata of
((StrataLabel, Tristrata)
_:[(StrataLabel, Tristrata)]
_) ->
case ((StrataLabel, Tristrata) -> Bool)
-> [(StrataLabel, Tristrata)] -> Maybe (StrataLabel, Tristrata)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(StrataLabel
_, Tristrata
t) -> Tristrata
t Tristrata -> Tristrata -> Bool
forall a. Eq a => a -> a -> Bool
== Tristrata
tPrev) [(StrataLabel, Tristrata)]
sameStrata of
Just (StrataLabel, Tristrata)
hit -> (StrataLabel, Tristrata) -> Maybe (StrataLabel, Tristrata)
forall a. a -> Maybe a
Just (StrataLabel, Tristrata)
hit
Maybe (StrataLabel, Tristrata)
Nothing -> [(StrataLabel, Tristrata)] -> Maybe (StrataLabel, Tristrata)
forall a. [a] -> Maybe a
listToMaybe (((StrataLabel, Tristrata) -> (StrataLabel, Tristrata) -> Ordering)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((StrataLabel, Tristrata) -> Int)
-> (StrataLabel, Tristrata) -> (StrataLabel, Tristrata) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Tristrata -> Int
tristrataDissonance (Tristrata -> Int)
-> ((StrataLabel, Tristrata) -> Tristrata)
-> (StrataLabel, Tristrata)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrataLabel, Tristrata) -> Tristrata
forall a b. (a, b) -> b
snd)) [(StrataLabel, Tristrata)]
sameStrata)
[] -> case [(StrataLabel, Tristrata)]
sameTristrata of
((StrataLabel, Tristrata)
_:[(StrataLabel, Tristrata)]
_) -> [(StrataLabel, Tristrata)] -> Maybe (StrataLabel, Tristrata)
forall a. [a] -> Maybe a
listToMaybe (((StrataLabel, Tristrata) -> (StrataLabel, Tristrata) -> Ordering)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((StrataLabel, Tristrata) -> (Int, Int))
-> (StrataLabel, Tristrata) -> (StrataLabel, Tristrata) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (StrataLabel, Tristrata) -> (Int, Int)
keyDiss) [(StrataLabel, Tristrata)]
sameTristrata)
[] -> [(StrataLabel, Tristrata)] -> Maybe (StrataLabel, Tristrata)
forall a. [a] -> Maybe a
listToMaybe [(StrataLabel, Tristrata)]
byDissonance
selectNextSeeded :: Int
-> (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)]
-> Maybe (StrataLabel, Tristrata)
selectNextSeeded :: Int
-> (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)]
-> Maybe (StrataLabel, Tristrata)
selectNextSeeded Int
_ (StrataLabel, Tristrata)
_ [] = Maybe (StrataLabel, Tristrata)
forall a. Maybe a
Nothing
selectNextSeeded Int
seed (StrataLabel
sPrev, Tristrata
tPrev) [(StrataLabel, Tristrata)]
pool =
let nonSelf :: [(StrataLabel, Tristrata)]
nonSelf = ((StrataLabel, Tristrata) -> Bool)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(StrataLabel
s, Tristrata
_) -> StrataLabel
s StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
/= StrataLabel
sPrev) [(StrataLabel, Tristrata)]
pool
sameTri :: [(StrataLabel, Tristrata)]
sameTri = ((StrataLabel, Tristrata) -> Bool)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(StrataLabel
_, Tristrata
t) -> Tristrata
t Tristrata -> Tristrata -> Bool
forall a. Eq a => a -> a -> Bool
== Tristrata
tPrev) [(StrataLabel, Tristrata)]
nonSelf
group :: [(StrataLabel, Tristrata)]
group = if Bool -> Bool
not ([(StrataLabel, Tristrata)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(StrataLabel, Tristrata)]
sameTri)
then [(StrataLabel, Tristrata)]
sameTri
else if Bool -> Bool
not ([(StrataLabel, Tristrata)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(StrataLabel, Tristrata)]
nonSelf)
then [(StrataLabel, Tristrata)]
nonSelf
else [(StrataLabel, Tristrata)]
pool
idx :: Int
idx = (Int -> Int
forall a. Num a => a -> a
abs Int
seed) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [(StrataLabel, Tristrata)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(StrataLabel, Tristrata)]
group
in (StrataLabel, Tristrata) -> Maybe (StrataLabel, Tristrata)
forall a. a -> Maybe a
Just ([(StrataLabel, Tristrata)]
group [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! Int
idx)