content: -- | Synth Definitions in SuperCollider are how you define the way synths should sound
  --   -- you describe parameters and a graph of sound generators, add them to the server
  --   with 'defineSD', and then create instances of the Synth Definition (called "synths"),
  --   which each play separately. You can set parameters of the synth at any time while
  --   they're playing
  -- 
  --   Usually, you shouldn't be making 'SynthDef's explicitly -- there's a state monad
  --   'SDBody' which lets you construct synthdefs like so:
  -- 
  --   @
  --   test :: SynthDef
  --   test = 'sd' (0 ::I \"note\") $ do
  --      s <- 0.1 'Vivid.UGens.~*' 'Vivid.UGens.sinOsc' (freq_ $ 'Vivid.UGens.midiCPS' (V::V \"note\"))
  --      out 0 [s, s]
  --   @
  -- 
  --   You then optionally explicitly send the synth definition to the SC server with
  -- 
  --   >>> defineSD test
  -- 
  --   You then create a synth from the synthdef like:
  -- 
  --   >>> s <- synth test (45 ::I "note")
  -- 
  --   This returns a 'NodeId' which is a reference to the synth, which you can
  --   use to e.g. change the params of the running synth with e.g.
  -- 
  --   >>> set s (38 ::I "note")
  -- 
  --   Then you can free it (stop its playing) with
  -- 
  --   >>> free s
  -- 
  --   (If you want interop with SClang, use "sdNamed" and "synthNamed")
  
  {-# OPTIONS_HADDOCK show-extensions #-}
  
  {-# LANGUAGE NoRebindableSyntax #-}
  
  {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TypeFamilies, NoMonoLocalBinds #-}
  {-# LANGUAGE ViewPatterns #-}
  
  {-# LANGUAGE NoIncoherentInstances #-}
  {-# LANGUAGE NoMonomorphismRestriction #-}
  {-# LANGUAGE NoUndecidableInstances #-}
  
  module Vivid.SynthDef (
    -- * Synth actions
  
    -- * Synth Definition Construction
      SynthDef(..)
    , UGen(..)
    , addUGen
    , addMonoUGen
    , addPolyUGen
    , ToSig(..)
    , Signal(..)
    , encodeSD
  --  , defineSD
    , sd
    , sdNamed
    , sdPretty
    , (?)
  --  , play
  --  , cmdPeriod
    , DoneAction(..)
    , doneActionNum
    , sdLitPretty
    , sdToLiteral
    -- literalToSD
  
    , execState
  
    , getCalcRate
  
    -- * Built-in Unit Generator Operations
  
    , UnaryOp(..)
    , uOpToSpecialI
    , specialIToUOp
  
    , BinaryOp(..)
    , biOpToSpecialI
    , specialIToBiOp
  
    , module Vivid.SynthDef.Types
  
    , getSDHashName
  
    , makeSynthDef
  
    , shrinkSDArgs
  
    , SDBody
    ) where
  
  import Vivid.SC.SynthDef.Literally as Literal
  import Vivid.SC.SynthDef.Types (CalculationRate(..), BinaryOp(..), UnaryOp(..))
  import Vivid.SynthDef.ToSig
  import Vivid.SynthDef.Types
  import Vivid.SynthDef.FromUA (SDBody)
  
  -- import Control.Applicative
  import Control.Arrow (first{-, second-})
  import Control.Monad.State (get, put, modify, execState)
  import Data.ByteString (ByteString)
  import qualified Data.ByteString.UTF8 as UTF8
  import Data.Hashable (Hashable, hashWithSalt, hash)
  import Data.Int
  import Data.List (nub, elemIndex, find) -- , sortBy)
  import Data.Map (Map)
  import qualified Data.Map as Map
  import Data.Maybe
  import Data.Monoid
  -- import qualified Data.Set as Set
  import Prelude
  
  sdPretty :: SynthDef a -> String
  sdPretty synthDef = unlines $ [
       "Name: " <> show (_sdName synthDef)
     , "Args: " <> show (_sdParams synthDef)
     , "UGens: "
     ] <> map show (Map.toAscList (_sdUGens synthDef))
  
  -- | Action to take with a UGen when it's finished
  -- 
  --   This representation will change in the future
  data DoneAction
     = DoNothing
     | FreeEnclosing
     | DoneAction_AsNum Int
   deriving (Show, Eq)
  
  doneActionNum :: DoneAction -> Float
  doneActionNum = \case
     DoNothing -> 0
     FreeEnclosing -> 2
     DoneAction_AsNum n -> toEnum n
  
  --invariants (to check):
  -- param names don't clash
  -- graph is real and acyclic
  -- no "dangling" pieces -- sign that something's wrong
  -- params are all used, and the ones that're used in the graph all exist
  
  
  sdToLiteral :: SynthDef a -> Literal.LiteralSynthDef
  sdToLiteral theSD@(SynthDef name params ugens) = fixAndSimplify $
     LiteralSynthDef
        (case name of
           SDName_Named s -> s
           SDName_Hash -> getSDHashName theSD
           )
        (gatherConstants $ Map.toAscList ugens )
        (map snd params)
        (zipWith (\s i -> ParamName s i) (map fst params) [0..])
        (makeUGenSpecs params $ Map.toAscList ugens)
        []
  
  fixAndSimplify :: Literal.LiteralSynthDef -> Literal.LiteralSynthDef
  fixAndSimplify =
     replaceBitNot
  
  
  -- Can unit test this by making a complex SD graph that uses
  -- multiple "bitNot"s and checking that it's exactly equal to if
  -- we'd used '& . bitXor 0xFFFFFF'
  
  -- silent:
  -- play $ (0.1 ~* sinOsc (freq_ 440)) >>= \x -> uOp BitNot x >>= \y -> biOp BitAnd y x >>= \z -> out 0 [z,z]
  
  -- | Fix for github.com/supercollider/supercollider/issues/1749
  replaceBitNot :: Literal.LiteralSynthDef -> Literal.LiteralSynthDef
  replaceBitNot lsd@(Literal.LiteralSynthDef name oldConsts params paramNames ugens variants) =
     case any isBitNot ugens of
        False -> lsd
        True ->
           Literal.LiteralSynthDef name newConsts params paramNames (map replaceIt ugens) variants
   where
     -- newConsts :: [Float];  newOneLoc :: Int32
     (newConsts, (toEnum::Int->Int32) -> negOneLoc) =
        case elemIndex (-1) oldConsts of
           Nothing -> (oldConsts <> [(-1)], (length::[a]->Int) oldConsts)
           Just i -> (oldConsts, i)
     isBitNot :: UGenSpec -> Bool
     isBitNot ug =
           (Literal._uGenSpec_name ug == "UnaryOpUGen")
        && (Literal._uGenSpec_specialIndex ug == uOpToSpecialI BitNot)
     replaceIt :: UGenSpec -> UGenSpec
     replaceIt ugspec = case isBitNot ugspec of
        False -> ugspec
        True -> UGenSpec
           "BinaryOpUGen"
           (Literal._uGenSpec_calcRate ugspec)
           (Literal._uGenSpec_inputs ugspec <>
              [InputSpec_Constant negOneLoc])
           (Literal._uGenSpec_outputs ugspec)
           (biOpToSpecialI BitXor)
  
  getSDHashName :: SynthDef a -> ByteString
  getSDHashName theSD =
     "vivid_" <> (UTF8.fromString . show . hash) theSD
  
  {-
  -- Anyone, write it for me if you wanna!:
  literalToSD :: Literal.SynthDef -> SD
  literalToSD =
  -}
  
  gatherConstants :: [(Int, UGen)] -> [Float]
  gatherConstants ugens =
     nub [ x | Constant x <- concatMap (_ugenIns . snd) ugens]
  
  makeUGenSpecs :: [(ByteString, Float)] -> [(Int, UGen)] -> [Literal.UGenSpec]
  makeUGenSpecs params ugens = case params of
     [] -> rest
     _ -> control : rest
   where
     control = UGenSpec
        (UTF8.fromString "Control")
        KR
        []
        (replicate ((length::[a]->Int) params) (OutputSpec KR))
        0
  
     rest = map makeSpec ugens
  
     makeSpec :: (Int, UGen) -> UGenSpec
     makeSpec (_, UGen name calcRate ins numOuts) =
        let (theName, specialIndex) = case name of
               UGName_S s -> (s, 0)
               UGName_U uop -> (UTF8.fromString "UnaryOpUGen", uOpToSpecialI uop)
               UGName_B biop -> (UTF8.fromString "BinaryOpUGen", biOpToSpecialI biop)
        in UGenSpec
              theName
              calcRate
              ((flip map) ins $ \case
                  Constant x -> InputSpec_Constant $ fromIntegral $ fromJust $
                     elemIndex x $ gatherConstants ugens
                  UGOut ugenId outputNum ->
                     let inputPosition =
                             -- If there are any params, there's a "Control" in
                             -- the 0th position:
                            toEnum ugenId + case params of { [] -> 0 ; _ -> 1 }
                     in InputSpec_UGen inputPosition outputNum
                  Param s -> InputSpec_UGen 0 (indexOfName params s)
                  )
              (replicate numOuts (OutputSpec calcRate))
              specialIndex
  
   -- invariant: strings are unique:
  indexOfName :: (Eq a) => [(ByteString, a)] -> ByteString -> Int32
  -- In the future: add levens(t|h)ein distance "did you mean?:"
  indexOfName haystack key =
     let foo = case find ((==key) . fst) haystack of
           Nothing -> error $ "missing param: " <> show key
           Just x -> x
     in fromIntegral $ fromJust $ (flip elemIndex) haystack $ foo
  
  getFreshUGenGraphId :: SDBody' args Int
  getFreshUGenGraphId = do
     (ids, synthDef, argList) <- get
     let (i:ds) = case ids of
            [] -> error "You got to the end of an infinite list!"
            _ -> ids
     put (ds, synthDef, argList)
     return i
  
  -- | Alias for 'addMonoUGen'
  addUGen :: UGen -> SDBody' args Signal
  addUGen = addMonoUGen
  
  -- | Add a unit generator with one output
  addMonoUGen :: UGen -> SDBody' args Signal
  addMonoUGen ugen = addPolyUGen ugen >>= \case
     [x] -> return x
     foo -> error $ "that ugen's not mono!: " <>   show ugen <>  show foo
  
  -- | Polyphonic -- returns a list of 'Signal's.
  --   In the future this might be a tuple instead of a list
  addPolyUGen :: UGen -> SDBody' args [Signal]
  addPolyUGen ugen = addPolyUGen' $ ugen
  
  addPolyUGen' :: UGen -> SDBody' args [Signal]
  addPolyUGen' ugen = do
     anId <- getFreshUGenGraphId
     modify . (\f (a,b,c)->(a,f b,c)) $ \synthDef -> synthDef { _sdUGens =
        Map.unionWith (\_ -> error "dammit keying broken") (_sdUGens synthDef) $
           Map.singleton anId ugen
        }
     return $ map (UGOut anId) [0.. toEnum (_ugenNumOuts ugen - 1)]
  
  -- | Define a Synth Definition
  sd :: VarList argList => argList -> SDBody' (InnerVars argList) [Signal] -> SynthDef (InnerVars argList)
  sd params theState =
     makeSynthDef SDName_Hash params theState
  
  -- | Define a Synth Definition and give it a name you can refer to from e.g. sclang
  sdNamed :: VarList argList => String -> argList -> SDBody' (InnerVars argList) [Signal] -> SynthDef (InnerVars argList)
  sdNamed name params theState =
     makeSynthDef (SDName_Named $ UTF8.fromString name) params theState
  
  makeSynthDef :: VarList argList => SDName -> argList -> SDBody' (InnerVars argList) [Signal] -> SynthDef (InnerVars argList)
  makeSynthDef name params theState =
     let theSD = SynthDef name (map (first UTF8.fromString) paramList) Map.empty
         (paramList, argSet) = makeTypedVarList params
     in (\(_,b,_)->b) $ execState theState $
           ({- id supply: -} [0 :: Int ..], theSD, argSet)
  
  -- | Set the calculation rate of a UGen
  -- 
  --   e.g.
  -- 
  --   @
  -- play $ do
  --    s0 <- 1 ~+ (lfSaw (freq_ 1) ? KR)
  --    s1 <- 0.1 ~* lfSaw (freq_ $ 220 ~* s0)
  --    out 0 [s1, s1]
  -- @
  -- 
  --   Mnemonic: \"?\" is like thinking
  -- 
  --   In the future, the representation of calculation rates may change
  (?) :: SDBody' args Signal -> CalculationRate -> SDBody' args Signal
  (?) i calcRate = do
     i' <- i
     case i' of
        UGOut ugId _o -> modify $ (\f (a,b,c)->(a,f b,c)) $ \synthDef ->
           let ugs = _sdUGens synthDef
               updatedUGens :: Map Int UGen
               updatedUGens = case Map.lookup ugId ugs of
                  Nothing -> error "ugen id not found"
                  Just UGen{} ->
                     Map.adjust (\ug -> ug { _ugenCalculationRate = calcRate }) ugId ugs
           in synthDef { _sdUGens = updatedUGens }
        _ -> return ()
     return i'
  
  getCalcRate :: Signal -> SDBody' args CalculationRate
  getCalcRate (Constant _) = return IR
  getCalcRate (Param _) = return KR
  getCalcRate (UGOut theUG _) = do
     -- Note: this assumes updates to the ugen graph are only appends
     -- (so don't break that invariant if you build your own graph by hand!):
     (_, ugenGraph, _) <- get
     case Map.lookup theUG (_sdUGens ugenGraph) of
        Just ug -> return $ _ugenCalculationRate ug
        Nothing -> error "that output isn't in the graph!"
  
  
  -- | Like 'Vivid.SCServer.shrinkSynthArgs' but for 'SynthDef's
  shrinkSDArgs :: Subset new old => SynthDef old -> SynthDef new
  shrinkSDArgs (SynthDef a b c) = SynthDef a b c
  
  
  
  encodeSD :: SynthDef a -> ByteString
  encodeSD =
     encodeSynthDefFile . SynthDefFile . (:[]) . sdToLiteral
  
  -- | This is the hash of the UGen graph and params, but not the name!
  --   So (re)naming a SynthDef will not change its hash.
  instance Hashable (SynthDef a) where
     hashWithSalt salt (SynthDef _name params ugens) =
        hashWithSalt salt . encodeSD $
           SynthDef (SDName_Named "VIVID FTW") params ugens
  