diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/System/MIDI/Launchpad/AppFramework.hs b/System/MIDI/Launchpad/AppFramework.hs new file mode 100644 --- /dev/null +++ b/System/MIDI/Launchpad/AppFramework.hs @@ -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) + +-------------------------------------------------------------------------------- + + diff --git a/System/MIDI/Launchpad/AppFramework/Internal.hs b/System/MIDI/Launchpad/AppFramework/Internal.hs new file mode 100644 --- /dev/null +++ b/System/MIDI/Launchpad/AppFramework/Internal.hs @@ -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 + +-------------------------------------------------------------------------------- + + diff --git a/System/MIDI/Launchpad/Apps/Conway.hs b/System/MIDI/Launchpad/Apps/Conway.hs new file mode 100644 --- /dev/null +++ b/System/MIDI/Launchpad/Apps/Conway.hs @@ -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) ] + +-------------------------------------------------------------------------------- + + diff --git a/System/MIDI/Launchpad/Apps/DrumSeq.hs b/System/MIDI/Launchpad/Apps/DrumSeq.hs new file mode 100644 --- /dev/null +++ b/System/MIDI/Launchpad/Apps/DrumSeq.hs @@ -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=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 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 + +-------------------------------------------------------------------------------- + + diff --git a/System/MIDI/Launchpad/Apps/MonoSeq.hs b/System/MIDI/Launchpad/Apps/MonoSeq.hs new file mode 100644 --- /dev/null +++ b/System/MIDI/Launchpad/Apps/MonoSeq.hs @@ -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=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+x0, y<-[7-p..7] + , let color = if column==x && y==0 then yellow else green ] + side = [ (Side u, green) ] + +-------------------------------------------------------------------------------- + + diff --git a/System/MIDI/Launchpad/Control.hs b/System/MIDI/Launchpad/Control.hs new file mode 100644 --- /dev/null +++ b/System/MIDI/Launchpad/Control.hs @@ -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 +-- +-- +-- 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 + +-------------------------------------------------------------------------------- + diff --git a/examples/launchpad-control-examples.hs b/examples/launchpad-control-examples.hs new file mode 100644 --- /dev/null +++ b/examples/launchpad-control-examples.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/launchpad-control.cabal b/launchpad-control.cabal new file mode 100644 --- /dev/null +++ b/launchpad-control.cabal @@ -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 +