{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}

module Sound.Tidal.Stream where

import           Control.Applicative ((<|>))
import           Control.Concurrent.MVar
import           Control.Concurrent
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromJust, fromMaybe, isJust, catMaybes)
import qualified Control.Exception as E
-- import Control.Monad.Reader
-- import Control.Monad.Except
-- import qualified Data.Bifunctor as BF
-- import qualified Data.Bool as B
-- import qualified Data.Char as C
import           System.IO (hPutStrLn, stderr)

import qualified Sound.OSC.FD as O

import           Sound.Tidal.Config
import           Sound.Tidal.Core (stack, silence)
import           Sound.Tidal.Pattern
import qualified Sound.Tidal.Tempo as T
-- import qualified Sound.OSC.Datum as O

data TimeStamp = BundleStamp | MessageStamp | NoStamp
 deriving (Eq, Show)

data Stream = Stream {sConfig :: Config,
                      sInput :: MVar StateMap,
                      sOutput :: MVar ControlPattern,
                      sListenTid :: Maybe ThreadId,
                      sPMapMV :: MVar PlayMap,
                      sTempoMV :: MVar T.Tempo,
                      sGlobalFMV :: MVar (ControlPattern -> ControlPattern),
                      sCxs :: [Cx]
                     }

type PatId = String

data Cx = Cx {cxTarget :: OSCTarget,
              cxUDP :: O.UDP
             }

data OSCTarget = OSCTarget {oName :: String,
                            oAddress :: String,
                            oPort :: Int,
                            oPath :: String,
                            oShape :: Maybe [(String, Maybe Value)],
                            oLatency :: Double,
                            oPreamble :: [O.Datum],
                            oTimestamp :: TimeStamp
                           }
                 deriving Show

superdirtTarget :: OSCTarget
superdirtTarget = OSCTarget {oName = "SuperDirt",
                             oAddress = "127.0.0.1",
                             oPort = 57120,
                             oPath = "/play2",
                             oShape = Nothing,
                             oLatency = 0.02,
                             oPreamble = [],
                             oTimestamp = BundleStamp
                            }

dirtTarget :: OSCTarget
dirtTarget = OSCTarget {oName = "Dirt",
                        oAddress = "127.0.0.1",
                        oPort = 7771,
                        oPath = "/play",
                        oShape = Just [("sec", Just $ VI 0),
                                       ("usec", Just $ VI 0),
                                       ("cps", Just $ VF 0),
                                       ("s", Nothing),
                                       ("offset", Just $ VF 0),
                                       ("begin", Just $ VF 0),
                                       ("end", Just $ VF 1),
                                       ("speed", Just $ VF 1),
                                       ("pan", Just $ VF 0.5),
                                       ("velocity", Just $ VF 0.5),
                                       ("vowel", Just $ VS ""),
                                       ("cutoff", Just $ VF 0),
                                       ("resonance", Just $ VF 0),
                                       ("accelerate", Just $ VF 0),
                                       ("shape", Just $ VF 0),
                                       ("kriole", Just $ VI 0),
                                       ("gain", Just $ VF 1),
                                       ("cut", Just $ VI 0),
                                       ("delay", Just $ VF 0),
                                       ("delaytime", Just $ VF (-1)),
                                       ("delayfeedback", Just $ VF (-1)),
                                       ("crush", Just $ VF 0),
                                       ("coarse", Just $ VI 0),
                                       ("hcutoff", Just $ VF 0),
                                       ("hresonance", Just $ VF 0),
                                       ("bandf", Just $ VF 0),
                                       ("bandq", Just $ VF 0),
                                       ("unit", Just $ VS "rate"),
                                       ("loop", Just $ VF 0),
                                       ("n", Just $ VF 0),
                                       ("attack", Just $ VF (-1)),
                                       ("hold", Just $ VF 0),
                                       ("release", Just $ VF (-1)),
                                       ("orbit", Just $ VI 0),
                                       ("id", Just $ VI 0)
                                      ],
                         oLatency = 0.02,
                         oPreamble = [],
                         oTimestamp = MessageStamp
                       }

startStream :: Config -> MVar StateMap -> [OSCTarget] -> IO (MVar ControlPattern, MVar T.Tempo, [Cx])
startStream config sMapMV targets
  = do cxs <- mapM (\target -> do u <- O.openUDP (oAddress target) (oPort target)
                                  return $ Cx {cxUDP = u,
                                               cxTarget = target
                                              }
                   ) targets
       pMV <- newMVar empty
       (tempoMV, _) <- T.clocked config $ onTick config sMapMV pMV cxs
       return $ (pMV, tempoMV, cxs)


data PlayState = PlayState {pattern :: ControlPattern,
                            mute :: Bool,
                            solo :: Bool,
                            history :: [ControlPattern]
                           }
               deriving Show

type PlayMap = Map.Map PatId PlayState

toDatum :: Value -> O.Datum
toDatum (VF x) = O.float x
toDatum (VI x) = O.int32 x
toDatum (VS x) = O.string x
toDatum (VR x) = O.float $ ((fromRational x) :: Double)
toDatum (VB True) = O.int32 (1 :: Int)
toDatum (VB False) = O.int32 (0 :: Int)

toData :: OSCTarget -> Event ControlMap -> Maybe [O.Datum]
toData target e
  | isJust (oShape target) = fmap (fmap toDatum) $ sequence $ map (\(n,v) -> Map.lookup n (value e) <|> v) (fromJust $ oShape target)
  | otherwise = Just $ concatMap (\(n,v) -> [O.string n, toDatum v]) $ Map.toList $ value e

toMessage :: Config -> Double -> OSCTarget -> T.Tempo -> Event (Map.Map String Value) -> Maybe O.Message
toMessage config t target tempo e = do vs <- toData target addExtra
                                       return $ O.Message (oPath target) $ oPreamble target ++ vs
  where on = sched tempo $ start $ whole e
        off = sched tempo $ stop $ whole e
        identifier = ((if (start $ whole e) == (start $ part e) then "X" else ">")
                      ++ show (start $ whole e)
                      ++ "-"
                      ++ show (stop $ whole e)
                      ++ "-"
                      ++ getString "n"
                      ++ "-"
                      ++ getString "note"
                      ++ "-"
                      ++ getString "s"
                     )
        getString s = fromMaybe "" $ do v <- Map.lookup s $ value e
                                        return $ simpleShow v
        simpleShow (VS s) = s
        simpleShow (VI i) = show i
        simpleShow (VF f) = show f
        simpleShow (VR r) = show r
        simpleShow (VB b) = show b
        delta = off - on
        messageStamp = oTimestamp target == MessageStamp
        -- If there is already cps in the event, the union will preserve that.
        addExtra = (\v -> (Map.union v $ Map.fromList (extra messageStamp)
                          )) <$> e
        addIdentifier | cSendParts config = (("id", VS identifier):)
                      | otherwise = id
        extra False = addIdentifier [("cps", (VF $ T.cps tempo)),
                                     ("delta", VF delta),
                                     ("cycle", VF (fromRational $ start $ whole e))
                                    ]
        extra True = timestamp ++ (extra False)
        timestamp = [("sec", VI sec),
                     ("usec", VI usec)
                    ]
        ut = O.ntpr_to_ut t
        sec = floor ut
        usec = floor $ 1000000 * (ut - (fromIntegral sec))

doCps :: MVar T.Tempo -> (Double, Maybe Value) -> IO ()
doCps tempoMV (d, Just (VF cps)) = do _ <- forkIO $ do threadDelay $ floor $ d * 1000000
                                                       -- hack to stop things from stopping !
                                                       _ <- T.setCps tempoMV (max 0.00001 cps)
                                                       return ()
                                      return ()
doCps _ _ = return ()

onTick :: Config -> MVar StateMap -> MVar ControlPattern -> [Cx] -> MVar T.Tempo -> T.State -> IO ()
onTick config sMapMV pMV cxs tempoMV st =
  do p <- readMVar pMV
     sMap <- readMVar sMapMV
     tempo <- readMVar tempoMV
     now <- O.time
     let sMap' = Map.insert "_cps" (pure $ VF $ T.cps tempo) sMap
         es = filterEvents $ query p (State {arc = T.nowArc st, controls = sMap'})
         filterEvents | cSendParts config = id
                      | otherwise = filter eventHasOnset
         on e = (sched tempo $ start $ whole e) + eventNudge e
         eventNudge e = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ value e
         messages target = catMaybes $ map (\e -> do m <- toMessage config (on e + latency target) target tempo e
                                                     return $ (on e, m)
                                           ) es
         cpsChanges = map (\e -> (on e - now, Map.lookup "cps" $ value e)) es
         latency target = oLatency target + cFrameTimespan config + T.nudged tempo
     mapM_ (\(Cx target udp) -> E.catch (mapM_ (send target (latency target) udp) (messages target))
                       (\(e ::E.SomeException)
                        -> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e
                       )
           ) cxs
     mapM_ (doCps tempoMV) cpsChanges
     return ()

send :: O.Transport t => OSCTarget -> Double -> t -> (Double, O.Message) -> IO ()
send target latency u (time, m)
  | oTimestamp target == BundleStamp = O.sendBundle u $ O.Bundle (time + latency) [m]
  | oTimestamp target == MessageStamp = O.sendMessage u m
  | otherwise = do _ <- forkIO $ do now <- O.time
                                    threadDelay $ floor $ ((time+latency) - now) * 1000000
                                    O.sendMessage u m
                   return ()

sched :: T.Tempo -> Rational -> Double
sched tempo c = ((fromRational $ c - (T.atCycle tempo)) / T.cps tempo) + (T.atTime tempo)

-- Interaction

streamNudgeAll :: Stream -> Double -> IO ()
streamNudgeAll s nudge = do tempo <- takeMVar $ sTempoMV s
                            putMVar (sTempoMV s) $ tempo {T.nudged = nudge}

streamResetCycles :: Stream -> IO ()
streamResetCycles s = do _ <- T.resetCycles (sTempoMV s)
                         return ()

hasSolo :: Map.Map k PlayState -> Bool
hasSolo = (>= 1) . length . filter solo . Map.elems

streamList :: Stream -> IO ()
streamList s = do pMap <- readMVar (sPMapMV s)
                  let hs = hasSolo pMap
                  putStrLn $ concatMap (showKV hs) $ Map.toList pMap
  where showKV :: Bool -> (PatId, PlayState) -> String
        showKV True  (k, (PlayState _  _ True _)) = k ++ " - solo\n"
        showKV True  (k, _) = "(" ++ k ++ ")\n"
        showKV False (k, (PlayState _ False _ _)) = k ++ "\n"
        showKV False (k, _) = "(" ++ k ++ ") - muted\n"

-- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern.
streamReplace :: Show a => Stream -> a -> ControlPattern -> IO ()
streamReplace s k !pat
  = E.catch (do let x = queryArc pat (Arc 0 0)
                tempo <- readMVar $ sTempoMV s
                input <- takeMVar $ sInput s
                -- put change time in control input
                now <- O.time
                let cyc = T.timeToCycles tempo now
                putMVar (sInput s) $
                  Map.insert ("_t_all") (pure $ VR cyc) $ Map.insert ("_t_" ++ show k) (pure $ VR cyc) input
                -- update the pattern itself
                pMap <- seq x $ takeMVar $ sPMapMV s
                let playState = updatePS $ Map.lookup (show k) pMap
                putMVar (sPMapMV s) $ Map.insert (show k) playState pMap
                calcOutput s
                return ()
          )
    (\(e :: E.SomeException) -> hPutStrLn stderr $ "Error in pattern: " ++ show e
    )
  where updatePS (Just playState) = do playState {pattern = pat, history = pat:(history playState)}
        updatePS Nothing = PlayState pat False False [pat]

streamMute :: Show a => Stream -> a -> IO ()
streamMute s k = withPatId s (show k) (\x -> x {mute = True})

streamMutes :: Show a => Stream -> [a] -> IO ()
streamMutes s ks = withPatIds s (map show ks) (\x -> x {mute = True})

streamUnmute :: Show a => Stream -> a -> IO ()
streamUnmute s k = withPatId s (show k) (\x -> x {mute = False})

streamSolo :: Show a => Stream -> a -> IO ()
streamSolo s k = withPatId s (show k) (\x -> x {solo = True})

streamUnsolo :: Show a => Stream -> a -> IO ()
streamUnsolo s k = withPatId s (show k) (\x -> x {solo = False})

streamOnce :: Stream -> ControlPattern -> IO ()
streamOnce st p
  = do sMap <- readMVar (sInput st)
       tempo <- readMVar (sTempoMV st)
       now <- O.time
       let fakeTempo = T.Tempo {T.cps = T.cps tempo,
                                T.atCycle = 0,
                                T.atTime = now,
                                T.paused = False,
                                T.nudged = 0
                               }
           sMap' = Map.insert "_cps" (pure $ VF $ T.cps tempo) sMap
           es = filter eventHasOnset $ query p (State {arc = (Arc 0 1),
                                                       controls = sMap'
                                                      }
                                               )
           at e = sched fakeTempo $ start $ whole e
           on e = sched tempo $ start $ whole e
           cpsChanges = map (\e -> (on e - now, Map.lookup "cps" $ value e)) es
           config = sConfig st
           messages target =
             catMaybes $ map (\e -> do m <- toMessage config (at e + (oLatency target)) target fakeTempo e
                                       return $ (at e, m)
                             ) es
       mapM_ (\(Cx target udp) ->
                 E.catch (mapM_ (send target (oLatency target) udp) (messages target))
                 (\(e ::E.SomeException)
                   -> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e
                 )
             ) (sCxs st)
       mapM_ (doCps $ sTempoMV st) cpsChanges
       return ()

withPatId :: Stream -> PatId -> (PlayState -> PlayState) -> IO ()
withPatId s k f = withPatIds s [k] f

withPatIds :: Stream -> [PatId] -> (PlayState -> PlayState) -> IO ()
withPatIds s ks f
  = do playMap <- takeMVar $ sPMapMV s
       let pMap' = foldr (Map.update (\x -> Just $ f x)) playMap ks
       putMVar (sPMapMV s) pMap'
       calcOutput s
       return ()

-- TODO - is there a race condition here?
streamMuteAll :: Stream -> IO ()
streamMuteAll s = do modifyMVar_ (sOutput s) $ return . const silence
                     modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = True})

streamHush :: Stream -> IO ()
streamHush s = do modifyMVar_ (sOutput s) $ return . const silence
                  modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {pattern = silence, history = silence:history x})

streamUnmuteAll :: Stream -> IO ()
streamUnmuteAll s = do modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = False})
                       calcOutput s


streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO ()
streamAll s f = do _ <- swapMVar (sGlobalFMV s) f
                   calcOutput s

streamSet :: Valuable a => Stream -> String -> Pattern a -> IO ()
streamSet s k pat = do sMap <- takeMVar $ sInput s
                       let pat' = toValue <$> pat
                           sMap' = Map.insert k pat' sMap
                       putMVar (sInput s) $ sMap'

streamSetI :: Stream -> String -> Pattern Int -> IO ()
streamSetI = streamSet

streamSetF :: Stream -> String -> Pattern Double -> IO ()
streamSetF = streamSet

streamSetS :: Stream -> String -> Pattern String -> IO ()
streamSetS = streamSet

streamSetB :: Stream -> String -> Pattern Bool -> IO ()
streamSetB = streamSet

streamSetR :: Stream -> String -> Pattern Rational -> IO ()
streamSetR = streamSet

calcOutput :: Stream -> IO ()
calcOutput s = do pMap <- readMVar $ sPMapMV s
                  globalF <- (readMVar $ sGlobalFMV s)
                  _ <- swapMVar (sOutput s) $ globalF $ toPat $ pMap
                  return ()
  where toPat pMap =
          stack $ map pattern $ filter (\pState -> if hasSolo pMap
                                                   then solo pState
                                                   else not (mute pState)
                                       ) (Map.elems pMap)

startTidal :: OSCTarget -> Config -> IO Stream
startTidal target config = startMulti [target] config

startMulti :: [OSCTarget] -> Config -> IO Stream
startMulti targets config =
  do sMapMV <- newMVar (Map.empty :: StateMap)
     listenTid <- ctrlListen sMapMV config
     (pMV, tempoMV, cxs) <- startStream config sMapMV targets
     pMapMV <- newMVar Map.empty
     globalFMV <- newMVar id
     return $ Stream {sConfig = config,
                      sInput = sMapMV,
                      sListenTid = listenTid,
                      sOutput = pMV,
                      sPMapMV = pMapMV,
                      sTempoMV = tempoMV,
                      sGlobalFMV = globalFMV,
                      sCxs = cxs
                     }

ctrlListen :: MVar StateMap -> Config -> IO (Maybe ThreadId)
ctrlListen sMapMV c
  | cCtrlListen c = do putStrLn $ "Listening for controls on " ++ cCtrlAddr c ++ ":" ++ show (cCtrlPort c)
                       catchAny run (\_ -> do putStrLn $ "Control listen failed. Perhaps there's already another tidal instance listening on that port?"
                                              return Nothing
                                    )
  | otherwise  = return Nothing
  where
        run = do sock <- O.udpServer (cCtrlAddr c) (cCtrlPort c)
                 tid <- forkIO $ loop sock
                 return $ Just tid
        loop sock = do ms <- O.recvMessages sock
                       mapM_ act ms
                       loop sock
        act (O.Message x (O.Int32 k:v:[]))
          = act (O.Message x [O.string $ show k,v])
        act (O.Message _ (O.ASCII_String k:v@(O.Float _):[]))
          = add (O.ascii_to_string k) (VF $ fromJust $ O.datum_floating v)
        act (O.Message _ (O.ASCII_String k:O.ASCII_String v:[]))
          = add (O.ascii_to_string k) (VS $ O.ascii_to_string v)
        act (O.Message _ (O.ASCII_String k:O.Int32 v:[]))
          = add (O.ascii_to_string k) (VI $ fromIntegral v)
        act m = putStrLn $ "Unhandled OSC: " ++ show m
        add :: String -> Value -> IO ()
        add k v = do sMap <- takeMVar sMapMV
                     putMVar sMapMV $ Map.insert k (pure v) sMap
                     return ()
        catchAny :: IO a -> (E.SomeException -> IO a) -> IO a
        catchAny = E.catch