Simple Jazz Foreground Algorithms
Donya Quick

Last Modified: 15-Oct-2015

Last updates:
- added support for more modes

> module Kulitta.Foregrounds.JazzFG where
> import Kulitta.PTGG
> import Kulitta.Grammars.MusicGrammars
> import System.Random
> import Kulitta.EuterpeaSpecial
> import Kulitta.ChordSpaces
> import Kulitta.PostProc
> import Data.List
> import Control.Parallel.Strategies 
> import Kulitta.Foregrounds.ClassicalFG 
> import Kulitta.Search
> import Kulitta.Constraints



First, we need to find the modes for Roman numerals interpreted
in a particular key/mode. The type JTriple is actually a synonym 
for TChord, but it is used for clarity to indicate that the pitch 
information represents a mode rather than a chord.

> rotateModes i = drop i allModes ++ (take i allModes)

> majorModes = allModes
> ionianModes = majorModes -- synonym
> dorianModes = rotateModes 1
> phrygianModes = rotateModes 2
> lydianModes = rotateModes 3
> mixolydianModes = rotateModes 4
> minorModes = rotateModes 5
> aoleanModes = minorModes -- synonym
> locrianModes = rotateModes 6

> modeLookup Major = majorModes
> modeLookup Dorian = dorianModes
> modeLookup Phrygian = phrygianModes
> modeLookup Lydian = lydianModes
> modeLookup Mixolydian = mixolydianModes
> modeLookup Minor = minorModes
> modeLookup Locrian = locrianModes

> chordMode :: CType -> Key -> AbsMode
> chordMode ct (k,m) = 
>     let pModes = modeLookup m -- what pattern of modes for each scale degree?
>         ctMode = pModes !! fromEnum ct -- pick the mode for the Roman numeral
>         ck = pModes !! 0 !! fromEnum ct -- pick the pitch offset for the Roman numeral
>     in  t (k+ck) ctMode -- transposition op and convert numeral to modal pitches

> toJTriple :: (Key, Dur, CType) -> (Key, Dur, AbsMode)
> toJTriple (km,d,c) = (km, d, chordMode c km)

============================

> jazzChords :: StdGen -> [(Key, Dur, CType)] -> Constraints -> (StdGen, [(Key, Dur, AbsChord)])
> jazzChords g chords consts = 
>     let [gJ, gOPC, g'] = take 3 $ splitN g
>         jts = map toJTriple chords
>         ms = map (\(a,b,c) -> ([],c)) jts -- get just modes as JChords
>         qJ = modeSpace' alg1Temps -- subset of ModeSpace desired
>         chordsJ = greedyLet (const True) nearFallJ consts (map (eqClass qJ modeEq) ms) gJ -- random walk through qj
>         qOPC = makeRange' alg1Rans // opcEq  -- subset of OPC-space desired
>         es = map (convOPC qOPC bassRoot) chordsJ -- OPC equivalence classes for chords
>         chordsOPC = greedyProg' (const True) nearFall gOPC es -- random walk through OPC-space
>         chordsOPC' = zipWith newP jts chordsOPC -- tag with dur & mode
>     in  (g', chordsOPC')

============================

Algorithm 1: chords and a stochastic bass. Let instantiation only takes 
place at the level of Roman numerals. 

> --            r t f 7    r 2 t f 7	r=root, r=third, f=fifth
> alg1Temps = [[0,2,4,6], [0,1,2,4,6]] 

> --          bass       chords
> alg1Rans = (34,45) : take 4 (repeat (50,64))

> bassRoot (chrd, m) = (minimum chrd `mod` 12) == head (normO m)

> jazzFG1 :: StdGen -> [(Key, Dur, CType)] -> Constraints -> (StdGen, Music Pitch)
> jazzFG1 g chords consts = 
>     let [gJ, gR, gOPC, gB] = take 4 $ splitN g
>         jts = map toJTriple chords
>         ms = map (\(a,b,c) -> ([],c)) jts -- get just modes as JChords
>         qJ = modeSpace' alg1Temps -- subset of ModeSpace desired
>         chordsJ = greedyLet (const True) nearFallJ consts (map (eqClass qJ modeEq) ms) gJ
>                -- greedyProg qJ modeEq (const True) nearFallJ gJ ms -- random walk through qj
>         qOPC = makeRange' alg1Rans // opcEq  -- subset of OPC-space desired
>         es = map (convOPC qOPC bassRoot) chordsJ -- OPC equivalence classes for chords
>         chordsOPC = greedyProg' (const True) nearFall gOPC es -- random walk through OPC-space
>         chordsOPC' = zipWith newP jts chordsOPC -- tag with dur & mode
>         voices = toVoices chordsOPC' -- place in voice format
>         (gRet, bassLine) = stochBass gB $ head voices -- stochastic bassline
>     in  (gRet, instrument AcousticBass bassLine :=: 
>                vsToMusicI (repeat AcousticGrandPiano) (tail voices))

> splitN g = let (g1,g2) = split g in g1 : splitN g2

Direct interface to grammar monad:

> jazzFG1T :: StdGen -> Sentence CType MP -> Constraints -> (StdGen, Music Pitch)
> jazzFG1T g t consts = jazzFG1 g (toChords $ expand [] t) consts

> convOPC :: QSpace AbsChord -> Predicate JChord -> JChord -> EqClass AbsChord
> convOPC q pj (c,m) = filter (\x -> pj (x,m)) $ eqClass q opcEq c

> stochBass :: StdGen -> [TNote] -> (StdGen, Music Pitch)
> stochBass g [] = (g, rest 0)
> stochBass g ((km,d,p):t) = 
>     let (g', pat) = pickPattern g d p
>         (g'', t') = stochBass g' t
>     in  (g'', pat :+: t')

> pickPattern g d p = 
>     let (r,g') = randomR (0,length pats - 1) g
>         f d p = note d (pitch p)
>         pats = [f d p,
>                 if d>=hn then f qn p :+: f (d-qn) p else f d p,
>                 if d>=hn then f (d-en) p :+: f en p else f d p]
>     in  (g', pats !! r)


=============================

Algorithm 2: simple bossa nova

This approach interprets Roman numerals through three separate
chord spaces in order to cut down the task's combinatorics. 

> alg2TempsC = [[0,2,4,6], [1,2,4,6]] -- for chords
> alg2TempsB = [[0,4]] -- for bass
> alg2TempsL = [[0],[2],[4]] -- for lead

> alg2RansB = [(34,49), (34,49)]
> alg2RansC = take 4 $ repeat (50,64)
> alg2RansL = [(65,80)]

> bassRoot2 ([b1,b2], m) = normO [b1,b2] == normO [m !! 0, m!! 4]
> bassRoot2 _ = error "(bassRoot2) Bad arguments."

> alg2FilterC x = sorted x && pianoChord x

> jazzFG2 :: StdGen -> [(Key, Dur, CType)] -> Constraints -> (StdGen, Music (Pitch, Volume))
> jazzFG2 g chords consts = 
>     let gs@[gJC, gJB, gJL, gRC, gRB, gRL, gOPC_C, gOPC_B, gOPC_L, gL] = take 10 $ splitN g
>         jts = map toJTriple chords
>         ms = map (\(a,b,c) -> ([],c)) jts
>         qs@[qJC, qJB, qJL] = map modeSpace' [alg2TempsC, alg2TempsB, alg2TempsL] -- jazz spaces
>         [chordsJ, bassJ, leadJ] = -- random walk for chords
>             zipWith (\q gx -> greedyProg q modeEq (const True) nearFallJ gx ms) qs $
>             take 3 gs 
>         qOPC_C = filter alg2FilterC (makeRange' alg2RansC) // opcEq 
>         qOPC_B = makeRange alg2RansB // opcEq 
>         qOPC_L = makeRange' alg2RansL // opcEq 
>         esC = map (convOPC qOPC_C (const True)) chordsJ -- OPC equivalence classes for chords
>         esB = map (convOPC qOPC_B bassRoot2) bassJ
>         esL = map (convOPC qOPC_L (const True)) leadJ
>         chordsOPC = greedyLet (const True) nearFall consts esC gOPC_C -- random walk through OPC-space
>         bassOPC = greedyLet (noCPL 7) nearFall consts esB gOPC_B -- random walk for bass
>         leadOPC = greedyLet (noCPL 7) nearFall consts esL gOPC_L -- random walk for lead
>         [cc, bc, lc] = map (zipWith newP jts) [chordsOPC, bassOPC, leadOPC] -- tag with dur & mode
>         cm = bossaChords cc
>         bm = bossaBass bc
>         (gRet, lm) = bossaLead gL lc
>     in  (gRet, chord [addVolume 127 $ instrument AcousticBass bm,
>                       addVolume 75 $ instrument AcousticGrandPiano cm, 
>                       addVolume 127 $ instrument Flute lm])

> jazzFG2T :: StdGen -> Sentence CType MP -> Constraints ->  (StdGen, Music (Pitch, Volume))
> jazzFG2T g t consts = jazzFG2 g (toChords $ expand [] t) consts

> bossaBass :: [TChord] -> Music Pitch
> bossaBass [] = rest 0
> bossaBass ((km,d,c@[p1,p2]):t) = 
>     if d > wn then bossaBass ((km,wn,c):(km,d-wn,c):t) else
>     if d == wn then f1 p1 p2 :+: bossaBass t else
>     if d == hn then f2 p1 p2 :+: bossaBass t  else f3 p1 d :+: bossaBass t where
>     f1 b1 b2 = f2 b1 b2 :+: f2 b2 b1
>     f2 b1 b2 = f3 b1 (qn+en) :+: f3 b2 en 
>     f3 b1 d = note d (pitch b1)
> bossaBass _ = error "(bossaBass) Bad input"

> bossaChords :: [TChord] -> Music Pitch
> bossaChords [] = rest 0
> bossaChords ((km,d,c):t) = 
>     if d > wn then bossaChords ((km,wn,c):(km,d-wn,c):t) else 
>     if d==wn then f1 c :+: bossaChords t else f2 d c :+: bossaChords t where
>     f1 c = let c' = f2 en c in rest qn :+: c' :+: rest qn :+: c' :+: rest qn
>     f2 d c = chord $ map (\p -> note d $ pitch p) c

> bossaLead :: StdGen -> [TChord] -> (StdGen, Music Pitch)
> bossaLead g ts = 
>     let ls = take (length ts - 1) (repeat False) ++ [True]
>         v = head $ toVoices ts
>         (g', v') = addFgToVoice jConsts (foreFunsJ defConsts) g v
>     in  (g', vsToMusic [v']) where
>     foreFunsJ c = [(0.5, f1 c), (0.5, f2 c)] :: [(Double, ForeFun)]
>     jConsts = CConstants 2 3 0.3 0.5 0.8 7


======================

Redefinition of nearest neighbor for modal chords:

> nearFallJ ::  EqClass JChord -> StdGen -> JChord -> (StdGen, JChord)
> nearFallJ e g (x,m) = 
>     let ds = map (simpleDist x) (map fst e) :: [Double]
>         y = e !! (head $ findIndices (==minimum ds) ds)
>     in  (g, y)