Skip to content
Create a gist now

Instantly share code, notes, and snippets.

import System.MIDI
import System.MIDI.Utility
import Control.Concurrent
import Control.Monad
import Data.Maybe
import Data.IORef
import Data.Tuple
import Data.Map hiding (filter, map)
import Prelude hiding (lookup, null)
type Coord = (Int,Int)
type State = Map Coord Bool
main :: IO ()
main = do
putStrLn "Hit ENTER to quit..."
launchpadOut <- selectOutputDevice (Just "Launchpad")
audioOut <- selectOutputDevice (Just "Bus 1")
launchpadIn <- selectInputDevice (Just "Launchpad")
launchpadSource <- openSource launchpadIn Nothing
launchpadDestination <- openDestination launchpadOut
audioDestination <- openDestination audioOut
start launchpadSource
state <- newIORef empty
chanA <- newChan
chanB <- newChan
chanC <- mergeChans [chanA, chanB]
chanD <- dupChan chanC
chanE <- dupChan chanD
chanF <- dupChan chanE
mapM_ forkIO [ processA chanA launchpadSource
, processB chanB state
, processC chanC launchpadDestination
, processD chanD state
, processE chanE audioDestination
, processF chanF
]
void getLine
stop launchpadSource
close launchpadSource
close launchpadDestination
close audioDestination
processA :: Chan MidiEvent -> Connection -> IO ()
processA c s = do
es <- getEvents s
writeList2Chan c (filter isOnEvent es)
threadDelay oneSplitSecond
processA c s
processB :: Chan MidiEvent -> IORef State -> IO ()
processB chanB state = do
previousState <- readIORef state
mapM_ (writeChan chanB) (coords >>= processB_cell previousState)
threadDelay oneSecond
processB chanB state
processB_cell :: State -> Coord -> [MidiEvent]
processB_cell previousState coord@(x,y) = if nextState == b then [] else [encodeEvent coord nextState]
where
nextState = rules b s
b = fromMaybe False $ lookup coord previousState
s = sum $ map (b2i . fromMaybe False . flip lookup previousState) neighbourhood
neighbourhood = [(mod (x+dx) limx , mod (y+dy) limy) | dx <- [-1..1], dy <- [-1..1]]
processC :: Chan MidiEvent -> Connection -> IO ()
processC chanC launchpadDestination = mapChan chanC (send launchpadDestination . getMessage)
processD :: Chan MidiEvent -> IORef State -> IO ()
processD chanD state = mapChan chanD (updateFromMessage . getMessage)
where
updateFromMessage m = modifyIORef state (insert `uncurry` decodeMessage m)
processE :: Chan MidiEvent -> Connection -> IO ()
processE chanE audioDestination = mapChan chanE (send audioDestination . getMessage)
processF :: Chan MidiEvent -> IO ()
processF chanF = mapChan chanF print
-- Helpers
getMessage :: MidiEvent -> MidiMessage
getMessage (MidiEvent _ m) = m
encodeEvent :: Coord -> Bool -> MidiEvent
encodeEvent (x,y) True = MidiEvent 0 $ MidiMessage 1 (NoteOn (num x y) 127)
encodeEvent (x,y) False = MidiEvent 0 $ MidiMessage 1 (NoteOff (num x y) 64 )
isOnEvent :: MidiEvent -> Bool
isOnEvent (MidiEvent _ (MidiMessage _ (NoteOn _ _))) = True
isOnEvent _ = False
num :: Int -> Int -> Int
num x y = 16 * y + x
pos :: Int -> (Int, Int)
pos n = swap $ divMod n 16
decodeMessage :: MidiMessage -> (Coord,Bool)
decodeMessage (MidiMessage _ (NoteOn n _)) = (pos n, True)
decodeMessage (MidiMessage _ (NoteOff n _)) = (pos n, False)
decodeMessage _ = ((0,0), False)
limx :: Int
limx = 8
limy :: Int
limy = 8
coords :: [Coord]
coords = [(x,y) | x <- [0..limx-1], y <- [0..limy-1]]
oneSplitSecond :: Int
oneSplitSecond = 10000
oneSecond :: Int
oneSecond = 100000
-- Life
--
rules :: Bool -> Int -> Bool
rules True 3 = True
rules True 4 = True
rules False 3 = True
rules _ _ = False
b2i :: Bool -> Int
b2i True = 1
b2i _ = 0
-- Chans
--
mergeChans :: [Chan x] -> IO (Chan x)
mergeChans l = do
o <- newChan
mapM_ (forkIO . (getChanContents >=> writeList2Chan o)) l
return o
mapChan :: Chan a -> (a -> IO b) -> IO ()
mapChan chan f = getChanContents chan >>= mapM_ f
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.