module System.MIDI.Launchpad.AppFramework.Internal where
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
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
controlColor :: Color
controlColor = amber
data PureApp cfg mode state = PureApp
{ pAppConfig :: cfg
, pAppIniState :: (mode,state)
, pAppStartStop :: cfg -> Bool -> (state -> state)
, pAppRender :: cfg -> mode -> state -> Maybe Int -> [(Button,Color)]
, pAppButton :: cfg -> ButtonPress -> (mode,state) -> ((mode,state),[MidiMessage'])
, pAppSync :: cfg -> mode -> state -> Int -> (state,[MidiMessage'])
}
safeRenderDiff :: [(Button,Color)] -> [(Button,Color)] -> Messages
safeRenderDiff old new = unsafeRenderDiff (sortNubMap old) (sortNubMap new)
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
theSyncCounter :: MVar Int
theSyncCounter = Unsafe.unsafePerformIO $ newMVar 0
thePlayingFlag :: MVar Bool
thePlayingFlag = Unsafe.unsafePerformIO $ newMVar False
theLaunchpadMode :: MVar Control
theLaunchpadMode = Unsafe.unsafePerformIO $ newMVar Session
theLedUpdateBuffer :: MVar [Messages]
theLedUpdateBuffer = Unsafe.unsafePerformIO $ newMVar []
theLastScreen :: MVar [(Button,Color)]
theLastScreen = Unsafe.unsafePerformIO $ newMVar []
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 [] = []
appUpdateLoop :: IO ()
appUpdateLoop = go where
go = do
buf <- takeMVar theLedUpdateBuffer
sendMsg $ concat (reverse buf)
putMVar theLedUpdateBuffer []
threadDelay (1000)
go
data GlobalConfig = GlobalConfig
{ defaultLaunchpadDevice :: String
, defaultMidiOutputDevice :: String
, outputChannel :: Int
, onlyUserMode2 :: Bool
}
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)
runPureApp :: GlobalConfig -> PureApp cfg mode state -> IO ()
runPureApp globalConfig clientApp = do
let (iniMode,iniState) = pAppIniState clientApp
appMode <- newMVar iniMode
appState <- newMVar iniState
(src1,dst1) <- selectDevice "\nplease select the Launchpad midi device" (defaultLaunchpadDevice globalConfig)
(src2,dst2) <- selectDevice "\nplease select the target midi device" (defaultMidiOutputDevice globalConfig)
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
forkIO $ appUpdateLoop
getLine
stop inconn1 ; stop inconn2 ; putStrLn "stopped."
close inconn1 ; close inconn2 ; putStrLn "closed."
close outconn1 ; close outconn2
appLaunchpadCallback
::
(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
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)
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)
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 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
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 ()
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