Internal.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

module Zwirn.Language.Evaluate.Internal where

{-
    Internal.hs - internal functions, specific to Expressions
    Copyright (C) 2023, 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.Applicative (liftA2)
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad (void)
import Data.Fixed (mod')
import Data.List (mapAccumL)
import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe)
import Data.Text (Text, pack)
import qualified Data.Text as T
import Sound.Tidal.Clock (getCPS, getCycleTime)
import Zwirn.Core.Cord
import Zwirn.Core.Core (withState)
import Zwirn.Core.Lib.Cord
import Zwirn.Core.Lib.Core (apply)
import Zwirn.Core.Lib.Map
import Zwirn.Core.Lib.State
import Zwirn.Core.Lib.Structure (segment)
import Zwirn.Core.Time (Time)
import Zwirn.Core.Tree (Tree)
import Zwirn.Core.Types
import Zwirn.Language.Evaluate.Convert
import Zwirn.Language.Evaluate.Expression
import Zwirn.Language.Location (SrcLoc)
import Zwirn.Language.Syntax
import Zwirn.Stream.Target (Targeted (..))
import Zwirn.Stream.Types (Identifier (..), Stream (..), StreamConfig (streamConfigClock))
import Zwirn.Stream.UI
import qualified Zwirn.Stream.UI as Stream

instance State Tree ExpressionMap SrcLoc where
  beatsPerCycle = (\(ENum x) -> x) <$> getStateNWith (pure $ T.pack "_beatsPerCycle") (pure 8)

insert :: (Text, Expression) -> ExpressionMap -> ExpressionMap
insert (k, x) = Map.insert k x

getStateN :: Zwirn Text -> Zwirn Expression
getStateN xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))
  where
    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromNum x
    fromLookup _ = silence
    fromNum (ENum n) = pure $ ENum n
    fromNum _ = silence

getStateNWith :: Zwirn Text -> Zwirn Expression -> Zwirn Expression
getStateNWith xc z = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))
  where
    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromNum x
    fromLookup _ = z
    fromNum (ENum n) = pure $ ENum n
    fromNum _ = silence

getStateT :: Zwirn Text -> Zwirn Expression
getStateT xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))
  where
    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromText x
    fromLookup _ = silence
    fromText (EText n) = pure $ EText n
    fromText _ = silence

getStateM :: Zwirn Text -> Zwirn Expression
getStateM xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))
  where
    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromMap x
    fromLookup _ = silence
    fromMap (EMap n) = pure $ EMap n
    fromMap _ = silence

modifyState :: Zwirn Text -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression
modifyState kz fz xz = (modifyState' <$> kz <*> fz) `apply` xz
  where
    modifyState' :: Text -> (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression
    modifyState' key f = withState (Map.update (Just . toExp . f . fromExp) key)

setState :: Zwirn Text -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression
setState t x = setMap t (pure $ EZwirn x)

getState :: Zwirn Expression -> Zwirn ExpressionMap
getState = get

bus :: Zwirn Double -> Zwirn Double
bus = segment (pure 128)

segbus :: Zwirn Int -> Zwirn Double -> Zwirn Double
segbus = segment

paramName :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Text
paramName f = headOrDef . Map.keys <$> (fromExp $ EZwirn $ apply f (pure (ENum 0)) :: Zwirn ExpressionMap)
  where
    headOrDef [] = ""
    headOrDef (x : _) = x

recvT :: Zwirn Text -> Zwirn Int -> Zwirn ExpressionMap
recvT t i = singleton t (fmap (toExp . (\x -> pack $ "c" ++ show x)) i)

recv :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Int -> Zwirn ExpressionMap
recv f = recvT t
  where
    t = paramName f

------------------------------------
------------- stream ui ------------
------------------------------------

toID :: Expression -> Identifier
toID (ENum i) = NumID (floor i :: Int)
toID (EText t) = TextID t
toID (EMap m) = TextID $ pack $ show m
toID _ = error "Error in toID!"

toBusID :: Zwirn Expression -> Zwirn (Targeted Int)
toBusID ex = innerJoin $ mapper <$> ex
  where
    mapper (ENum i) = pure $ Targeted [] (floor i)
    mapper (EMap mex) = Targeted targs <$> idd
      where
        idd = maybe silence toIDD (Map.lookup "id" mex)
        targs = toTarget <$> Map.elems (Map.delete "id" mex)
        toIDD (ENum i) = pure $ floor i :: Zwirn Int
        toIDD _ = silence
        toTarget (EText t) = t
        toTarget _ = error "Error in toTargetedID!"
    mapper _ = silence

toTargetedID :: Expression -> Targeted Identifier
toTargetedID (EMap mex) = Targeted targs idd
  where
    idd = toID $ fromMaybe (EText "default") $ Map.lookup "id" mex
    targs = toTarget <$> Map.elems (Map.delete "id" mex)
    toTarget (EText t) = t
    toTarget _ = error "Error in toTargetedID!"
toTargetedID ex = Targeted [] (toID ex)

target :: Zwirn Text -> Zwirn Expression -> Zwirn Expression
target tz = liftA2 (\tm idd -> EMap $ Map.insert "id" idd tm) targs
  where
    targs = innerJoin $ foldl (liftA2 (\m t -> Map.insert t (EText t) m)) (pure Map.empty :: Zwirn ExpressionMap) <$> collect tz

tempo :: Zwirn Expression
tempo = getStateN (pure "tempo")

bpc :: Zwirn Expression
bpc = getStateN (pure "_beatsPerCycle")

allID :: Zwirn Text
allID = pure "_all"

noneID :: Zwirn Text
noneID = pure "_none"

replace :: Stream -> Zwirn Expression -> Zwirn ExpressionMap -> Zwirn (IO ())
replace str iz mz = (\f -> f $ EMap <$> mz) . streamReplace str . toTargetedID <$> iz

replaceAction :: Stream -> Zwirn Expression -> Zwirn Expression -> Zwirn (IO ())
replaceAction str iz mz = (\f -> f mz) . streamReplaceAction str . toID <$> iz

replaceBus :: Stream -> Zwirn Expression -> Zwirn Expression -> Zwirn (IO ())
replaceBus str iz mz = (\f -> f mz) . streamReplaceBus str <$> toBusID iz

hush :: Stream -> Zwirn (IO ())
hush str = pure $ streamHush str

mute :: Stream -> Zwirn Expression -> Zwirn (IO ())
mute str iz = streamMute str . toID <$> iz

once :: Stream -> Zwirn Expression -> Zwirn (IO ())
once str iz = pure (streamFirst str iz)

tonce :: Stream -> Zwirn Text -> Zwirn Expression -> Zwirn (IO ())
tonce str tz iz = flip (streamFirstTarget str) iz <$> tz

unmute :: Stream -> Zwirn Expression -> Zwirn (IO ())
unmute str iz = streamUnmute str . toID <$> iz

toggle :: Stream -> Zwirn Expression -> Zwirn (IO ())
toggle str iz = streamToggle str . toID <$> iz

solo :: Stream -> Zwirn Expression -> Zwirn (IO ())
solo str iz = streamSolo str . toID <$> iz

togglesolo :: Stream -> Zwirn Expression -> Zwirn (IO ())
togglesolo str iz = streamToggleSolo str . toID <$> iz

unsolo :: Stream -> Zwirn Expression -> Zwirn (IO ())
unsolo str iz = streamUnsolo str . toID <$> iz

fx :: Stream -> Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn (IO ())
fx str key fxz = (\f -> f fxz) . streamSetFx str . toID <$> key

bpm :: Stream -> Zwirn Double -> Zwirn (IO ())
bpm str iz = streamSetBPM str . realToFrac <$> iz

cps :: Stream -> Zwirn Double -> Zwirn (IO ())
cps str iz = streamSetCPS str . realToFrac <$> iz

setcycle :: Stream -> Zwirn Double -> Zwirn (IO ())
setcycle str iz = streamSetCycle str . realToFrac <$> iz

resetcycles :: Stream -> Zwirn (IO ())
resetcycles str = pure $ streamResetCycles str

enablelink :: Stream -> Zwirn (IO ())
enablelink str = pure $ streamEnableLink str

disablelink :: Stream -> Zwirn (IO ())
disablelink str = pure $ streamDisableLink str

execIn :: Zwirn Double -> Zwirn (IO ()) -> Zwirn (IO ())
execIn dz acz = execInSecs_ <$> dz <*> acz
  where
    execInSecs_ :: Double -> IO () -> IO ()
    execInSecs_ d ac = void $ forkIO $ threadDelay (floor $ d * 1000000) >> ac

execIn' :: Stream -> Zwirn Double -> Zwirn (IO ()) -> Zwirn (IO ())
execIn' str dz acz = execInCycs_ <$> dz <*> acz
  where
    execInCycs_ :: Double -> IO () -> IO ()
    execInCycs_ d ac = do
      xcps <- getCPS (streamConfigClock $ sConfig str) (sClockRef str)
      void $ forkIO $ threadDelay (floor $ d * realToFrac xcps * 1000000) >> ac

execMod :: Stream -> Zwirn Double -> Zwirn (IO ()) -> Zwirn (IO ())
execMod str dz acz = execMod_ <$> dz <*> acz
  where
    execMod_ :: Double -> IO () -> IO ()
    execMod_ d ac = do
      xcps <- getCPS (streamConfigClock $ sConfig str) (sClockRef str)
      now <- getCycleTime (streamConfigClock $ sConfig str) (sClockRef str)
      let del = d - mod' (realToFrac now) d
      void $ forkIO $ threadDelay (floor $ del * realToFrac xcps * 1000000) >> ac

transition :: Stream -> Zwirn Expression -> Zwirn (Zwirn Double -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> Zwirn (IO ())
transition str kz = liftA2 (Stream.transition str) (toID <$> kz)

transition' :: Stream -> Zwirn Expression -> Zwirn Time -> Zwirn Expression -> Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> Zwirn (IO ())
transition' str kz dur def sig fun = (\k -> Stream.transition' str k dur def sig fun) . toID <$> kz