Tiny piano – Rondo Alla Turca

hs-golf-turca.hs

import Control.Parallel

main = mapM_ (\(d,s)->(\p->p>>p>>p>>p).putChar.toEnum.round.(+d).(*62).min 2.abs$s+1).zip(dθ 1).lim.rev.hgp 9. render 9e6 (\_->0) . Sequence[]
 $[mT%8.1,t2%16.1,t3(∡7)%8,t4%8,t5%16,t3(∡7)%8,mT%8.1,t2%16.1,t3(tev arp8)%8,cdT%99] >>= \e->[e,e]

mM=Sequence[][2-^8,1-^8,0-^8,1-^8,3-^4]
cM=Sequence[][7-^20,8-^20,9.^4,Sequence[(7,0),(6,1)](map((∡2).(.^4))[6,5,6])%0.75]
cMv=Sequence[][10-^2,8.^4,9.^4,hom(.^4)[[24,5],[23,8,12],[22,4],[21,6,9],[22,3],[19,5,8],[20,4],[18,6,9],[17]]#7&(-14)%2.5,tr 2%0.4,1-^9,2-^12,1-^1]%4.5
 ⋎(Sequence[][6-^4,lp(8.^4∡3)%(3/4),sil%2,lp(5.^4∡3)%h,lp(5.^4∡2)%h,1-^1∡7]&(-14)#7#4%5)
mMa f=Sequence[][(1-3*f).^4,lp(5.^4∡(-2-f))%0.75,mMa f%1.5,mMa(f*2)%h,mMa f%1]#7
mTm=Sequence[][mM%1,mM&2%1,mM#4&4%h,mM&7%h,mM&7%1,8.^4,Sequence[][10.^4]%0.2,cM%1,cM%1,cM%0.85,Sequence[][4.^4∡2,5.^2]#6#4%2]#7
mT=p$Sequence[][mTm%8.1⋎(Sequence[][sil%h,mMa 0%4,mMa 1%2.75,2.^4,(-2)-^2]&(-7)%8)]
m2=Sequence[][Sequence[](map((∡2).(.^4))[1,2,3,3]++[es[6,5,4,3]%h]++[0-^2∡2])%2
 ⋎(Sequence[][sil%h,1.^4,8.^4,3.^4,10.^4,5-^2]⊿1.3&(-14)%2)]
t2=p$Sequence[][m2&2%1.8,0-^5,m2&2%2,m2#7%1.8,(-2)-^5,m2#7%2,mT%3.5,cMv]
m3=Sequence[]$[3-^4,4-^4,5-^2]++map(-^4)[3,4,5,4,3,2,1,2,3,4,2,0]
m3a=Sequence[][(Sequence[][sil%(1/8),lp(8.^4)%1]:zw(\d n->Sequence[][sil%(d/24),n-^1]⊿cos d)[0..][1,3,5],s),m3a%1]
m3ra=(map((%1). \[a,b,c]->es[a,c,b,c,a,c,b,c])[[1,3,5],[1,4,6],[-2,0,5]]!!)
t3 o=Sequence[][Sequence[][o$ḋ[m3%4,m3%2.5,1-^4,4-^4,2-^4,0-^4]&(-2)%7.5,1-^2∡7]%8
 ⋎(ḋ[sil%(3/8),m3a&4%2,m3a%h,m3a#4%h,m3a&1%1,m3a&4%2,m3a%h,m3a&1%(5/8),5-^2]&(-18)%8)]
mQ=es[2,1,0,2]
m4=mM⇆4
i4 e=ḋ[m4⇅11%h,m4⇅9%h,mQ⇆4⇅8%h,Sequence[(5,e),(4,1)][mQ⇅7%h,mQ⇅5%h,m4&5%h,m4&7%h]%2,es[10,9,10,9]#2%h ]
mla[b,c,d]=Sequence[][b-^4,lp(c-^4⋎(d-^4))%1]%1
i4a=ḋ[sil%h,Sequence[](map mla[[1,3,5],[2,4,5],[1,3,5],[0,2,5]])#5%4,Sequence[](map mla[[1,3,5],[2,5,7],[2,6,8]])#4%3,5-^2⋎(7-^2)]
t4=p$Sequence[][ḋ[i4 1%4,i4 0%2.5,Sequence[][mQ⇅6%h,mQ⇅4%h]#4#2%1,3-^2]%8⋎(i4a&(-9)%8)]
mlaa=mla[1,3,5]
m5=Sequence[]$map(-^8)[1..4]
i5=ḋ[m5⇅6%h,m5%h,m5&4%h,m5⇅9%h]
i5d=hom(-^4)[[2],[4,5],[0],[4,5]]%1
i5a=ḋ[sil%h,mlaa,i5d,mlaa,mla[-2,0,4],mlaa,i5d,sq 4[1,-1,-3,-2,-6,1]%2]&(-7)
t5=ḋ[ḋ[i5%2,i5%1.5,Sequence[][8-^4,9-^4]#1%h,i5%2,ḋ[es[5,4,3,2,3,5,1,3,2,4,0,2]%2]%1.5,1-^2]%8⋎(i5a%8)
 ,p(Sequence[][Sequence[][i4 1%4,es[3,2,3,1,4,3,4,3,4,3,4,3]#2#1&7%1.5,m5⇅13%h,mQ⇅8%h,m5&7%(3/8),6-^8,mQ⇅7#5%h,6-^2]%8
 ⋎(Sequence[][i4a%3.5,Sequence[(1,-1),(7,0),(6,1)][hom(-^4)[[-2],[3,5],[2,5],[1,5]]%1]%1,mla[-3,1,4],mla[-3,2,4],hom(-^4)[[-2],[1,3],[-2],[2,4],[1,3]]%1.5]&(-9)%8)])%8]⊿0.8
am d=3-^d∡2∡5
amf=1-^υ∡2⋎(5-^1∡3)
vh v(c,d)=lp(Sequence[][v-^12]:map(\t->Sequence[][t⊿0%0.04,t%d])c,d)
aam=vh 11.am
aar=Sequence[][1-^10,4-^10,6-^1]&4
eam=vh 10.em
dm=6-^1∡2⋎(11-^1)
em d=5-^d∡2⋎(9-^1)
cdM=ḋ[4-^8,3-^8,2.^8,3.^8,cdM%1]
cdT=ḋ[Sequence[][3-^(8/3)∡7,10-^6,am 1,am 1,cdM&7%1,dm,aam 4.05%1,em(4/3),12-^4,am 1,am 1,cdM&7%1,dm,aam 1%1,eam 4%1]%12.5⋎(Sequence[](sil%(11/24) : map((%1).(m3a&))[4,4,4,0,4,1,4,4,4,0,4,1])&(-18)%13.1)
 ,p(Sequence[][Sequence[][Sequence[][8-^2]⊿2%h,aar%(3/8),10-^8,aar%1,aar%1,cdM&7%1,11-^1,vh 11(10-^4)%1,9-^(4/3)]%7⋎(Sequence[](map m3ra[0,0,0,0,1,0,2])&(-7)%7)])%6.75
 ,Sequence[][p(Sequence[][12-^4])%(1/4),am 1,am 1,cdM&7%1,dm,aam 1%1,eam 4%1,amf,Sequence[][3-^4,1-^υ,5-^4,1-^υ,3-^4,1-^4,3-^4,1-^4,5-^4,1-^2]%3.75∡7,Sequence[][amf∡(-14)]%0.56,Sequence[][amf∡(-14)]⊿0.8%1]%12⋎(Sequence[](sil%(1/8):map((%1).(m3a&))[4,4,4,0,4,1,4,4,4]++[m3a&4%h,m3a&4%h,5-^(8/5)])&(-18)%12)]
 


type Volume = Double
type SemitoneShift = Double
type Duration = Double
type Frequency = Double

type DiatonicPitch = Int

type Accidental = (DiatonicPitch, SemitoneShift)
type Accidental'd = DiatonicPitch -> SemitoneShift
type TimeBlock = ([Figure], Duration)

data Figure
  = Note { notePitch :: DiatonicPitch
         , noteVelo :: Volume         }
  | Sequence { accidentals :: [Accidental]
             , theSequence :: [TimeBlock] }

-- | Apply a function to all the sub-sequences, rather than the top sequence as a whole.
(⇸) :: (Figure->Figure) -> Figure->Figure
φ⇸Sequence a fs=Sequence a$map(\(f,d)->(map φ f,d))fs
_⇸Note i d=Note i d

-- | Look up the frequency of the diatonic pitch, which may be subject to semitone shifting via accidentals.
(##) :: DiatonicPitch -> Accidental'd -> Frequency
i##c
 |i<1=(i+7)##c/2
 |i>7=(i-7)##c*2
 |1>0=1.06**(c i+case i of{1->0;4->5;5->7;6->8;7->10;_->fromIntegral i})



type Audio = [Double]


render :: Duration -> Accidental'd -> Figure -> Audio
render dur acc (Note n v) = map (harmExcite . oscillate) [1..dur]
 where harmExcite x = sin $ x + τ x ^ 2 / η
       oscillate i = v * envelope * sin(i*ω)
        where envelope = attack * decay * release
              decay = exp $ -i*η/s
              attack = τ(i*v)
              release = 0.8-τ((i-dur)/90)
       ω = n##acc / 15.5
       η = exp $ fromIntegral n/9
render dur acc(Sequence accm fs)=render' dur (foldr(\(q,m)f i->if q==i then m else f i)acc accm) fs

render' :: Duration -> Accidental'd -> [TimeBlock] -> Audio
render' dur _ _|dur<=0 = []
render' dur _ []=map(\_->0)[1..dur]
render' dur acc((f,dr):fs)|n<-min dr dur=transition(round n)(foldr1(\a b->sum a`par`sum b`pseq`zw(+)a b)(map(render(n+99)acc)f))$render'(dur-dr)acc fs

transition :: Int -> Audio -> Audio -> Audio
transition n a b|(f,ol)<-splitAt n a,(or,l)<-splitAt 99 b=f++zw(+)ol or++l


-- | Apply a sharp-accidental to all notes of the specified pitch in the sequence.
(#) :: Figure -> DiatonicPitch -> Figure
Sequence a fs#q=Sequence((q,1):a)fs


(&), (⇅), (⇆) :: Figure -> Int -> Figure

-- | Transpose the sequence by /n/ (diatonic) steps.
Note i d&n=Note(n+i)d
f&n=(&n)⇸f

-- | Invert the sequence.
Note i d⇅n=Note(n-i)d
f⇅n=(⇅n)⇸f

-- | Retrograde.
Note i d⇆_=Note i d
Sequence a fs⇆n=Sequence a.reverse$take n fs

-- | Adjust the dynamics/volume.
(⊿) :: Figure -> Volume -> Figure
Note i d⊿v=Note i$d*v
f⊿v=(⊿v)⇸f

-- | Play in piano (dynamics).
p=(⊿0.3)


type InverseDuration = Double

(.^), (-^) :: DiatonicPitch -> InverseDuration -> TimeBlock

-- | A simple staccato note of the specified note value.
n.^q=([Sequence[][([Note n 1],s/2/q)]],s/q)

-- | Legato note.
n-^q=([Note n 1],s/q)



-- | Put two time-blocks in parallel / play them simultaneously.
(⋎) :: TimeBlock -> TimeBlock -> TimeBlock
(l,d)⋎(r,_)=(l++r,d)

-- | Add the nth note above as a harmony to all notes in the block.
(∡) :: TimeBlock -> Int -> TimeBlock
(l,d)∡j=(l++map(\h->Sequence[][h⊿0%0.01,h&j%100])l,d)


-- | Cut a sequence to the specified duration.
(%) :: Figure -> Duration -> TimeBlock
f%t=([f],s*t)


tr n=Sequence[]$cycle[n-^15,(n+1)-^20]
ḋ=Sequence$zip[6,3,7][1,1,1]
lp=Sequence[].repeat
sil=Note 0 0
tev f(l,d)=(map f l,d)
h=1/2
υ=4/3
s=4e+4
sq d=Sequence[].map(-^d)
es=sq 8 
arp8 n@(Note i v)=Sequence[][([n,Sequence[][n⊿0%(1/8),n&7⊿(v/υ)%100]],s)]
arp8 f=arp8⇸f
hom q=Sequence[].map(foldr((⋎).q)$sil%1)
dθ l=2*asin l/pi:dθ(abs.sin$l*1e+9)
rev ls=(\z->z id(foldr(\m sg->(\v->z(*v)(map(*0)[0..m*14349]++sg)sg)$abs(cos$(m*3)^2)-0.6)ls.take 9$dθ 1)ls)$(.lwp 3 0).zw.((+).)
lwp ω c(x:l)=c:lwp ω((x+c*ω)/(ω+1))l
lwp _ _ _=[]
hgp ω l=zw(-)l$lwp ω 0 l
lime e(x:l)
 |abs(e*x)>1,e'<-((e*8+abs(1/x))/9)=e':lime e' l
 |1>0=e:lime((e*49999+1)/5e4)l
lime _[]=[]
lim ls=zw(\a u->τ$a/9+max(-2)(min 2$a*u)/6)(map(*0)[0..500]++ls).lwp 9 0.lime 1$hgp 9 ls
zw=zipWith
τ=tanh

This program generates Mozart's Ronda Alla Turca (Piano Sonata #11) as ahem CD-Quality pcm audio on standard output, so it can be piped in real-time (with enormous latency) to aplay -f cd. This is a solution to this challenge on codegolf.stackexchange.