public
Last active

  • Download Gist
LifeFeedback.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.