-- thb (rd)
import Data.List
import qualified Music.Theory.Contour.Polansky_1992 as T {- hmt -}
import qualified Music.Theory.Pitch as T
import Sound.SC3 {- hsc3 -}
import qualified Sound.SC3.Lang.Math as M
import Sound.SC3.Lang.Pattern {- hsc3-lang -}
import Sound.OSC {- hosc -}
-- | Happy birthday
--
-- > nub hb == "hapy birtd"
-- > sort (nub hb) == " abdhiprty"
hb :: String
hb = "happy birthday"
-- | Scale degrees
hb_d :: Num n => [[n]]
hb_d =
[[5,5,6,5,1,7]
,[5,5,6,5,2,1]
,[5,5,5,3,1,7,6]
,[4,4,3,1,2,1]]
-- | Octaves
hb_o :: Num n => [[n]]
hb_o =
[[3,3,3,3,4,3]
,[3,3,3,3,4,4]
,[3,3,4,4,4,3,3]
,[4,4,4,4,4,4]]
-- | Durations
hb_t :: Num n => [[n]]
hb_t =
[[3,1,4,4,4,8]
,[3,1,4,4,4,8]
,[3,1,4,4,4,4,4]
,[3,1,4,4,4,4]]
-- | Test typing
--
-- > withSC3 plain
plain :: Transport m => m ()
plain = do
_ <- async (d_recv defaultSynthdef)
let p :: [[Double]] -> P Field
p = toP . map realToFrac . concat
play (pbind [(K_degree,p hb_d - 1)
,(K_octave,p hb_o + 1)
,(K_dur,p hb_t / 16)])
-- | Pitch classes
--
-- > tail hb_k == [[7,7,9,7,2,0],[7,7,7,4,0,11,9],[5,5,4,0,2,0]]
hb_k :: Integral n => [[n]]
hb_k =
let f = floor . M.degreeToKey [0,2,4,5,7,9,11] 12 . pred
in map (map f) (hb_d :: [[Double]])
-- | Midi note numbers
--
-- > tail hb_m == [[55,55,57,55,62,60],[55,55,67,64,60,59,57],[65,65,64,60,62,60]]
hb_m :: [[Integer]]
hb_m = zipWith (\p q -> map T.octpc_to_midi (zip p q)) hb_o hb_k
-- | Transposition predicate.
is_trs :: (Eq a,Num a) => [a] -> [a] -> Bool
is_trs p q = T.all_equal (zipWith (-) p q)
-- | 'Enum' transposition predicate.
--
-- > e_is_trs "abc" "bcd" == True
e_is_trs :: Enum a => [a] -> [a] -> Bool
e_is_trs p q = is_trs (map fromEnum p) (map fromEnum q)
-- | Delete transpositions
--
-- > del_trs ["abc","bcd","bca"] == ["abc","bca"]
del_trs :: Enum a => [[a]] -> [[a]]
del_trs = nubBy e_is_trs
-- | All /n/ element combinations from /x/, degree is 'length' /x/ '^' /n/.
--
-- > all_n_cmb 3 "ab" == ["aaa","aab","aba","abb","baa","bab","bba","bbb"]
-- > length (nub hb) ^ maximum (map length hb_d) == 10000000
all_n_cmb :: Monad m => Int -> m a -> m [a]
all_n_cmb n = sequence . replicate n
-- | All non transpositionally equivalent combinations of elements of
-- list 'hb' that match the contour of /x/.
--
-- > filter ((== 'h') . head) (gen_c [0..5]) == ["hiprty"]
-- > sort (gen_c [0,1]) == [" a"," b"," d"," h"," i"," p"," r"," t"," y","ad","ah","ap","at","ay","bh","bp","br","bt","by","dy","hi","hp","hr","ht","hy","it","pr","pt","py","ty"]
gen_c :: Ord a => [a] -> [String]
gen_c x =
let c = T.contour_description x
p = all_n_cmb (length x) (nub hb)
f q = T.contour_description q == c
in del_trs (filter f p)
-- | Cache of 'map' 'gen_c' 'hb_m'
--
-- > gen_c_hb_m_cache == map gen_c hb_m
-- > map length gen_c_hb_m_cache == [209,209,210,209]
gen_c_hb_m_cache :: [[String]]
gen_c_hb_m_cache =
[["hhphyr","hhphyt","hhphtr","hhihyp","hhihyr","hhihyt","hhihrp","hhihtp","hhihtr","hhrhyt","aahapi","aahayp","aahayi","aahayr","aahayt","aaharp","aahari","aahatp","aahati","aahatr","aapayr","aapayt","aapatr","aabahd","aabaph","aabapi","aabapd","aabayh","aabayp","aabayi","aabayr","aabayt","aabayd","aabaih","aabaid","aabarh","aabarp","aabard","aabath","aabatp","aabati","aabatr","aabatd","aaiayp","aaiayr","aaiayt","aaiarp","aaiatp","aaiatr","aarayt","aadaph","aadapi","aadayh","aadayp","aadayi","aadayr","aadayt","aadaih","aadarh","aadarp","aadari","aadath","aadatp","aadati","aadatr","pprpyt"," h pi"," h yp"," h yi"," h yr"," h yt"," h rp"," h ri"," h tp"," h ti"," h tr"," a hb"," a hd"," a ph"," a pb"," a pi"," a pd"," a yh"," a yp"," a yb"," a yi"," a yr"," a yt"," a yd"," a ih"," a ib"," a id"," a rh"," a rp"," a rb"," a ri"," a rd"," a th"," a tp"," a tb"," a ti"," a tr"," a td"," a db"," p yr"," p yt"," p tr"," b hd"," b ph"," b pi"," b pd"," b yh"," b yp"," b yi"," b yr"," b yt"," b yd"," b ih"," b id"," b rh"," b rp"," b ri"," b rd"," b th"," b tp"," b ti"," b tr"," b td"," i yp"," i yr"," i yt"," i rp"," i tp"," i tr"," r yt"," d ph"," d pi"," d yh"," d yp"," d yi"," d yr"," d yt"," d ih"," d rh"," d rp"," d ri"," d th"," d tp"," d ti"," d tr","bbhbpi","bbhbyp","bbhbyi","bbhbyr","bbhbyt","bbhbrp","bbhbri","bbhbtp","bbhbti","bbhbtr","bbpbyr","bbpbyt","bbpbtr","bbibyp","bbibyr","bbibyt","bbibrp","bbibtp","bbibtr","bbrbyt","bbdbph","bbdbpi","bbdbyh","bbdbyp","bbdbyi","bbdbyr","bbdbyt","bbdbih","bbdbrh","bbdbrp","bbdbri","bbdbth","bbdbtp","bbdbti","bbdbtr","iipiyr","iipiyt","iipitr","iiriyt","ddhdpi","ddhdyp","ddhdyi","ddhdyr","ddhdyt","ddhdrp","ddhdri","ddhdtp","ddhdti","ddhdtr","ddpdyr","ddpdyt","ddpdtr","ddidyp","ddidyr","ddidyt","ddidrp","ddidtp","ddidtr","ddrdyt"]
,["hhphyr","hhphyt","hhphtr","hhihyp","hhihyr","hhihyt","hhihrp","hhihtp","hhihtr","hhrhyt","aahapi","aahayp","aahayi","aahayr","aahayt","aaharp","aahari","aahatp","aahati","aahatr","aapayr","aapayt","aapatr","aabahd","aabaph","aabapi","aabapd","aabayh","aabayp","aabayi","aabayr","aabayt","aabayd","aabaih","aabaid","aabarh","aabarp","aabard","aabath","aabatp","aabati","aabatr","aabatd","aaiayp","aaiayr","aaiayt","aaiarp","aaiatp","aaiatr","aarayt","aadaph","aadapi","aadayh","aadayp","aadayi","aadayr","aadayt","aadaih","aadarh","aadarp","aadari","aadath","aadatp","aadati","aadatr","pprpyt"," h pi"," h yp"," h yi"," h yr"," h yt"," h rp"," h ri"," h tp"," h ti"," h tr"," a hb"," a hd"," a ph"," a pb"," a pi"," a pd"," a yh"," a yp"," a yb"," a yi"," a yr"," a yt"," a yd"," a ih"," a ib"," a id"," a rh"," a rp"," a rb"," a ri"," a rd"," a th"," a tp"," a tb"," a ti"," a tr"," a td"," a db"," p yr"," p yt"," p tr"," b hd"," b ph"," b pi"," b pd"," b yh"," b yp"," b yi"," b yr"," b yt"," b yd"," b ih"," b id"," b rh"," b rp"," b ri"," b rd"," b th"," b tp"," b ti"," b tr"," b td"," i yp"," i yr"," i yt"," i rp"," i tp"," i tr"," r yt"," d ph"," d pi"," d yh"," d yp"," d yi"," d yr"," d yt"," d ih"," d rh"," d rp"," d ri"," d th"," d tp"," d ti"," d tr","bbhbpi","bbhbyp","bbhbyi","bbhbyr","bbhbyt","bbhbrp","bbhbri","bbhbtp","bbhbti","bbhbtr","bbpbyr","bbpbyt","bbpbtr","bbibyp","bbibyr","bbibyt","bbibrp","bbibtp","bbibtr","bbrbyt","bbdbph","bbdbpi","bbdbyh","bbdbyp","bbdbyi","bbdbyr","bbdbyt","bbdbih","bbdbrh","bbdbrp","bbdbri","bbdbth","bbdbtp","bbdbti","bbdbtr","iipiyr","iipiyt","iipitr","iiriyt","ddhdpi","ddhdyp","ddhdyi","ddhdyr","ddhdyt","ddhdrp","ddhdri","ddhdtp","ddhdti","ddhdtr","ddpdyr","ddpdyt","ddpdtr","ddidyp","ddidyr","ddidyt","ddidrp","ddidtp","ddidtr","ddrdyt"]
,["hhytrpi","aapihdb","aayphdb","aaypihb","aaypihd","aaypidb","aayihdb","aayrhdb","aayrphb","aayrphd","aayrpih","aayrpib","aayrpid","aayrpdb","aayrihb","aayrihd","aayridb","aaythdb","aaytphb","aaytphd","aaytpih","aaytpib","aaytpid","aaytpdb","aaytihb","aaytihd","aaytidb","aaytrhb","aaytrhd","aaytrph","aaytrpb","aaytrpi","aaytrpd","aaytrih","aaytrib","aaytrid","aaytrdb","aarphdb","aarpihb","aarpihd","aarpidb","aarihdb","aatphdb","aatpihb","aatpihd","aatpidb","aatihdb","aatrhdb","aatrphb","aatrphd","aatrpih","aatrpib","aatrpid","aatrpdb","aatrihb","aatrihd","aatridb"," phdba"," pihba"," pihda"," pihdb"," pidba"," yhdba"," yphba"," yphda"," yphdb"," ypiha"," ypihb"," ypihd"," ypiba"," ypida"," ypidb"," ypdba"," yihba"," yihda"," yihdb"," yidba"," yrhba"," yrhda"," yrhdb"," yrpha"," yrphb"," yrphd"," yrpba"," yrpih"," yrpia"," yrpib"," yrpid"," yrpda"," yrpdb"," yriha"," yrihb"," yrihd"," yriba"," yrida"," yridb"," yrdba"," ythba"," ythda"," ythdb"," ytpha"," ytphb"," ytphd"," ytpba"," ytpih"," ytpia"," ytpib"," ytpid"," ytpda"," ytpdb"," ytiha"," ytihb"," ytihd"," ytiba"," ytida"," ytidb"," ytrha"," ytrhb"," ytrhd"," ytrph"," ytrpa"," ytrpb"," ytrpi"," ytrpd"," ytrba"," ytrih"," ytria"," ytrib"," ytrid"," ytrda"," ytrdb"," ytdba"," ihdba"," rhdba"," rphba"," rphda"," rphdb"," rpiha"," rpihb"," rpihd"," rpiba"," rpida"," rpidb"," rpdba"," rihba"," rihda"," rihdb"," ridba"," thdba"," tphba"," tphda"," tphdb"," tpiha"," tpihb"," tpihd"," tpiba"," tpida"," tpidb"," tpdba"," tihba"," tihda"," tihdb"," tidba"," trhba"," trhda"," trhdb"," trpha"," trphb"," trphd"," trpba"," trpih"," trpia"," trpib"," trpid"," trpda"," trpdb"," triha"," trihb"," trihd"," triba"," trida"," tridb"," trdba","bbypihd","bbyrphd","bbyrpih","bbyrpid","bbyrihd","bbytphd","bbytpih","bbytpid","bbytihd","bbytrhd","bbytrph","bbytrpi","bbytrpd","bbytrih","bbytrid","bbrpihd","bbtpihd","bbtrphd","bbtrpih","bbtrpid","bbtrihd","ddyrpih","ddytpih","ddytrph","ddytrpi","ddytrih","ddtrpih"]
,["hhb a ","hhdaba","hhd a ","hhd b ","pphaba","pphada","pph a ","pph b ","pph d ","pphbdb","ppb a ","ppiaha","ppiaba","ppiada","ppi h ","ppi a ","ppi b ","ppi d ","ppibhb","ppibdb","ppidhd","ppdaba","ppd a ","ppd b ","yyhaba","yyhada","yyh a ","yyh b ","yyh d ","yyhbdb","yyphih","yypaha","yypaba","yypaia","yypada","yyp h ","yyp a ","yyp b ","yyp i ","yyp d ","yypbhb","yypbib","yypbdb","yypdhd","yypdid","yyb a ","yyiaha","yyiaba","yyiada","yyi h ","yyi a ","yyi b ","yyi d ","yyibhb","yyibdb","yyidhd","yyrhph","yyrhih","yyraha","yyrapa","yyraba","yyraia","yyrada","yyr h ","yyr a ","yyr p ","yyr b ","yyr i ","yyr d ","yyrbhb","yyrbpb","yyrbib","yyrbdb","yyripi","yyrdhd","yyrdpd","yyrdid","yythph","yythih","yythrh","yytaha","yytapa","yytaba","yytaia","yytara","yytada","yytprp","yyt h ","yyt a ","yyt p ","yyt b ","yyt i ","yyt r ","yyt d ","yytbhb","yytbpb","yytbib","yytbrb","yytbdb","yytipi","yytiri","yytdhd","yytdpd","yytdid","yytdrd","yydaba","yyd a ","yyd b ","iihaba","iihada","iih a ","iih b ","iih d ","iihbdb","iib a ","iidaba","iid a ","iid b ","rrhaba","rrhada","rrh a ","rrh b ","rrh d ","rrhbdb","rrphih","rrpaha","rrpaba","rrpaia","rrpada","rrp h ","rrp a ","rrp b ","rrp i ","rrp d ","rrpbhb","rrpbib","rrpbdb","rrpdhd","rrpdid","rrb a ","rriaha","rriada","rri h ","rri a ","rri b ","rri d ","rribhb","rribdb","rridhd","rrdaba","rrd a ","rrd b ","tthaba","tthada","tth a ","tth b ","tth d ","tthbdb","ttphih","ttpaha","ttpaba","ttpaia","ttpada","ttp h ","ttp a ","ttp b ","ttp i ","ttp d ","ttpbhb","ttpbib","ttpbdb","ttpdhd","ttpdid","ttb a ","ttiaha","ttiaba","ttiada","tti h ","tti a ","tti b ","tti d ","ttibhb","ttibdb","ttidhd","ttrhph","ttrhih","ttraha","ttrapa","ttraba","ttraia","ttrada","ttr h ","ttr a ","ttr p ","ttr b ","ttr i ","ttr d ","ttrbhb","ttrbpb","ttrbib","ttrbdb","ttripi","ttrdhd","ttrdpd","ttrdid","ttdaba","ttd a ","ttd b ","ddb a "]]
-- | 'concat' of 'tail' of 'gen_c_hb_m_cache'. The first two phrases
-- of 'hb' have the same contour.
--
-- > gen_c_hb_m_cache !! 0 == gen_c_hb_m_cache !! 1
-- > length gen_c_hb_m_cache' == 209 + 210 + 209
-- > gen_c_hb_m_cache' == nub gen_c_hb_m_cache'
gen_c_hb_m_cache' :: [String]
gen_c_hb_m_cache' = concat (tail gen_c_hb_m_cache)
-- | Multiply enumeration index of /c/ by /n/.
--
-- > map (unc 1) hb == [104,97,112,112,121,32,98,105,114,116,104,100,97,121]
-- > map (unc 1e-2) hb == [1.04,0.97,1.12,1.12,1.21,0.32,0.98,1.05,1.1400000000000001,1.16,1.04,1.0,0.97,1.21]
unc :: (Num a, Enum b) => a -> b -> a
unc n c = fromIntegral (fromEnum c) * n
-- | 'unc' variant for 'hb' such that minima is @0@ and maxima @1@.
--
-- > map hb_md " y" == [0,1]
hb_md :: (Ord a, Fractional a, Enum b) => b -> a
hb_md c =
let i = map (unc 1) hb
l = minimum i
r = maximum i
n = r - l
in (unc 1 c - l) * (1 / n)
-- | /(frequency,amplitude,zero-one)/
type Cim n = (n,n,n)
-- | 'Cim' scaled variants of 'unc'.
--
-- > map cim " y" == [(320.0,1.6e-2,0.0),(1210.0,6.05e-2,1.0)]
cim :: (Fractional t,Ord t,Enum e) => e -> Cim t
cim c =
let i = unc 1e-2 c
in (i * 1e3, i * 5e-2,hb_md c)
-- | 'cim' of 'gen_c_hb_m_cache''.
ph :: [(Double,Double,Double)]
ph = concatMap (map cim) gen_c_hb_m_cache'
-- | Trivial 'impulse' instrument
--
-- > audition ins_s
ins_s :: Synthdef
ins_s =
let f = control IR "freq" 440
l = control IR "loc" 0
a = control IR "amp" 0.1
d = control IR "sustain" 0.1
s = envSine d a
e = envGen AR 1 1 0 1 RemoveSynth s
i = impulse AR f 0
in synthdef "ins" (out 0 (pan2 i l e))
-- | 'audition' 'ph' using pattern library. /blur/ is @legato@.
--
-- > withSC3 (hear 1 (map cim "hiprty"))
-- > withSC3 (hear 9 (map cim hb))
hear :: Transport m => Double -> [Cim Double] -> m ()
hear blur x =
let (f,d,c) = unzip3 x
p = toP . map realToFrac
in play (pbind [(K_instr,psynth ins_s)
,(K_freq,p f)
,(K_dur,p d)
,(K_legato,p (repeat blur))
,(K_amp,p c * 0.1 + 0.1)
,(K_param "loc",p c * 2 - 1)])
main :: IO ()
main = withSC3 (hear 9 ph)
-- Local Variables:
-- truncate-lines:t
-- End: