module System.MIDI.Launchpad.Control where
import Data.Array
import Data.Bits
import Control.Concurrent
import Control.Concurrent.MVar ()
import Control.Monad
import Data.Map (Map) ; import qualified Data.Map as Map
import System.IO.Unsafe as Unsafe
import System.MIDI
data Button
= Pad { _padX :: !Int , _padY :: !Int }
| Side { _sideCol :: !Int }
| Dir { _unDir :: !Dir }
| Ctrl { _unCtrl :: !Control }
deriving (Eq,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
data Dir = U | D | L | R deriving (Eq,Ord,Show)
data Control
= Session
| User1
| User2
| Mixer
deriving (Eq,Ord,Show)
data Buffer = Front | Back deriving (Eq,Ord,Show)
data FullColor = Red | Amber | Yellow | Green deriving (Eq,Ord,Show)
data Brightness = Off | Low | Medium | Full deriving (Eq,Ord,Show)
data Color
= None
| Color !FullColor !Brightness
| RedGreen !Brightness !Brightness
deriving (Eq,Ord,Show)
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)
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
encodeColor :: Color -> Int
encodeColor None = 12
encodeColor (Color full br) = colorTable full br
encodeColor (RedGreen a b) = encodeBrightness a + 12 + 16 * encodeBrightness b
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
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
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)
resetMsg :: Messages
resetMsg =
[ cc 0 2, noteOn 64 12
, cc 0 1, noteOn 0 12
, noteOff 0 0
, cc 0 0
, cc 0 48
]
turnOnAll :: Brightness -> Messages
turnOnAll Off = []
turnOnAll Low = [cc 0 125]
turnOnAll Medium = [cc 0 126]
turnOnAll Full = [cc 0 127]
resetLaunchpad :: Bool -> IO ()
resetLaunchpad b = do
putStrLn "reset launchpad"
wait
sendMsg resetMsg
wait
when b $ do
putStrLn "flashing all leds"
sendMsg (turnOnAll Low)
threadDelay (100*1000)
sendMsg resetMsg
threadDelay (200*1000)
where
fake = sendMsg (turnOff1 (Pad 0 0))
wait = threadDelay 5000
handShake :: IO ()
handShake = do
wait
sendMsg [Reset]
wait
where
wait = threadDelay 5000
data ButtonPress
= Press !Button
| Release !Button
deriving (Eq,Ord,Show)
buttonPress :: Bool -> Button -> ButtonPress
buttonPress True b = Press b
buttonPress False b = Release b
decodeLaunchpadMessage' :: Message -> Maybe ButtonPress
decodeLaunchpadMessage' (MidiMessage chn 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
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
decodeLaunchpadMessage :: Message -> ButtonPress
decodeLaunchpadMessage msg = case decodeLaunchpadMessage' msg of
Just p -> p
Nothing -> error ("decodeLaunchpadMessage: " ++ show msg)
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
, _gridSide :: Array Int Color
, _gridCtrl :: Array Int Color
}
deriving (Show)
ledUpdateInit :: Messages
ledUpdateInit = [ ]
ledUpdateClose :: Messages
ledUpdateClose = [ cc 0 1 ]
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"
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
sortNubMap :: [(Button,Color)] -> [(Button,Color)]
sortNubMap = Map.toList . Map.fromList