DrumMachine.hs

import Control.Monad
import Data.IORef
import Data.Functor

import Paths
import System.FilePath

import qualified Graphics.UI.Threepenny as UI
import Graphics.UI.Threepenny.Core

{-----------------------------------------------------------------------------
    Configuration
------------------------------------------------------------------------------}
bars  = 4
beats = 4
defaultBpm = 120

bpm2ms :: Int -> Int
bpm2ms bpm = ceiling $ 1000*60 / fromIntegral bpm

-- NOTE: Samples taken from "conductive-examples"

instruments = words "kick snare hihat"

loadInstrumentSample name = return $ "static/" ++ name ++ ".wav"

{-----------------------------------------------------------------------------
    Main
------------------------------------------------------------------------------}
main :: IO ()
main = do
    static <- getStaticDir
    startGUI defaultConfig { jsStatic = Just static } setup

setup :: Window -> UI ()
setup w = void $ do
    return w # set title "Ha-ha-ha-ks-ks-ks-ha-ha-ha-ell-ell-ell"

    elBpm  <- UI.input # set value (show defaultBpm)
    elTick <- UI.span
    (kit, elInstruments) <- mkDrumKit
    let status = grid [[UI.string "BPM:" , element elBpm]
                      ,[UI.string "Beat:", element elTick]]
    getBody w #+ [UI.div #. "wrap" #+ (status : map element elInstruments)]
    
    timer <- UI.timer # set UI.interval (bpm2ms defaultBpm)
    eBeat <- accumE (0::Int) $
        (\beat -> (beat + 1) `mod` (beats * bars)) <$ UI.tick timer
    void . onEvent eBeat $ \beat -> do
        -- display beat count
        element elTick # set text (show $ beat + 1)
        -- play corresponding sounds
        sequence_ $ map (!! beat) kit
    
    -- allow user to set BPM
    on UI.keydown elBpm $ \keycode -> when (keycode == 13) $ void $ do
        bpm <- read <$> get value elBpm
        return timer # set UI.interval (bpm2ms bpm)
    
    -- start the timer
    UI.start timer


type Kit        = [Instrument]
type Instrument = [Beat]
type Beat       = UI ()         -- play the corresponding sound

mkDrumKit :: UI (Kit, [Element])
mkDrumKit = unzip <$> mapM mkInstrument instruments

mkInstrument :: String -> UI (Instrument, Element)
mkInstrument name = do
    elCheckboxes <-
        sequence $ replicate bars  $
        sequence $ replicate beats $
            UI.input # set UI.type_ "checkbox"

    url     <- loadInstrumentSample name
    elAudio <- UI.audio # set (attr "preload") "1" # set UI.src url

    let play box = do
            checked <- get UI.checked box
            when checked $ do
                runFunction $ ffi "%1.pause()" elAudio
                runFunction $ ffi "%1.currentTime = 0" elAudio 
                runFunction $ ffi "%1.play()" elAudio
        beats    = map play . concat $ elCheckboxes
        elGroups = [UI.span #. "bar" #+ map element bar | bar <- elCheckboxes]
    
    elInstrument <- UI.div #. "instrument"
        #+ (element elAudio : UI.string name : elGroups)
    
    return (beats, elInstrument)