launchpad-control-0.0.1.0: System/MIDI/Launchpad/Control.hs
-- | 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
--------------------------------------------------------------------------------