module Main
   where

import Char

-- square wave of period x, with error amortization for nonintegral periods
square :: Double -> [Int]
square x = cycle (sqh x False x)
    where sqh c on x = ((if on then 20 else 0) :
                        sqh (if c<0 then c+x-1 else c-1) (if c<0 then not on else on) x)

space = repeat 0

-- output frequency/Hz
freq = 44100

-- zero is two octaves below middle C
tuning = log(freq/440)/log(2)+3/4

-- period for semitone n
period :: Int -> Double
period n = 2**(tuning-fromIntegral(n)/12)

tick = floor (freq / 50)

-- I can't quite decide whether this is astoundingly ugly or kinda neat...
z = -10000 :: Int

-- begin tune data
legato n = [(n, 6)]
staccato n = [(n, 4), (z,2)]
accomp n (x,y) = concat (concat ((replicate n [staccato (x), staccato (x+y)])))
accomp2 (x,y) = accomp 2 (x,y)
accomp4 (x,y) = accomp 4 (x,y)

bar1 = concat [(concatMap accomp2 [(11,3),(11,3),(9,3),(16,3),(12,4),(4,7),(11,7)]),
               (concatMap staccato [4,11,15,16])]
bar2 = concatMap accomp2 [(12,7),(12,7),(14,7),(16,3)]
bar3 = concatMap accomp4 [(14,7)]
bar4 = concatMap accomp4 [(16,3)]
bar5 = concatMap legato [16,11,7,6,4]

bassify l notes = zipWith (\n (x,y) -> (x-12*n,y)) (quadruple l) notes
    where
      quadruple [] = []
      quadruple (h:hs) = h:0:0:0:quadruple hs

bar6 = bassify [2,0,1,0,2,1,2,1] bar2
bar7 = bassify [2,1,2,1,2,1,2,1] (concat [bar3,bar4])
bar8 = bassify [2,0,0,1,2,0,0,0] (concat [bar3, concatMap accomp2 [(12,7)], concatMap staccato [12,16,7,9]])

makemel q = [(x+24,y) | (x,y) <- q]
mel1 = makemel [(11,48), (9,12), (11,12), (7,6), (6,6), (4,6), (z,6)]
mel2 = makemel [(9,6), (z,6), (11,6), (z,6), (7,4), (z,2), (6,4), (z,2), (4,4), (z,2), (z,6), (-1,12)]
mel3 = makemel [(1,6), (3,6), (4,4), (z,6), (15,2), (16,12)]
mel4 = makemel [(1,4), (z,2), (3,4), (z,2), (4,10), (15,2), (16,4), (z,8)]
mel5 = makemel [(0,6), (z, 6), (0,6), (2,6), (4,24), (7,6), (z,6), (7,6), (9,6), (4,18), (z,6)]
mel6 = concat [(makemel [(6,12), (2,6), (z,6)]),
               (concatMap staccato [30,31,33,35]),
               (makemel [(6,12), (4,6), (z,6), (4,18), (z,6)])]
mel7 = makemel [(6,12), (2,6), (z,6), (9,6), (7,6), (6,6), (7,6), (4,22), (15,2), (16,4), (z,2)]
mel8 = concat [(concatMap legato [24,z,24,26]), [(28,24)],
               (concatMap staccato [30,31,33,35]), [(28, 18), (z,6)]]
mel9 = concat [(concatMap legato [30,z,26,z]), 
               (concatMap staccato [36,35,33,31]), [(30,12), (28,4), (z,8), (28, 18), (z,6)]]
mel10 = concat [(concatMap staccato [30,z,26,z]),
                (concatMap legato [30,28,33,31]),
                makemel [(6,12),(4,6),(z,6),(4,10),(15,2), (16,12)]]

octavedown q = [(x-12,y) | (x,y) <- q]

mid0 = concatMap staccato [11,7,6]
mid0od = octavedown mid0
mid1 = concat [staccato(-8), (accomp 5 (31,-20)), staccato(31), staccato(30)]
mid2 = concat [concat (concat (replicate 6 [staccato(4), arp])), arp]
    where arp = [(23,1), (28,2), (23,1), (28,2)]
mid3 = [(-1,6), (2,6), (3,6)]
mid3od = octavedown mid3
mid4 = [(-1,6), (4,6), (-1,6)]
mid4od = octavedown mid4
-- end tune data

note (n, d) = take (tick*d) (square (period n))
makechan x = cycle (concatMap note (concat x))

chan1 :: [Int]
chan1 = makechan [bar1, bar1, bar2, bar3, bar4, bar2, bar3, bar5,
                  mid0od, mid1, mid3od, mid1, mid3od, mid1, mid3od, mid1, mid4od,
                  bar6, bar7, bar6, bar8]

chan2 :: [Int]
chan2 = makechan [mel1, mel2, mel3, mel1, mel2, mel4, mel5, mel6, mel5, mel7,
                  mid0, mid2, mid3, mid2, mid3, mid2, mid3, mid2, mid4,
                  mel8, mel9, mel8, mel10]

mix = zipWith (+)
echo input delay = zipWith (\x y -> (x + y * 2)) (concat [(take delay space), input]) input

--output = (echo (mix chan1 chan2) (tick*3))
output = (mix chan1 chan2)
--output = chan1

string = concatMap (\x -> (replicate 4 (chr x))) output
main = putStr string