launchpad-control (empty) → 0.0.1.0
raw patch · 11 files changed
+1979/−0 lines, 11 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, hmidi, launchpad-control, mtl, transformers
Files
- LICENSE +29/−0
- Setup.hs +3/−0
- System/MIDI/Launchpad/AppFramework.hs +189/−0
- System/MIDI/Launchpad/AppFramework/Internal.hs +353/−0
- System/MIDI/Launchpad/Apps/Conway.hs +280/−0
- System/MIDI/Launchpad/Apps/DrumSeq.hs +223/−0
- System/MIDI/Launchpad/Apps/FXControl.hs +168/−0
- System/MIDI/Launchpad/Apps/MonoSeq.hs +241/−0
- System/MIDI/Launchpad/Control.hs +376/−0
- examples/launchpad-control-examples.hs +52/−0
- launchpad-control.cabal +65/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2013, Balazs Komuves+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither names of the copyright holders nor the names of the contributors+may be used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain
+ System/MIDI/Launchpad/AppFramework.hs view
@@ -0,0 +1,189 @@++-- | A framework to create functional Launchpad \"apps\".+--+-- See the modules below @System.MIDI.Launchpad.Apps@ for examples.+--+-- Notes:+--+-- * Both Ableton and the Launchpad embedded software seems to be somewhat+-- buggy... If you experience issues, try resetting the Launchpad, try to launch +-- Ableton and your app in the opposite order, etc...+--+-- * /ALWAYS/ compile with the threaded runtime (ghc option -threaded)+--+-- * When the programs start, the Launchpad is reseted, and Session mode+-- is assumed. Press User mode 2 to start playing with the app. Sometimes you have to +-- press Session mode \/ User mode 2 a few times so that Ableton and the launchpad+-- app thinks the same thing about the state...+--+-- * How to setup Ableton: Use a loopback device (eg. IAC Bus 1 on OSX) to+-- communicate between the app and Ableton. In Ableton midi setup,+-- enable the track and remote MIDI /input/ for the loopback device, and+-- enable the sync MIDI /output/ for the loopback device; disable everything else.+-- Also disable all Launchpad MIDI inputs and outputs (it can remain a control+-- surface).+--++{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}+module System.MIDI.Launchpad.AppFramework+ ( -- * simple colors+ red , green , amber , yellow , orange+ -- * pure interface+ , PureApp(..)+ , runPureApp + -- * monadic interface+ , MonadicApp(..) , runMonadicApp+ , RenderMonad , ButtonMonad , SyncMonad+ , setButtonColor , setButtonColor' , setButtonColors+ , getMode , setMode + , CanChangeState , setState , getState , modifyState+ , CanSendMessage , sendMessage , sendMessages+ -- * global configuration+ , GlobalConfig(..) , defaultGlobalConfig+ )+ where++--------------------------------------------------------------------------------++-- import Data.List++import Control.Monad+import System.MIDI+import System.MIDI.Utility++import Control.Concurrent+import Control.Concurrent.MVar ()++import Control.Monad.Trans+import Control.Monad.Identity+import Control.Monad.Writer+import Control.Monad.State++-- import Data.Array.IO+import System.IO.Unsafe as Unsafe++import System.MIDI.Launchpad.Control+import System.MIDI.Launchpad.AppFramework.Internal++--------------------------------------------------------------------------------+-- * monadic interface++-- | Monadic application (equivalent to the above pure application, +-- but may be more convenient to use)+data MonadicApp cfg mode state = MonadicApp+ { mAppConfig :: cfg+ , mAppIniState :: (mode,state)+ , mAppStartStop :: cfg -> Bool -> (state -> state) -- ^ start or stop playing+ , mAppRender :: cfg -> mode -> state -> Maybe Int -> RenderMonad () -- ^ render the screen (it will optimized, don't worry); the @Maybe Int@ is the sync signal+ , mAppButton :: cfg -> ButtonPress -> ButtonMonad mode state () -- ^ the user presses a button+ , mAppSync :: cfg -> mode -> Int -> SyncMonad state () -- ^ external MIDI sync signal (24 times per quarter note)+ } ++newtype RenderMonad a + = RM { unRM :: WriterT [(Button,Color)] Identity a } + deriving Monad++newtype ButtonMonad mode state a + = BM { unBM :: StateT (mode,state) (WriterT [ MidiMessage' ] Identity) a } + deriving Monad++newtype SyncMonad state a + = SM { unSM :: StateT state (WriterT [ MidiMessage' ] Identity) a } + deriving Monad++---------------------++setButtonColor :: (Button,Color) -> RenderMonad ()+setButtonColor bc = RM $ tell [bc]++setButtonColor' :: Button -> Color -> RenderMonad ()+setButtonColor' b c = setButtonColor (b,c)++setButtonColors :: [(Button,Color)] -> RenderMonad ()+setButtonColors bcs = RM $ tell bcs++---------------------++getMode :: ButtonMonad mode state mode+getMode = BM $ do+ (mode,_) <- get+ return mode++setMode :: mode -> ButtonMonad mode state ()+setMode newmode = BM $ do+ (_,b) <- get+ put (newmode,b) ++---------------------++class Monad m => CanSendMessage m where+ sendMessages :: [MidiMessage'] -> m ()+ sendMessage :: MidiMessage' -> m ()+ sendMessage msg = sendMessages [msg]++instance CanSendMessage (ButtonMonad mode state) where+ sendMessages ms = BM $ lift $ tell ms++instance CanSendMessage (SyncMonad state) where+ sendMessages ms = SM $ lift $ tell ms++---------------------++class CanChangeState m where+ getState :: Monad (m state) => m state state + setState :: Monad (m state) => state -> m state ()+ +modifyState :: (CanChangeState m, Monad (m state)) => (state -> state) -> m state ()+modifyState f = do+ old <- getState + setState $! f old+ +instance CanChangeState (ButtonMonad mode) where+ getState = BM $ do+ (_,state) <- get+ return state + setState newstate = BM $ do+ (a,_) <- get+ put (a,newstate)++instance CanChangeState SyncMonad where+ getState = SM $ get+ setState s = SM $ put $! s+ +--------------------------------------------------------------------------------+-- * conversion++monadicAppToPureApp :: MonadicApp cfg mode state -> PureApp cfg mode state+monadicAppToPureApp mApp@(MonadicApp cfg ini startstop render button sync) = pApp where+ pApp = PureApp+ { pAppConfig = cfg+ , pAppIniState = ini+ , pAppStartStop = startstop+ , pAppRender = \c m s i -> runIdentity $ execWriterT (unRM $ render c m s i)+ , pAppButton = \c b ms -> runIdentity $ runWriterT (execStateT (unBM $ button c b ) ms)+ , pAppSync = \c m s i -> runIdentity $ runWriterT (execStateT (unSM $ sync c m i ) s)+ } ++-- pureAppToMonadicApp :: PureApp mode state -> MonadicApp mode state+ +-------------------------------------------------------------------------------- +-- * run applications++-- | A default global state+defaultGlobalConfig :: GlobalConfig +defaultGlobalConfig = GlobalConfig+ { defaultLaunchpadDevice = "Launchpad"+ , defaultMidiOutputDevice = "IAC Bus 1"+ , outputChannel = 1+ , onlyUserMode2 = True+ } + +-------------------------------------------------------------------------------- ++-- | Executes a monadic application+runMonadicApp :: {- Show state => -} GlobalConfig -> MonadicApp cfg mode state -> IO ()+runMonadicApp globalConfig mApp = runPureApp globalConfig (monadicAppToPureApp mApp)++-------------------------------------------------------------------------------- ++
+ System/MIDI/Launchpad/AppFramework/Internal.hs view
@@ -0,0 +1,353 @@++{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}+module System.MIDI.Launchpad.AppFramework.Internal where++--------------------------------------------------------------------------------++-- import Data.List++import Control.Monad+import System.MIDI+import System.MIDI.Utility++import Control.Concurrent+import Control.Concurrent.MVar ()++import System.IO.Unsafe as Unsafe++import System.MIDI.Launchpad.Control++--------------------------------------------------------------------------------+-- * simple colors ++red, green, amber, yellow, orange :: Color+red = Color Red Full+green = Color Green Full+amber = Color Amber Full+yellow = Color Yellow Full+orange = RedGreen Full Low++-- | Default color of the control buttons (session, user modes, mixer), which is amber+controlColor :: Color+controlColor = amber++--------------------------------------------------------------------------------+-- * pure interface++-- | We suppose an application can have different modes (similarly as +-- in Ableton one can have session, session overview, different mixer modes,+-- etc), which are basically different \"screens\" on the Launchpad; and also+-- a global state. See the example applications how it is intended to be used.+--+data PureApp cfg mode state = PureApp+ { pAppConfig :: cfg -- ^ application-specific configuration+ , pAppIniState :: (mode,state) -- ^ initial state of the application+ , pAppStartStop :: cfg -> Bool -> (state -> state) -- ^ what to do when get start or stop playing MIDI signal+ , pAppRender :: cfg -> mode -> state -> Maybe Int -> [(Button,Color)] -- ^ render the screen (it will optimized, don't worry)+ , pAppButton :: cfg -> ButtonPress -> (mode,state) -> ((mode,state),[MidiMessage']) -- ^ the user presses a button+ , pAppSync :: cfg -> mode -> state -> Int -> (state,[MidiMessage']) -- ^ external MIDI sync signal (24 times per quarter note)+ } ++--------------------------------------------------------------------------------+-- * render only the difference between old and new display++safeRenderDiff :: [(Button,Color)] -> [(Button,Color)] -> Messages+safeRenderDiff old new = unsafeRenderDiff (sortNubMap old) (sortNubMap new)++-- | Optimized led update. We assume that the inputs are sorted.+unsafeRenderDiff :: [(Button,Color)] -> [(Button,Color)] -> Messages+unsafeRenderDiff old new = stuff where++ stuff = if length diff > 40+ then rapidLedUpdateList new+ else setColor diff+ + diff = go old new+ + go old [] = [ (b,None) | (b,c)<-old, c/=None ]+ go [] new = [ (b,c ) | (b,c)<-new, c/=None ]+ go oos@((ob,oc):os) nns@((nb,nc):ns) = case compare ob nb of+ LT -> (ob,None) : go os nns+ GT -> (nb,nc ) : go oos ns+ EQ -> if nc/=oc + then (nb,nc) : go os ns+ else go os ns+ +--------------------------------------------------------------------------------+-- * global variables++-- | 24 tick per quarter note+theSyncCounter :: MVar Int+theSyncCounter = Unsafe.unsafePerformIO $ newMVar 0++{-+theSyncBuffer :: MVar [Double]+theSyncBuffer = unsafePerformIO $ newMVar []++-- | Estimated BPM. +theBPM :: MVar Double+theBPM = unsafePerformIO $ newMVar 120+-}++thePlayingFlag :: MVar Bool+thePlayingFlag = Unsafe.unsafePerformIO $ newMVar False++-- | We should only use "user2" mode to be compatible with Ableton.+-- We default to session mode (a hack, but who cares :) +theLaunchpadMode :: MVar Control+theLaunchpadMode = Unsafe.unsafePerformIO $ newMVar Session+ +theLedUpdateBuffer :: MVar [Messages]+theLedUpdateBuffer = Unsafe.unsafePerformIO $ newMVar []++theLastScreen :: MVar [(Button,Color)]+theLastScreen = Unsafe.unsafePerformIO $ newMVar []++-------------------------------------------------------------------------------- +-- * helper functions++whenUser2 :: GlobalConfig -> IO () -> IO ()+whenUser2 globalConfig action = + if (onlyUserMode2 globalConfig) + then whenUser2' action+ else action+ +whenUser2' :: IO () -> IO ()+whenUser2' action = do+ readMVar theLaunchpadMode >>= \mode -> when (mode == User2) action++pushUpdates :: Messages -> IO ()+pushUpdates new = do+ old <- takeMVar theLedUpdateBuffer+ putMVar theLedUpdateBuffer (forceList new : old)++replaceMVar :: MVar a -> a -> IO () +replaceMVar mv !x = do+ tryTakeMVar mv+ putMVar mv x+ +forceList :: [a] -> [a]+forceList (!x:xs) = x : forceList xs+forceList [] = []+ +-------------------------------------------------------------------------------- +-- * update loop++appUpdateLoop :: IO ()+appUpdateLoop = go where++ go = do+ buf <- takeMVar theLedUpdateBuffer+ sendMsg $ concat (reverse buf)+ putMVar theLedUpdateBuffer []+ + threadDelay (1000) -- 1 msec+ go++-------------------------------------------------------------------------------- +-- * run applications++-- | Global configuration of an app+data GlobalConfig = GlobalConfig+ { defaultLaunchpadDevice :: String -- ^ Should be probably \"Launchpad\"+ , defaultMidiOutputDevice :: String -- ^ default output device name (eg. \"IAC Bus 1\")+ , outputChannel :: Int -- ^ The midi channel we send the messages (towards the DAW or synth) + , onlyUserMode2 :: Bool -- ^ If we want to be Ableton-compatible, we should only do anything in \"User mode 2\"+ } + +-------------------------------------------------------------------------------- ++selectDevice :: String -> String -> IO (Source,Destination)+selectDevice prompt defaultName = do+ srclist <- enumerateSources+ src <- selectInputDevice (prompt ++ " (input):") (Just defaultName)+ dstlist <- enumerateDestinations+ dst <- selectOutputDevice (prompt ++ " (output):") (Just defaultName)+ return (src,dst)++-------------------------------------------------------------------------------- ++-- | Executes a pure application+runPureApp :: {- Show state => -} GlobalConfig -> PureApp cfg mode state -> IO ()+runPureApp globalConfig clientApp = do++ let (iniMode,iniState) = pAppIniState clientApp+ -- let appConfig = pAppConfig clientApp+ appMode <- newMVar iniMode -- :: IO (MVar mode )+ appState <- newMVar iniState -- :: IO (MVar state)+ + (src1,dst1) <- selectDevice "\nplease select the Launchpad midi device" (defaultLaunchpadDevice globalConfig)+ (src2,dst2) <- selectDevice "\nplease select the target midi device" (defaultMidiOutputDevice globalConfig) -- "IAC Bus 1"+ + outconn1 <- openDestination dst1+ outconn2 <- openDestination dst2++ inconn1 <- openSource src1 $ Just $ appLaunchpadCallback (globalConfig,clientApp,appMode,appState) outconn2+ inconn2 <- openSource src2 $ Just $ appSyncHandler (globalConfig,clientApp,appMode,appState) outconn2+ + putStrLn "\nconnected" + initializeLaunchpad inconn1 outconn1+ + start inconn1 ; start inconn2+ putStrLn "started. Press 'ENTER' to exit."++ putStrLn "\n================================\n"+ + resetLaunchpad False -- True+ forkIO $ appUpdateLoop -- outconn1 outconn2+ getLine+ + stop inconn1 ; stop inconn2 ; putStrLn "stopped." + close inconn1 ; close inconn2 ; putStrLn "closed."++ close outconn1 ; close outconn2+ +-------------------------------------------------------------------------------- ++appLaunchpadCallback + :: {- Show state => -} + (GlobalConfig, PureApp cfg mode state, MVar mode, MVar state) -> Connection -> MidiEvent -> IO ()+appLaunchpadCallback + app@(globalConfig,clientApp,appMode,appState) + outconn2 + event@(MidiEvent _ fullmsg@(MidiMessage chn msg)) + = case (decodeLaunchpadMessage' fullmsg) of+ Nothing -> return ()+ Just press -> do + -- putStrLn (show press)+ + case press of+ Release _ -> return ()+ Press button -> case button of+ + Ctrl ctrl -> do+ oldctrl <- takeMVar theLaunchpadMode + putMVar theLaunchpadMode ctrl+ when (oldctrl/=ctrl) $ do+ putStrLn $ "mode = " ++ show ctrl+ pushUpdates (turnOff1 (Ctrl oldctrl) ++ setColor1 (Ctrl ctrl) controlColor) + when (ctrl == User2) $ do+ threadDelay (100*1000) -- Ableton also wants to erase the launchpad. 50 msec does not seem to be always enough+ sendMsg resetMsg+ fullRender app+ + _ -> return ()+ + whenUser2 globalConfig $ do + mode <- takeMVar appMode+ state <- takeMVar appState+ let cfg = pAppConfig clientApp+ let ((mode',state'),messages) = (pAppButton clientApp) cfg press (mode,state) + + -- print messages+ -- print state'+ + putMVar appMode mode'+ putMVar appState state' + + mapM_ (send outconn2) $ map (MidiMessage (outputChannel globalConfig)) messages + + diffRender app+ +appLaunchpadCallback _ _ _ = return ()++--------------------------------------------------------------------------------++appSyncHandler :: (GlobalConfig, PureApp cfg mode state, MVar mode, MVar state) -> Connection -> MidiEvent -> IO ()+appSyncHandler app@(globalConfig,clientApp,appMode,appState) outconn2 event@(MidiEvent time msg) = case msg of+ + SRTStart -> do+ -- replaceMVar theSyncBuffer [] + replaceMVar thePlayingFlag True+ replaceMVar theSyncCounter (-1)+ + state <- takeMVar appState+ let cfg = pAppConfig clientApp+ let !state' = (pAppStartStop clientApp) cfg True state+ putMVar appState state'++ whenUser2 globalConfig $ diffRender' (Just 0) app+ + SRTClock -> do+ oldn <- takeMVar theSyncCounter+ let counter = oldn + 1+ putMVar theSyncCounter counter+ + readMVar thePlayingFlag >>= \b -> when b $ do+ + mode <- readMVar appMode+ state <- takeMVar appState+ let cfg = pAppConfig clientApp+ let (!state',messages) = (pAppSync clientApp) cfg mode state counter+ putMVar appState state'+ + mapM_ (send outconn2) $ map (MidiMessage (outputChannel globalConfig)) messages+ + whenUser2 globalConfig $ diffRender' (Just counter) app+ +{- +-- we don't really need this + xs <- takeMVar theSyncBuffer+ let t = fromIntegral time :: Double+ ys = (t:xs)+ putMVar theSyncBuffer (take 24 ys)+ let avg = foldl' (+) 0 (zipWith (-) ys xs) / fromIntegral (length xs)+ bpm = 2500 / avg+ replaceMVar theBPM bpm+ putStrLn $ "estimated bpm = " ++ show bpm+-}+ + SRTStop -> do+ replaceMVar thePlayingFlag False++ state <- takeMVar appState+ let cfg = pAppConfig clientApp+ let !state' = (pAppStartStop clientApp) cfg False state+ putMVar appState state'++ whenUser2 globalConfig $ diffRender' Nothing app++ _ -> return ()++-------------------------------------------------------------------------------- +-- * render the buttons++diffRender :: (GlobalConfig, PureApp cfg mode state, MVar mode, MVar state) -> IO ()+diffRender app = do+ b <- readMVar thePlayingFlag+ n <- readMVar theSyncCounter+ let mcnt = if b then Just n else Nothing+ diffRender' mcnt app++fullRender :: (GlobalConfig, PureApp cfg mode state, MVar mode, MVar state) -> IO ()+fullRender app = do+ b <- readMVar thePlayingFlag+ n <- readMVar theSyncCounter+ let mcnt = if b then Just n else Nothing+ fullRender' mcnt app+ +diffRender' :: Maybe Int -> (GlobalConfig, PureApp cfg mode state, MVar mode, MVar state) -> IO ()+diffRender' mcounter (globalConfig, clientApp, appMode, appState) = do+ mode <- readMVar appMode+ state <- readMVar appState+ let cfg = pAppConfig clientApp + let newScreen = sortNubMap $ (Ctrl User2, controlColor) : (pAppRender clientApp) cfg mode state mcounter+ oldScreen <- takeMVar theLastScreen+ putMVar theLastScreen newScreen+ let diff = unsafeRenderDiff oldScreen newScreen + pushUpdates diff+ +fullRender' :: Maybe Int -> (GlobalConfig, PureApp cfg mode state, MVar mode, MVar state) -> IO ()+fullRender' mcounter (globalConfig, clientApp, appMode, appState) = do+ mode <- readMVar appMode+ state <- readMVar appState+ let cfg = pAppConfig clientApp + let newScreen = sortNubMap $ (Ctrl User2, controlColor) : (pAppRender clientApp) cfg mode state mcounter+ _ <- takeMVar theLastScreen+ putMVar theLastScreen newScreen+ let full = rapidLedUpdateList newScreen + pushUpdates full+ +-------------------------------------------------------------------------------- ++
+ System/MIDI/Launchpad/Apps/Conway.hs view
@@ -0,0 +1,280 @@++-- | Conway's game of life on a 8x8 torus grid, outputting sound.+--+-- Press buttons to turn turn them on. The simulation is running only if +-- there is external MIDI sync signal coming (that is, press play in your DAW+-- of choice).+--+-- The triangle side buttons trigger predefined patterns (the bottom one +-- erasing the grid).+-- +-- The directional buttons choose between four different modes of +-- associating notes to the grid cells.+--+-- Example usage:+--+-- > main = runPureApp defaultGlobalConfig $ conway defaultCfg+--++{-# LANGUAGE BangPatterns #-}+module System.MIDI.Launchpad.Apps.Conway where++--------------------------------------------------------------------------------++import Data.List++import Control.Monad+import System.MIDI++import Data.Array.Unboxed+import Data.Array.IArray++import System.MIDI.Launchpad.Control+import System.MIDI.Launchpad.AppFramework++--------------------------------------------------------------------------------+ +data Cfg = Cfg+ { noteFrom :: !Int -- ^ the first note (eg. 60 is middle C)+ , midiScale :: !Scale -- ^ the musical scale to use + , stepFrequency :: !Int -- ^ speed of the simulation (larger is slower)+ }+ deriving Show+ +defaultCfg :: Cfg+defaultCfg = Cfg + { noteFrom = 0+ , midiScale = Chromatic -- Pentatonic+ , stepFrequency = 12+ }+ +--------------------------------------------------------------------------------++data Scale + = Chromatic + | Pentatonic+ | CMinor + | CMajor+ deriving (Eq,Show)++noteNumber :: Cfg -> Int -> Int+noteNumber (Cfg midiFrom midiScale _) y = + case midiScale of+ Chromatic -> midiFrom + y + Pentatonic -> midiFrom + penta !! y + CMajor -> midiFrom + cmajor !! y + CMinor -> midiFrom + cminor !! y + where+ penta = [ 0,2,4, 7,9, 12,14,16, 19,21 ] + cmajor = [ 0,2,4,5,7,9,11, 12,14,16,17,19,21,23] + cminor = [ 0,2,3,5,7,8,10, 12,14,15,17,19,20,22] + +gridNote :: Cfg -> Dir -> (Int,Int) -> Int+gridNote cfg notemode (x,y) = flip mod 128 $ case notemode of+ U -> noteNumber cfg y + 12*x+ D -> noteNumber cfg (7-y) + 12*x + L -> noteNumber cfg x + 12*y+ R -> noteNumber cfg (7-x) + 12*y+ +--------------------------------------------------------------------------------++data Mode = Conway deriving (Eq,Ord,Show)+ +data State = State + { _table :: !(UArray (Int,Int) Bool)+ , _playing :: !Bool+ , _screen :: !Int+ , _noteMode :: !Dir -- ^ four different ways to associate notes to the grid cells+ }+ deriving (Eq,Ord,Show)++ +initialState :: State +initialState = State + { _table = predefinedTable 0+ , _playing = False+ , _screen = 0+ , _noteMode = U+ }++--------------------------------------------------------------------------------++readTable :: [String] -> UArray (Int,Int) Bool+readTable lines = table where+ table = accumArray (flip const) False ((0,0),(7,7)) elems+ elems = [ ((x,y), c/=' ') | (y,line) <- zip [0..] lines, (x,c) <- zip [0..] line ]++-- | A \"block-laying switch engine\"+table0 :: [String]+table0 =+ [ ""+ , " xxx x"+ , " x "+ , " xx"+ , " xx x"+ , " x x x"+ ]+ +-- | The famous \"glider\"+table1 :: [String]+table1 =+ [ "" + , " x "+ , " x"+ , " xxx"+ ]+ +-- | The \"Lightweight spaceship\"+table2 :: [String]+table2 = + [ ""+ , " x x"+ , " x"+ , " x x"+ , " xxxx"+ ]+ +-- | \"Toad\" (period 2 oscillator)+table3 :: [String]+table3 = + [ ""+ , " x "+ , " x x"+ , " x x"+ , " x "+ ]++-- | \"Acorn\" +table4 :: [String]+table4 = + [ ""+ , ""+ , " x "+ , " x "+ , "xx xxx"+ ]++-- | Almost a \"Loaf\" (stationary), but added 1 extra cell to have something+table5 :: [String]+table5 = + [ " x" + , " xx "+ , " x xx "+ , " x x "+ , " x "+ ]++-- | \"R-pentonimo\"+table6 :: [String]+table6 = + [ " " + , " xx"+ , " xx "+ , " x "+ ]+ +predefinedTable :: Int -> UArray (Int,Int) Bool+predefinedTable k = readTable $ if k==7 then [] else (cycle allTables) !! k where+ allTables = + [ table0+ , table1+ , table2+ , table3+ , table4+ , table5+ , table6+ ]++-------------------------------------------------------------------------------- + +-- | Conway's game of life on a 8x8 grid+conway :: Cfg -> MonadicApp Cfg Mode State+conway cfg = MonadicApp + { mAppConfig = cfg+ , mAppIniState = (Conway,initialState)+ , mAppRender = render+ , mAppButton = button+ , mAppStartStop = startStop+ , mAppSync = sync+ } ++-------------------------------------------------------------------------------- ++neighbours :: (Int,Int) -> [(Int,Int)]+neighbours (x,y) = [(x-1,y ),(x+1,y ),(x ,y-1),(x ,y+1)+ ,(x-1,y-1),(x+1,y-1),(x-1,y+1),(x+1,y+1)+ ]++rule :: Bool -> Int -> Bool+rule True k = (k==2) || (k==3)+rule False 3 = True+rule _ _ = False+ +step :: State -> State+step state = state { _table = newtable } where+ oldtable = _table state + newtable = array ((0,0),(7,7)) [ (xy, rule (lkp xy) (countNeighbours xy)) | x<-[0..7], y<-[0..7], let xy=(x,y) ]+ lkp (x,y) = oldtable ! (mod x 8, mod y 8)+ countNeighbours xy = length $ filter id $ map lkp $ neighbours xy++-------------------------------------------------------------------------------- + +startStop :: Cfg -> Bool -> State -> State+startStop _ playing state = state { _playing = playing }++--------------------------------------------------------------------------------++button :: Cfg -> ButtonPress -> ButtonMonad Mode State ()+button cfg press = do+ case but of+ Side k -> modifyState $ \old -> old { _table = predefinedTable k , _screen = k } + Dir d -> when down $ modifyState $ \old -> old { _noteMode = d } + Pad x y -> when down $ do+ oldstate <- getState :: ButtonMonad Mode State State+ let table = _table oldstate+ new = not (table!(x,y))+ setState $ oldstate { _table = table // [ ( (x,y), new ) ] } + when (_playing oldstate) $ do + let k = gridNote cfg (_noteMode oldstate) (x,y) + sendMessage $ noteOnOff k new + _ -> return ()+ + where+ (but,down) = case press of+ Press b -> (b,True )+ Release b -> (b,False) + +--------------------------------------------------------------------------------++noteOnOff :: Int -> Bool -> MidiMessage'+noteOnOff k b = if b then NoteOn k 127 else NoteOff k 64++sync :: Cfg -> Mode -> Int -> SyncMonad State () +sync cfg@(Cfg _ _ stepFrequency) mode counter = + when (mod counter stepFrequency == 0) $ do + oldstate <- getState + let newstate = step oldstate+ oldtable = _table oldstate+ newtable = _table newstate+ setState $ newstate+ sendMessages [ noteOnOff k (bnew /= bold) + | (xy,bnew) <- assocs newtable+ , let bold = oldtable!xy+ , let k = gridNote cfg (_noteMode oldstate) xy + ] + +--------------------------------------------------------------------------------+ +render :: Cfg -> Mode -> State -> Maybe Int -> RenderMonad ()+render cfg mode state msync = do++ let sidecol = case msync of+ Just k -> if odd (div k (stepFrequency cfg)) then red else amber+ Nothing -> green+ setButtonColor (Side (_screen state) , sidecol) + setButtonColor (Dir (_noteMode state) , red)+ setButtonColors [ (Pad x y, if b then yellow else None) | ((x,y),b) <- assocs (_table state) ]+ +--------------------------------------------------------------------------------+ +
+ System/MIDI/Launchpad/Apps/DrumSeq.hs view
@@ -0,0 +1,223 @@+++-- | A simple drum sequencer app.+--+-- Each row plays a different note. +-- Each note can have a velocity; to set this, press the triangle button on the+-- right corresponding to the given row; then the columns represent velocities.+--+-- When there are more than 8 step, you can scroll with the left/right buttons+-- (jumping 8 steps).++-- Example usage:+--+-- > main = runMonadicApp defaultGlobalConfig $ drumSequencer defaultCfg+--++{-# LANGUAGE BangPatterns #-}+module System.MIDI.Launchpad.Apps.DrumSeq where++--------------------------------------------------------------------------------++import Data.List++import Control.Monad+import System.MIDI++import Data.Array.Unboxed+import Data.Array.IArray++import System.MIDI.Launchpad.Control+import System.MIDI.Launchpad.AppFramework++--------------------------------------------------------------------------------+ +data Cfg = Cfg + { seqSteps :: !Int -- ^ How many steps we have (it can be more than 8!)+ , stepResolution :: !Int -- ^ Length of a step. 24 is quarter note, 12 is 1/8th, etc.+ , midiFrom :: !Int -- ^ which note should be the lowest (MIDI notes, for example 36 or 48 or 60 are C notes)+ , defaultVelocity :: !Int -- ^ default velocity of a note (0..7)+ }+ deriving Show+ +-- | 8 steps by default, and 1/8th note per step+defaultCfg :: Cfg+defaultCfg = Cfg + { seqSteps = 8 + , stepResolution = 12 + , midiFrom = 36 -- in ableton, drum racks typically start here?+ , defaultVelocity = 5 + }++--------------------------------------------------------------------------------++data Mode + = Pattern + | Velocities !Int+ deriving (Eq,Ord,Show)+ +data State = State + { _playing :: !Bool+ , _screenPos :: !Int+ , _notes :: !(UArray (Int,Int) Int) -- ^ encoding both velocities and notes+ , _playNotes :: [PlayNote]+ }+ deriving (Eq,Ord,Show)++-- | Notes played at the moment+data PlayNote = PlayNote+ { _note :: !Int+ , _stopAt :: !Int+ }+ deriving (Eq,Ord,Show)++-- | A drum sequencer app. +drumSequencer :: Cfg -> MonadicApp Cfg Mode State+drumSequencer cfg = MonadicApp+ { mAppConfig = cfg+ , mAppIniState = (Pattern, initialState cfg)+ , mAppStartStop = startStop+ , mAppRender = render+ , mAppButton = button+ , mAppSync = sync+ } ++--------------------------------------------------------------------------------+ +initialState :: Cfg -> State +initialState cfg@(Cfg seqSteps stepResolution _ _) = State + { _playing = False+ , _screenPos = 0+ , _notes = listArray ((0,0),(seqSteps+7,7)) (repeat (-1))+ , _playNotes = []+ }+ where+ rep = replicate seqSteps+ +startStop :: Cfg -> Bool -> State -> State+startStop cfg playing state = state { _playing = playing }++--------------------------------------------------------------------------------++button :: Cfg -> ButtonPress -> ButtonMonad Mode State ()+button _ (Release _) = return ()+button cfg@(Cfg seqSteps _ _ _) (Press but) = do++ mode <- getMode+ state <- getState ++ let pos = _screenPos state+ notes = _notes state++ let lastScreenPos = 8 * div (seqSteps - 1) 8++ case but of++ Dir d -> case d of+ L -> setState $ state { _screenPos = max (pos-8) 0 } + R -> setState $ state { _screenPos = min (pos+8) lastScreenPos }+ _ -> return ()++ Side k -> case mode of+ Pattern -> setMode $ Velocities k+ Velocities u -> setMode $ if u/=k then Velocities k else Pattern + + Pad x y -> case mode of++ Pattern -> do+ let old = notes!(pos+x,y)+ new = if old>=0 then -1 else (defaultVelocity cfg) + setState $ state { _notes = notes // [((pos+x,y),new)] } + return ()+{- + -- also give a sound? but who will stop it?+ when (not $ _playing state) $ do+ sendMessage $ noteOnOff cfg True (7-y) (defaultVelocity cfg)+-}+ + Velocities u -> when (notes!(pos+x,u) >= 0) $+ setState $ state { _notes = notes // [((pos+x,u), 7-y)] } where+ + _ -> return ()+ ++--------------------------------------------------------------------------------++counterStep :: Cfg -> Int -> Int +counterStep (Cfg seqSteps stepResolution _ _) cnt = ((div cnt stepResolution) `mod` seqSteps)++invCounterStep :: Cfg -> Int -> Int+invCounterStep (Cfg seqSteps stepResolution _ _) step = step*stepResolution++totalTicks :: Cfg -> Int+totalTicks (Cfg seqSteps stepResolution _ _) = stepResolution * seqSteps++-- velo 0..7 (ahol 0 nem nulla hanem -1 az igazi csondes)+noteOnOff :: Cfg -> Bool -> Int -> Int -> MidiMessage'+noteOnOff cfg True y velo = NoteOn (midiFrom cfg + 7-y) ((velo+1)*16-1)+noteOnOff cfg False y velo = NoteOff (midiFrom cfg + 7-y) 64+ +--------------------------------------------------------------------------------++sync :: Cfg -> Mode -> Int -> SyncMonad State () +sync cfg@(Cfg seqSteps stepResolution midiFrom _) mode counter = do+ state <- getState ++ let notes = _notes state++ let newIdx = [ (x,y) | x <- [0..seqSteps-1], y<-[0..7], let v = notes!(x,y), v>=0+ , invCounterStep cfg x == mod counter (totalTicks cfg) ]++ let newNotes = [ PlayNote y (counter + stepResolution) + | (x,y) <- newIdx ]+ + let (stopNotes, contNotes) = partition (\(PlayNote note stop) -> stop == counter) (_playNotes state)+ + sendMessages [ noteOnOff cfg False stop 64 | PlayNote stop _ <- stopNotes ]+ sendMessages [ noteOnOff cfg True y vel | (x,y) <- newIdx, let vel = notes!(x,y) ]+ + setState $ state { _playNotes = newNotes ++ contNotes }+++--------------------------------------------------------------------------------++renderArrows :: Cfg -> State -> [(Button,Color)]+renderArrows cfg state = concat+ [ if _screenPos state > 0 then [(Dir L, green)] else []+ , if _screenPos state < (seqSteps cfg)-8 then [(Dir R, green)] else [] + ]+ +render :: Cfg -> Mode -> State -> Maybe Int -> RenderMonad ()+render cfg mode state msync = + do+ + setButtonColors $ renderArrows cfg state + setButtonColors $ stuff + + where++ pos = _screenPos state+ notes = _notes state+ + steps = seqSteps cfg+ + column = case msync of+ Nothing -> (-1)+ Just cnt -> counterStep cfg cnt - pos+ + stuff = case mode of+ + Pattern -> time ++ note where+ time = if column >= 0 && column < 8 then [ (Pad column y, amber) | y<-[0..7] ] else [] + note = [ (Pad x y, color) | x<-[0..7], y<-[0..7], let v = notes!(pos+x,y), pos+x<steps, v>=0+ , let color = if column==x then orange else red ]+ + Velocities u -> time ++ par ++ side where+ time = if column >= 0 && column < 8 then [ (Pad column 0, amber) ] else []+ par = [ (Pad x y, color) | x<-[0..7], let p = notes!(pos+x,u), p>=0, pos+x<steps, y<-[7-p..7]+ , let color = if column==x && y==0 then yellow else green ] + side = [ (Side u, green) ]+ +--------------------------------------------------------------------------------+ +
+ System/MIDI/Launchpad/Apps/FXControl.hs view
@@ -0,0 +1,168 @@++-- | A very simple generic live FX control surface.+--+-- There are 8 CCs (the 8 columns of the grid), and 8 trigger buttons+-- (the side buttons).+--+-- The trigger buttons can function either as an on/off switch or +-- as gate (active only during pressed). This is selectable by pressing +-- down the side button(s) and at the same time the up/down button.+-- By default, the top four are switched, the bottom four gate.+--+-- Example usage:+--+-- > main = runPureApp defaultGlobalConfig $ fxControl defaultCfg+--++{-# LANGUAGE BangPatterns #-}+module System.MIDI.Launchpad.Apps.FXControl where++--------------------------------------------------------------------------------++import Data.List++import Control.Monad+import System.MIDI++import Data.Array.Unboxed+import Data.Array.IArray++import System.MIDI.Launchpad.Control+import System.MIDI.Launchpad.AppFramework++--------------------------------------------------------------------------------++data Cfg = Cfg+ { ccFrom :: !Int -- ^ the first CC number, corresponding to the first column on the Launchpad+ , onOffFrom :: !Int -- ^ the first note (used as on/off switch), corresponding the topmost triangle button on Launchpad+ }+ deriving Show+ +defaultCfg :: Cfg+defaultCfg = Cfg + { ccFrom = 100+ , onOffFrom = 100+ }+ +--------------------------------------------------------------------------------++data Mode = FX deriving (Eq,Ord,Show)+ +data Trigger = Switch | Gate deriving (Eq,Ord,Show) {- InvGate -}++data State = State + { _onOff :: !(UArray Int Bool)+ , _isPressed :: !(UArray Int Bool)+ , _triggerMode :: !(Array Int Trigger) + , _params :: !(UArray Int Int)+ , _playing :: !Bool+ }+ deriving (Eq,Ord,Show)+ +-- | A very simple generic live FX control surface+fxControl :: Cfg -> PureApp Cfg Mode State+fxControl cfg = PureApp + { pAppConfig = cfg+ , pAppIniState = (FX,initialState)+ , pAppRender = render+ , pAppButton = button+ , pAppStartStop = startStop+ , pAppSync = sync+ } ++--------------------------------------------------------------------------------+ +initialState :: State +initialState = State + { _onOff = listArray (0,7) (repeat False)+ , _isPressed = listArray (0,7) (repeat False)+ , _triggerMode = listArray (0,7) (replicate 4 Switch ++ replicate 4 Gate)+ , _params = listArray (0,7) (repeat 4)+ , _playing = False+ }+ +startStop :: Cfg -> Bool -> State -> State+startStop _ playing state = state { _playing = playing }++--------------------------------------------------------------------------------++button :: Cfg -> ButtonPress -> (Mode,State) -> ((Mode,State),[MidiMessage'])+button (Cfg ccfrom notefrom) press (mode,state) = + case but of++ Dir d -> case d of+ U -> ((mode, trigger' Switch),[])+ D -> ((mode, trigger' Gate ),[])+ _ -> ((mode,state),[]) ++ Side k -> case (trigger!k) of+ Switch -> if not down + then ( ( mode , state' k ) , [] )+ else ( ( mode , (state' k) { _onOff = onOff // [(k,new)] } ) , [ noteOnOff k new ] )+ where old = onOff ! k+ new = not old + Gate -> ( ( mode , (state' k) { _onOff = onOff // [(k,down)] } ) , [ noteOnOff k down ] )+ + Pad x y -> if down+ then ( ( mode, state { _params = params // [(x, 7-y)] } ) , [CC (ccNumber x) ((7-y)*16)] ) + else ((mode,state),[])+ + _ -> ((mode,state),[])+ + where + state' k = state { _isPressed = isPressed // [(k,down)] }++ trigger' Gate = state { _triggerMode = trigger // [ (k,Gate ) | (k,True) <- pressedList ] + , _onOff = onOff // [ (k,True ) | (k,True) <- pressedList ] + }+ trigger' Switch = state { _triggerMode = trigger // [ (k,Switch) | (k,True) <- pressedList ]+ , _onOff = onOff // [ (k,True ) | (k,True) <- pressedList, trigger!k == Gate ] + }+ + noteOnOff k b = if b + then NoteOn (notefrom+k) 127+ else NoteOn (notefrom+k) 127 -- hmm, Ableton seems to work like that (only changes on NoteOn)++ ccNumber x = ccfrom + x+ + onOff = _onOff state+ params = _params state+ trigger = _triggerMode state+ isPressed = _isPressed state+ pressedList = assocs isPressed++ (but,down) = case press of+ Press b -> (b,True )+ Release b -> (b,False)++ +--------------------------------------------------------------------------------++sync :: Cfg -> Mode -> State -> Int -> (State,[MidiMessage']) +sync _ mode state counter = (state,[]) ++--------------------------------------------------------------------------------+ +render :: Cfg -> Mode -> State -> Maybe Int -> [(Button,Color)]+render _ mode state msync = stuff where++ onOff = _onOff state+ params = _params state+ trigger = _triggerMode state+ isPressed = _isPressed state+ + stuff = par ++ side+ + par = [ (Pad x y, color) | x<-[0..7], let p = params!x, p>0, y<-[7-p..7]+ , let color = green ] ++ side = [ (Side y, color) | y<-[0..7], let b = onOff!y, let color = trigColor y b ] ++ trigColor y b = case trigger!y of+ Switch -> if b then amber else None+ Gate -> if b then red else None+ -- InvGate -> if not b then green else None+ +--------------------------------------------------------------------------------+ +
+ System/MIDI/Launchpad/Apps/MonoSeq.hs view
@@ -0,0 +1,241 @@++-- | A monophonic sequencer app.+--+-- Each note can have a velocity, length, offset (small delay relative to +-- the grid position), and 5 custom CC commands.+-- The parameters can be set up using the 8 triangle buttons (top one is +-- velocity, second is length, etc).+--+-- When there are more than 8 step, you can scroll with the left/right buttons+-- (jumping 8 steps).+--+-- Example usage:+--+-- > main = runPureApp defaultGlobalConfig $ monoSequencer defaultCfg+--++{-# LANGUAGE BangPatterns #-}+module System.MIDI.Launchpad.Apps.MonoSeq where++--------------------------------------------------------------------------------++import Data.List++import Control.Monad+import System.MIDI++import Data.Array.Unboxed+import Data.Array.IArray++import System.MIDI.Launchpad.Control+import System.MIDI.Launchpad.AppFramework++--------------------------------------------------------------------------------++data Scale + = Chromatic + | Pentatonic+ | CMinor + | CMajor+ deriving (Eq,Show)+ +data Cfg = Cfg + { seqSteps :: !Int -- ^ How many steps we have (it can be more than 8!)+ , stepResolution :: !Int -- ^ Length of a step. 24 is quarter note, 12 is 1/8th, etc.+ , midiFrom :: !Int -- ^ which note should be the lowest (MIDI notes, for example 36 or 48 or 60 are C notes)+ , midiScale :: !Scale+ , ccFrom :: !Int -- ^ where to start to 5 consecutive CC commands+ }+ deriving Show+ +-- | 8 steps by default, and 1/8th note per step+defaultCfg :: Cfg+defaultCfg = Cfg + { seqSteps = 8 + , stepResolution = 12 + , midiFrom = 48+ , midiScale = Pentatonic+ , ccFrom = 90+ }++--------------------------------------------------------------------------------++data Mode + = Notes + | Params !Int+ deriving (Eq,Ord,Show)+ +data State = State + { _playing :: !Bool+ , _screenPos :: !Int+ , _notes :: !(UArray Int Int)+ , _params :: !(UArray (Int,Int) Int)+ , _playNotes :: [PlayNote]+ }+ deriving (Eq,Ord,Show)++-- | Notes played at the moment+data PlayNote = PlayNote+ { _note :: !Int+ , _stopAt :: !Int+ }+ deriving (Eq,Ord,Show)++-- | A monophonic sequencer app. +monoSequencer :: Cfg -> PureApp Cfg Mode State+monoSequencer cfg = PureApp+ { pAppConfig = cfg+ , pAppIniState = (Notes, initialState cfg)+ , pAppStartStop = startStop+ , pAppRender = render+ , pAppButton = button+ , pAppSync = sync+ } ++--------------------------------------------------------------------------------+ +initialState :: Cfg -> State +initialState cfg@(Cfg seqSteps stepResolution _ _ _) = State + { _playing = False+ , _screenPos = 0+ , _notes = listArray (0,seqSteps+7) (repeat (-1))+ , _params = listArray ((0,0),(seqSteps+7,7)) + $ concat $ transpose $ + [ rep 5 , rep 3 , rep 0 , rep 4+ , rep 4 , rep 4 , rep 4 , rep 4 ]+ , _playNotes = []+ }+ where+ rep = replicate seqSteps+ +startStop :: Cfg -> Bool -> State -> State+startStop cfg playing state = state { _playing = playing }++--------------------------------------------------------------------------------++button :: Cfg -> ButtonPress -> (Mode,State) -> ((Mode,State),[MidiMessage'])+button cfg@(Cfg seqSteps stepResolution _ _ _) (Release _) old = (old,[])+button cfg@(Cfg seqSteps stepResolution _ _ _) (Press but) (mode,state) = ++ case but of++ Dir d -> case d of+ L -> ((mode, state { _screenPos = max (pos-8) 0 }) , []) + R -> ((mode, state { _screenPos = min (pos+8) lastScreenPos }) , [])+ _ -> ((mode,state),[])++ Side k -> case mode of+ Notes -> ( ( Params k , state ) , [] )+ Params u -> ( ( if u/=k then Params k else Notes , state ) + , if _playing state then [] else [CC (ccNumber cfg k) 64] )+ + Pad x y -> case mode of++ Notes -> ( ( mode, state { _notes = notes // [(pos+x, new)] } ) , [] ) where+ new = if old==y then -1 else y + old = notes!(pos+x)+ + Params u -> ( ( mode, state { _params = params // [((pos+x,u), 7-y)] } ) , [] ) where+ old = params!(pos+x,u)+ + _ -> ((mode,state),[])+ + where ++ lastScreenPos = 8 * div (seqSteps - 1) 8++ pos = _screenPos state+ notes = _notes state+ params = _params state++--------------------------------------------------------------------------------++counterStep :: Cfg -> Int -> Int +counterStep (Cfg seqSteps stepResolution _ _ _) cnt = ((div cnt stepResolution) `mod` seqSteps)++invCounterStep :: Cfg -> Int -> Int+invCounterStep (Cfg seqSteps stepResolution _ _ _) step = step*stepResolution++totalTicks :: Cfg -> Int+totalTicks (Cfg seqSteps stepResolution _ _ _) = stepResolution * seqSteps++ccNumber :: Cfg -> Int -> Int+ccNumber (Cfg _ _ _ _ ccFrom) y = ccFrom + y - 3++noteNumber :: Cfg -> Int -> Int+noteNumber (Cfg _ _ midiFrom midiScale _) y = + case midiScale of+ Chromatic -> midiFrom + y + Pentatonic -> midiFrom + penta !! y + CMajor -> midiFrom + cmajor !! y + CMinor -> midiFrom + cminor !! y + where+ penta = [ 0,2,4, 7,9, 12,14,16, 19,21 ] + cmajor = [ 0,2,4,5,7,9,11, 12,14,16,17,19,21,23] + cminor = [ 0,2,3,5,7,8,10, 12,14,15,17,19,20,22] + +--------------------------------------------------------------------------------++sync :: Cfg -> Mode -> State -> Int -> (State,[MidiMessage']) +sync cfg@(Cfg seqSteps stepResolution midiFrom midiScale ccFrom) mode state counter = (state',msgs) where++ state' = state { _playNotes = newNotes ++ contNotes }+ newNotes = [ PlayNote note (counter + 2*(len+1)) + | x <- newIdx, let len = (div stepResolution 4) * (1+params!(x,1))+ , let note = notes!x, note>=0 ]++ newIdx = [ x | x <- [0..seqSteps-1], let y = notes!x, y>=0+ , invCounterStep cfg x + delay x == mod counter (totalTicks cfg) ]++ (stopNotes, contNotes) = partition (\(PlayNote note stop) -> stop == counter) (_playNotes state)+ + notes = _notes state+ params = _params state+ delay x = params!(x,2) -- 0 is velocity, 1 is length, 2 is delay+ + msgs = [ NoteOff (toNote stop) 64 | PlayNote stop _ <- stopNotes ]+ ++ [ CC (ccNumber cfg y) value | x <- newIdx, let start = notes!x+ , y <-[3..7] , let value = (params!(x,y))*16 ]+ ++ [ NoteOn (toNote start) vel | x <- newIdx, let start = notes!x+ , let vel = (params!(x,0)+1)*16-1 ] + + toNote y = if y>=0 then noteNumber cfg (7-y) else error "MonoSeq/sync/toNote: shouldn't happen"+++--------------------------------------------------------------------------------++renderArrows :: Cfg -> State -> [(Button,Color)]+renderArrows cfg@(Cfg seqSteps _ _ _ _) state = concat+ [ if _screenPos state > 0 then [(Dir L, green)] else []+ , if _screenPos state < seqSteps-8 then [(Dir R, green)] else [] + ]+ +render :: Cfg -> Mode -> State -> Maybe Int -> [(Button,Color)]+render cfg mode state msync = renderArrows cfg state ++ stuff where++ pos = _screenPos state+ notes = _notes state+ params = _params state + + steps = seqSteps cfg+ + column = case msync of+ Nothing -> (-1)+ Just cnt -> counterStep cfg cnt - pos+ + stuff = case mode of+ + Notes -> time ++ note where+ time = if column >= 0 && column < 8 then [ (Pad column y, amber) | y<-[0..7] ] else [] + note = [ (Pad x y, color) | x<-[0..7], let y = notes!(pos+x), pos+x<steps, y>=0+ , let color = if column==x then orange else red ]+ + Params u -> time ++ par ++ side where+ time = if column >= 0 && column < 8 then [ (Pad column 0, amber) ] else []+ par = [ (Pad x y, color) | x<-[0..7], let p = params!(pos+x,u), pos+x<steps, p>0, y<-[7-p..7]+ , let color = if column==x && y==0 then yellow else green ] + side = [ (Side u, green) ]+ +--------------------------------------------------------------------------------+ +
+ System/MIDI/Launchpad/Control.hs view
@@ -0,0 +1,376 @@++-- | Low-level interface to the Novation Launchpad.++module System.MIDI.Launchpad.Control where++--------------------------------------------------------------------------------++import Data.Array+import Data.Bits++import Control.Concurrent+import Control.Concurrent.MVar ()+import Control.Monad++-- import Data.Set (Set) ; import qualified Data.Set as Set+import Data.Map (Map) ; import qualified Data.Map as Map++import System.IO.Unsafe as Unsafe++import System.MIDI++-- import Debug.Trace++--------------------------------------------------------------------------------+-- * definitions++-- | A button of the launchpad. Numbering starts from zero. +-- +-- (Note that the derived ordering is the same as the \"rapid LED update\" order!)+--+data Button+ = Pad { _padX :: !Int , _padY :: !Int } -- ^ the 64 buttons in the grid+ | Side { _sideCol :: !Int } -- ^ the 8 buttons on the right side + | Dir { _unDir :: !Dir } -- ^ the left 4 buttons in the control row+ | Ctrl { _unCtrl :: !Control } -- ^ the right 4 buttons in the control row+ deriving (Eq,{-Ord,-}Show)+ +instance Ord Button where++ compare (Pad x1 y1) (Pad x2 y2) = compare (y1,x1) (y2,x2) -- !!+ compare (Pad _ _ ) _ = LT+ compare _ (Pad _ _ ) = GT++ compare (Side a) (Side b) = compare a b+ compare (Side _) _ = LT+ compare _ (Side _) = GT+ + compare (Dir d1) (Dir d2) = compare d1 d2+ compare (Dir _ ) _ = LT+ compare _ (Dir _ ) = GT+ + compare (Ctrl c1) (Ctrl c2) = compare c1 c2 ++-- compare x y = trace "jajj" $ trace (show x ++ " | " ++ show y) $ error (show x ++ " | " ++ show y)+ +-------------------------------------------------------------------------------- + +-- | A direction, also the left top 4 control buttons in the top row.+data Dir = U | D | L | R deriving (Eq,Ord,Show)++-- | A control button (right 4 in the top row)+data Control + = Session + | User1 + | User2 + | Mixer+ deriving (Eq,Ord,Show)+ +-- | Double-buffering.+data Buffer = Front | Back deriving (Eq,Ord,Show) ++-- | Note: there is some overlap between 'Yellow' and 'Amber'.+data FullColor = Red | Amber | Yellow | Green deriving (Eq,Ord,Show)++-- | Note: there is some overlap between 'Off' and 'None',+data Brightness = Off | Low | Medium | Full deriving (Eq,Ord,Show)++-- | A color. There are two possible specifications:+--+-- * either a predefined color with a brightness;+--+-- * or exact control of the red and greed leds.+--+data Color + = None+ | Color !FullColor !Brightness+ | RedGreen !Brightness !Brightness+-- | Flash !FulLColor+ deriving (Eq,Ord,Show)+ +--------------------------------------------------------------------------------+-- * basic midi ++type Message = MidiMessage+type Messages = [Message]++noteOn, noteOff, cc :: Int -> Int -> Message+noteOn k v = MidiMessage 1 (NoteOn k v)+noteOff k v = MidiMessage 1 (NoteOff k v)+cc k v = MidiMessage 1 (CC k v)++-- | in-connection, out-connection+theGlobalConnections :: MVar (Connection,Connection)+theGlobalConnections = Unsafe.unsafePerformIO newEmptyMVar ++initializeLaunchpad :: Connection -> Connection -> IO ()+initializeLaunchpad inconn outconn = do+ _ <- tryTakeMVar theGlobalConnections+ putMVar theGlobalConnections (inconn,outconn)+ handShake -- ??????????+ +sendMsg :: Messages -> IO ()+sendMsg msgs = do+ (inconn,outconn) <- readMVar theGlobalConnections+ mapM_ (send outconn) msgs + +--------------------------------------------------------------------------------+-- * encoding colors++encodeColor :: Color -> Int+encodeColor None = 12+encodeColor (Color full br) = colorTable full br+encodeColor (RedGreen a b) = encodeBrightness a + 12 + 16 * encodeBrightness b +-- encodeColor (Flash full ) = flashColor full++encodeBrightness :: Brightness -> Int+encodeBrightness br = case br of+ Off -> 0+ Low -> 1+ Medium -> 2 + Full -> 3 ++colorTable :: FullColor -> Brightness -> Int+colorTable _ Off = 12+colorTable Red br = case br of { Low -> 13 ; Medium -> 14 ; Full -> 15 ; Off -> 12 }+colorTable Amber br = case br of { Low -> 29 ; Medium -> 46 ; Full -> 63 ; Off -> 12 }+colorTable Yellow br = case br of { Low -> 45 ; Medium -> 45 ; Full -> 62 ; Off -> 12 }+colorTable Green br = case br of { Low -> 28 ; Medium -> 44 ; Full -> 60 ; Off -> 12 }++flashColor :: FullColor -> Int+flashColor c = case c of+ Red -> 11+ Amber -> 59+ Yellow -> 58+ Green -> 56++{- +xyLayout :: Button -> Int+xyLayout b = case b of+ Pad x y -> x + y*16+ Side y -> 8 + y*16+ Ctrl _ -> error "xyLayout"+-}++--------------------------------------------------------------------------------+-- * setting single leds++setColor1 :: Button -> Color -> Messages+setColor1 but col = [setColor' but (encodeColor col)]++turnOff1 :: Button -> Messages+turnOff1 but = setColor1 but None++turnOff :: [Button] -> Messages+turnOff buts = setColor $ zip buts (repeat None)++setColor :: [(Button,Color)] -> Messages+setColor bcs = map f bcs where f (b,c) = setColor' b (encodeColor c)++setColor' :: Button -> Int -> Message+setColor' but dat = case but of+ Pad x y -> noteOn (x + y*16) dat+ Side y -> noteOn (8 + y*16) dat+ _ -> cc (marshalControl but) dat+ +--------------------------------------------------------------------------------+-- * control buttons++marshalControl :: Button -> Int+marshalControl (Dir d) = case d of { U -> 104 ; D -> 105 ; L -> 106 ; R -> 107 }+marshalControl (Ctrl c) = case c of + Session -> 108+ User1 -> 109+ User2 -> 110+ Mixer -> 111+marshalControl _ = error "marshalControl"++unmarshalControl' :: Int -> Maybe Button+unmarshalControl' key = case key of+ 104 -> Just $ Dir U+ 105 -> Just $ Dir D+ 106 -> Just $ Dir L+ 107 -> Just $ Dir R+ 108 -> Just $ Ctrl Session+ 109 -> Just $ Ctrl User1+ 110 -> Just $ Ctrl User2+ 111 -> Just $ Ctrl Mixer+ _ -> Nothing++unmarshalControl :: Int -> Button +unmarshalControl key = case unmarshalControl' key of+ Just but -> but+ Nothing -> error ("unmarshalControl: " ++ show key)+ +--------------------------------------------------------------------------------+-- * initialization++-- | Officially, reset is simply @CC 0 0@. But the Launchpad implementation+-- is rather strange and somewhat stupid, see+-- <http://linuxaudio.org/mailarchive/lau/2012/7/12/191303>+--+-- This convoluted reset sequence may or may not help...+resetMsg :: Messages+resetMsg = + [ cc 0 2, noteOn 64 12 -- just do something with both cc and noteon+ , cc 0 1, noteOn 0 12+ , noteOff 0 0 -- just to be safe??????+ , cc 0 0 -- reset+ , cc 0 48 -- double buffering control + ]+ +-- | Turns on all leds+turnOnAll :: Brightness -> Messages+turnOnAll Off = []+turnOnAll Low = [cc 0 125]+turnOnAll Medium = [cc 0 126]+turnOnAll Full = [cc 0 127]++-- | The argument controls if we want to flash all the leds for a moment+resetLaunchpad :: Bool -> IO ()+resetLaunchpad b = do+ putStrLn "reset launchpad"+ +-- wait+-- fake+ wait+ sendMsg resetMsg -- reset+ wait+-- fake+-- wait+ when b $ do+ putStrLn "flashing all leds" + sendMsg (turnOnAll Low)+ threadDelay (100*1000)+ sendMsg resetMsg -- reset+ threadDelay (200*1000)+-- fake +-- wait+ where+ fake = sendMsg (turnOff1 (Pad 0 0))+ wait = threadDelay 5000 -- it seems that Launchpad needs some time after a reset++--------------------------------------------------------------------------------++-- Launchpad is stupid... see http://linuxaudio.org/mailarchive/lau/2012/7/12/191303+-- this causes all kinds of problems+++-- some serious hacking here+-- from http://grrrue.midimidimidi.org/launchpad/reversepad/index.php +handShake :: IO ()+handShake = do+ wait+ sendMsg [Reset] -- midi reset?+ wait+{-+ sendMsg+ [ cc 16 1+ , cc 17 103+ , cc 18 29+ , cc 19 83+ , cc 20 23+ ]+ wait+-}+ where+ wait = threadDelay 5000 + ++--------------------------------------------------------------------------------+-- * button presses++-- | A button is pressed or released+data ButtonPress + = Press !Button+ | Release !Button+ deriving (Eq,Ord,Show)++-- | Constructor +buttonPress :: Bool -> Button -> ButtonPress+buttonPress True b = Press b+buttonPress False b = Release b+ +decodeLaunchpadMessage' :: Message -> Maybe ButtonPress+decodeLaunchpadMessage' (MidiMessage chn msg) = {- trace (show msg) $ -} case msg of+ NoteOn key vel -> Just $ buttonPress (vel>0) button where+ button = case x of { 8 -> Side y ; _ -> Pad x y } + (y,x) = divMod key 16 + NoteOff key vel -> Just $ buttonPress False button where -- hmidi translates velocity 0 to noteoff+ button = case x of { 8 -> Side y ; _ -> Pad x y } + (y,x) = divMod key 16 + CC key vel -> liftM (buttonPress (vel>0)) (unmarshalControl' key) + _ -> Nothing+decodeLaunchpadMessage' _ = Nothing+ +-- | Unsafe decoding, may throw error+decodeLaunchpadMessage :: Message -> ButtonPress+decodeLaunchpadMessage msg = case decodeLaunchpadMessage' msg of+ Just p -> p+ Nothing -> error ("decodeLaunchpadMessage: " ++ show msg)+ +--------------------------------------------------------------------------------+-- * led update++-- | Sorted list of all Launchpad buttons (sort order is the \"rapid led update\" order)+allButtons :: [Button]+allButtons + = [ Pad x y | y<-[0..7] , x<-[0..7] ]+ ++ [ Side y | y<-[0..7] ]+ ++ [ Dir U, Dir D, Dir L, Dir R]+ ++ [ Ctrl Session, Ctrl User1, Ctrl User2, Ctrl Mixer ]++-- | +data Grid = Grid+ { _gridMain :: Array (Int,Int) Color -- ^ 8x8 array of the main grid+ , _gridSide :: Array Int Color -- ^ length 8 array of the right column+ , _gridCtrl :: Array Int Color -- ^ length 8 array of the top row+ }+ deriving (Show)++-- | Actually this is at the moment empty.+ledUpdateInit :: Messages+ledUpdateInit = [ ] ++-- | We have to exit the rapid led update mode before the next update!+-- Setting the grid coordinate mode to XY should do the trick.+ledUpdateClose :: Messages+ledUpdateClose = [ cc 0 1 ] ++-- | Untested (the grid may be trransposed??) +rapidLedUpdateArr :: Grid -> Messages+rapidLedUpdateArr (Grid main side ctrl) = ledUpdateInit ++ msg1 ++ msg2 ++ msg3 ++ ledUpdateClose where+ msg1 = [ MidiMessage 3 (xxNoteOn p q) | (p,q) <- pairs (elems main) ]+ msg2 = [ MidiMessage 3 (xxNoteOn p q) | (p,q) <- pairs (elems side) ]+ msg3 = [ MidiMessage 3 (xxNoteOn p q) | (p,q) <- pairs (elems ctrl) ]++rapidLedUpdateList :: [(Button,Color)] -> Messages+rapidLedUpdateList stuff = ledUpdateInit ++ list ++ ledUpdateClose where++ list = [ MidiMessage 3 (xxNoteOn p q) | (p,q) <- pairs (go stuff1 allButtons) ] + stuff1 = sortNubMap stuff+ + go :: [(Button,Color)] -> [Button] -> [Color]+ go [] ns = [ None | n <- ns ]+ go bcbcs@((b,c):bcs) (n:ns) = if b<=n + then (c ) : go bcs ns+ else (None) : go bcbcs ns+ go _ [] = error "rapidLedUpdate: shouldn't happen"++--------------------------------------------------------------------------------+-- * helper functions++pairs :: [a] -> [(a,a)] +pairs (x:y:rest) = (x,y) : pairs rest+pairs [] = []+pairs [x] = []++xxNoteOn :: Color -> Color -> MidiMessage' +xxNoteOn p q = NoteOn (f $ encodeColor p) (f $ encodeColor q) where+ f x = (x .&. 0x37) .|. 12 {- 4 -} -- erase clear bit, set copy bit?+ +sortNubMap :: [(Button,Color)] -> [(Button,Color)]+sortNubMap = Map.toList . Map.fromList++--------------------------------------------------------------------------------+
+ examples/launchpad-control-examples.hs view
@@ -0,0 +1,52 @@++module Main where++--------------------------------------------------------------------------------++import System.IO++import System.MIDI.Launchpad.AppFramework++import qualified System.MIDI.Launchpad.Apps.DrumSeq as DrumSeq+import qualified System.MIDI.Launchpad.Apps.MonoSeq as MonoSeq+import qualified System.MIDI.Launchpad.Apps.FXControl as FXControl+import qualified System.MIDI.Launchpad.Apps.Conway as Conway++--------------------------------------------------------------------------------++appList :: [String]+appList = + [ "1: Drum sequencer"+ , "2: Monomorphic sequencer"+ , "3: Effect control"+ , "4: Conway's game of life"+ ]+ +main :: IO ()+main = do+ putStrLn "\nplease select the application (default is the first one):\n"+ mapM_ putStrLn appList+ putStr "your selection: "+ hFlush stdout+ l <- getLine+ let k0 = 1+ let k = case maybeRead l of+ Nothing -> k0+ Just m -> if m<1 || m>3 then k0 else m+ putStrLn $ "\nyou selected " ++ appList!!(k-1)+ putStrLn "\n------------------------------------------\n"+ case k of+ 1 -> runMonadicApp defaultGlobalConfig $ DrumSeq.drumSequencer $ DrumSeq.defaultCfg -- { DrumSeq.seqSteps = 16 }+ 2 -> runPureApp defaultGlobalConfig $ MonoSeq.monoSequencer $ MonoSeq.defaultCfg -- { MonoSeq.seqSteps = 16 }+ 3 -> runPureApp defaultGlobalConfig $ FXControl.fxControl $ FXControl.defaultCfg+ 4 -> runMonadicApp defaultGlobalConfig $ Conway.conway $ Conway.defaultCfg+ _ -> error "shouldn't happen"+ +--------------------------------------------------------------------------------+ +maybeRead :: Read a => String -> Maybe a+maybeRead s = case reads s of + [(x,"")] -> Just x+ _ -> Nothing + +--------------------------------------------------------------------------------
+ launchpad-control.cabal view
@@ -0,0 +1,65 @@++Name: launchpad-control+Version: 0.0.1.0+Synopsis: High and low-level interface to the Novation Launchpad midi controller.+Description: High and low-level interface to the Novation Launchpad midi controller.+ Allows to make "Launchpad apps" easily, or to access the controller+ in a more low-level way. Some example apps are included.+ Presently only Mac OSX and Windows is supported (because we rely on hmidi). +License: BSD3+License-file: LICENSE+Author: Balazs Komuves+Copyright: (c) 2013 Balazs Komuves+Maintainer: bkomuves (plus) hackage (at) gmail (dot) com+Homepage: http://code.haskell.org/~bkomuves/+Stability: Experimental+Category: Music, System+Tested-With: GHC == 7.4.2+Cabal-Version: >= 1.8+Build-Type: Simple++source-repository head+ type: darcs+ location: http://code.haskell.org/~bkomuves/projects/launchpad-control/++Flag base4+ Description: Base v4+ +Library++ if flag(base4)+ Build-Depends: base >= 4 && < 5+ cpp-options: -DBASE_VERSION=4+ else + Build-Depends: base >= 3 && < 4+ cpp-options: -DBASE_VERSION=3++ Build-Depends: array, containers, transformers, mtl, + hmidi >= 0.2.1++ Exposed-Modules: System.MIDI.Launchpad.Control+ System.MIDI.Launchpad.AppFramework+ System.MIDI.Launchpad.AppFramework.Internal + System.MIDI.Launchpad.Apps.DrumSeq+ System.MIDI.Launchpad.Apps.MonoSeq+ System.MIDI.Launchpad.Apps.FXControl+ System.MIDI.Launchpad.Apps.Conway++ Extensions: BangPatterns++ Hs-Source-Dirs: .++ ghc-options: -Wall -fno-warn-unused-matches -fno-warn-name-shadowing+++Executable launchpad-control-examples+ + main-is: launchpad-control-examples.hs+ + Build-Depends: base >= 3, launchpad-control++ Hs-Source-Dirs: ./examples+ + -- note that using the threaded runtime is very important when using hmidi!+ ghc-options: -threaded +