Conway in Haskell. Requires http://hackage.haskell.org/package/hosc

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Sound.OpenSoundControl
import qualified Sound.OpenSoundControl.OSC as OSC
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Control.Monad.Reader
import System.Random
import Data.Array
--import qualified Network.Socket as N
import Debug.Trace

data Press = Press Int Int Int deriving (Show, Eq)

isDownPress (Press _ _ 1) = True
isDownPress _ = False
data Led = Led Int Int Int | LedRow Int Int | LedCol Int Int deriving (Show, Eq)

--would rather use MVar instead of Chan, but UDP piles up otherwise
data MonomeState = MonomeState String UDP (Chan OSC.OSC)

--host: 8080, listen: 8000
newtype Monome a = Monome (ReaderT MonomeState IO a) deriving (Monad, MonadIO)

main = runMonome "/40h" $ clearAll >> test  -- life (listArray ((0, 0), (7, 7)) $ repeat 0)

clearAll :: Monome ()
clearAll = mapM_ (switchLed . flip LedRow 0) [0..7]

-- conway's game of life. 
life :: Array (Int, Int) Int -> Monome ()
life array = do
    presses <- getPresses
    let arrm = array // map (\((x, y), t) -> (,) (x, y) . (\x -> fromEnum $ elem x $ if t==1 then [3, 4] else [3]) . sum $ liftM2 (\u v -> array!(mod u 8, mod v 8)) [x-1, x, x+1] [y-1, y, y+1]) (assocs array)
        arrp = arrm // (map (\(Press x y t) -> (,) (x, y) $ 1 - arrm ! (x, y)) . filter isDownPress $ presses)
    forM_ (assocs arrp) $ \((x, y), t) -> switchLed (Led x y t)
    liftIO (threadDelay $ 300*1000)
    life arrp

-- Randomly pick a position and light it up every 100ms
populate :: Monome ()
populate = forever $ do
    x <- liftIO $ randomRIO (0, 7)
    y <- liftIO $ randomRIO (0, 7)
    switchLed (Led x y 1)
    liftIO (threadDelay $ 100*1000)

-- Press as long as 
test :: Monome ()
test = forever $ do
    press@(Press x y state) <- getPress
    liftIO (print press)
    switchLed (Led x y state)

-- add unbinding abilities, so we don't have to fuser/kill if the socket gets lost somewhere...
runMonome :: String -> Monome a -> IO a
runMonome prefix (Monome r) = do
    udp <- udpServer "127.0.0.1" 8000
    udpSend <- openUDP "127.0.0.1" 8080
    var <- newChan
    let state = MonomeState prefix udpSend var
    forkIO (oscReader $ MonomeState prefix udp var)
    runReaderT r state

-- Monome monad wrappers
getTryPress :: Monome (Maybe Press)
getTryPress = Monome (ReaderT takeTryPress)
getPresses :: Monome [Press]
getPresses = Monome (ReaderT takePresses)
getPress :: Monome Press
getPress = Monome (ReaderT takePress)
switchLed :: Led -> Monome ()
switchLed led = Monome (ReaderT $ sendLed led)

-- Get a list
takePresses :: MonomeState -> IO [Press]
takePresses state = do
    mpress <- takeTryPress state
    case mpress of
        Just press -> fmap (press:) (takePresses state)
        Nothing    -> return []

-- Parse OSC packets which are presses
messageToPress :: String -> OSC -> Maybe Press
messageToPress prefix (Message str [OSC.Int x, OSC.Int y, OSC.Int state]) | str == prefix ++ "/press" = Just (Press x y state)
messageToPress _      _ = Nothing

-- Putting and taking OSC packets concurrency
takeTryPress :: MonomeState -> IO (Maybe Press)
takeTryPress (MonomeState prefix _ var) = do
    cempty <- isEmptyChan var
    if cempty then return Nothing
              else messageToPress prefix `liftM` readChan var
--  mpacket <- tryTakeMVar var
--  return (maybe Nothing (messageToPress prefix) mpacket)

takePress :: MonomeState -> IO Press
takePress state@(MonomeState prefix _ var) = do
    packet <- readChan var --takeMVar var
    case messageToPress prefix packet of
        Just msg -> return msg
        Nothing  -> takePress state

oscReader :: MonomeState -> IO ()
oscReader (MonomeState _ udp var) = forever $ do
    packet <- recv udp
    trace ("get " ++ show packet) $ writeChan var packet

-- Make the led-lighting OSC packets
sendLed :: Led -> MonomeState -> IO ()
sendLed led (MonomeState prefix udp _) = send udp packet
  where packet = case led of
            Led x y on -> Message (prefix ++ "/led") [OSC.Int x, OSC.Int y, OSC.Int on]
            LedRow y mask -> Message (prefix ++ "/led_row") [OSC.Int y, OSC.Int mask]
            LedCol x mask -> Message (prefix ++ "/led_col") [OSC.Int x, OSC.Int mask]%             

Controller