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 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.Play
import Zwirn.Language.Syntax

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

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

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

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

allID :: Zwirn Text
allID = pure "_all"

noneID :: Zwirn Text
noneID = pure "_none"

replace :: PlayEnv -> Zwirn Expression -> Zwirn ExpressionMap -> Zwirn (IO ())
replace str iz mz = (\f -> f $ EMap <$> addOrbit) . playReplace str . toTargetedID <$> iz
  where
    orbit = (\(Targeted _ i) -> case i of TextID _ -> ENum 0; NumID n -> ENum $ fromIntegral n) . toTargetedID <$> iz
    addOrbit = mz `unionL` singleton (pure "orbit") orbit

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

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

hush :: PlayEnv -> Zwirn (IO ())
hush str = pure $ playHush str

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

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

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

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

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

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

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