Play.hs

{-# LANGUAGE DeriveFunctor #-}

module Zwirn.Language.Play where

{-
    Play.hs - defines active zwirns
    Copyright (C) 2026, Martin Gius

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

import Control.Concurrent.MVar (MVar, modifyMVar_)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import Data.Version (showVersion)
import Paths_zwirn (version)
import Zwirn.Core.Lib.Core (apply)
import Zwirn.Core.Lib.Structure (segment)
import Zwirn.Language.Evaluate.Expression (Expression, Zwirn)

data PlayEnv = PlayEnv
  { playMap :: MVar PlayMap,
    actionMap :: MVar ActionMap,
    busMap :: MVar BusMap
  }

type TargetName = Text

-- | wraps a type in a list of target names
data Targeted a
  = Targeted
  { targets :: [TargetName],
    tValue :: a
  }
  deriving (Functor)

data PlayState
  = Normal
  | Solo
  | Mute
  deriving (Eq, Show)

-- | type for overloading channel IDs
data Identifier
  = TextID Text
  | NumID Int
  deriving (Eq, Show, Ord)

-- | a playmap assosciates an channel ID with a PlayState, a zwirn and an fx function to be applied to the zwirn before querying
type PlayMap =
  Map.Map Identifier (Targeted (PlayState, Zwirn Expression, Maybe (Zwirn (Zwirn Expression -> Zwirn Expression))))

-- | an actionmap associates an ID with an zwirn of actions (i.e. values of type IO ())
type ActionMap = Map.Map Identifier (Zwirn Expression)

-- | a busmap associates a busnumber with a zwirn of numbers
type BusMap = Map.Map Int (Targeted (Zwirn Expression))

playReplace :: PlayEnv -> Targeted Identifier -> Zwirn Expression -> IO ()
playReplace _ (Targeted _ (TextID "_all")) _ = return ()
playReplace _ (Targeted _ (TextID "_none")) _ = return ()
playReplace penv (Targeted ts key) p = modifyMVar_ (playMap penv) (return . Map.alter alterFunc key)
  where
    alterFunc Nothing = Just (Targeted ts (Normal, p, Nothing))
    alterFunc (Just (Targeted _ (_, _, fx))) = Just (Targeted ts (Normal, p, fx))

playReplaceBus :: PlayEnv -> Targeted Int -> Zwirn Expression -> IO ()
playReplaceBus penv (Targeted ts key) p = modifyMVar_ (busMap penv) (return . Map.insert key (Targeted ts $ segment (pure 128) p))

playReplaceAction :: PlayEnv -> Identifier -> Zwirn Expression -> IO ()
playReplaceAction _ (TextID "_all") _ = return ()
playReplaceAction _ (TextID "_none") _ = return ()
playReplaceAction penv key p = modifyMVar_ (actionMap penv) (return . Map.insert key p)

playHush :: PlayEnv -> IO ()
playHush penv = do
  modifyMVar_ (playMap penv) (return . const Map.empty)
  modifyMVar_ (actionMap penv) (return . const Map.empty)
  modifyMVar_ (busMap penv) (return . const Map.empty)

playSetFx :: PlayEnv -> Identifier -> Zwirn (Zwirn Expression -> Zwirn Expression) -> IO ()
playSetFx penv (TextID "_all") fx = modifyMVar_ (playMap penv) (return . fmap (fmap (\(st, p, _) -> (st, p, Just fx))))
playSetFx penv (TextID "_none") _ = modifyMVar_ (playMap penv) (return . fmap (fmap (\(st, p, _) -> (st, p, Nothing))))
playSetFx penv key fx = modifyMVar_ (playMap penv) (return . Map.update (\(Targeted ts (st, p, _)) -> Just $ Targeted ts (st, p, Just fx)) key)

playToggle :: PlayEnv -> Identifier -> IO ()
playToggle penv key = case key of
  (TextID "_all") -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
  _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
  where
    toggle (Mute, p, fx) = (Normal, p, fx)
    toggle (_, p, fx) = (Mute, p, fx)

playMute :: PlayEnv -> Identifier -> IO ()
playMute penv key = case key of
  TextID "_all" -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
  TextID "_none" -> playUnmute penv (TextID "_all")
  _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
  where
    toggle (Normal, p, fx) = (Mute, p, fx)
    toggle (Solo, p, fx) = (Mute, p, fx)
    toggle x = x

playUnmute :: PlayEnv -> Identifier -> IO ()
playUnmute penv key = case key of
  TextID "_all" -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
  TextID "_none" -> playMute penv (TextID "_all")
  _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
  where
    toggle (Mute, p, fx) = (Normal, p, fx)
    toggle x = x

playSolo :: PlayEnv -> Identifier -> IO ()
playSolo penv key = case key of
  (TextID "_all") -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
  (TextID "_none") -> playUnsolo penv (TextID "_all")
  _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
  where
    toggle (Normal, p, fx) = (Solo, p, fx)
    toggle (Mute, p, fx) = (Solo, p, fx)
    toggle x = x

playUnsolo :: PlayEnv -> Identifier -> IO ()
playUnsolo penv key = case key of
  (TextID "_all") -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
  (TextID "_none") -> playSolo penv (TextID "_all")
  _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
  where
    toggle (Solo, p, fx) = (Normal, p, fx)
    toggle x = x

playToggleSolo :: PlayEnv -> Identifier -> IO ()
playToggleSolo penv key = case key of
  (TextID "_all") -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
  _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
  where
    toggle (Solo, p, fx) = (Normal, p, fx)
    toggle (_, p, fx) = (Solo, p, fx)

applyFx :: Targeted (PlayState, Zwirn Expression, Maybe (Zwirn (Zwirn Expression -> Zwirn Expression))) -> Targeted (Zwirn Expression)
applyFx (Targeted ts (_, x, Nothing)) = Targeted ts x
applyFx (Targeted ts (_, x, Just fx)) = Targeted ts (apply fx x)

resolvePlayMap :: PlayMap -> [Targeted (Zwirn Expression)]
resolvePlayMap pm = if null ss then map applyFx rs else map applyFx ss
  where
    ps = Map.elems pm
    ss = filter (\(Targeted _ (x, _, _)) -> x == Solo) ps
    rs = filter (\(Targeted _ (x, _, _)) -> x == Normal) ps

renderStatus :: Double -> PlayMap -> Text
renderStatus b pm = "zwirn " <> T.pack (showVersion version) <> "\ntempo: " <> T.pack (show b) <> "bpm\n" <> if null pm then "" else "active: " <> T.intercalate " | " ps
  where
    ps = map (\(key, Targeted _ (st, _, _)) -> ppID key <> renderState sol st) $ Map.toList pm
    sol = noSolo pm
    renderState True Normal = ""
    renderState False Normal = " (not soloed)"
    renderState _ Solo = " (solo)"
    renderState _ Mute = " (muted)"
    ppID (TextID t) = t
    ppID (NumID i) = T.show i

-- | true if no pattern has a solo status
noSolo :: PlayMap -> Bool
noSolo pm = all (\(_, Targeted _ (ps, _, _)) -> ps /= Solo) $ Map.toList pm