summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAntonKholomiov <>2017-06-12 16:36:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-06-12 16:36:00 (GMT)
commit1aa1b942e5f397828e81e80d432d26d3ee1f39b1 (patch)
tree095eefe16a929b3d3281d220d3ab8a15b9b0df15
parent0470a5ba9ed182f74c94eaf27b4283cdc61924a3 (diff)
version 0.2.0.10.2.0.1
-rw-r--r--csound-expression-typed.cabal22
-rw-r--r--src/Csound/Typed/Control/Evt.hs86
-rw-r--r--src/Csound/Typed/Control/Mix.hs52
-rw-r--r--src/Csound/Typed/Control/Osc.hs56
-rw-r--r--src/Csound/Typed/GlobalState/Elements.hs140
-rw-r--r--src/Csound/Typed/Types/Evt.hs32
-rw-r--r--src/Csound/Typed/Types/Prim.hs290
-rw-r--r--src/Csound/Typed/Types/SigSpace.hs180
-rw-r--r--src/Csound/Typed/Types/Tuple.hs78
9 files changed, 377 insertions, 559 deletions
diff --git a/csound-expression-typed.cabal b/csound-expression-typed.cabal
index 5880d0b..c6afff5 100644
--- a/csound-expression-typed.cabal
+++ b/csound-expression-typed.cabal
@@ -1,5 +1,5 @@
Name: csound-expression-typed
-Version: 0.2.0.0
+Version: 0.2.0.1
Cabal-Version: >= 1.22
License: BSD3
License-file: LICENSE
@@ -11,7 +11,7 @@ Build-Type: Simple
Category: Music, Sound
Maintainer: <anton.kholomiov@gmail.com>
-Description:
+Description:
Data-Files :
data/hrtf-44100-left.dat
@@ -47,9 +47,9 @@ Data-Files :
data/opcodes/MultiFX/PitchShifter.udo
data/opcodes/MultiFX/Reverse.udo
data/opcodes/MultiFX/RingModulator.udo
- data/opcodes/MultiFX/StChorus.udo
- data/opcodes/MultiFX/StereoPingPongDelay.udo
- data/opcodes/Utility/Delay1k.udo
+ data/opcodes/MultiFX/StChorus.udo
+ data/opcodes/MultiFX/StereoPingPongDelay.udo
+ data/opcodes/Utility/Delay1k.udo
Homepage: https://github.com/anton-k/csound-expression-typed
@@ -63,7 +63,7 @@ Source-repository head
Library
Ghc-Options: -Wall
Build-Depends:
- base >= 4, base < 5, ghc-prim, containers, transformers >= 0.3, Boolean >= 0.1.0, colour >= 2.0, data-default, deepseq,
+ base >= 4, base < 5, ghc-prim, containers, transformers >= 0.3, Boolean >= 0.1.0, colour >= 2.0, data-default, deepseq, NumInstances,
wl-pprint, csound-expression-dynamic >= 0.3.0, temporal-media >= 0.6.0, hashable
Hs-Source-Dirs: src/
Exposed-Modules:
@@ -76,7 +76,7 @@ Library
Csound.Typed.Gui
Csound.Typed.Gui.Cab
- Csound.Typed.Types.Prim
+ Csound.Typed.Types.Prim
Csound.Typed.Types.Evt
Csound.Typed.Types.Tuple
Csound.Typed.Types.Lift
@@ -84,7 +84,7 @@ Library
Csound.Typed.Types.MonoArg
Csound.Typed.Types.SigSpace
- Csound.Typed.Plugins
+ Csound.Typed.Plugins
Other-Modules:
Csound.Typed.GlobalState
@@ -95,8 +95,8 @@ Library
Csound.Typed.GlobalState.InstrApi
Csound.Typed.GlobalState.Cache
Csound.Typed.GlobalState.Elements
- Csound.Typed.GlobalState.Opcodes
- Csound.Typed.GlobalState.Port
+ Csound.Typed.GlobalState.Opcodes
+ Csound.Typed.GlobalState.Port
Csound.Typed.InnerOpcodes
Csound.Typed.Types.TupleHelpers
@@ -110,7 +110,7 @@ Library
Csound.Typed.Control.Sf2
Csound.Typed.Control.Osc
Csound.Typed.Control.Channel
- Csound.Typed.Control.Ref
+ Csound.Typed.Control.Ref
Csound.Typed.Control.Instr
Csound.Typed.Control.InstrRef
Csound.Typed.Control.ArrayTraverse
diff --git a/src/Csound/Typed/Control/Evt.hs b/src/Csound/Typed/Control/Evt.hs
index 94356e0..29bc107 100644
--- a/src/Csound/Typed/Control/Evt.hs
+++ b/src/Csound/Typed/Control/Evt.hs
@@ -36,9 +36,9 @@ renderEvts = fmap (fmap unEvt . T.render)
where unEvt e = (T.eventStart e, T.eventDur e, T.eventContent e)
sched :: (Arg a, Sigs b) => (a -> SE b) -> Evt (Sco a) -> b
-sched instr evts = apInstr0 $ do
+sched instr evts = apInstr0 $ do
instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp instr)
- saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts evts)
+ saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts evts)
-- | Triggers a procedure on the event stream.
sched_ :: (Arg a) => (a -> SE ()) -> Evt (Sco a) -> SE ()
@@ -50,7 +50,7 @@ sched_ instr evts = fromDep_ $ hideGEinDep $ do
schedBy :: (Arg a, Sigs b, Arg c) => (a -> SE b) -> (c -> Evt (Sco a)) -> (c -> b)
schedBy instr evts args = flip apInstr args $ do
instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp instr)
- saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts $ evts toArg)
+ saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts $ evts toArg)
-------------------------------------------------
-- triggereing the events
@@ -64,28 +64,28 @@ saveEvtInstr arity instrId evts = saveInstr $ do
evtMixInstr aliveCountRef = do
chnId <- fromDep $ C.chnRefAlloc arity
go aliveCountRef chnId evts
- fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId
+ fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId
aliveCount <- readRef aliveCountRef
- fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount
+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount
go :: Arg a => Ref D -> GE C.ChnRef -> Evt [(D, D, a)] -> SE ()
- go aliveCountRef mchnId events =
+ go aliveCountRef mchnId events =
runEvt events $ \es -> do
writeRef aliveCountRef $ int $ 2 * length es
chnId <- geToSe mchnId
fromDep_ $ mapM_ (event chnId) es
-
+
event :: Arg a => C.ChnRef -> (D, D, a) -> Dep ()
- event chnId (start, dur, args) = hideGEinDep $ fmap C.event $
- C.Event (primInstrId instrId) <$> toGE start <*> toGE dur <*> (fmap (++ [C.chnRefId chnId]) $ toNote args)
-
+ event chnId (start, dur, args) = hideGEinDep $ fmap C.event $
+ C.Event (primInstrId instrId) <$> toGE start <*> toGE dur <*> (fmap (++ [C.chnRefId chnId]) $ toNote args)
+
-- | Retriggers an instrument every time an event happens. The note
-- is held until the next event happens.
retrigs :: (Arg a, Sigs b) => (a -> SE b) -> Evt [a] -> b
retrigs instr evts = apInstr0 $ do
instrId <- saveSourceInstrCachedWithLivenessWatchAndRetrig (funArity instr) (insExp instr)
saveRetrigEvtInstr (arityOuts $ funArity instr) instrId evts
-
+
saveRetrigEvtInstr :: Arg a => Int -> C.InstrId -> Evt [a] -> GE C.InstrId
saveRetrigEvtInstr arity instrId evts = saveInstr $ do
aliveCountRef <- newRef (10 :: D)
@@ -96,24 +96,24 @@ saveRetrigEvtInstr arity instrId evts = saveInstr $ do
evtMixInstr aliveCountRef retrigWatchRef = do
chnId <- fromDep $ C.chnRefAlloc arity
go aliveCountRef retrigWatchRef chnId evts
- fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId
+ fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId
aliveCount <- readRef aliveCountRef
- fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount
+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount
go :: Arg a => Ref D -> Ref D -> GE C.ChnRef -> Evt [a] -> SE ()
- go aliveCountRef retrigWatchRef mchnId events =
+ go aliveCountRef retrigWatchRef mchnId events =
runEvt events $ \es -> do
- writeRef aliveCountRef $ int $ 2 * length es
+ writeRef aliveCountRef $ int $ 2 * length es
modifyRef retrigWatchRef (+ 1)
chnId <- geToSe mchnId
currentRetrig <- readRef retrigWatchRef
- fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig
+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig
fromDep_ $ mapM_ (event chnId currentRetrig) es
-
+
event :: Arg a => C.ChnRef -> D -> a -> Dep ()
event chnId currentRetrig args = hideGEinDep $ fmap C.event $ do
currentRetrigExp <- toGE currentRetrig
- C.Event (primInstrId instrId) 0 infiniteDur <$> (fmap (++ [C.chnRefId chnId, currentRetrigExp]) $ toNote args)
+ C.Event (primInstrId instrId) 0 infiniteDur <$> (fmap (++ [C.chnRefId chnId, currentRetrigExp]) $ toNote args)
evtLoop :: (Num a, Tuple a, Sigs a) => Maybe (Evt Unit) -> [SE a] -> [Evt Unit] -> a
evtLoop = evtLoopGen True
@@ -125,7 +125,7 @@ evtLoopGen :: (Num a, Tuple a, Sigs a) => Bool -> Maybe (Evt Unit) -> [SE a] ->
evtLoopGen mustLoop maybeOffEvt instrs evts = apInstr0 $ do
(instrId, evtInstrId) <- saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop (constArity instr) (insExp $ toInstrExp instr) (toSingleEvt evts)
saveEvtLoopInstr mustLoop loopLength maybeOffEvt (arityOuts $ constArity instr) instrId evtInstrId
- where
+ where
loopLength = int $ lcm (length instrs) (length evts)
instr = toSingleInstr instrs
@@ -138,7 +138,7 @@ evtLoopGen mustLoop maybeOffEvt instrs evts = apInstr0 $ do
ref <- newRef 0
zipWithM_ (f ref n) (fmap (sig . int) [0 .. ]) as
readRef ref
- where
+ where
f :: Tuple a => Ref a -> Sig -> Sig -> SE a -> SE ()
f ref n ix a = when1 (n ==* ix) $ writeRef ref =<< a
@@ -146,7 +146,7 @@ evtLoopGen mustLoop maybeOffEvt instrs evts = apInstr0 $ do
toSingleEvt evts = do
let n = mod' (fromE $ getRetrigVal 4) (sig $ int $ length evts)
zipWithM_ (f n) (fmap (sig . int) [0 .. ]) evts
- where
+ where
f :: Sig -> Sig -> Evt Unit -> SE ()
f n ix evt = when1 (n ==* ix) $ evtLoopInstr evt
@@ -157,7 +157,7 @@ evtLoopInstr evts = do
saveEvtLoopInstr :: Bool -> D -> Maybe (Evt Unit) -> Int -> C.InstrId -> C.InstrId -> GE C.InstrId
saveEvtLoopInstr mustLoop loopLength maybeOffEvt arity instrId evtInstrId = saveInstr $ do
aliveCountRef <- newRef (10 :: D)
- retrigWatchRef <- newRef (0 :: D)
+ retrigWatchRef <- newRef (0 :: D)
evtMixInstr aliveCountRef retrigWatchRef
where
evtMixInstr :: Ref D -> Ref D -> SE ()
@@ -167,43 +167,43 @@ saveEvtLoopInstr mustLoop loopLength maybeOffEvt arity instrId evtInstrId = save
isOn <- fmap sig $ case maybeOffEvt of
Nothing -> return 1
Just offEvt -> do
- isOn <- newRef (1 :: D)
+ isOn <- newRef (1 :: D)
runEvt offEvt $ const $ do
writeRef isOn 0
modifyRef retrigWatchRef (+ 1)
currentRetrig <- readRef retrigWatchRef
- fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig chnId $ toGE currentRetrig
- readRef isOn
+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig chnId $ toGE currentRetrig
+ readRef isOn
masterEvt <- fmap (sigToEvt . (* isOn) . fromGE . fmap C.changed . toGE) $ readServantEvt chnId
go aliveCountRef retrigWatchRef chnId masterEvt
- fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId
+ fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId
aliveCount <- readRef aliveCountRef
- fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount
+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount
- go = goBy (+ 1)
+ go = goBy (+ 1)
goBy :: (D -> D) -> Ref D -> Ref D -> GE C.ChnRef -> Evt Unit -> SE ()
- goBy updateRetrig aliveCountRef retrigWatchRef mchnId events =
- runEvt events $ \es -> do
+ goBy updateRetrig aliveCountRef retrigWatchRef mchnId events =
+ runEvt events $ \es -> do
modifyRef retrigWatchRef updateRetrig
chnId <- geToSe mchnId
currentRetrig <- readRef retrigWatchRef
- if not mustLoop
+ if not mustLoop
then do
when1 (sig currentRetrig >=* (sig loopLength)) $ do
fromDep_ turnoff
else return ()
- fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig
+ fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig
audioEvent chnId currentRetrig
- evtEvent chnId currentRetrig
+ evtEvent chnId currentRetrig
fireEventFor :: (C.ChnRef -> E -> C.Event) -> C.ChnRef -> D -> SE ()
fireEventFor f chnId currentRetrig = fromDep_ $ hideGEinDep $ fmap C.event $ do
currentRetrigExp <- toGE currentRetrig
- return $ f chnId currentRetrigExp
+ return $ f chnId currentRetrigExp
audioEvent = fireEventFor eventForAudioInstr
evtEvent = fireEventFor eventForEvtInstr
@@ -214,21 +214,21 @@ saveEvtLoopInstr mustLoop loopLength maybeOffEvt arity instrId evtInstrId = save
chnId <- mchnId
return $ initStartEvtInstr chnId >> initStartAudioInstr chnId
- initStartEvtInstr chnId = C.event_i $ eventForEvtInstr chnId 0
+ initStartEvtInstr chnId = C.event_i $ eventForEvtInstr chnId 0
initStartAudioInstr chnId = C.event_i $ eventForAudioInstr chnId 0
eventForEvtInstr = eventFor evtInstrId
eventForAudioInstr = eventFor instrId
- eventFor idx chnId currentRetrig =
- C.Event (primInstrId idx) 0 infiniteDur [C.chnRefId chnId, currentRetrig]
+ eventFor idx chnId currentRetrig =
+ C.Event (primInstrId idx) 0 infiniteDur [C.chnRefId chnId, currentRetrig]
readServantEvt :: GE C.ChnRef -> SE Sig
readServantEvt chnId = SE $ fmap fromE $ hideGEinDep $ fmap readChnEvtLoop chnId
--- | An instrument is triggered with event stream and delay time is set to zero
--- (event fires immediately) and duration is set to inifinite time. The note is
+-- | An instrument is triggered with event stream and delay time is set to zero
+-- (event fires immediately) and duration is set to inifinite time. The note is
-- held while the instrument is producing something. If the instrument is silent
-- for some seconds (specified in the first argument) then it's turned off.
schedHarp :: (Arg a, Sigs b) => D -> (a -> SE b) -> Evt [a] -> b
@@ -246,7 +246,7 @@ schedHarpBy turnOffTime instr evts args = flip apInstr args $ do
autoOff :: Sigs a => D -> a -> SE a
autoOff dt sigs = fmap toTuple $ fromDep $ hideGEinDep $ phi =<< fromTuple sigs
- where
+ where
phi x = do
dtE <- toGE dt
return $ C.autoOff dtE x
@@ -275,7 +275,7 @@ samLoop = undefined
-------------------------------------------------------------
-- monophonic scheduling
--- | Turns
+-- | Turns
monoSched :: Evt (Sco (D, D)) -> SE MonoArg
monoSched evts = evtPort instr evts read
where
@@ -290,7 +290,7 @@ monoSched evts = evtPort instr evts read
return $ MonoArg amp cps (ifB (gate `equalsTo` 0) 0 1) (changed [amp, cps, gate])
runSco :: Arg a => Evt (Sco a) -> ((D,D,a) -> SE ()) -> SE ()
-runSco evts f = runEvt (renderEvts evts) $ mapM_ f
+runSco evts f = runEvt (renderEvts evts) $ mapM_ f
-- | Plays the note until next note comes or something happens on the second event stream.
monoSchedUntil :: Evt (D, D) -> Evt a -> SE MonoArg
@@ -302,7 +302,7 @@ monoSchedUntil evts stop = do
where
go ref = either (ons ref) (const $ offs ref)
- ons ref (amp, cps) =
+ ons ref (amp, cps) =
writeRef ref $ MonoArg { monoAmp = sig amp, monoCps = sig cps, monoGate = 1, monoTrig = 1 }
offs ref = modifyRef ref $ \arg -> arg { monoGate = 0 }
diff --git a/src/Csound/Typed/Control/Mix.hs b/src/Csound/Typed/Control/Mix.hs
index 2e34106..fd01dc9 100644
--- a/src/Csound/Typed/Control/Mix.hs
+++ b/src/Csound/Typed/Control/Mix.hs
@@ -1,6 +1,6 @@
{-# Language FlexibleContexts, ScopedTypeVariables #-}
module Csound.Typed.Control.Mix(
- Mix,
+ Mix,
sco, eff, mix, mixBy, monoSco,
sco_, mix_, mixBy_,
Sco, CsdEventList(..), CsdEvent
@@ -30,12 +30,12 @@ toCsdEventList :: Sco a -> CsdEventList a
toCsdEventList = id
singleCsdEvent :: (D, D, a) -> Sco a
-singleCsdEvent (start, duration, content) = del start $ str duration $ temp content
+singleCsdEvent (start, duration, content) = del start $ str duration $ temp content
-- | Special type that represents a scores of sound signals.
-- If an instrument is triggered with the scores the result is wrapped
--- in the value of this type.
-newtype Mix a = Mix { unMix :: GE M }
+-- in the value of this type.
+newtype Mix a = Mix { unMix :: GE M }
type Sco a = Track D a
@@ -45,34 +45,34 @@ wrapSco notes getContent = singleCsdEvent (0, csdEventListDur evts, Mix $ getCon
-- | Plays a bunch of notes with the given instrument.
--
--- > res = sco instrument scores
+-- > res = sco instrument scores
sco :: (Arg a, Sigs b) => (a -> SE b) -> Sco a -> Sco (Mix b)
sco instr notes = wrapSco notes $ \events -> do
- events' <- traverse toNote events
+ events' <- traverse toNote events
instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp instr)
return $ Snd instrId events'
-- | Invokes a procedure for the given bunch of events.
sco_ :: (Arg a) => (a -> SE ()) -> Sco a -> Sco (Mix Unit)
sco_ instr notes = wrapSco notes $ \events -> do
- events' <- traverse toNote events
+ events' <- traverse toNote events
instrId <- saveSourceInstrCached_ (unitExp $ fmap (const unit) $ instr toArg)
return $ Snd instrId events'
--- | Applies an effect to the sound. Effect is applied to the sound on the give track.
+-- | Applies an effect to the sound. Effect is applied to the sound on the give track.
--
--- > res = eff effect sco
+-- > res = eff effect sco
--
--- * @effect@ - a function that takes a tuple of signals and produces
+-- * @effect@ - a function that takes a tuple of signals and produces
-- a tuple of signals.
--
--- * @sco@ - something that is constructed with 'Csound.Base.sco' or
--- 'Csound.Base.eff'.
+-- * @sco@ - something that is constructed with 'Csound.Base.sco' or
+-- 'Csound.Base.eff'.
--
--- With the function 'Csound.Base.eff' you can apply a reverb or adjust the
--- level of the signal. It functions like a mixing board but unlike mixing
+-- With the function 'Csound.Base.eff' you can apply a reverb or adjust the
+-- level of the signal. It functions like a mixing board but unlike mixing
-- board it produces the value that you can arrange with functions from your
--- favorite Score-generation library. You can delay it or mix with some other track and
+-- favorite Score-generation library. You can delay it or mix with some other track and
-- apply some another effect on top of it!
eff :: (Sigs a, Sigs b) => (a -> SE b) -> Sco (Mix a) -> Sco (Mix b)
eff ef sigs = wrapSco sigs $ \events -> do
@@ -83,37 +83,37 @@ eff ef sigs = wrapSco sigs $ \events -> do
-- | Plays a bunch of notes with the given monophonic instrument. See details on type @MonoArg@.
-- The scores contain the pairs of amplitude (0 to 1) and frequency (in Hz).
--
--- > res = monoSco instrument scores
+-- > res = monoSco instrument scores
monoSco :: forall a . Sigs a => (MonoArg -> SE a) -> Sco (D, D) -> Sco (Mix a)
monoSco instr notes = wrapSco notes $ \events -> do
- events' <- traverse toNote events
+ events' <- traverse toNote events
argId <- saveSourceInstrCached_ (unitExp $ fmap (const unit) $ instrMonoArg toArg)
instrId <- saveEffectInstr ((funArity instr) { arityIns = 3 }) (effExp effInstr)
- return $ MonoSnd instrId argId events'
- where
+ return $ MonoSnd instrId argId events'
+ where
instrMonoArg :: ((D, D), Port Sig3) -> SE ()
instrMonoArg ((amp, cps), port) =
- modifyPort port $ \(_, _, notnum) -> (sig amp, sig cps, notnum + 1)
+ modifyPort port $ \(_, _, notnum) -> (sig amp, sig cps, notnum + 1)
effInstr :: Sigs a => (Sig, Sig, Sig) -> SE a
effInstr (amp, cps, notnum) = instr (MonoArg amp cps gate (changed [amp, cps, gate]))
where gate = ifB (notnum ==* 0) 0 1
-
+
-- | Renders a scores to the sound signals. we can use it inside the other instruments.
mix :: (Sigs a) => Sco (Mix a) -> a
mix a = flip apInstr unit $ do
key <- mixKey a
durE <- toGE $ dur a
- withCache (ExpDur durE) getMixKey saveMixKey key $
+ withCache (ExpDur durE) getMixKey saveMixKey key $
saveMixInstr (mixArity a) =<< toEventList a'
where a' = toCsdEventList a
--- | Imitates a closure for a bunch of notes to be played within another instrument.
+-- | Imitates a closure for a bunch of notes to be played within another instrument.
mixBy :: (Arg a, Sigs b) => (a -> Sco (Mix b)) -> (a -> b)
mixBy evts args = flip apInstr args $ do
key <- mixKey evts
durE <- toGE $ dur evts'
- withCache (ExpDur durE) getMixKey saveMixKey key $
+ withCache (ExpDur durE) getMixKey saveMixKey key $
saveMixInstr (mixArityFun evts) =<< (toEventList evts')
where evts' = toCsdEventList $ evts toArg
@@ -126,7 +126,7 @@ mix_ a = fromDep_ $ hideGEinDep $ do
saveMixInstr_ =<< toEventList a'
where a' = toCsdEventList a
--- | Imitates a closure for a bunch of procedures to be played within another instrument.
+-- | Imitates a closure for a bunch of procedures to be played within another instrument.
mixBy_ :: (Arg a) => (a -> Sco (Mix Unit)) -> (a -> SE ())
mixBy_ evts args = mix_ $ evts args
@@ -136,7 +136,7 @@ mixKey :: a -> GE MixKey
mixKey = liftIO . fmap (MixKey . hashStableName) . makeStableName
toEventList :: Sco (Mix a) -> GE (CsdEventList M)
-toEventList evts = fmap delayAndRescaleCsdEventListM $ traverse unMix $ evts
+toEventList evts = fmap delayAndRescaleCsdEventListM $ traverse unMix $ evts
mixArity :: Sigs b => f (Mix b) -> Int
mixArity = tupleArity . proxy
diff --git a/src/Csound/Typed/Control/Osc.hs b/src/Csound/Typed/Control/Osc.hs
index 3ffd9ff..1bae61a 100644
--- a/src/Csound/Typed/Control/Osc.hs
+++ b/src/Csound/Typed/Control/Osc.hs
@@ -1,12 +1,12 @@
--- | Open sound control
+-- | Open sound control
{-# Language ScopedTypeVariables #-}
module Csound.Typed.Control.Osc(
- OscRef, OscHost, OscPort, OscAddress, OscType,
+ OscRef, OscHost, OscPort, OscAddress, OscType,
initOsc, listenOsc, sendOsc,
OscVal, listenOscVal
) where
-import Data.Boolean ((==*))
+import Data.Boolean (ifB, (==*))
import Csound.Dynamic(Rate(..))
import Csound.Typed.Types
@@ -24,10 +24,10 @@ type OscPort = Int
-- | Path-like string ("/foo/bar/baz")
type OscAddress = String
-
--- | The string specifies the type of expected arguments.
--- The string can contain the characters "bcdfilmst" which stand for
--- Boolean, character, double, float, 32-bit integer, 64-bit integer, MIDI,
+
+-- | The string specifies the type of expected arguments.
+-- The string can contain the characters "bcdfilmst" which stand for
+-- Boolean, character, double, float, 32-bit integer, 64-bit integer, MIDI,
-- string and timestamp.
type OscType = String
@@ -44,9 +44,9 @@ initOsc port = OscRef $ fromGE $ getOscPortHandle port
--
-- > /foo/bar/baz
--
--- The latter specifies the type of expected arguments.
--- The string can contain the characters "bcdfilmst" which stand for
--- Boolean, character, double, float, 32-bit integer, 64-bit integer, MIDI,
+-- The latter specifies the type of expected arguments.
+-- The string can contain the characters "bcdfilmst" which stand for
+-- Boolean, character, double, float, 32-bit integer, 64-bit integer, MIDI,
-- string and timestamp.
--
-- The result is an event of messages. We can run a callback on it
@@ -54,7 +54,7 @@ initOsc port = OscRef $ fromGE $ getOscPortHandle port
--
-- > runEvt :: Evt a -> (a -> SE ()) -> SE ()
listenOsc :: forall a . Tuple a => OscRef -> OscAddress -> OscType -> Evt a
-listenOsc oscRef oscAddr oscType = Evt $ \bam -> do
+listenOsc oscRef oscAddr oscType = Evt $ \bam -> do
resRef <- initOscRef oscType
cond <- listen resRef
when1 cond $ bam =<< readRef resRef
@@ -63,12 +63,12 @@ listenOsc oscRef oscAddr oscType = Evt $ \bam -> do
listen ref = fmap (==* 1) $ csdOscListen ref oscRef oscAddr oscType
csdOscListen :: Tuple a => Ref a -> OscRef -> OscAddress -> OscType -> SE Sig
- csdOscListen (Ref refVars) oscHandle addr ty =
- fmap fromGE $ fromDep $ hideGEinDep $ do
+ csdOscListen (Ref refVars) oscHandle addr ty =
+ fmap fromGE $ fromDep $ hideGEinDep $ do
expOscHandle <- toGE $ unOscRef oscHandle
expAddr <- toGE $ text addr
expOscType <- toGE $ text ty
- return $ C.oscListen expOscHandle expAddr expOscType refVars
+ return $ C.oscListen expOscHandle expAddr expOscType refVars
initOscRef :: OscType -> SE (Ref a)
initOscRef typeStr = fmap Ref $ newLocalVars (fmap getOscRate typeStr) (fromTuple $ (defTuple :: a))
@@ -81,22 +81,32 @@ listenOsc oscRef oscAddr oscType = Evt $ \bam -> do
'f' -> Kr
_ -> Kr
--- | Sends OSC-messages. It takes in a name of the host computer
--- (empty string is alocal machine), port on which the target
+-- | Sends OSC-messages. It takes in a name of the host computer
+-- (empty string is alocal machine), port on which the target
-- machine is listening, OSC-addres and type. The last argument
-- produces the values for OSC-messages.
sendOsc :: forall a . Tuple a => OscHost -> OscPort -> OscAddress -> OscType -> Evt a -> SE ()
-sendOsc host port addr ty evts = runEvt evts send
- where
- send :: Tuple a => a -> SE ()
- send as = SE $ hideGEinDep $ do
+sendOsc host port addr ty evts = do
+ flagRef <- newRef (0 :: Sig)
+ valRef <- newRef defTuple
+ runEvt evts $ \a -> do
+ flag <- readRef flagRef
+ writeRef flagRef (flag + 1)
+ writeRef valRef a
+
+ flag <- readRef flagRef
+ value <- readRef valRef
+ send flag value
+ where
+ send :: Tuple a => Sig -> a -> SE ()
+ send trig as = SE $ hideGEinDep $ do
args <- fromTuple as
+ expTrig <- toGE trig
expHost <- toGE $ text $ host
expPort <- toGE $ int $ port
expAddr <- toGE $ text $ addr
expTy <- toGE $ text $ ty
- return $ C.oscSend $ 1 : expHost : expPort : expAddr : expTy : args
-
+ return $ C.oscSend $ expTrig : expHost : expPort : expAddr : expTy : args
class Tuple a => OscVal a where
getOscTypes :: a -> String
@@ -146,7 +156,7 @@ instance (OscVal a, OscVal b, OscVal c, OscVal d, OscVal e) => OscVal (a, b, c,
-- | Listens for tuples of continuous signals read from OSC-channel.
--
--- > listenOscVal ref address initValue
+-- > listenOscVal ref address initValue
listenOscVal :: (Tuple a, OscVal a) => OscRef -> String -> a -> SE a
listenOscVal port path initVal = do
ref <- getOscRef initVal
diff --git a/src/Csound/Typed/GlobalState/Elements.hs b/src/Csound/Typed/GlobalState/Elements.hs
index 3b2f75a..879ecee 100644
--- a/src/Csound/Typed/GlobalState/Elements.hs
+++ b/src/Csound/Typed/GlobalState/Elements.hs
@@ -17,8 +17,8 @@ module Csound.Typed.GlobalState.Elements(
-- * Midi
MidiType(..), Channel, MidiMap, MidiKey(..), saveMidiInstr,
-- * Global variables
- Globals(..), newPersistentGlobalVar, newClearableGlobalVar,
- newPersistentGloabalArrVar,
+ Globals(..), newPersistentGlobalVar, newClearableGlobalVar,
+ newPersistentGloabalArrVar,
renderGlobals,
-- * Instruments
Instrs(..), saveInstr, getInstrIds, -- newInstrId, saveInstrById, saveInstr, CacheName, makeCacheName, saveCachedInstr, getInstrIds,
@@ -36,12 +36,12 @@ module Csound.Typed.GlobalState.Elements(
-- * Udo plugins
UdoPlugin, addUdoPlugin, getUdoPluginNames,
tabQueuePlugin, tabQueue2Plugin,
- zdfPlugin, solinaChorusPlugin, audaciouseqPlugin, adsr140Plugin,
+ zdfPlugin, solinaChorusPlugin, audaciouseqPlugin, adsr140Plugin,
diodePlugin, korg35Plugin, zeroDelayConvolutionPlugin,
pitchShifterDelayPlugin,
analogDelayPlugin, distortionPlugin, envelopeFolollowerPlugin, flangerPlugin, freqShifterPlugin,
- loFiPlugin, panTremPlugin, monoTremPlugin, phaserPlugin, pitchShifterPlugin, reversePlugin,
- ringModulatorPlugin, stChorusPlugin, stereoPingPongDelayPlugin,
+ loFiPlugin, panTremPlugin, monoTremPlugin, phaserPlugin, pitchShifterPlugin, reversePlugin,
+ ringModulatorPlugin, stChorusPlugin, stereoPingPongDelayPlugin,
delay1kPlugin,
) where
@@ -64,26 +64,26 @@ import Csound.Typed.GlobalState.Opcodes
data IdMap a = IdMap
{ idMapContent :: M.Map a Int
- , idMapNewId :: Int
+ , idMapNewId :: Int
} deriving (Eq, Ord)
-instance Default (IdMap a) where
+instance Default (IdMap a) where
def = IdMap def 1
saveId :: Ord a => a -> State (IdMap a) Int
-saveId a = state $ \s ->
+saveId a = state $ \s ->
case M.lookup a (idMapContent s) of
- Nothing ->
+ Nothing ->
let newId = idMapNewId s
s1 = s{ idMapContent = M.insert a newId (idMapContent s)
- , idMapNewId = succ newId }
+ , idMapNewId = succ newId }
in (newId, s1)
Just n -> (n, s)
newIdMapId :: State (IdMap a) Int
-newIdMapId = state $ \s ->
+newIdMapId = state $ \s ->
let newId = idMapNewId s
- s1 = s { idMapNewId = succ newId }
+ s1 = s { idMapNewId = succ newId }
in (newId, s1)
-- gens
@@ -98,19 +98,19 @@ newTabOfGens = (saveGenId . intTab =<<) . mapM saveGenId
where intTab ns = Gen (length ns) (IntGenId (-2)) (fmap fromIntegral ns) Nothing
saveGenId :: Ord a => a -> State (IdMap a) Int
-saveGenId a = state $ \s ->
+saveGenId a = state $ \s ->
case M.lookup a (idMapContent s) of
- Nothing ->
+ Nothing ->
let newId = nextReadOnlyTableId $ idMapNewId s
s1 = s{ idMapContent = M.insert a newId (idMapContent s)
- , idMapNewId = nextReadOnlyTableId newId }
+ , idMapNewId = nextReadOnlyTableId newId }
in (newId, s1)
Just n -> (n, s)
newGenId :: State GenMap Int
-newGenId = state $ \s ->
+newGenId = state $ \s ->
let newId = idMapNewId s
- s1 = s { idMapNewId = nextReadOnlyTableId newId }
+ s1 = s { idMapNewId = nextReadOnlyTableId newId }
in (newId, s1)
-- writeable gens
@@ -121,24 +121,24 @@ newWriteGen :: Gen -> State WriteGenMap E
newWriteGen = fmap int . saveWriteGenId
newWriteTab :: Int -> State WriteGenMap E
-newWriteTab = newWriteGen . fromSize
+newWriteTab = newWriteGen . fromSize
where fromSize n = Gen n (IntGenId 2) (replicate n 0) Nothing
saveWriteGenId :: Gen -> State WriteGenMap Int
saveWriteGenId a = state $ \s -> case s of
[] -> (initId, [(initId, a)])
- (i,_):_ -> let newId = nextWriteTableId i
+ (i,_):_ -> let newId = nextWriteTableId i
in (newId, (newId, a) : s)
- where
+ where
initId = tableWriteStep
tableWriteStep :: Int
tableWriteStep = 10
nextReadOnlyTableId :: Int -> Int
-nextReadOnlyTableId x
+nextReadOnlyTableId x
| y `mod` tableWriteStep == 0 = y + 1
- | otherwise = y
+ | otherwise = y
where y = x + 1
nextWriteTableId :: Int -> Int
@@ -158,14 +158,14 @@ nextGlobalGenCounter = state $ \s -> (s, s + 1)
-- sf
-data SfFluid = SfFluid
+data SfFluid = SfFluid
{ sfId :: Int
, sfVars :: [Var] }
data SfSpec = SfSpec
{ sfName :: String
, sfBank :: Int
- , sfProgram :: Int
+ , sfProgram :: Int
} deriving (Eq, Ord, Show)
type SfMap = IdMap SfSpec
@@ -183,14 +183,14 @@ sfInstrName :: Int -> String
sfInstrName n = "i_Sf_instr_" ++ show n
renderSf :: Monad m => SfSpec -> Int -> DepT m ()
-renderSf (SfSpec name bank prog) n = verbatim $
+renderSf (SfSpec name bank prog) n = verbatim $
engineStr ++ "\n" ++
loadStr ++ "\n" ++
selectProgStr ++ "\n"
- where
+ where
engineStr = engineName ++ " fluidEngine"
loadStr = insName ++ " fluidLoad \"" ++ name ++ "\", " ++ engineName ++ ", 1"
- selectProgStr = "fluidProgramSelect " ++ engineName ++ ", 1, " ++ insName
+ selectProgStr = "fluidProgramSelect " ++ engineName ++ ", 1, " ++ insName
++ ", " ++ show bank ++ ", " ++ show prog
engineName = sfEngineName n
@@ -211,7 +211,7 @@ bandLimitedIdToExpr x = case x of
bandLimitedVar userId = Var GlobalVar Ir ("BandLim" ++ show userId)
-data BandLimitedMap = BandLimitedMap
+data BandLimitedMap = BandLimitedMap
{ simpleBandLimitedMap :: M.Map BandLimited BandLimitedId
, vcoInitMap :: GenMap
} deriving (Eq, Ord)
@@ -229,27 +229,27 @@ saveBandLimited x = case x of
UserGen gen -> userGen gen
where
simpleWave writeId readId = state $ \blMap ->
- if (M.member x (simpleBandLimitedMap blMap))
+ if (M.member x (simpleBandLimitedMap blMap))
then (SimpleBandLimitedWave readId, blMap)
else (SimpleBandLimitedWave readId, blMap { simpleBandLimitedMap = M.insert x (SimpleBandLimitedWave writeId) (simpleBandLimitedMap blMap) })
- userGen gen = state $ \blMap ->
+ userGen gen = state $ \blMap ->
let genMap = vcoInitMap blMap
(newId, genMap1) = runState (saveId gen) genMap
- blMap1 = blMap { vcoInitMap = genMap1 }
+ blMap1 = blMap { vcoInitMap = genMap1 }
in (UserBandLimitedWave newId, blMap1)
renderBandLimited :: Monad m => GenMap -> BandLimitedMap -> DepT m ()
-renderBandLimited genMap blMap =
- if isEmptyBlMap blMap
+renderBandLimited genMap blMap =
+ if isEmptyBlMap blMap
then return ()
else render (idMapNewId genMap) (M.toList $ idMapContent $ vcoInitMap blMap) (M.toList $ simpleBandLimitedMap blMap)
- where
+ where
isEmptyBlMap m = (M.null $ simpleBandLimitedMap m) && (M.null $ idMapContent $ vcoInitMap m)
render lastGenId gens vcos = do
- writeVar freeVcoVar $ int (lastGenId + length gens + 100)
+ writeVar freeVcoVar $ int (lastGenId + length gens + 100)
mapM_ (renderGen lastGenId) gens
mapM_ renderVco vcos
@@ -257,12 +257,12 @@ renderBandLimited genMap blMap =
renderGen lastGenId (gen, genId) = do
renderFtgen lastGenId (gen, genId)
renderVcoGen genId
- renderVcoVarAssignment genId
+ renderVcoVarAssignment genId
freeVcoVar = Var GlobalVar Ir "free_vco"
- ftVar n = Var GlobalVar Ir $ "vco_table_" ++ show n
+ ftVar n = Var GlobalVar Ir $ "vco_table_" ++ show n
- renderFtgen lastGenId (g, n) = writeVar (ftVar n) $ ftgen (int $ lastGenId + n) g
+ renderFtgen lastGenId (g, n) = writeVar (ftVar n) $ ftgen (int $ lastGenId + n) g
renderVcoGen ftId = do
ft <- readVar (ftVar ftId)
@@ -278,16 +278,16 @@ renderBandLimited genMap blMap =
writeVar freeVcoVar $ vco2init [int waveId, free]
UserBandLimitedWave _ -> return ()
-
+
{-
renderFirstVco n (head vcos)
- mapM_ renderTailVco (tail vcos)
+ mapM_ renderTailVco (tail vcos)
getUserGens as = phi =<< as
where phi (x, gId) = case x of
UserGen g -> [(g, gId)]
_ -> []
-
+
renderGen (g, n) = toDummy $ ftgen (int n) g
renderFirstVco n x = renderVco (int n) x
@@ -300,7 +300,7 @@ renderBandLimited genMap blMap =
vcoVar = dummyVar
toVcoVar = toDummy
- dummyVar = Var LocalVar Ir "ft"
+ dummyVar = Var LocalVar Ir "ft"
toDummy = writeVar dummyVar
-}
@@ -318,7 +318,7 @@ readHardSyncBandLimited msmoothShape mphase n slaveCps masterCps = smoothWave *
Nothing -> 1
Just shape -> readShape shape phasorMaster masterCps
- readShape shapeId phasor freq = tableikt phasor (vco2ft freq (bandLimitedIdToExpr shapeId))
+ readShape shapeId phasor freq = tableikt phasor (vco2ft freq (bandLimitedIdToExpr shapeId))
----------------------------------------------------------
-- Midi
@@ -342,11 +342,11 @@ data Globals = Globals
{ globalsNewId :: Int
, globalsVars :: [AllocVar] }
-data AllocVar = AllocVar
- { allocVarType :: GlobalVarType
+data AllocVar = AllocVar
+ { allocVarType :: GlobalVarType
, allocVar :: Var
, allocVarInit :: E }
- | AllocArrVar
+ | AllocArrVar
{ allocArrVar :: Var
, allocArrVarSizes :: [E] }
@@ -359,8 +359,8 @@ instance Default Globals where
newGlobalVar :: GlobalVarType -> Rate -> E -> State Globals Var
newGlobalVar ty rate initVal = state $ \s ->
- let newId = globalsNewId s
- var = Var GlobalVar rate ('g' : show newId)
+ let newId = globalsNewId s
+ var = Var GlobalVar rate ('g' : show newId)
s1 = s { globalsNewId = succ newId
, globalsVars = AllocVar ty var initVal : globalsVars s }
in (var, s1)
@@ -374,8 +374,8 @@ newClearableGlobalVar = newGlobalVar ClearableGlobalVar
newPersistentGloabalArrVar :: Rate -> [E] -> State Globals Var
newPersistentGloabalArrVar rate sizes = state $ \s ->
let newId = globalsNewId s
- var = Var GlobalVar rate ('g' : show newId)
- s1 = s { globalsNewId = succ newId
+ var = Var GlobalVar rate ('g' : show newId)
+ s1 = s { globalsNewId = succ newId
, globalsVars = AllocArrVar var sizes : globalsVars s }
in (var, s1)
@@ -388,7 +388,7 @@ renderGlobals a = (initAll, clear)
gs = globalsVars a
initAlloc x = case x of
- AllocVar _ var init -> initVar var init
+ AllocVar _ var init -> initVar var init
AllocArrVar var sizes -> initArr var sizes
clearAlloc x = case x of
@@ -419,11 +419,11 @@ getInstrIds = fmap fst . instrsContent
saveInstr :: InstrBody -> State Instrs InstrId
-saveInstr body = state $ \s ->
+saveInstr body = state $ \s ->
let h = hash body
in case IM.lookup h $ instrsCache s of
Just n -> (n, s)
- Nothing ->
+ Nothing ->
let newId = instrsNewId s
s1 = s { instrsCache = IM.insert h (intInstrId newId) $ instrsCache s
, instrsNewId = succ newId
@@ -431,11 +431,11 @@ saveInstr body = state $ \s ->
in (intInstrId newId, s1)
{-
-saveCachedInstr :: InstrBody -> State Instrs InstrId
-saveCachedInstr name body = state $ \s ->
+saveCachedInstr :: InstrBody -> State Instrs InstrId
+saveCachedInstr name body = state $ \s ->
case IM.lookup name $ instrsCache s of
Just n -> (n, s)
- Nothing ->
+ Nothing ->
let newId = instrsNewId s
s1 = s { instrsCache = IM.insert name (intInstrId newId) $ instrsCache s
, instrsNewId = succ newId
@@ -445,11 +445,11 @@ saveCachedInstr name body = state $ \s ->
newInstrId :: State Instrs InstrId
newInstrId = state $ \s ->
let newId = instrsNewId s
- s1 = s { instrsNewId = succ newId }
+ s1 = s { instrsNewId = succ newId }
in (intInstrId newId, s1)
saveInstrById :: InstrId -> InstrBody -> State Instrs ()
-saveInstrById instrId body = state $ \s ->
+saveInstrById instrId body = state $ \s ->
let s1 = s { instrsContent = (instrId, body) : instrsContent s }
in ((), s1)
@@ -477,20 +477,10 @@ saveNamedInstr name body = state $ \(NamedInstrs xs) -> ((), NamedInstrs $ (name
getIn :: Monad m => Int -> DepT m [E]
getIn arity
| arity == 0 = return []
- | otherwise = ($ arity ) $ mdepT $ mopcs name (replicate arity Ar, []) []
- where
- name
- | arity == 1 = "in"
- | arity == 2 = "ins"
- | arity == 4 = "inq"
- | arity == 6 = "inh"
- | arity == 8 = "ino"
- | arity == 16 = "inx"
- | arity == 32 = "in32"
- | otherwise = "ins"
+ | otherwise = ($ arity ) $ mdepT $ mopcs "inch" (replicate arity Ar, replicate arity Kr) (fmap int [1 .. arity])
sendOut :: Monad m => Int -> [E] -> DepT m ()
-sendOut arity sigs
+sendOut arity sigs
| arity == 0 = return ()
| otherwise = do
vars <- newLocalVars (replicate arity Ar) (return $ replicate arity 0)
@@ -498,7 +488,7 @@ sendOut arity sigs
vals <- mapM readVar vars
depT_ $ opcsNoInlineArgs name [(Xr, replicate arity Ar)] vals
where
- name
+ name
| arity == 1 = "out"
| arity == 2 = "outs"
| arity == 4 = "outq"
@@ -537,7 +527,7 @@ getOscPortVar port = state $ \st@(OscListenPorts m, globals) -> case IM.lookup p
Just a -> (a, st)
Nothing -> onNothing port m globals
where
- onNothing port m globals = (var, (OscListenPorts m1, newGlobals))
+ onNothing port m globals = (var, (OscListenPorts m1, newGlobals))
where
(var, newGlobals) = runState (allocOscPortVar port) globals
m1 = IM.insert port var m
@@ -551,17 +541,17 @@ allocOscPortVar oscPort = newGlobalVar PersistentGlobalVar Ir $ oscInit (fromInt
type MacrosInits = M.Map String MacrosInit
-data MacrosInit
+data MacrosInit
= MacrosInitDouble { macrosInitName :: String, macrosInitValueDouble :: Double }
| MacrosInitString { macrosInitName :: String, macrosInitValueString :: String }
| MacrosInitInt { macrosInitName :: String, macrosInitValueInt :: Int }
deriving (Show, Eq, Ord)
initMacros :: MacrosInit -> State MacrosInits ()
-initMacros macrosInit = modify $ \xs -> M.insert (macrosInitName macrosInit) macrosInit xs
+initMacros macrosInit = modify $ \xs -> M.insert (macrosInitName macrosInit) macrosInit xs
--------------------------------------------------------
--- Udo plugins
+-- Udo plugins
newtype UdoPlugin = UdoPlugin { unUdoPlugin :: String }
diff --git a/src/Csound/Typed/Types/Evt.hs b/src/Csound/Typed/Types/Evt.hs
index 0791b61..706907d 100644
--- a/src/Csound/Typed/Types/Evt.hs
+++ b/src/Csound/Typed/Types/Evt.hs
@@ -1,6 +1,6 @@
{-# Language TypeFamilies, FlexibleContexts #-}
module Csound.Typed.Types.Evt(
- Evt(..), Bam, sync,
+ Evt(..), Bam, sync,
boolToEvt, evtToBool, sigToEvt, stepper,
filterE, filterSE, accumSE, accumE, filterAccumE, filterAccumSE,
Snap, snapshot, snaps, readSnap
@@ -26,12 +26,12 @@ data Evt a = Evt { runEvt :: Bam a -> SE () }
type Bam a = a -> SE ()
instance Functor Evt where
- fmap f a = Evt $ \bam -> runEvt a (bam . f)
+ fmap f a = Evt $ \bam -> runEvt a (bam . f)
instance Monoid (Evt a) where
mempty = Evt $ const $ return ()
mappend a b = Evt $ \bam -> runEvt a bam >> runEvt b bam
-
+
-- | Converts booleans to events.
boolToEvt :: BoolSig -> Evt Unit
boolToEvt b = Evt $ \bam -> when1 b $ bam unit
@@ -49,7 +49,7 @@ filterE pr evt = Evt $ \bam -> runEvt evt $ \a ->
filterSE :: (a -> SE BoolD) -> Evt a -> Evt a
filterSE mpr evt = Evt $ \bam -> runEvt evt $ \a -> do
pr <- mpr a
- when1 (boolSig pr) $ bam a
+ when1 (boolSig pr) $ bam a
-- | Accumulator for events with side effects.
accumSE :: (Tuple s) => s -> (a -> s -> SE (b, s)) -> Evt a -> Evt b
@@ -84,7 +84,7 @@ filterAccumE s0 update = filterAccumSE s0 $ \a s -> return $ update a s
-- | Get values of some signal at the given events.
snapshot :: (Tuple a, Tuple (Snap a)) => (Snap a -> b -> c) -> a -> Evt b -> Evt c
-snapshot f asig evt = Evt $ \bam -> runEvt evt $ \a ->
+snapshot f asig evt = Evt $ \bam -> runEvt evt $ \a ->
bam (f (readSnap asig) a)
readSnap :: (Tuple (Snap a), Tuple a) => a -> Snap a
@@ -94,13 +94,13 @@ readSnap = toTuple . fromTuple
-- given signal. Events happens only when the signal changes.
snaps :: Sig -> Evt D
snaps asig = snapshot const asig trigger
- where
+ where
trigger = sigToEvt $ fromGE $ fmap C.changed $ toGE asig
-------------------------------------------------------------------
--- snap
+-- snap
--- | A snapshot of the signal. It converts a type of the signal to the
+-- | A snapshot of the signal. It converts a type of the signal to the
-- type of the value in the given moment. Instances:
--
--
@@ -109,7 +109,7 @@ snaps asig = snapshot const asig trigger
-- > type instance Snap Tab = Tab
-- >
-- > type instance Snap Sig = D
--- >
+-- >
-- > type instance Snap (a, b) = (Snap a, Snap b)
-- > type instance Snap (a, b, c) = (Snap a, Snap b, Snap c)
-- > type instance Snap (a, b, c, d) = (Snap a, Snap b, Snap c, Snap d)
@@ -130,7 +130,7 @@ type instance Snap (a, b, c, d, e) = (Snap a, Snap b, Snap c, Snap d, Snap e)
type instance Snap (a, b, c, d, e, f) = (Snap a, Snap b, Snap c, Snap d, Snap e, Snap f)
-- | Converts an event to boolean signal. It forgets
--- everything about the event values. Signal equals to one when
+-- everything about the event values. Signal equals to one when
-- an event happens and zero otherwise.
evtToBool :: Evt a -> SE BoolSig
evtToBool evt = do
@@ -151,25 +151,25 @@ stepper v0 evt = do
-- synchronization
-- | Executes actions synchronized with global tempo (in Hz).
---
+--
-- > runEvtSync tempoCps evt proc
sync :: (Default a, Tuple a) => Sig -> Evt a -> Evt a
-sync dt evt = Evt $ \bam -> do
+sync dt evt = Evt $ \bam -> do
refVal <- newRef def
refFire <- newRef (0 :: D)
runEvt evt $ \a -> do
writeRef refVal a
- writeRef refFire 1
-
+ writeRef refFire 1
+
fire <- readRef refFire
when1 (metro dt ==* 1 &&* sig fire ==* 1) $ do
val <- readRef refVal
bam val
- writeRef refFire 0
+ writeRef refFire 0
where
metro :: Sig -> Sig
metro asig = fromGE $ fmap C.metro $ toGE asig
-
+
diff --git a/src/Csound/Typed/Types/Prim.hs b/src/Csound/Typed/Types/Prim.hs
index ea86e3e..af31198 100644
--- a/src/Csound/Typed/Types/Prim.hs
+++ b/src/Csound/Typed/Types/Prim.hs
@@ -3,17 +3,18 @@ module Csound.Typed.Types.Prim(
Sig(..), unSig, D(..), unD, Tab(..), unTab, Str(..), Spec(..), Wspec(..), renderTab,
BoolSig(..), unBoolSig, BoolD(..), unBoolD, Unit(..), unit, Val(..), hideGE, SigOrD,
Sig2, Sig3, Sig4, Sig5, Sig6, Sig7, Sig8,
+ Sig2_2, Sig2_3, Sig2_4, Sig2_5, Sig2_6, Sig2_7, Sig2_8,
D2, D3, D4, D5, D6,
-- ** Tables
preTab, preStringTab, TabSize(..), TabArgs(..), updateTabSize,
fromPreTab, getPreTabUnsafe, skipNorm, forceNorm,
nsamp, ftlen, ftchnls, ftsr, ftcps,
- TabList, tabList, fromTabList, fromTabListD,
+ TabList, tabList, fromTabList, fromTabListD,
-- ** constructors
- double, int, text,
-
+ double, int, text,
+
-- ** constants
idur, getSampleRate, getControlRate, getBlockSize, getZeroDbfs,
@@ -25,11 +26,13 @@ module Csound.Typed.Types.Prim(
-- ** numeric funs
quot', rem', div', mod', ceil', floor', round', int', frac',
-
+
-- ** logic funs
when1, whens, untilDo, whileDo, boolSig,
equalsTo, notEqualsTo, lessThan, greaterThan, lessThanEquals, greaterThanEquals,
- whenD1, whenDs, untilDoD, whileDoD, untilBeginD
+ whenD1, whenDs, untilDoD, whileDoD, untilBeginD,
+
+ module Data.NumInstances.Tuple
) where
import Prelude hiding ((<*))
@@ -41,6 +44,8 @@ import Data.Monoid
import qualified Data.IntMap as IM
import qualified Data.Map as M
+import Data.NumInstances.Tuple
+
import Control.Monad.Trans.Reader
import Data.Default
@@ -54,7 +59,7 @@ import Csound.Typed.GlobalState.Options
import Csound.Typed.GlobalState.Opcodes(tableK, tableI)
-- | Signals
-data Sig
+data Sig
= Sig (GE E)
| PrimSig Double
@@ -62,7 +67,7 @@ unSig :: Sig -> GE E
unSig = toGE
-- | Constant numbers
-data D
+data D
= D (GE E)
| PrimD Double
@@ -92,10 +97,18 @@ type Sig6 = (Sig, Sig, Sig, Sig, Sig, Sig)
type Sig7 = (Sig, Sig, Sig, Sig, Sig, Sig, Sig)
type Sig8 = (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)
+type Sig2_2 = (Sig2, Sig2)
+type Sig2_3 = (Sig2, Sig2, Sig2)
+type Sig2_4 = (Sig2, Sig2, Sig2, Sig2)
+type Sig2_5 = (Sig2, Sig2, Sig2, Sig2, Sig2)
+type Sig2_6 = (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2)
+type Sig2_7 = (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2)
+type Sig2_8 = (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2)
+
-- Booleans
-- | A signal of booleans.
-data BoolSig
+data BoolSig
= BoolSig (GE E)
| PrimBoolSig Bool
@@ -103,7 +116,7 @@ unBoolSig :: BoolSig -> GE E
unBoolSig = toGE
-- | A constant boolean value.
-data BoolD
+data BoolD
= BoolD (GE E)
| PrimBoolD Bool
@@ -120,7 +133,7 @@ type instance BooleanOf Spec = BoolD
-- Procedures
-- | Csound's empty tuple.
-newtype Unit = Unit { unUnit :: GE () }
+newtype Unit = Unit { unUnit :: GE () }
-- | Constructs Csound's empty tuple.
unit :: Unit
@@ -136,7 +149,7 @@ instance Default Unit where
-- tables
-- | Tables (or arrays)
-data Tab
+data Tab
= Tab (GE E)
| TabPre PreTab
@@ -152,11 +165,11 @@ data PreTab = PreTab
, preTabArgs :: TabArgs }
-- Table size.
-data TabSize
+data TabSize
-- Size is fixed by the user.
= SizePlain Int
-- Size is relative to the renderer settings.
- | SizeDegree
+ | SizeDegree
{ hasGuardPoint :: Bool
, sizeDegree :: Int -- is the power of two
}
@@ -165,9 +178,9 @@ instance Default TabSize where
def = SizeDegree
{ hasGuardPoint = False
, sizeDegree = 0 }
-
+
-- Table arguments can be
-data TabArgs
+data TabArgs
-- absolute
= ArgsPlain (Reader Int [Double])
{- -- or relative to the table size (used for tables that implement interpolation)
@@ -177,7 +190,7 @@ data TabArgs
| FileAccess String [Double]
renderPreTab :: PreTab -> GE E
-renderPreTab a = (fmap D.int . saveGen) =<< fromPreTab a
+renderPreTab a = (fmap D.int . saveGen) =<< fromPreTab a
getPreTabUnsafe :: String -> Tab -> PreTab
getPreTabUnsafe msg x = case x of
@@ -200,20 +213,20 @@ getTabSizeBase tf tab = case preTabGen tab of
defineTabSize :: Int -> TabSize -> Int
defineTabSize base x = case x of
SizePlain n -> n
- SizeDegree guardPoint degree ->
+ SizeDegree guardPoint degree ->
byGuardPoint guardPoint $
byDegree base degree
- where byGuardPoint guardPoint
+ where byGuardPoint guardPoint
| guardPoint = (+ 1)
| otherwise = id
-
- byDegree zero n = 2 ^ max 0 (zero + n)
+
+ byDegree zero n = 2 ^ max 0 (zero + n)
defineTabArgs :: Int -> TabArgs -> ([Double], Maybe String)
defineTabArgs size args = case args of
ArgsPlain as -> (runReader as size, Nothing)
FileAccess filename as -> (as, Just filename)
-
+
-- | Skips normalization (sets table size to negative value)
skipNorm :: Tab -> Tab
skipNorm x = case x of
@@ -247,12 +260,12 @@ updateTabSize phi x = case x of
----------------------------------------------------------------------------
-- Tab of tabs
--- | Container list of tables
+-- | Container list of tables
data TabList = TabList { unTabList :: GE E }
tabList :: [Tab] -> TabList
tabList xs = TabList $ saveTabs =<< mapM fromPreTab (getPreTabs xs)
- where
+ where
getPreTabs xs = case xs of
[] -> []
Tab _ : as -> getPreTabs as
@@ -289,7 +302,7 @@ text = fromE . D.str
-- constants
-- | Querries a total duration of the note. It's equivallent to Csound's @p3@ field.
-idur :: D
+idur :: D
idur = fromE $ pn 3
getSampleRate :: D
@@ -337,14 +350,14 @@ class Val a where
hideGE :: Val a => GE a -> a
hideGE = fromGE . join . fmap toGE
-instance Val Sig where
- fromGE = Sig
-
+instance Val Sig where
+ fromGE = Sig
+
toGE x = case x of
Sig a -> a
PrimSig d -> return $ D.double d
-instance Val D where
+instance Val D where
fromGE = D
toGE x = case x of
D a -> a
@@ -356,8 +369,8 @@ instance Val Wspec where { fromGE = Wspec ; toGE = unWspec}
instance Val TabList where { fromGE = TabList; toGE = unTabList }
-instance Val Tab where
- fromGE = Tab
+instance Val Tab where
+ fromGE = Tab
toGE = unTab
unTab :: Tab -> GE E
@@ -370,13 +383,13 @@ renderTab x = case x of
TabPre a -> saveGen =<< fromPreTab a
Tab _ -> error "table should be primitive"
-instance Val BoolSig where
- fromGE = BoolSig
+instance Val BoolSig where
+ fromGE = BoolSig
toGE x = case x of
BoolSig a -> a
PrimBoolSig b -> return $ if b then true else false
-instance Val BoolD where
+instance Val BoolD where
fromGE = BoolD
toGE x = case x of
BoolD a -> a
@@ -415,7 +428,7 @@ instance Default Sig where def = 0
instance Default D where def = 0
instance Default Tab where def = fromE 0
instance Default Str where def = text ""
-instance Default Spec where def = fromE 0
+instance Default Spec where def = fromE 0
instance Default TabList where def = fromE 0
@@ -439,7 +452,7 @@ sigOn2 numFun exprFun xa xb = case (xa, xb) of
_ -> on2 exprFun xa xb
-instance Num Sig where
+instance Num Sig where
{ (+) = sigOn2 (+) (+); (*) = sigOn2 (*) (*); negate = sigOn1 negate negate
; (-) = sigOn2 (\a b -> a - b) (\a b -> a - b)
; fromInteger = PrimSig . fromInteger; abs = sigOn1 abs abs; signum = sigOn1 signum signum }
@@ -454,7 +467,7 @@ dOn2 numFun exprFun xa xb = case (xa, xb) of
(PrimD a, PrimD b) -> PrimD $ numFun a b
_ -> on2 exprFun xa xb
-instance Num D where
+instance Num D where
{ (+) = dOn2 (+) (+); (*) = dOn2 (*) (*); negate = dOn1 negate negate
; (-) = dOn2 (\a b -> a - b) (\a b -> a - b)
; fromInteger = PrimD . fromInteger; abs = dOn1 abs abs; signum = dOn1 signum signum }
@@ -479,7 +492,7 @@ class IsPrim a where
instance IsPrim Sig where
type PrimOf Sig = Double
-
+
getPrim x = case x of
PrimSig a -> Just a
_ -> Nothing
@@ -488,7 +501,7 @@ instance IsPrim Sig where
instance IsPrim D where
type PrimOf D = Double
-
+
getPrim x = case x of
PrimD a -> Just a
_ -> Nothing
@@ -497,7 +510,7 @@ instance IsPrim D where
instance IsPrim BoolSig where
type PrimOf BoolSig = Bool
-
+
getPrim x = case x of
PrimBoolSig a -> Just a
_ -> Nothing
@@ -506,7 +519,7 @@ instance IsPrim BoolSig where
instance IsPrim BoolD where
type PrimOf BoolD = Bool
-
+
getPrim x = case x of
PrimBoolD a -> Just a
_ -> Nothing
@@ -528,8 +541,8 @@ floor' = op1 (\x -> fromIntegral ((floor x) :: Int)) floorE
int' = op1 (\x -> fromIntegral ((truncate x) :: Int)) intE
round' = op1 (\x -> fromIntegral ((round x) :: Int)) roundE
quot' = op2 (\a b -> fromIntegral $ quot ((truncate a) :: Int) ((truncate b):: Int)) quot
-rem' = op2 (\a b -> fromIntegral $ rem ((truncate a) :: Int) ((truncate b):: Int)) rem
-div' = op2 (\a b -> fromIntegral $ div ((truncate a) :: Int) ((truncate b):: Int)) div
+rem' = op2 (\a b -> fromIntegral $ rem ((truncate a) :: Int) ((truncate b):: Int)) rem
+div' = op2 (\a b -> fromIntegral $ div ((truncate a) :: Int) ((truncate b):: Int)) div
mod' = op2 (\a b -> fromIntegral $ mod ((truncate a) :: Int) ((truncate b):: Int)) mod
-------------------------------------------------------------------------------
@@ -539,38 +552,38 @@ boolSigOn1 :: (Bool -> Bool) -> (E -> E) -> BoolSig -> BoolSig
boolSigOn1 = op1
boolSigOn2 :: (Bool -> Bool -> Bool) -> (E -> E -> E) -> BoolSig -> BoolSig -> BoolSig
-boolSigOn2 = op2
+boolSigOn2 = op2
boolDOn1 :: (Bool -> Bool) -> (E -> E) -> BoolD -> BoolD
boolDOn1 = op1
boolDOn2 :: (Bool -> Bool -> Bool) -> (E -> E -> E) -> BoolD -> BoolD -> BoolD
-boolDOn2 = op2
+boolDOn2 = op2
instance Boolean BoolSig where { true = PrimBoolSig True; false = PrimBoolSig False; notB = boolSigOn1 not notB; (&&*) = boolSigOn2 (&&) (&&*); (||*) = boolSigOn2 (||) (||*) }
instance Boolean BoolD where { true = PrimBoolD True; false = PrimBoolD False; notB = boolDOn1 not notB; (&&*) = boolDOn2 (&&) (&&*); (||*) = boolDOn2 (||) (||*) }
-instance IfB Sig where
+instance IfB Sig where
ifB x a b = case x of
PrimBoolSig cond -> if cond then a else b
_ -> on3 ifB x a b
-instance IfB D where
+instance IfB D where
ifB x a b = case x of
PrimBoolD cond -> if cond then a else b
_ -> on3 ifB x a b
-instance IfB Tab where
+instance IfB Tab where
ifB x a b = case x of
PrimBoolD cond -> if cond then a else b
_ -> on3 ifB x a b
-instance IfB Str where
+instance IfB Str where
ifB x a b = case x of
PrimBoolD cond -> if cond then a else b
_ -> on3 ifB x a b
-instance IfB Spec where
+instance IfB Spec where
ifB x a b = case x of
PrimBoolD cond -> if cond then a else b
_ -> on3 ifB x a b
@@ -599,7 +612,7 @@ whens bodies el = case bodies of
ifBegin (fst a)
snd a
elseIfs as
- elseBegin
+ elseBegin
el
foldl1 (>>) $ replicate (length bodies) ifEnd
where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBegin p >> body)
@@ -631,7 +644,7 @@ whenDs bodies el = case bodies of
ifBeginD (fst a)
snd a
elseIfs as
- elseBegin
+ elseBegin
el
foldl1 (>>) $ replicate (length bodies) ifEnd
where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBeginD p >> body)
@@ -699,7 +712,7 @@ notEqualsTo :: EqB a => a -> a -> BooleanOf a
notEqualsTo = (/=*)
lessThan :: OrdB a => a -> a -> BooleanOf a
-lessThan = (<*)
+lessThan = (<*)
greaterThan :: OrdB a => a -> a -> BooleanOf a
greaterThan = (>*)
@@ -740,85 +753,7 @@ ftcps = on1 $ opr1 "ftcps"
-------------------------------------------------
-- numeric instances
-instance Num Sig2 where
- (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2)
- (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2)
- negate (a1, a2) = (negate a1, negate a2)
-
- fromInteger n = (fromInteger n, fromInteger n)
- signum (a1, a2) = (signum a1, signum a2)
- abs (a1, a2) = (abs a1, abs a2)
-
-instance Fractional Sig2 where
- recip (a1, a2) = (recip a1, recip a2)
- fromRational n = (fromRational n, fromRational n)
-
-instance Num Sig3 where
- (a1, a2, a3) + (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3)
- (a1, a2, a3) * (b1, b2, b3) = (a1 * b1, a2 * b2, a3 * b3)
- negate (a1, a2, a3) = (negate a1, negate a2, negate a3)
-
- fromInteger n = (fromInteger n, fromInteger n, fromInteger n)
- signum (a1, a2, a3) = (signum a1, signum a2, signum a3)
- abs (a1, a2, a3) = (abs a1, abs a2, abs a3)
-
-instance Fractional Sig3 where
- recip (a1, a2, a3) = (recip a1, recip a2, recip a3)
- fromRational n = (fromRational n, fromRational n, fromRational n)
-
-instance Num Sig4 where
- (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4)
- (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4)
- negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4)
-
- fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n)
- signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4)
- abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4)
-
-instance Fractional Sig4 where
- recip (a1, a2, a3, a4) = (recip a1, recip a2, recip a3, recip a4)
- fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n)
-
-instance Num Sig5 where
- (a1, a2, a3, a4, a5) + (b1, b2, b3, b4, b5) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5)
- (a1, a2, a3, a4, a5) * (b1, b2, b3, b4, b5) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5)
- negate (a1, a2, a3, a4, a5) = (negate a1, negate a2, negate a3, negate a4, negate a5)
-
- fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n)
- signum (a1, a2, a3, a4, a5) = (signum a1, signum a2, signum a3, signum a4, signum a5)
- abs (a1, a2, a3, a4, a5) = (abs a1, abs a2, abs a3, abs a4, abs a5)
-
-instance Fractional Sig5 where
- recip (a1, a2, a3, a4, a5) = (recip a1, recip a2, recip a3, recip a4, recip a5)
- fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n)
-
-instance Num Sig6 where
- (a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6)
- (a1, a2, a3, a4, a5, a6) * (b1, b2, b3, b4, b5, b6) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6)
- negate (a1, a2, a3, a4, a5, a6) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6)
-
- fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n)
- signum (a1, a2, a3, a4, a5, a6) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6)
- abs (a1, a2, a3, a4, a5, a6) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6)
-
-instance Fractional Sig6 where
- recip (a1, a2, a3, a4, a5, a6) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6)
- fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n)
-
-instance Num Sig7 where
- (a1, a2, a3, a4, a5, a6, a7) + (b1, b2, b3, b4, b5, b6, b7) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6, a7 + b7)
- (a1, a2, a3, a4, a5, a6, a7) * (b1, b2, b3, b4, b5, b6, b7) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6, a7 * b7)
- negate (a1, a2, a3, a4, a5, a6, a7) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6, negate a7)
-
- fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n)
- signum (a1, a2, a3, a4, a5, a6, a7) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6, signum a7)
- abs (a1, a2, a3, a4, a5, a6, a7) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6, abs a7)
-
-instance Fractional Sig7 where
- recip (a1, a2, a3, a4, a5, a6, a7) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6, recip a7)
- fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n)
-
-instance Num Sig8 where
+instance (Num a1, Num a2, Num a3, Num a4, Num a5, Num a6, Num a7, Num a8) => Num (a1, a2, a3, a4, a5, a6, a7, a8) where
(a1, a2, a3, a4, a5, a6, a7, a8) + (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6, a7 + b7, a8 + b8)
(a1, a2, a3, a4, a5, a6, a7, a8) * (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6, a7 + b7, a8 + b8)
negate (a1, a2, a3, a4, a5, a6, a7, a8) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6, negate a7, negate a8)
@@ -827,97 +762,6 @@ instance Num Sig8 where
signum (a1, a2, a3, a4, a5, a6, a7, a8) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6, signum a7, signum a8)
abs (a1, a2, a3, a4, a5, a6, a7, a8) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6, abs a7, abs a8)
-instance Fractional Sig8 where
+instance (Fractional a1, Fractional a2, Fractional a3, Fractional a4, Fractional a5, Fractional a6, Fractional a7, Fractional a8) => Fractional (a1, a2, a3, a4, a5, a6, a7, a8) where
recip (a1, a2, a3, a4, a5, a6, a7, a8) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6, recip a7, recip a8)
fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n)
-
-instance Num (Sig8, Sig8) where
- (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2)
- (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2)
- negate (a1, a2) = (negate a1, negate a2)
-
- fromInteger n = (fromInteger n, fromInteger n)
- signum (a1, a2) = (signum a1, signum a2)
- abs (a1, a2) = (abs a1, abs a2)
-
-instance Fractional (Sig8, Sig8) where
- recip (a1, a2) = (recip a1, recip a2)
- fromRational n = (fromRational n, fromRational n)
-
-instance Num (Sig8, Sig8, Sig8, Sig8) where
- (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4)
- (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4)
- negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4)
-
- fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n)
- signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4)
- abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4)
-
-instance Fractional (Sig8, Sig8, Sig8, Sig8) where
- recip (a1, a2, a3, a4) = (recip a1, recip a2, recip a3, recip a4)
- fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n)
-
-instance Num (Sig2, Sig2) where
- (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2)
- (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2)
- negate (a1, a2) = (negate a1, negate a2)
-
- fromInteger n = (fromInteger n, fromInteger n)
- signum (a1, a2) = (signum a1, signum a2)
- abs (a1, a2) = (abs a1, abs a2)
-
-instance Fractional (Sig2, Sig2) where
- recip (a1, a2) = (recip a1, recip a2)
- fromRational n = (fromRational n, fromRational n)
-
-instance Num (Sig2, Sig2, Sig2) where
- (a1, a2, a3) + (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3)
- (a1, a2, a3) * (b1, b2, b3) = (a1 * b1, a2 * b2, a3 * b3)
- negate (a1, a2, a3) = (negate a1, negate a2, negate a3)
-
- fromInteger n = (fromInteger n, fromInteger n, fromInteger n)
- signum (a1, a2, a3) = (signum a1, signum a2, signum a3)
- abs (a1, a2, a3) = (abs a1, abs a2, abs a3)
-
-instance Fractional (Sig2, Sig2, Sig2) where
- recip (a1, a2, a3) = (recip a1, recip a2, recip a3)
- fromRational n = (fromRational n, fromRational n, fromRational n)
-
-instance Num (Sig2, Sig2, Sig2, Sig2) where
- (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4)
- (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4)
- negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4)
-
- fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n)
- signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4)
- abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4)
-
-instance Fractional (Sig2, Sig2, Sig2, Sig2) where
- recip (a1, a2, a3, a4) = (recip a1, recip a2, recip a3, recip a4)
- fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n)
-
-instance Num (Sig2, Sig2, Sig2, Sig2, Sig2) where
- (a1, a2, a3, a4, a5) + (b1, b2, b3, b4, b5) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5)
- (a1, a2, a3, a4, a5) * (b1, b2, b3, b4, b5) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5)
- negate (a1, a2, a3, a4, a5) = (negate a1, negate a2, negate a3, negate a4, negate a5)
-
- fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n)
- signum (a1, a2, a3, a4, a5) = (signum a1, signum a2, signum a3, signum a4, signum a5)
- abs (a1, a2, a3, a4, a5) = (abs a1, abs a2, abs a3, abs a4, abs a5)
-
-instance Fractional (Sig2, Sig2, Sig2, Sig2, Sig2) where
- recip (a1, a2, a3, a4, a5) = (recip a1, recip a2, recip a3, recip a4, recip a5)
- fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n)
-
-instance Num (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where
- (a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6)
- (a1, a2, a3, a4, a5, a6) * (b1, b2, b3, b4, b5, b6) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6)
- negate (a1, a2, a3, a4, a5, a6) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6)
-
- fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n)
- signum (a1, a2, a3, a4, a5, a6) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6)
- abs (a1, a2, a3, a4, a5, a6) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6)
-
-instance Fractional (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where
- recip (a1, a2, a3, a4, a5, a6) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6)
- fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n)
diff --git a/src/Csound/Typed/Types/SigSpace.hs b/src/Csound/Typed/Types/SigSpace.hs
index 57e9082..4a7cf7c 100644
--- a/src/Csound/Typed/Types/SigSpace.hs
+++ b/src/Csound/Typed/Types/SigSpace.hs
@@ -1,11 +1,11 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# Language
- TypeFamilies,
- MultiParamTypeClasses,
- FlexibleInstances,
+{-# Language
+ TypeFamilies,
+ MultiParamTypeClasses,
+ FlexibleInstances,
FlexibleContexts #-}
module Csound.Typed.Types.SigSpace(
- SigSpace(..), BindSig(..), mul, mul', on, uon, At(..), MixAt(..),
+ SigSpace(..), BindSig(..), mul, mul', on, uon, At(..), MixAt(..),
cfd, genCfds, cfd4, cfds,
-- * Stereo sig-space
@@ -53,17 +53,17 @@ mul2' k = bindSig2 (\(xa, xb) -> fmap (\(ka, kb) -> (ka * xa, kb * xb)) k)
-- rescaling
-- | Rescaling of the bipolar signal (-1, 1) -> (a, b)
---
+--
-- > on a b biSig
on :: SigSpace a => Sig -> Sig -> a -> a
-on a b x = uon a b $ mapSig unipolar x
+on a b x = uon a b $ mapSig unipolar x
where unipolar a = 0.5 + 0.5 * a
-- | Rescaling of the unipolar signal (0, 1) -> (a, b)
---
+--
-- > on a b uniSig
uon :: SigSpace a => Sig -> Sig -> a -> a
-uon a b = mapSig (\x -> a + (b - a) * x)
+uon a b = mapSig (\x -> a + (b - a) * x)
-- | Crossfade.
--
@@ -72,16 +72,16 @@ uon a b = mapSig (\x -> a + (b - a) * x)
-- If coeff equals 0 then we get the first signal and if it equals 1 we get the second signal.
cfd :: (Num a, SigSpace a) => Sig -> a -> a -> a
cfd coeff a b = (1 - coeff) `mul` a + coeff `mul` b
-
+
genCfds :: a -> (Sig -> a -> a -> a) -> [Sig] -> [a] -> a
genCfds zero mixFun cs xs = case xs of
[] -> zero
- a:as -> foldl (\x f -> f x) a $ zipWith mix' cs as
+ a:as -> foldl (\x f -> f x) a $ zipWith mix' cs as
where mix' c a b = mixFun c b a
-- | Bilinear interpolation for four signals.
-- The signals are placed in the corners of the unit square.
--- The first two signals are the xy coordinates in the square.
+-- The first two signals are the xy coordinates in the square.
--
-- > cfd4 x y a b c d
--
@@ -92,9 +92,9 @@ genCfds zero mixFun cs xs = case xs of
-- * (1, 1) is for c
--
-- * (0, 1) is for d
-cfd4 :: (Num a, SigSpace a) => Sig -> Sig -> a -> a -> a -> a -> a
+cfd4 :: (Num a, SigSpace a) => Sig -> Sig -> a -> a -> a -> a -> a
cfd4 x y a b c d = sum $ zipWith mul [(1 - x) * (1 - y), x * (1 - y) , x * y, (1 - x) * y] [a, b, c, d]
-
+
-- | Generic crossfade for n coefficients and n+1 signals.
--
-- > cfds coeffs sigs
@@ -105,59 +105,29 @@ cfds = genCfds 0 cfd
instance SigSpace Sig where mapSig = id
instance BindSig Sig where bindSig = id
-instance SigSpace (Sig, Sig) where mapSig f (a1, a2) = (f a1, f a2)
-instance BindSig (Sig, Sig) where bindSig f (a1, a2) = (,) <$> f a1 <*> f a2
-
-instance SigSpace (Sig, Sig, Sig) where mapSig f (a1, a2, a3) = (f a1, f a2, f a3)
-instance BindSig (Sig, Sig, Sig) where bindSig f (a1, a2, a3) = (,,) <$> f a1 <*> f a2 <*> f a3
-
-instance SigSpace (Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4) = (f a1, f a2, f a3, f a4)
-instance BindSig (Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4) = (,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4
-
-instance SigSpace (Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5) = (f a1, f a2, f a3, f a4, f a5)
-instance BindSig (Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5) = (,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5
-
-instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5, a6) = (f a1, f a2, f a3, f a4, f a5, f a6)
-instance BindSig (Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 <*> f a6
-
-instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5, a6, a7) = (f a1, f a2, f a3, f a4, f a5, f a6, f a7)
-instance BindSig (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6, a7) = (,,,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 <*> f a6 <*> f a7
-
-instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (f a1, f a2, f a3, f a4, f a5, f a6, f a7, f a8)
-instance BindSig (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (,,,,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 <*> f a6 <*> f a7 <*> f a8
+instance (SigSpace a1, SigSpace a2) => SigSpace (a1, a2) where mapSig f (a1, a2) = (mapSig f a1, mapSig f a2)
+instance (BindSig a1, BindSig a2) => BindSig (a1, a2) where bindSig f (a1, a2) = (,) <$> bindSig f a1 <*> bindSig f a2
-instance SigSpace (Sig2, Sig2) where mapSig f (a1, a2) = (mapSig f a1, mapSig f a2)
-instance BindSig (Sig2, Sig2) where bindSig f (a1, a2) = (,) <$> bindSig f a1 <*> bindSig f a2
+instance (SigSpace a1, SigSpace a2, SigSpace a3) => SigSpace (a1, a2, a3) where mapSig f (a1, a2, a3) = (mapSig f a1, mapSig f a2, mapSig f a3)
+instance (BindSig a1, BindSig a2, BindSig a3) => BindSig (a1, a2, a3) where bindSig f (a1, a2, a3) = (,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3
-instance SigSpace (Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3) = (mapSig f a1, mapSig f a2, mapSig f a3)
-instance BindSig (Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3) = (,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3
+instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4) => SigSpace (a1, a2, a3, a4) where mapSig f (a1, a2, a3, a4) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4)
+instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4) => BindSig (a1, a2, a3, a4) where bindSig f (a1, a2, a3, a4) = (,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4
-instance SigSpace (Sig2, Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3, a4) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4)
-instance BindSig (Sig2, Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3, a4) = (,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4
+instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4, SigSpace a5) => SigSpace (a1, a2, a3, a4, a5) where mapSig f (a1, a2, a3, a4, a5) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5)
+instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4, BindSig a5) => BindSig (a1, a2, a3, a4, a5) where bindSig f (a1, a2, a3, a4, a5) = (,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5
-instance SigSpace (Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3, a4, a5) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5)
-instance BindSig (Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3, a4, a5) = (,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5
+instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4, SigSpace a5, SigSpace a6) => SigSpace (a1, a2, a3, a4, a5, a6) where mapSig f (a1, a2, a3, a4, a5, a6) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6)
+instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4, BindSig a5, BindSig a6) => BindSig (a1, a2, a3, a4, a5, a6) where bindSig f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6
-instance SigSpace (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3, a4, a5, a6) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6)
-instance BindSig (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6
+instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4, SigSpace a5, SigSpace a6, SigSpace a7) => SigSpace (a1, a2, a3, a4, a5, a6, a7) where mapSig f (a1, a2, a3, a4, a5, a6, a7) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6, mapSig f a7)
+instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4, BindSig a5, BindSig a6, BindSig a7) => BindSig (a1, a2, a3, a4, a5, a6, a7) where bindSig f (a1, a2, a3, a4, a5, a6, a7) = (,,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6 <*> bindSig f a7
-instance SigSpace (Sig8, Sig8) where mapSig f (a1, a2) = (mapSig f a1, mapSig f a2)
-instance BindSig (Sig8, Sig8) where bindSig f (a1, a2) = (,) <$> bindSig f a1 <*> bindSig f a2
+instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4, SigSpace a5, SigSpace a6, SigSpace a7, SigSpace a8) => SigSpace (a1, a2, a3, a4, a5, a6, a7, a8) where mapSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6, mapSig f a7, mapSig f a8)
+instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4, BindSig a5, BindSig a6, BindSig a7, BindSig a8) => BindSig (a1, a2, a3, a4, a5, a6, a7, a8) where bindSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (,,,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6 <*> bindSig f a7 <*> bindSig f a8
-instance SigSpace (Sig8, Sig8, Sig8, Sig8) where mapSig f (a1, a2, a3, a4) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4)
-instance BindSig (Sig8, Sig8, Sig8, Sig8) where bindSig f (a1, a2, a3, a4) = (,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4
-
-instance SigSpace (SE Sig) where mapSig f = fmap (mapSig f)
-instance BindSig (SE Sig) where bindSig f = fmap (bindSig f)
-
-instance SigSpace (SE (Sig, Sig)) where mapSig f = fmap (mapSig f)
-instance BindSig (SE (Sig, Sig)) where bindSig f = fmap (bindSig f)
-
-instance SigSpace (SE (Sig, Sig, Sig)) where mapSig f = fmap (mapSig f)
-instance BindSig (SE (Sig, Sig, Sig)) where bindSig f = fmap (bindSig f)
-
-instance SigSpace (SE (Sig, Sig, Sig, Sig)) where mapSig f = fmap (mapSig f)
-instance BindSig (SE (Sig, Sig, Sig, Sig)) where bindSig f = fmap (bindSig f)
+instance SigSpace a => SigSpace (SE a) where mapSig f = fmap (mapSig f)
+instance BindSig a => BindSig (SE a) where bindSig f = fmap (bindSig f)
----------------------------------------------------------------------------------------------------------
@@ -171,79 +141,79 @@ instance BindSig2 Sig where bindSig2 f a = fmap toMono $ f (a, a)
instance SigSpace2 (Sig, Sig) where mapSig2 = id
instance BindSig2 (Sig, Sig) where bindSig2 = id
-instance SigSpace2 (Sig, Sig, Sig) where
+instance SigSpace2 (Sig, Sig, Sig) where
mapSig2 f (a1, a2, a3) = (b1, b2, toMono (b3, b4))
where
(b1, b2, b3, b4) = mapSig2 f (a1, a2, a3, a4)
a4 = a3
-instance BindSig2 (Sig, Sig, Sig) where
+instance BindSig2 (Sig, Sig, Sig) where
bindSig2 f (a1, a2, a3) = do
(b1, b2, b3, b4) <- bindSig2 f (a1, a2, a3, a4)
return (b1, b2, toMono (b3, b4))
where
a4 = a3
-instance SigSpace2 (Sig, Sig, Sig, Sig) where
+instance SigSpace2 (Sig, Sig, Sig, Sig) where
mapSig2 f (a1, a2, a3, a4) = (b1, b2, b3, b4)
where
(b1, b2) = f (a1, a2)
(b3, b4) = f (a3, a4)
-instance BindSig2 (Sig, Sig, Sig, Sig) where
+instance BindSig2 (Sig, Sig, Sig, Sig) where
bindSig2 f (a1, a2, a3, a4) = do
(b1, b2) <- f (a1, a2)
(b3, b4) <- f (a3, a4)
- return (b1, b2, b3, b4)
+ return (b1, b2, b3, b4)
-instance SigSpace2 (Sig, Sig, Sig, Sig, Sig) where
+instance SigSpace2 (Sig, Sig, Sig, Sig, Sig) where
mapSig2 f (a1, a2, a3, a4, a5) = (b1, b2, b3, b4, toMono (b5, b6))
- where
+ where
(b1, b2, b3, b4, b5, b6) = mapSig2 f (a1, a2, a3, a4, a5, a6)
a6 = a5
-instance BindSig2 (Sig, Sig, Sig, Sig, Sig) where
+instance BindSig2 (Sig, Sig, Sig, Sig, Sig) where
bindSig2 f (a1, a2, a3, a4, a5) = do
(b1, b2, b3, b4, b5, b6) <- bindSig2 f (a1, a2, a3, a4, a5, a6)
return (b1, b2, b3, b4, toMono (b5, b6))
where
a6 = a5
-instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig) where
+instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig) where
mapSig2 f (a1, a2, a3, a4, a5, a6) = (b1, b2, b3, b4, b5, b6)
where
(b1, b2, b3, b4) = mapSig2 f (a1, a2, a3, a4)
(b5, b6) = f (a5, a6)
-
-instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig) where
- bindSig2 f (a1, a2, a3, a4, a5, a6) = do
+
+instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig) where
+ bindSig2 f (a1, a2, a3, a4, a5, a6) = do
(b1, b2, b3, b4) <- bindSig2 f (a1, a2, a3, a4)
- (b5, b6) <- f (a5, a6)
+ (b5, b6) <- f (a5, a6)
return (b1, b2, b3, b4, b5, b6)
-instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where
+instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where
mapSig2 f (a1, a2, a3, a4, a5, a6, a7) = (b1, b2, b3, b4, b5, b6, toMono (b7, b8))
where
(b1, b2, b3, b4, b5, b6, b7, b8) = mapSig2 f (a1, a2, a3, a4, a5, a6, a7, a8)
a8 = a7
-instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where
+instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where
bindSig2 f (a1, a2, a3, a4, a5, a6, a7) = do
(b1, b2, b3, b4, b5, b6, b7, b8) <- bindSig2 f (a1, a2, a3, a4, a5, a6, a7, a8)
return (b1, b2, b3, b4, b5, b6, toMono (b7, b8))
where
a8 = a7
-instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where
+instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where
mapSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = (b1, b2, b3, b4, b5, b6, b7, b8)
where
(b1, b2, b3, b4, b5, b6) = mapSig2 f (a1, a2, a3, a4, a5, a6)
(b7, b8) = f (a7, a8)
-instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where
- bindSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = do
+instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where
+ bindSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = do
(b1, b2, b3, b4, b5, b6) <- bindSig2 f (a1, a2, a3, a4, a5, a6)
- (b7, b8) <- f (a7, a8)
+ (b7, b8) <- f (a7, a8)
return (b1, b2, b3, b4, b5, b6, b7, b8)
instance SigSpace2 (Sig2, Sig2) where mapSig2 f (a1, a2) = (mapSig2 f a1, mapSig2 f a2)
@@ -261,6 +231,12 @@ instance BindSig2 (Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3,
instance SigSpace2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig2 f (a1, a2, a3, a4, a5, a6) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3, mapSig2 f a4, mapSig2 f a5, mapSig2 f a6)
instance BindSig2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 <*> bindSig2 f a4 <*> bindSig2 f a5 <*> bindSig2 f a6
+instance SigSpace2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig2 f (a1, a2, a3, a4, a5, a6, a7) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3, mapSig2 f a4, mapSig2 f a5, mapSig2 f a6, mapSig2 f a7)
+instance BindSig2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3, a4, a5, a6, a7) = (,,,,,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 <*> bindSig2 f a4 <*> bindSig2 f a5 <*> bindSig2 f a6 <*> bindSig2 f a7
+
+instance SigSpace2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3, mapSig2 f a4, mapSig2 f a5, mapSig2 f a6, mapSig2 f a7, mapSig2 f a8)
+instance BindSig2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = (,,,,,,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 <*> bindSig2 f a4 <*> bindSig2 f a5 <*> bindSig2 f a6 <*> bindSig2 f a7 <*> bindSig2 f a8
+
instance SigSpace2 (Sig8, Sig8) where mapSig2 f (a1, a2) = (mapSig2 f a1, mapSig2 f a2)
instance BindSig2 (Sig8, Sig8) where bindSig2 f (a1, a2) = (,) <$> bindSig2 f a1 <*> bindSig2 f a2
@@ -491,7 +467,7 @@ instance At Sig (SE Sig) (SE Sig4) where
at f a = join $ bindSig f a
-----------------------------------------------------
--- mono to stereo
+-- mono to stereo
instance At Sig Sig2 Sig where
type AtOut Sig Sig2 Sig = Sig2
@@ -509,9 +485,9 @@ instance At Sig Sig2 (SE Sig2) where
type AtOut Sig Sig2 (SE Sig2) = SE Sig2
at f a = fmap (at f) a
----------------------------------------------------------
+---------------------------------------------------------
----------------------------------------------------------
+---------------------------------------------------------
-- Sig2 -> Sig2
fromMono a = (a, a)
@@ -558,23 +534,23 @@ instance At Sig2 (SE Sig2) (SE Sig2) where
-- | It applies an effect and mixes the processed signal with original one.
-- The first argument is for proportion of dry/wet (original/processed).
-- It's like @at@ but it allows to balance processed signal with original one.
-class (SigSpace b, At a b c) => MixAt a b c where
+class (SigSpace b, At a b c) => MixAt a b c where
mixAt :: Sig -> (a -> b) -> c -> AtOut a b c
---------------------------------------------------
-instance SigSpace a => MixAt Sig Sig a where
+instance SigSpace a => MixAt Sig Sig a where
mixAt k f a = mapSig (\x -> cfd k x (f x)) a
------------------------------------------------------
-- for (Sig -> SE Sig)
-instance MixAt Sig (SE Sig) Sig where
+instance MixAt Sig (SE Sig) Sig where
mixAt k f dry = do
wet <- f dry
return $ cfd k dry wet
-instance MixAt Sig (SE Sig) Sig2 where
+instance MixAt Sig (SE Sig) Sig2 where
mixAt k f (dry1, dry2) = do
wet1 <- f dry1
wet2 <- f dry2
@@ -587,7 +563,7 @@ instance MixAt Sig (SE Sig) Sig3 where
wet3 <- f dry3
return $ cfd k (dry1, dry2, dry3) (wet1, wet2, wet3)
-instance MixAt Sig (SE Sig) Sig4 where
+instance MixAt Sig (SE Sig) Sig4 where
mixAt k f (dry1, dry2, dry3, dry4) = do
wet1 <- f dry1
wet2 <- f dry2
@@ -595,7 +571,7 @@ instance MixAt Sig (SE Sig) Sig4 where
wet4 <- f dry4
return $ cfd k (dry1, dry2, dry3, dry4) (wet1, wet2, wet3, wet4)
-instance MixAt Sig (SE Sig) (SE Sig) where
+instance MixAt Sig (SE Sig) (SE Sig) where
mixAt k f dry = do
dry1 <- dry
wet1 <- f dry1
@@ -626,42 +602,42 @@ instance MixAt Sig (SE Sig) (SE Sig4) where
return $ cfd k (dry1, dry2, dry3, dry4) (wet1, wet2, wet3, wet4)
-----------------------------------------------------
--- mono to stereo
+-- mono to stereo
instance MixAt Sig Sig2 Sig where
mixAt k f dry = cfd k (dry, dry) wet
where wet = f dry
-instance MixAt Sig Sig2 (SE Sig) where
+instance MixAt Sig Sig2 (SE Sig) where
mixAt k f dry = fmap (\x -> cfd k (x, x) (f x)) dry
-instance MixAt Sig Sig2 Sig2 where
+instance MixAt Sig Sig2 Sig2 where
mixAt k f dry = cfd k dry wet
where wet = 0.5 * (f (fst dry) + f (snd dry))
-instance MixAt Sig Sig2 (SE Sig2) where
+instance MixAt Sig Sig2 (SE Sig2) where
mixAt k f dry = do
(dry1, dry2) <- dry
- let wet = 0.5 * (f dry1 + f dry2)
+ let wet = 0.5 * (f dry1 + f dry2)
return $ cfd k (dry1, dry2) wet
----------------------------------------------------------
+---------------------------------------------------------
----------------------------------------------------------
+---------------------------------------------------------
-- Sig2 -> Sig2
-instance MixAt Sig2 Sig2 Sig where
+instance MixAt Sig2 Sig2 Sig where
mixAt k f dry1 = cfd k dry wet
- where
+ where
dry = fromMono dry1
wet = f dry
-instance MixAt Sig2 Sig2 Sig2 where
+instance MixAt Sig2 Sig2 Sig2 where
mixAt k f dry = cfd k dry wet
where
wet = f dry
-instance MixAt Sig2 Sig2 (SE Sig) where
+instance MixAt Sig2 Sig2 (SE Sig) where
mixAt k f dry1 = do
dry <- fmap fromMono dry1
let wet = f dry
@@ -677,19 +653,19 @@ instance MixAt Sig2 Sig2 (SE Sig2) where
---------------------------------------------
-- Sig2 -> SE Sig2
-instance MixAt Sig2 (SE Sig2) Sig where
+instance MixAt Sig2 (SE Sig2) Sig where
mixAt k f dry1 = do
wet <- f dry
return $ cfd k dry wet
where
dry = fromMono dry1
-instance MixAt Sig2 (SE Sig2) Sig2 where
+instance MixAt Sig2 (SE Sig2) Sig2 where
mixAt k f dry = do
wet <- f dry
return $ cfd k dry wet
-instance MixAt Sig2 (SE Sig2) (SE Sig) where
+instance MixAt Sig2 (SE Sig2) (SE Sig) where
mixAt k f dry1 = do
dry <- fmap fromMono dry1
wet <- f dry
diff --git a/src/Csound/Typed/Types/Tuple.hs b/src/Csound/Typed/Types/Tuple.hs
index 25a3a91..7332d42 100644
--- a/src/Csound/Typed/Types/Tuple.hs
+++ b/src/Csound/Typed/Types/Tuple.hs
@@ -1,15 +1,15 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# Language
+{-# Language
TypeFamilies,
FlexibleContexts,
FlexibleInstances #-}
module Csound.Typed.Types.Tuple(
-- ** Tuple
- Tuple(..), TupleMethods, makeTupleMethods,
+ Tuple(..), TupleMethods, makeTupleMethods,
fromTuple, toTuple, tupleArity, tupleRates, defTuple, mapTuple,
-
+
-- ** Outs
- Sigs, outArity,
+ Sigs, outArity, Sig2s,
-- *** Multiple outs
multiOuts,
@@ -34,6 +34,8 @@ import Control.Monad.Trans.Class
import Data.Default
import Data.Boolean
+import Data.NumInstances.Tuple
+
import Csound.Dynamic
import Csound.Typed.Types.Prim
import Csound.Typed.Types.SigSpace
@@ -52,7 +54,7 @@ data TupleMethods a = TupleMethods
, tupleRates_ :: a -> [Rate]
, defTuple_ :: a }
-fromTuple :: Tuple a => a -> GE [E]
+fromTuple :: Tuple a => a -> GE [E]
fromTuple = fromTuple_ tupleMethods
toTuple :: Tuple a => GE [E] -> a
@@ -72,9 +74,9 @@ mapTuple f a = toTuple (fmap (fmap f) $ fromTuple a)
-- | Defines instance of type class 'Tuple' for a new type in terms of an already defined one.
makeTupleMethods :: (Tuple a) => (a -> b) -> (b -> a) -> TupleMethods b
-makeTupleMethods to from = TupleMethods
+makeTupleMethods to from = TupleMethods
{ fromTuple_ = fromTuple . from
- , toTuple_ = to . toTuple
+ , toTuple_ = to . toTuple
, tupleArity_ = const $ tupleArity $ proxy to
, tupleRates_ = tupleRates . from
, defTuple_ = to defTuple }
@@ -84,7 +86,7 @@ makeTupleMethods to from = TupleMethods
-- Tuple instances
primTupleMethods :: (Val a, Default a) => Rate -> TupleMethods a
-primTupleMethods rate = TupleMethods
+primTupleMethods rate = TupleMethods
{ fromTuple_ = fmap return . toGE
, toTuple_ = fromGE . fmap head
, tupleArity_ = const 1
@@ -92,14 +94,14 @@ primTupleMethods rate = TupleMethods
, defTuple_ = def }
instance Tuple Unit where
- tupleMethods = TupleMethods
+ tupleMethods = TupleMethods
{ fromTuple_ = \x -> unUnit x >> (return [])
, toTuple_ = \es -> Unit $ es >> return ()
, tupleArity_ = const 0
, tupleRates_ = const []
, defTuple_ = Unit $ return () }
-instance Tuple Sig where tupleMethods = primTupleMethods Ar
+instance Tuple Sig where tupleMethods = primTupleMethods Ar
instance Tuple D where tupleMethods = primTupleMethods Kr
instance Tuple Tab where tupleMethods = primTupleMethods Kr
instance Tuple Str where tupleMethods = primTupleMethods Sr
@@ -107,16 +109,16 @@ instance Tuple Spec where tupleMethods = primTupleMethods Fr
instance Tuple TabList where tupleMethods = primTupleMethods Kr
-instance (Tuple a, Tuple b) => Tuple (a, b) where
+instance (Tuple a, Tuple b) => Tuple (a, b) where
tupleMethods = TupleMethods fromTuple' toTuple' tupleArity' tupleRates' defTuple'
- where
+ where
fromTuple' (a, b) = liftA2 (++) (fromTuple a) (fromTuple b)
tupleArity' x = let (a, b) = proxy x in tupleArity a + tupleArity b
where proxy :: (a, b) -> (a, b)
- proxy = const (undefined, undefined)
+ proxy = const (undefined, undefined)
toTuple' xs = (a, b)
where a = toTuple $ fmap (take (tupleArity a)) xs
- xsb = fmap (drop (tupleArity a)) xs
+ xsb = fmap (drop (tupleArity a)) xs
b = toTuple $ fmap (take (tupleArity b)) xsb
tupleRates' (a, b) = tupleRates a ++ tupleRates b
@@ -142,31 +144,29 @@ ar4 :: (Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig)
ar6 :: (Sig, Sig, Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig, Sig, Sig)
ar8 :: (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)
-ar1 = id; ar2 = id; ar4 = id; ar6 = id; ar8 = id
+ar1 = id; ar2 = id; ar4 = id; ar6 = id; ar8 = id
---------------------------------------------------------------------------------
-- out instances
-- | The tuples of signals.
-class (Tuple a, Num a, Fractional a, SigSpace a, BindSig a, SigSpace2 a, BindSig2 a) => Sigs a where
+class (Tuple a, Num a, Fractional a, SigSpace a, BindSig a) => Sigs a where
+class (Sigs a, SigSpace2 a, BindSig2 a) => Sig2s a where
instance Sigs Sig
-instance Sigs Sig2
-instance Sigs Sig3
-instance Sigs Sig4
-instance Sigs Sig5
-instance Sigs Sig6
-instance Sigs Sig7
-instance Sigs Sig8
-
-instance Sigs (Sig2, Sig2)
-instance Sigs (Sig2, Sig2, Sig2)
-instance Sigs (Sig2, Sig2, Sig2, Sig2)
-instance Sigs (Sig2, Sig2, Sig2, Sig2, Sig2)
-instance Sigs (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2)
-
-instance Sigs (Sig8, Sig8)
-instance Sigs (Sig8, Sig8, Sig8, Sig8)
+instance (Sigs a1, Sigs a2) => Sigs (a1, a2)
+instance (Sigs a1, Sigs a2, Sigs a3) => Sigs (a1, a2, a3)
+instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4) => Sigs (a1, a2, a3, a4)
+instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5) => Sigs (a1, a2, a3, a4, a5)
+instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6) => Sigs (a1, a2, a3, a4, a5, a6)
+instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6, Sigs a7) => Sigs (a1, a2, a3, a4, a5, a6, a7)
+instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6, Sigs a7, Sigs a8) => Sigs (a1, a2, a3, a4, a5, a6, a7, a8)
+
+instance Sig2s Sig
+instance Sig2s Sig2
+instance Sig2s Sig4
+instance Sig2s Sig6
+instance Sig2s Sig8
outArity :: Tuple a => SE a -> Int
outArity = tupleArity . proxy
@@ -205,10 +205,10 @@ argArity = tupleArity
toNote :: Arg a => a -> GE [E]
toNote a = zipWithM phi (tupleRates a) =<< fromTuple a
where
- phi rate x = case rate of
+ phi rate x = case rate of
Sr -> saveStr $ getStringUnsafe x
_ -> return x
-
+
getStringUnsafe x = case getPrimUnsafe x of
PrimString y -> y
_ -> error "Arg(Str):getStringUnsafe value is not a string"
@@ -229,7 +229,7 @@ fromBoolTuple = toTuple . unBoolTuple
type instance BooleanOf BoolTuple = BoolSig
instance IfB BoolTuple where
- ifB mp (BoolTuple mas) (BoolTuple mbs) = BoolTuple $
+ ifB mp (BoolTuple mas) (BoolTuple mbs) = BoolTuple $
liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs
-- | @ifB@ for tuples of csound values.
@@ -257,7 +257,7 @@ fromBoolArg = toTuple . unBoolArg
type instance BooleanOf BoolArg = BoolD
instance IfB BoolArg where
- ifB mp (BoolArg mas) (BoolArg mbs) = BoolArg $
+ ifB mp (BoolArg mas) (BoolArg mbs) = BoolArg $
liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs
-- | @ifB@ for constants.
@@ -281,11 +281,9 @@ pureTuple a = res
dirtyTuple :: Tuple a => GE (MultiOut [E]) -> SE a
dirtyTuple a = res
- where
- res = fmap (toTuple . return) $ SE
+ where
+ res = fmap (toTuple . return) $ SE
$ mapM depT =<< (lift $ fmap ($ (tupleArity $ proxy res)) a)
proxy :: SE a -> a
proxy = const undefined
-
-