module Cogito.Ficta where
import Debug.Trace
(trace)
import Data.List
( findIndex
, foldl'
)
import Data.List.Index as I
( imap
, indexed
)
import Data.Function
(on)
import Data.Maybe
( fromJust
, isNothing
, maybe
)
import Aedifico
( Arca (..)
, ArkConfig (..)
, Accid (..)
, AccidType (..)
, Dur (..)
, Tone
, ToneList
, ToneSystem
, Pitch (..)
, Pnum (..)
, System (..)
, VoiceName (..)
)
import Cogito.Musarithmetic
( MusicChorus (..)
, MusicSection (..)
, MusicPhrase (..)
, Note (..)
, toneMollis
, modalFinal
, p7diffMod
, p12diffMod
, pnumAccidEq
)
changeNotePitch :: Note -> Pitch -> Note
changeNotePitch note pitch = Note {
noteSyllable = noteSyllable note,
notePitch = pitch
}
adjustNotePitch :: (Pitch -> Pitch) -> Note -> Note
adjustNotePitch fn note = changeNotePitch note $ fn $ notePitch note
accidentalShift :: Pitch
-> Accid
-> Pitch
accidentalShift pitch direction
| accid pitch == AccidNil
= pitch
| newAccidNum < fromEnum Fl || newAccidNum > fromEnum Sh
= pitch
| otherwise = Pitch {
pnum = pnum pitch,
oct = oct pitch,
dur = dur pitch,
accid = toEnum newAccidNum,
accidType = Suggested
}
where
newAccidNum = operation (fromEnum $ accid pitch) 1
operation = case direction of
Fl -> (-)
Sh -> (+)
flatten :: Pitch -> Pitch
flatten pitch = accidentalShift pitch Fl
sharpen :: Pitch -> Pitch
sharpen pitch = accidentalShift pitch Sh
changeAccid :: Accid -> AccidType -> Pitch -> Pitch
changeAccid newAccid newAccidType p
| accid p == AccidNil = p
| otherwise = Pitch {
pnum = pnum p,
oct = oct p,
dur = dur p,
accid = newAccid,
accidType = newAccidType
}
changeNoteAccid :: Accid -> AccidType -> Note -> Note
changeNoteAccid newAccid newAccidType n = Note {
noteSyllable = noteSyllable n,
notePitch = changeAccid newAccid newAccidType $ notePitch n
}
cancel :: Pitch -> Pitch
cancel = changeAccid Na Suggested
noteCancel :: Note -> Note
noteCancel = adjustNotePitch cancel
fictaAccid :: Pitch -> Pitch
fictaAccid p = changeAccid (accid p) Suggested p
writeAccid :: Pitch -> Pitch
writeAccid p = changeAccid (accid p) Written p
adjustNotesInSection :: ([Note] -> [Note]) -> MusicSection -> MusicSection
adjustNotesInSection fn sec = MusicSection {
secVoiceID = secVoiceID sec,
secConfig = secConfig sec,
secSentences = map (map (adjustNotesInPhrase fn)) $ secSentences sec
}
changeNotesInPhrase :: MusicPhrase -> [Note] -> MusicPhrase
changeNotesInPhrase phrase newNotes = MusicPhrase {
phraseVoiceID = phraseVoiceID phrase,
notes = newNotes
}
adjustNotesInPhrase :: ([Note] -> [Note]) -> MusicPhrase -> MusicPhrase
adjustNotesInPhrase fn phrase = changeNotesInPhrase phrase $ fn $ notes phrase
fixFictaInSection :: ([Note] -> Note -> [Note])
-> MusicSection
-> MusicSection
fixFictaInSection fn = adjustNotesInSection $ foldStack fn
fixFictaInPhrase :: ([Note] -> Note -> [Note])
-> MusicPhrase
-> MusicPhrase
fixFictaInPhrase fn = adjustNotesInPhrase $ foldStack fn
foldStack :: ([a] -> a -> [a])
-> ([a] -> [a])
foldStack fn = reverse . foldl' fn []
adjustPhrasesRelative :: (MusicPhrase -> MusicPhrase -> MusicPhrase)
-> MusicSection
-> MusicSection
-> MusicSection
adjustPhrasesRelative fn lower upper = MusicSection {
secVoiceID = secVoiceID upper,
secConfig = secConfig upper,
secSentences = zipWith (zipWith fn) (secSentences lower) (secSentences upper)
}
findCounterpoint :: MusicPhrase
-> MusicPhrase
-> Int
-> Note
findCounterpoint cptPhrase ptPhrase index =
maybe (error "no counterpoint found") ((!!) cptNotes) cptIndexMatch
where
ptNotes = notes ptPhrase
cptNotes = notes cptPhrase
ptPitches = map notePitch ptNotes
cptPitches = map notePitch cptNotes
ptLengths = map (durQuantity . dur) ptPitches
cptLengths = map (durQuantity . dur) cptPitches
ptIndexElapsed = sum $ take index ptLengths
cptIndexSums = scanl1 (+) cptLengths
cptIndexMatch = findIndex (> ptIndexElapsed) cptIndexSums
durQuantity :: Dur -> Int
durQuantity dur | dur `elem` [Fs, FsR] = 1
| dur `elem` [Sm, SmR] = 2
| dur == SmD = 3
| dur `elem` [Mn, MnR] = 4
| dur == MnD = 6
| dur `elem` [Sb, SbR] = 8
| dur == SbD = 12
| dur `elem` [Br, BrR] = 16
| dur == BrD = 24
| dur `elem` [Lg, LgR] = 32
| dur == LgD = 48
| dur == DurNil = error "can't compute this unset dur"
| otherwise = error $ "unknown dur " ++ show dur
adjustFictaChorus :: ToneSystem -> ToneList -> MusicChorus -> MusicChorus
adjustFictaChorus toneSystems toneList chorus = MusicChorus {
cantus = adjustCantus,
alto = adjustAlto,
tenor = adjustTenor,
bass = adjustBass
}
where
tone = arkTone $ secConfig $ bass chorus
adjust = adjustFictaVoice toneList tone
adjustBass = adjust $ bass chorus
adjustCantus = adjustRelBass toneList tone adjustBass
$ adjust $ cantus chorus
adjustAlto = adjustRelUpper adjustCantus
$ adjustRelBass toneList tone adjustBass
$ adjust $ alto chorus
adjustTenor = adjustRelUpper adjustCantus
$ adjustRelUpper adjustAlto
$ adjustRelBass toneList tone adjustBass
$ adjust $ tenor chorus
adjustFictaVoice :: ToneList -> Tone -> MusicSection -> MusicSection
adjustFictaVoice toneList tone sec = adjust sec
where
voiceID = secVoiceID sec
adjust = case voiceID of
Bass -> repeats . sharpSevens . bassIntervals
_ -> repeats . sharpSevens
repeats = fixFictaInSection fixRepeats
sharpSevens = fixFictaInSection fixSharpSevens
bassIntervals = fixFictaInSection fixIllicitIntervals
fixRepeats :: [Note] -> Note -> [Note]
fixRepeats [] next = [next]
fixRepeats (x:xs) next
| pitchClass x /= pitchClass next = next:x:xs
| (isFictaAccidNote Sh x || isFictaAccidNote Fl x)
&& isFictaAccidNote Na next
= trace "canceled (#/b)-♮" next:(cancelNote x):xs
| isNatural x && isFictaAccidNote Sh next
= trace "raised ♮-#" next:(sharpenNote x):xs
| isNatural x && isFictaAccidNote Fl next
= trace "lowered ♮-b" next:(flattenNote x):xs
| isFictaAccidNote Fl x && isNatural next
= trace "lowered next in b-♮" (flattenNote next):x:xs
| otherwise = next:x:xs
fixSharpSevens :: [Note] -> Note -> [Note]
fixSharpSevens [] next = [next]
fixSharpSevens (x:xs) next
| voiceID == Bass
&& ((isSharpSeven x && isTritoneNote (cancelNote x) next)
|| (isSharpSeven next && isTritoneNote (cancelNote next) x))
= trace "leaving bass #7 to avoid tritone"
next:x:xs
| voiceID == Bass && isSharpSeven x
= trace "canceled this bass #7"
next:(cancelNote x):xs
| voiceID == Bass && isSharpSeven next
= trace "canceled next bass #7"
(cancelNote next):x:xs
| isSharpSeven x && (not . isFinal) next
= trace "canceled non-ascending #7"
next:(cancelNote x):xs
| isFlatSix x && isSharpSeven next
= trace "canceled b6-#7"
next:(cancelNote x):xs
| (noteAccid x == Fl && noteAccid next == Sh)
|| (noteAccid x == Sh && noteAccid next == Fl)
= trace "fixed b-# or #-b"
next:(cancelNote x):xs
| otherwise = next:x:xs
fixIllicitIntervals [] next = [next]
fixIllicitIntervals (x:xs) next
| (isBnatural x || isBflat next) && tritoneNotes next x
= trace "bad bass interval: flatten before"
next:(flattenNote x):xs
| isBflat x && tritoneNotes next x
= trace "bad bass interval: flatten after"
(flattenNote next):x:xs
| isEflat x && (tritoneNotes next x || augFifthNotes next x)
= trace "bad bass interval: cancel before"
next:(cancelNote x):xs
| isEflat next && tritoneNotes next x
= trace "bad bass interval: cancel after"
(cancelNote next):x:xs
| isCsharp x && isThree x && tritoneNotes next x
= trace "bass bass interval: cancel signature C#"
next:(cancelNote x):xs
| isCsharp next && isThree next && tritoneNotes next x
= trace "bass bass interval: cancel signature C#"
(cancelNote next):x:xs
| otherwise = next:x:xs
isSharpSeven n = isSeven n && isFictaAccidNote Sh n
isNaturalSeven n = isSeven n && isFictaAccidNote Na n
isNatural = (== Na) . accid . notePitch
isFlatSix n = isSix n && isFictaAccidNote Fl n
isFinal = (== 1) . degree
isThree = (== 3) . degree
isSix = (== 6) . degree
isSeven = (== 7) . degree
degree = (scaleDegree1 toneList tone) . notePitch
isBflat = checkPnumAccid PCb Fl
isBnatural = checkPnumAccid PCb Na
isEflat = checkPnumAccid PCe Fl
isCsharp = checkPnumAccid PCc Sh
tritoneNotes = isTritone `on` notePitch
augFifthNotes = isAugFifth `on` notePitch
cancelNote = changeNoteAccid Na Suggested
sharpenNote = changeNoteAccid Sh Suggested
flattenNote = changeNoteAccid Fl Suggested
pitchClass :: Note -> Pnum
pitchClass = pnum . notePitch
noteAccid :: Note -> Accid
noteAccid = accid . notePitch
checkPnumAccid :: Pnum -> Accid -> Note -> Bool
checkPnumAccid thisPnum thisAccid n =
pnum p == thisPnum && accid p == thisAccid
where p = notePitch n
adjustRelBass :: ToneList
-> Tone
-> MusicSection
-> MusicSection
-> MusicSection
adjustRelBass toneList tone = adjustPhrasesRelative (adjustFictaPhrase toneList tone)
where
adjustFictaPhrase :: ToneList -> Tone -> MusicPhrase -> MusicPhrase -> MusicPhrase
adjustFictaPhrase toneList tone lower = fixIntervalsInPhrase lower
fixIntervalsInPhrase lowerPhrase thisPhrase =
adjustNotesInPhrase (imap (\i thisNote ->
fixIntervals (findCounterpoint lowerPhrase thisPhrase i) thisNote))
thisPhrase
fixIntervals :: Note
-> Note
-> Note
fixIntervals lowerNote thisNote = adjustNotePitch (adjust $ notePitch lowerNote) thisNote
where
adjust :: Pitch -> Pitch -> Pitch
adjust lowerPitch thisPitch
| isCrossRelation lowerPitch thisPitch
= trace "fixed cross relation"
changeAccid (accid lowerPitch) Suggested thisPitch
| isAugFifth lowerPitch thisPitch
= trace "canceled upper accid to fix augmented fifth"
cancel thisPitch
| isTritone lowerPitch thisPitch
= trace "found tritone against bass:"
tritone lowerPitch thisPitch
| otherwise = thisPitch
tritone lowerPitch thisPitch
| accid lowerPitch == Fl
= trace "flattened upper note against bass flat"
flatten thisPitch
| accid thisPitch == Fl
&& scaleDegree1 toneList tone lowerPitch == 2
= trace "canceled upper b against bass ^2"
cancel thisPitch
| accid thisPitch == Fl
&& isFictaAccid Na lowerPitch
= trace "canceled upper b against canceled bass"
cancel thisPitch
| accid lowerPitch == Sh
= trace "raised upper note against bass #"
sharpen thisPitch
| accid thisPitch == Na
&& pnum thisPitch == PCf
&& pnum lowerPitch == PCb
= trace "raised upper F against bass B"
sharpen thisPitch
| otherwise
= trace "tritone is okay"
thisPitch
adjustRelUpper :: MusicSection
-> MusicSection
-> MusicSection
adjustRelUpper = adjustPhrasesRelative adjustFictaPhrase
where
adjustFictaPhrase :: MusicPhrase -> MusicPhrase -> MusicPhrase
adjustFictaPhrase upper = adjustFictaNotes upper
adjustFictaNotes upper lower =
adjustNotesInPhrase (imap (\i n ->
fixUpperCrossRelations (findCounterpoint upper lower i) n))
lower
fixUpperCrossRelations :: Note
-> Note
-> Note
fixUpperCrossRelations upper lower
| (isCrossRelation `on` notePitch) upper lower
= trace "fixed cross relation in upper voices"
changeNoteAccid (noteAccid upper) Suggested lower
| otherwise = lower
scaleDegree :: ToneList -> Tone -> Pitch -> Int
scaleDegree toneList tone pitch = p7diffMod pitch $ modalFinal toneList tone
scaleDegree1 toneList tone pitch = scaleDegree toneList tone pitch + 1
isFictaAccid :: Accid -> Pitch -> Bool
isFictaAccid a p = accid p == a && accidType p == Suggested
isFictaAccidNote :: Accid -> Note -> Bool
isFictaAccidNote a n = isFictaAccid a $ notePitch n
isCrossRelation:: Pitch -> Pitch -> Bool
isCrossRelation p1 p2 = pnum p1 == pnum p2
&& accid p1 /= accid p2
isAugFifth :: Pitch
-> Pitch
-> Bool
isAugFifth p1 p2 = p12diffMod p2 p1 == 8 && p7diffMod p2 p1 == 4
isTritone :: Pitch -> Pitch -> Bool
isTritone p1 p2 = p12diffMod p2 p1 == 6 && (p7diffMod p2 p1 `elem` [3, 4])
isTritoneNote = isTritone `on` notePitch