Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
49 lines (45 sloc) 2.24 KB
Interactive Stochastic Music
Donya Quick
A Euterpea/HSoM port of a JythonMusic program I wrote a couple years back.
> {-# LANGUAGE Arrows #-}
> module Main where
> import Euterpea
> import HSoM
> import FRP.UISF
> import System.Random
> main :: IO()
> main = runMUI defaultMUIParams{uiSize=(300,500), uiTickDelay=0} interactive
> interactive :: UISF () ()
> interactive = proc _ -> do
> mIn <- selectInput -< ()
> mOut <- selectOutput -< ()
> playOut <- stickyButton "Play" -< ()
> label "" -< () -- to make some space on the screen
> rate <- title "Rate (Seconds)" $ withDisplay $ hSlider (0.1, 1.5) 0.2 -< ()
> bSize <- title "Buffer Size" $ withDisplay $ hiSlider 1 (1,12) 5 -< ()
> tick <- timer -< rate
> mi <- midiIn -< mIn
> rec lastPlay <- delay False -< playOut -- to catch T-F edge and turn notes off when it happens
> lastP <- delay 60 -< if tick/=Nothing then nextP else lastP -- for correct ordering of on-off messages
> (pBuffer, vBuffer) <- delay ([],[]) -< procBuffer (pBuffer, vBuffer) bSize mi
> title "Pitches" $ display -< pBuffer
> title "Volumes" $ display -< vBuffer
> let (pbSize, vbSize) = (length pBuffer, length vBuffer)
> r1 <- liftAIO randomRIO -< (0::Int, pbSize-1) -- random pitch index
> r2 <- liftAIO randomRIO -< (0::Int, vbSize-1) -- random volume index
> let nextP = if pbSize <= 0 then 60 else pBuffer !! r1 -- select from buffer if not empty
> nextV = if vbSize <= 0 then 80 else vBuffer !! r2
> let outMsgs = if not playOut && lastPlay then Just [Std(ControlChange 0 123 0)] else
> if playOut && tick/=Nothing then Just [Std (NoteOff 0 lastP 0), Std (NoteOn 0 nextP nextV)] else Nothing
> midiOut -< (mOut, outMsgs)
> returnA -< ()
> procBuffer :: ([AbsPitch], [Volume]) -> Int -> Maybe [MidiMessage] -> ([AbsPitch], [Volume])
> procBuffer (pb, vb) s ms = -- extract pitches and volumes from MIDI message lists
> let (ps, vs) = unzip $ getPVs ms
> in (take s (ps ++ pb), take s (vs++vb)) where
> getPVs Nothing = []
> getPVs (Just ms) = f ms where
> f (ANote c k v d : t) = (k,v) : f t
> f (Std (NoteOn c k v) : t) = (k,v) : f t
> f (h:t) = f t
> f [] = []