Music.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
module Music (withMusic) where

#ifdef NO_SOUND

import Data.IORef
withMusic :: ((IORef Double, IORef Double) -> IO ()) -> IO ()
withMusic f = do
  a <- newIORef 0
  b <- newIORef 0
  f (a, b)

#else

import Control.Concurrent
import Control.Monad
import System.IO.Unsafe
import Data.Fixed (mod')
import Data.IORef (IORef, newIORef)
import Data.List
import Data.StateVar (get, ($=))
import qualified Foreign as F
import qualified Sound.ALUT as AL

sampleRate :: (Num a) => a
sampleRate = 44100

withMusic :: ((IORef Double, IORef Double) -> IO ()) -> IO ()
withMusic f =
  AL.withProgNameAndArgs AL.runALUT $ \_progName _args -> do
    tempoRef <- newIORef 0.5
    pitchRef <- newIORef 0
    notes <- tetrisTheme
    _ <- forkIO $ do
      sinks <- mapM (const AL.genObjectName) notes
      forM_ (cycle notes) $
        \chord -> do
          pitch <- get pitchRef
          tempo <- get tempoRef
          forM_ (zip sinks chord) $ \(sink, note) -> do
            AL.pitch sink $= realToFrac (2 ** (pitch/12))
            case note of
              Keep ->
                return ()
              Rest ->
                AL.stop [sink]
              Note buf -> do
                AL.stop [sink]
                AL.buffer sink $= Just buf
                AL.play [sink]

          threadDelay (floor $ 400000 * tempo)
    f (tempoRef, pitchRef)

data Note = Keep | Rest | Note AL.Buffer

-- Instruments
instrument :: (Double -> Double) -> Double -> [IO AL.Buffer]
instrument waveform env =
  let envelope = takeWhile (>0.15) $ sample $ \t -> (1-t)**env
      waves = for [0..127] $ \p -> sample $ \t -> waveform (t * freq p)
   in for waves $ toBuffer . map toU8 . zipWith (*) envelope
  where
    for = flip map
    sample = for [0,1/sampleRate..]
    freq p = 2**((p-69)/12) * 440
    toU8 s = floor $ 0x1F*s + 0x7F :: F.Word8
    toBuffer bytes = once $ F.withArray bytes $ \array -> do
      let mem = AL.MemoryRegion array (genericLength bytes)
      buf <- AL.genObjectName
      AL.bufferData buf $= AL.BufferData mem AL.Mono8 sampleRate
      return buf

-- Using this on the toBuffer function reduces loading time by ~25%, but
-- «unsafePerformIO» is scary. Not sure if it's worth it.
once :: IO a -> IO a
once io = unsafePerformIO $ do
  state <- newIORef Nothing
  return $ get state >>= \case
      Nothing -> do
        value <- io
        state $= Just value
        return value
      Just x -> return x

tenuto, normal, staccato, staccatissimo :: [IO AL.Buffer]
tenuto        = instrument sawtooth 1
normal        = instrument square 3
staccato      = instrument sawSquare 7
staccatissimo = instrument sine 10

-- Waveforms
sine, sawtooth, sawSquare, square :: Double -> Double
sine x     = sin (2*pi*x)
sawtooth x = (2*x + 1) `mod'` 2 - 1
sawSquare  = fromIntegral . round . sawtooth
square     = signum . sawtooth

tetrisTheme :: IO [[Note]]
tetrisTheme = do -- This is really slow. I'd like it to be faster.
  p1 <- part1
  p2 <- part2
  return $ transpose p1 ++ transpose p1 ++ transpose p2
  where
    z = 0 -- Simply to get another syntax highlight color
    part inst notes =
      forM notes $ \case 0    -> return Keep
                         (-1) -> return Rest
                         n    -> Note <$> inst !! n
-- {{{ Just the music definition below here.
    part1 = sequence
      [ part normal
        [ 76,  z, 71, 72, 74,  z, 72, 71
        , 69,  z, 69, 72, 76,  z, 74, 72
        , 71,  z,  z, 72, 74,  z, 76,  z
        , 72,  z, 69,  z, 69,  z, -1,  z

        , -1, 74,  z, 77, 81,  z, 79, 77
        , 76,  z, -1, 72, 76,  z, 74, 72
        , 71,  z, 71, 72, 74,  z, 76,  z
        , 72,  z, 69,  z, 69,  z, -1,  z
        ]
      , part staccato
        [ 40, 52, 40, 52, 40, 52, 40, 52
        , 45, 57, 45, 57, 45, 57, 45, 57
        , 44, 52, 44, 52, 40, 52, 40, 52
        , 45, 57, 45, 57, 45, 57, 47, 48

        , 50, 38, -1, 38, -1, 38, 45, 41
        , 36, 48, -1, 48, 36, 43, -1,  z
        , 47, 59, -1, 59, -1, 52, -1, 56
        , 45, 52, 45, 52, 45,  z, -1,  z
        ]
      , part undefined $ replicate 64 z
      ]
    part2 = sequence
      [ part staccatissimo
        [ 57, 64, 57, 64, 57, 64, 57, 64
        , 56, 64, 56, 64, 56, 64, 56, 64
        , 57, 64, 57, 64, 52, 57, 52, 57
        , 56, 64, 56, 64, -1,  z,  z,  z

        , 57, 64, 57, 64, 57, 64, 57, 64
        , 56, 64, 56, 64, 56, 64, 56, 64
        , 57, 64, 57, 64, 57, 64, 57, 64
        , 56, 64, 56, 64, -1,  z,  z,  z
        ]
      , part tenuto
        [ 52,  z,  z,  z, 48,  z,  z,  z
        , 50,  z,  z,  z, 47,  z,  z,  z
        , 48,  z,  z,  z, 45,  z,  z,  z
        , 44,  z,  z,  z, 47,  z,  z,  z

        , 52,  z,  z,  z, 48,  z,  z,  z
        , 50,  z,  z,  z, 47,  z,  z,  z
        , 48,  z, 52,  z, 57,  z, 57,  z
        , 56,  z,  z,  z,  z,  z, -1,  z
        ]
      , part tenuto
        [ 48,  z,  z,  z, -1,  z,  z,  z
        , 47,  z,  z,  z, -1,  z,  z,  z
        , 45,  z,  z,  z, -1,  z,  z,  z
        , -1,  z,  z,  z, 44,  z,  z,  z

        , 48,  z,  z,  z, -1,  z,  z,  z
        , 47,  z,  z,  z, -1,  z,  z,  z
        , 48,  z,  z,  z, 52,  z,  z,  z
        , 50,  z,  z,  z,  z,  z, -1,  z
        ]
      ]
-- }}}
#endif
-- vim: tw=78 cc=79