diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/Synthesizer/LLVM/ALSA/BendModulation.hs b/src/Synthesizer/LLVM/ALSA/BendModulation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/ALSA/BendModulation.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | +Various LLVM related instances of the BendModulation type. +I have setup a separate module since these instances are orphan +and need several language extensions. +-} +module Synthesizer.LLVM.ALSA.BendModulation where + +import Synthesizer.PiecewiseConstant.ALSA.MIDI + (BendModulation(BendModulation), ) + + +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Control as C +import qualified LLVM.Util.Loop as Loop +import qualified LLVM.Core as LLVM + +import Foreign.Storable (Storable(sizeOf, alignment, peek, poke), ) +import Foreign.Storable.Traversable as Store + +import qualified Control.Applicative as App +import qualified Data.Foldable as Fold +import qualified Data.Traversable as Trav + +import Control.Applicative (Applicative, (<*>), pure, liftA2, ) +import qualified Data.TypeLevel.Num as TypeNum + + + +-- 'fmap' is lazy which is important for the Store functions +instance Functor BendModulation where + {-# INLINE fmap #-} + fmap f ~(BendModulation b m) = BendModulation (f b) (f m) + +-- useful for defining Additive instance +instance Applicative BendModulation where + {-# INLINE pure #-} + pure a = BendModulation a a + {-# INLINE (<*>) #-} + ~(BendModulation fb fm) <*> ~(BendModulation b m) = + BendModulation (fb b) (fm m) + +instance Fold.Foldable BendModulation where + {-# INLINE foldMap #-} + foldMap = Trav.foldMapDefault + +-- this allows for kinds of generic programming +instance Trav.Traversable BendModulation where + {-# INLINE sequenceA #-} + sequenceA ~(BendModulation b m) = + liftA2 BendModulation b m + + +instance (Storable a) => Storable (BendModulation a) where + {-# INLINE sizeOf #-} + sizeOf = Store.sizeOf + {-# INLINE alignment #-} + alignment = Store.alignment + {-# INLINE peek #-} + peek = Store.peekApplicative + {-# INLINE poke #-} + poke = Store.poke + + +instance (Class.Zero a) => Class.Zero (BendModulation a) where + zeroTuple = Class.zeroTuplePointed + +instance (LLVM.ValueTuple a) => LLVM.ValueTuple (BendModulation a) where + buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) + +instance LLVM.IsTuple a => LLVM.IsTuple (BendModulation a) where + tupleDesc = Class.tupleDescFoldable + +instance (LLVM.Undefined a) => LLVM.Undefined (BendModulation a) where + undefTuple = Class.undefTuplePointed + +instance (C.Select a) => C.Select (BendModulation a) where + select = C.selectTraversable + +instance LLVM.CmpRet a b => + LLVM.CmpRet (BendModulation a) (BendModulation b) where + +instance LLVM.MakeValueTuple h l => + LLVM.MakeValueTuple (BendModulation h) (BendModulation l) where + valueTupleOf = Class.valueTupleOfFunctor + +memory :: + (Rep.Memory l s, LLVM.IsSized s ss) => + Rep.MemoryRecord r (LLVM.Struct (s, (s, ()))) (BendModulation l) +memory = + liftA2 BendModulation + (Rep.memoryElement (\(BendModulation b _) -> b) TypeNum.d0) + (Rep.memoryElement (\(BendModulation _ m) -> m) TypeNum.d1) + +instance + (Rep.Memory l s, LLVM.IsSized s ss) => + Rep.Memory (BendModulation l) (LLVM.Struct (s, (s, ()))) where + load = Rep.loadRecord memory + store = Rep.storeRecord memory + decompose = Rep.decomposeRecord memory + compose = Rep.composeRecord memory + + +instance (Loop.Phi a) => Loop.Phi (BendModulation a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + + +instance (Vector.ShuffleMatch n v) => + Vector.ShuffleMatch n (BendModulation v) where + shuffleMatch = Vector.shuffleMatchTraversable + +instance (Vector.Access n a v) => + Vector.Access n (BendModulation a) (BendModulation v) where + insert = Vector.insertTraversable + extract = Vector.extractTraversable diff --git a/src/Synthesizer/LLVM/ALSA/MIDI.hs b/src/Synthesizer/LLVM/ALSA/MIDI.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/ALSA/MIDI.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{- | +Convert MIDI events of a MIDI controller to a control signal. +-} +module Synthesizer.LLVM.ALSA.MIDI ( + module Synthesizer.LLVM.ALSA.MIDI, + Gen.applyModulation, + PC.BendModulation(PC.BendModulation), + ) where + +import Synthesizer.EventList.ALSA.MIDI + (Program, Channel, Filter, Note, + {- + LazyTime, Controller, + getControllerEvents, getSlice, + maybePitchBend, maybeChannelPressure, + -} ) +import qualified Synthesizer.Generic.ALSA.MIDI as Gen +import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC +-- import qualified Synthesizer.MIDIValue as MV +import Synthesizer.LLVM.ALSA.BendModulation () + +import Synthesizer.LLVM.CausalParameterized.Process (($>), ) +-- import Synthesizer.LLVM.Parameterized.Signal (($#), ) +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Parameter as Param +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.Sample as Sample + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Core as LLVM + +import qualified Data.TypeLevel.Num as TypeNum + +import qualified Synthesizer.Generic.Cut as CutG + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +{- +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import qualified Data.EventList.Relative.TimeTime as EventListTT +import qualified Data.EventList.Relative.MixedTime as EventListMT +import qualified Data.EventList.Relative.BodyTime as EventListBT +-} + +import Foreign.Storable (Storable, ) + +{- +import qualified Numeric.NonNegative.Class as NonNeg +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Chunky as NonNegChunky +-} + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Control.Arrow (second, (<<<), (<<^), ) +import Control.Monad ({- liftM, -} liftM2, ) + +-- import NumericPrelude.Base +import NumericPrelude.Numeric +import Prelude () + + +{- +{-# INLINE piecewiseConstantInit #-} +piecewiseConstantInit :: + (Storable y, LLVM.MakeValueTuple y yl, + Rep.Memory yl ym, LLVM.IsSized ym ys) => + y -> EventListTT.T LazyTime y -> SigP.T p yl +piecewiseConstantInit initial evs = + SigP.piecewiseConstant $# + (PC.subdivideInt $ + EventListMT.consBody initial evs) + + +{-# INLINE controllerLinear #-} +controllerLinear :: + (Field.C y, Storable y, LLVM.MakeValueTuple y yl, + Rep.Memory yl ym, LLVM.IsSized ym ys) => + Channel -> Controller -> + (y,y) -> y -> + Filter (SigP.T p yl) +controllerLinear chan ctrl bnd initial = + liftM (piecewiseConstantInit initial . + EventListTT.mapBody (MV.controllerLinear bnd)) $ + getControllerEvents chan ctrl + + +{-# INLINE controllerExponential #-} +controllerExponential :: + (Trans.C y, Storable y, LLVM.MakeValueTuple y yl, + Rep.Memory yl ym, LLVM.IsSized ym ys) => + Channel -> Controller -> + (y,y) -> y -> + Filter (SigP.T p yl) +controllerExponential chan ctrl bnd initial = + liftM (piecewiseConstantInit initial . + EventListTT.mapBody (MV.controllerExponential bnd)) $ + getControllerEvents chan ctrl + + +{- | +@pitchBend channel range center@: +emits frequencies on an exponential scale from +@center/range@ to @center*range@. +-} +{-# INLINE pitchBend #-} +pitchBend :: + (Trans.C y, Storable y, LLVM.MakeValueTuple y yl, + Rep.Memory yl ym, LLVM.IsSized ym ys) => + Channel -> + y -> y -> + Filter (SigP.T p yl) +pitchBend chan range center = + liftM (piecewiseConstantInit center . + EventListTT.mapBody (MV.pitchBend range center)) $ + getSlice (maybePitchBend chan) +-- getPitchBendEvents chan + +{-# INLINE channelPressure #-} +channelPressure :: + (Trans.C y, Storable y, LLVM.MakeValueTuple y yl, + Rep.Memory yl ym, LLVM.IsSized ym ys) => + Channel -> + y -> y -> + Filter (SigP.T p yl) +channelPressure chan maxVal initVal = + liftM (piecewiseConstantInit initVal . + EventListTT.mapBody (MV.controllerLinear (0,maxVal))) $ + getSlice (maybeChannelPressure chan) + + +{-# INLINE bendWheelPressure #-} +bendWheelPressure :: + (Ring.C a, LLVM.IsConst a, + RealField.C y, Trans.C y, + LLVM.IsConst y, SoV.Fraction y, SoV.Replicate a y, + Storable y, LLVM.MakeValueTuple y (LLVM.Value y), LLVM.IsSized y ys) => + Channel -> + Int -> y -> y -> y -> + Filter (SigP.T p (LLVM.Value y)) +bendWheelPressure chan + pitchRange speed wheelDepth pressDepth = + do bend <- pitchBend chan + (2^?(fromIntegral pitchRange/12) `asTypeOf` speed) 1 + fm <- controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0 + press <- channelPressure chan pressDepth 0 + return $ + SigP.envelope bend $ + SigP.mapSimple (A.add (LLVM.valueOf 1)) $ + SigP.envelope + (SigP.mix fm press) + (SigP.osciSimple Wave.approxSine2 zero $# speed) +-} + + +frequencyFromBendModulation :: + (Ring.C a, LLVM.IsConst a, + Ring.C y, Additive.C y, LLVM.IsConst y, LLVM.IsSized y size, + Storable y, LLVM.MakeValueTuple y (LLVM.Value y), + SoV.Fraction y, SoV.Replicate a y) => + Param.T p y -> + CausalP.T p (PC.BendModulation (LLVM.Value y)) (LLVM.Value y) +frequencyFromBendModulation speed = + CausalP.envelope + <<< + second + (CausalP.mapSimple (A.add (SoV.replicateOf 1)) <<< CausalP.envelope + $> SigP.osciSimple Wave.approxSine2 zero speed) + <<^ + (\(PC.BendModulation b m) -> (b,m)) + + +frequencyFromBendModulationPacked :: + (RealField.C a, LLVM.IsConst a, LLVM.IsFloating a, + Storable a, LLVM.MakeValueTuple a (LLVM.Value a), LLVM.IsSized a size, + Vector.Real a, SoV.Replicate a (LLVM.Vector n a), LLVM.IsPowerOf2 n, + TypeNum.Mul n size vsize, TypeNum.Pos vsize) => + Param.T p a -> + CausalP.T p + (PC.BendModulation (LLVM.Value a)) + (LLVM.Value (LLVM.Vector n a)) +frequencyFromBendModulationPacked speed = + CausalP.envelope + <<< + second + (CausalP.mapSimple (A.add (SoV.replicateOf 1)) <<< CausalP.envelope + $> SigPS.osciSimple Wave.approxSine2 zero speed) + <<< + CausalP.mapSimple + (\(PC.BendModulation b m) -> + liftM2 (,) (SoV.replicate b) (SoV.replicate m)) + + + +type Instrument y yv = Gen.Instrument y (SigSt.T yv) +type Bank y yv = Gen.Bank y (SigSt.T yv) + + +{-# INLINE sequenceCore #-} +sequenceCore :: + (Storable yv, Sample.Additive value, + LLVM.MakeValueTuple yv value, Rep.Memory value struct) => + SigSt.ChunkSize -> + Channel -> + Program -> + Gen.Modulator Note (SigSt.T yv) -> + Filter (SigSt.T yv) +sequenceCore chunkSize = + Gen.sequenceCore (SigStL.arrange chunkSize) + + +{-# INLINE sequence #-} +sequence :: + (Storable yv, Trans.C y, Sample.Additive value, + LLVM.MakeValueTuple yv value, Rep.Memory value struct) => + SigSt.ChunkSize -> + Channel -> + Instrument y yv -> + Filter (SigSt.T yv) +sequence chunkSize = + Gen.sequence (SigStL.arrange chunkSize) + + +{-# INLINE sequenceModulated #-} +sequenceModulated :: + (CutG.Transform ctrl, CutG.NormalForm ctrl, + Storable yv, Trans.C y, Sample.Additive value, + LLVM.MakeValueTuple yv value, Rep.Memory value struct) => + SigSt.ChunkSize -> + ctrl -> + Channel -> + (ctrl -> Instrument y yv) -> + Filter (SigSt.T yv) +sequenceModulated chunkSize = + Gen.sequenceModulated (SigStL.arrange chunkSize) + + +{-# INLINE sequenceMultiModulated #-} +sequenceMultiModulated :: + (Storable yv, Trans.C y, Sample.Additive value, + LLVM.MakeValueTuple yv value, Rep.Memory value struct) => + SigSt.ChunkSize -> + Channel -> + instrument -> + Gen.Modulator (instrument, Note) (Instrument y yv, Note) -> + Filter (SigSt.T yv) +sequenceMultiModulated chunkSize = + Gen.sequenceMultiModulated (SigStL.arrange chunkSize) + + +{-# INLINE sequenceMultiProgram #-} +sequenceMultiProgram :: + (Storable yv, Trans.C y, Sample.Additive value, + LLVM.MakeValueTuple yv value, Rep.Memory value struct) => + SigSt.ChunkSize -> + Channel -> + Program -> + [Instrument y yv] -> + Filter (SigSt.T yv) +sequenceMultiProgram chunkSize = + Gen.sequenceMultiProgram (SigStL.arrange chunkSize) + + +{-# INLINE sequenceModulatedMultiProgram #-} +sequenceModulatedMultiProgram :: + (CutG.Transform ctrl, CutG.NormalForm ctrl, + Storable yv, Trans.C y, Sample.Additive value, + LLVM.MakeValueTuple yv value, Rep.Memory value struct) => + SigSt.ChunkSize -> + ctrl -> + Channel -> + Program -> + [ctrl -> Instrument y yv] -> + Filter (SigSt.T yv) +sequenceModulatedMultiProgram chunkSize = + Gen.sequenceModulatedMultiProgram (SigStL.arrange chunkSize) diff --git a/src/Synthesizer/LLVM/Causal/Process.hs b/src/Synthesizer/LLVM/Causal/Process.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/Process.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.Causal.Process where + +import qualified Synthesizer.LLVM.Simple.Signal as Sig +import qualified LLVM.Extra.Representation as Rep +import qualified Synthesizer.LLVM.Sample as Sample +import qualified Synthesizer.LLVM.Execution as Exec +import qualified LLVM.Extra.MaybeContinuation as Maybe +-- import qualified LLVM.Extra.Control as U + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import LLVM.Core +import LLVM.Util.Loop (Phi, ) +import LLVM.ExecutionEngine (simpleFunction, ) + +import qualified Control.Arrow as Arr +import qualified Control.Category as Cat +import Control.Arrow ((^<<), (<<<), (<<^), ) +import Control.Monad (liftM2, liftM3, ) + +import Data.Word (Word32, ) +import Foreign.Storable (Storable, ) +import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, ) +import Foreign.Ptr (FunPtr, ) +import Control.Exception (bracket, ) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) + +import Data.Tuple.HT (swap, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (and, map, zip, zipWith, ) + + +data T a b = + forall state packed size ioContext. + (Rep.Memory state packed, IsSized packed size) => + Cons (forall r c. + (Phi c) => + ioContext -> + a -> state -> Maybe.T r c (b, state)) + -- compute next value + (forall r. + ioContext -> + CodeGenFunction r state) + -- initial state + (IO ioContext) + -- initialization from IO monad + (ioContext -> IO ()) + -- finalization from IO monad + +simple :: + (Rep.Memory state packed, IsSized packed size) => + (forall r c. + (Phi c) => + a -> state -> Maybe.T r c (b, state)) -> + (forall r. CodeGenFunction r state) -> + T a b +simple next start = + Cons + (const next) + (const start) + (return ()) + (const $ return ()) + +toSignal :: T () a -> Sig.T a +toSignal (Cons next start createIOContext deleteIOContext) = Sig.Cons + (\ioContext -> next ioContext ()) + start + createIOContext deleteIOContext + +fromSignal :: Sig.T a -> T () a +fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons + (\ioContext () -> next ioContext) + start + createIOContext deleteIOContext + + +map :: + (forall r. a -> CodeGenFunction r b) -> + T a b +map f = + mapAccum (\a s -> fmap (flip (,) s) $ f a) (return ()) + +mapAccum :: + (Rep.Memory state packed, IsSized packed size) => + (forall r. + a -> state -> CodeGenFunction r (b, state)) -> + (forall r. CodeGenFunction r state) -> + T a b +mapAccum next = + simple (\a s -> Maybe.lift $ next a s) + + +apply :: + T a b -> Sig.T a -> Sig.T b +apply proc sig = + toSignal (proc <<< fromSignal sig) + +feedFst :: Sig.T a -> T b (a,b) +feedFst sig = + first (fromSignal sig) <<^ (\b -> ((),b)) + +feedSnd :: Sig.T a -> T b (b,a) +feedSnd sig = + swap ^<< feedFst sig + + +applyFst :: T (a,b) c -> Sig.T a -> T b c +applyFst proc sig = + proc <<< feedFst sig + +applySnd :: T (a,b) c -> Sig.T b -> T a c +applySnd proc sig = + proc <<< feedSnd sig + +compose :: T a b -> T b c -> T a c +compose + (Cons nextA startA createIOContextA deleteIOContextA) + (Cons nextB startB createIOContextB deleteIOContextB) = Cons + (\(ioContextA, ioContextB) a (sa0,sb0) -> do + (b,sa1) <- nextA ioContextA a sa0 + (c,sb1) <- nextB ioContextB b sb0 + return (c, (sa1,sb1))) + (\(ioContextA, ioContextB) -> + liftM2 (,) + (startA ioContextA) + (startB ioContextB)) + (liftM2 (,) + createIOContextA + createIOContextB) + (\(ca,cb) -> + deleteIOContextA ca >> + deleteIOContextB cb) + + +first :: T b c -> T (b, d) (c, d) +first (Cons next start createIOContext deleteIOContext) = Cons + (\ioContext (b,d) sa0 -> + fmap + (\(c,sa1) -> ((c,d), sa1)) + (next ioContext b sa0)) + start + createIOContext deleteIOContext + + +instance Cat.Category T where + id = map return + (.) = flip compose + +instance Arr.Arrow T where + arr f = map (return . f) + first = first + + +mix :: + (IsArithmetic a) => + T (Value a, Value a) (Value a) +mix = map (uncurry Sample.mixMono) + +mixStereo :: + (IsArithmetic a) => + T (Stereo.T (Value a), Stereo.T (Value a)) (Stereo.T (Value a)) +mixStereo = map (uncurry Sample.mixStereo) + + +envelope :: + (IsArithmetic a) => + T (Value a, Value a) (Value a) +envelope = map (uncurry Sample.amplifyMono) + +envelopeStereo :: + (IsArithmetic a) => + T (Value a, Stereo.T (Value a)) (Stereo.T (Value a)) +envelopeStereo = map (uncurry Sample.amplifyStereo) + +amplify :: + (IsArithmetic a, IsConst a) => + a -> T (Value a) (Value a) +amplify x = + map (Sample.amplifyMono (valueOf x)) + +amplifyStereo :: + (IsArithmetic a, IsConst a) => + a -> T (Stereo.T (Value a)) (Stereo.T (Value a)) +amplifyStereo x = + map (Sample.amplifyStereo (valueOf x)) + + + +applyStorable :: + (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA, + Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) => + T valueA valueB -> SV.Vector a -> SV.Vector b +applyStorable (Cons next start createIOContext deleteIOContext) as = + unsafePerformIO $ + bracket createIOContext deleteIOContext $ \ ioContext -> + SVB.withStartPtr as $ \ aPtr len -> + SVB.createAndTrim len $ \ bPtr -> do + fill <- + simpleFunction $ + createFunction ExternalLinkage $ \ size alPtr blPtr -> do + s <- start ioContext + (pos,_) <- Maybe.arrayLoop2 size alPtr blPtr s $ + \ aPtri bPtri s0 -> do + a <- Maybe.lift $ Rep.load aPtri + (b,s1) <- next ioContext a s0 + Maybe.lift $ Rep.store b bPtri + return s1 + ret (pos :: Value Word32) + fmap (fromIntegral :: Word32 -> Int) $ + fill (fromIntegral len) + (Rep.castStorablePtr aPtr) + (Rep.castStorablePtr bPtr) + + +foreign import ccall safe "dynamic" derefStartPtr :: + Exec.Importer (IO (Ptr stateStruct)) + +foreign import ccall safe "dynamic" derefStopPtr :: + Exec.Importer (Ptr stateStruct -> IO ()) + +foreign import ccall safe "dynamic" derefChunkPtr :: + Exec.Importer (Ptr stateStruct -> Word32 -> + Ptr aStruct -> Ptr bStruct -> IO Word32) + + +compileChunky :: + (Rep.Memory aValue aStruct, + Rep.Memory bValue bStruct, + Rep.Memory state stateStruct, + IsSized stateStruct stateSize) => + (forall r. + aValue -> state -> + Maybe.T r (Value Bool, (Value (Ptr bStruct), state)) (bValue, state)) -> + (forall r. + CodeGenFunction r state) -> + IO (FunPtr (IO (Ptr stateStruct)), + FunPtr (Ptr stateStruct -> IO ()), + FunPtr (Ptr stateStruct -> Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32)) +compileChunky next start = + Exec.compileModule $ + liftM3 (,,) + (createFunction ExternalLinkage $ + do + -- FIXME: size computation in LLVM currently does not work for structs! + pptr <- Rep.malloc + flip Rep.store pptr =<< start + ret pptr) + (createFunction ExternalLinkage $ + \ pptr -> Rep.free pptr >> ret ()) + (createFunction ExternalLinkage $ + \ sptr loopLen aPtr bPtr -> do + sInit <- Rep.load sptr + (pos,sExit) <- Maybe.arrayLoop2 loopLen aPtr bPtr sInit $ + \ aPtri bPtri s0 -> do + a <- Maybe.lift $ Rep.load aPtri + (b,s1) <- next a s0 + Maybe.lift $ Rep.store b bPtri + return s1 + Rep.store sExit sptr + ret (pos :: Value Word32)) + + +{-# DEPRECATED runStorableChunky "this function will not work when the process itself depends on a lazy storable vector" #-} +{- | +This function will not work as expected, +since feeding a lazy storable vector to the causal process +means that createIOContext creates a StablePtr to an IORef refering to a chunk list. +The IORef will be created once for all uses of the generated function +of type @(SVL.Vector a -> SVL.Vector b)@. +This means that the pointer into the chunks list will conflict. +An alternative would be to create the StablePtr in a foreign function +that calls back to Haskell. +But this way is disallowed for foreign finalizers. +-} +runStorableChunky :: + (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA, + Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) => + T valueA valueB -> IO (SVL.Vector a -> SVL.Vector b) +runStorableChunky + (Cons next start createIOContext deleteIOContext) = do + ioContext <- createIOContext + (startFunc, stopFunc, fill) <- + compileChunky (next ioContext) (start ioContext) + + {- + This is a dummy pointer, that we need for correct finalization. + Concerning the live time the FunPtr 'fill' also has the live time + that we are after, + but it is unsafe to treat a FunPtr as a Ptr or ForeignPtr. + -} + ioContextPtr <- Rep.newForeignPtr (deleteIOContext ioContext) False + + return $ \sig -> SVL.fromChunks $ unsafePerformIO $ do + statePtr <- Rep.newForeignPtrInit stopFunc startFunc + let go xt = + unsafeInterleaveIO $ + case xt of + [] -> return [] + x:xs -> SVB.withStartPtr x $ \aPtr size -> do + v <- + withForeignPtr statePtr $ \sptr -> + SVB.createAndTrim size $ + fmap (fromIntegral :: Word32 -> Int) . + derefChunkPtr fill sptr (fromIntegral size) + (Rep.castStorablePtr aPtr) . + Rep.castStorablePtr + touchForeignPtr ioContextPtr + (if SV.length v > 0 + then fmap (v:) + else id) $ + (if SV.length v < size + then return [] + else go xs) + go (SVL.chunks sig) + + +applyStorableChunky :: + (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA, + Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) => + T valueA valueB -> SVL.Vector a -> SVL.Vector b +applyStorableChunky + (Cons next start createIOContext deleteIOContext) sig = + SVL.fromChunks $ unsafePerformIO $ do + ioContext <- createIOContext + (startFunc, stopFunc, fill) <- + compileChunky (next ioContext) (start ioContext) + + statePtr <- Rep.newForeignPtrInit stopFunc startFunc + {- + This is a dummy pointer, that we need for correct finalization. + Concerning the live time the FunPtr 'fill' also has the live time + that we are after, + but it is unsafe to treat a FunPtr as a Ptr or ForeignPtr. + -} + ioContextPtr <- Rep.newForeignPtr (deleteIOContext ioContext) False + + let go xt = + unsafeInterleaveIO $ + case xt of + [] -> return [] + x:xs -> SVB.withStartPtr x $ \aPtr size -> do + v <- + withForeignPtr statePtr $ \sptr -> + SVB.createAndTrim size $ + fmap (fromIntegral :: Word32 -> Int) . + derefChunkPtr fill sptr (fromIntegral size) + (Rep.castStorablePtr aPtr) . + Rep.castStorablePtr + touchForeignPtr ioContextPtr + (if SV.length v > 0 + then fmap (v:) + else id) $ + (if SV.length v < size + then return [] + else go xs) + go (SVL.chunks sig) diff --git a/src/Synthesizer/LLVM/CausalParameterized/Controlled.hs b/src/Synthesizer/LLVM/CausalParameterized/Controlled.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/CausalParameterized/Controlled.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{- | +This module provides a type class that automatically selects a filter +for a given parameter type. +We choose the dependency this way +because there may be different ways to specify the filter parameters +but there is only one implementation of the filter itself. +-} +module Synthesizer.LLVM.CausalParameterized.Controlled where + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFiltPack +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilt +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Vector as Vector +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified Synthesizer.LLVM.Simple.Value as Value + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, Vector, IsArithmetic, IsFloating, IsConst, IsSized, IsFirstClass, ) + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Data.TypeLevel.Num as TypeNum +import qualified Data.TypeLevel.Num.Sets as TypeSet + +import Foreign.Storable (Storable, ) + +import qualified Algebra.Field as Field +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring + + +{- | +A filter parameter type uniquely selects a filter function. +However it does not uniquely determine the input and output type, +since the same filter can run on mono and stereo signals. +-} +class C parameter a b | parameter a -> b, parameter b -> a where + process :: CausalP.T p (parameter, a) b + + +processCtrlRate :: + (C parameter a b, + Rep.Memory parameter struct, + IsSized struct ss, + Ring.C r, IsFloating r, Storable r, IsConst r, + LLVM.MakeValueTuple r (Value r), + LLVM.CmpRet r Bool, + IsSized r rs) => + Param.T p r -> + (Param.T p r -> SigP.T p parameter) -> + CausalP.T p a b +processCtrlRate reduct ctrlGen = + CausalP.applyFst process + (SigP.interpolateConstant reduct (ctrlGen reduct)) + + +{- +Instances for the particular filters shall are defined here +in order to avoid orphan instances. +-} + +instance + (Ring.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a, + IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) => + C (Filt1.Parameter (Value a)) + (Value v) (Filt1.Result (Value v)) where + process = Filt1.causalP + +instance + (Ring.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a, + IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) => + C (Filt2.Parameter (Value a)) + (Value v) (Value v) where + process = Filt2.causalP + +instance + (Field.C a, IsConst a, Vector.Arithmetic a, + IsSized (Vector TypeNum.D4 a) as) => + C (Filt2P.Parameter a) + (Value a) (Value a) where + process = Filt2P.causalP + +instance + (Ring.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a, + IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v, + TypeSet.Nat n, + TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) => + C (Cascade.ParameterValue n a) + (Value v) (Value v) where + process = Cascade.causalP + + +instance + (Field.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a, + IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) => + C (Allpass.Parameter (Value a)) + (Value v) (Value v) where + process = Allpass.causalP + +instance + (Field.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a, + IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v, + TypeNum.Nat n) => + C (Allpass.CascadeParameter n (Value a)) + (Value v) (Value v) where + process = Allpass.cascadeP + + +instance + (Module.C a v, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a, + IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v, + LLVM.MakeValueTuple a (Value a), + LLVM.MakeValueTuple v (Value v), + Storable v, + TypeSet.Nat n) => + C (Moog.Parameter n (Value a)) + (Value v) (Value v) where + process = Moog.causalP + + +instance + (Field.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a, + IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) => + C (UniFilter.Parameter (Value a)) + (Value v) (UniFilter.Result (Value v)) where + process = UniFilter.causalP + +instance + (IsFirstClass a, IsSized a sa, IsConst a, IsFloating a) => + C (ComplexFilt.Parameter (Value a)) + (Stereo.T (Value a)) (Stereo.T (Value a)) where + process = ComplexFilt.causalP + +instance + (IsConst a, Vector.Arithmetic a, + IsSized (Vector TypeNum.D4 a) as) => + C (ComplexFiltPack.Parameter a) + (Stereo.T (Value a)) (Stereo.T (Value a)) where + process = ComplexFiltPack.causalP diff --git a/src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs b/src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{- | +This is like "Synthesizer.LLVM.CausalParameterized.Controlled" +but for vectorised signals. +-} +module Synthesizer.LLVM.CausalParameterized.ControlledPacked ( + C(process), processCtrlRate, + ) where + +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter + +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Vector as Vector +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, Vector, IsArithmetic, IsFloating, IsConst, IsSized, + IsFirstClass, IsPrimitive, IsPowerOf2, ) + +import qualified Data.TypeLevel.Num as TypeNum +import qualified Data.TypeLevel.Num.Sets as TypeSet + +import Foreign.Storable (Storable, ) + +import Control.Arrow ((<<<), first, ) + +import qualified Algebra.Field as Field +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +{- | +A filter parameter type uniquely selects a filter function. +However it does not uniquely determine the input and output type, +since the same filter can run on mono and stereo signals. +-} +class C parameter a b | parameter a -> b, parameter b -> a where + process :: CausalP.T p (parameter, a) b + +processCtrlRate :: + (C parameter av bv, + Vector.Access n a av, + Vector.Access n b bv, + Rep.Memory parameter struct, IsSized struct ss, + Field.C r, IsFloating r, Storable r, IsConst r, + LLVM.MakeValueTuple r (Value r), + LLVM.CmpRet r Bool, + IsSized r rs) => + Param.T p r -> + (Param.T p r -> SigP.T p parameter) -> + CausalP.T p av bv +processCtrlRate reduct ctrlGen = withSize $ \n -> + CausalP.applyFst process + (SigP.interpolateConstant + (fmap (/ fromIntegral (TypeNum.toInt n)) reduct) + (ctrlGen reduct)) + +withSize :: + (Vector.Access n a av, + Vector.Access n b bv) => + (n -> CausalP.T p av bv) -> + CausalP.T p av bv +withSize f = f undefined + + +{- +Instances for the particular filters shall be defined here +in order to avoid orphan instances. +-} + +instance + (Ring.C a, IsArithmetic a, IsPrimitive a, + IsFirstClass a, IsConst a, IsSized a as, + IsPowerOf2 n) => + C (Filt1.Parameter (Value a)) + (Value (Vector n a)) (Filt1.Result (Value (Vector n a))) where + process = Filt1.causalPackedP + +instance + (Ring.C a, IsFirstClass a, IsArithmetic a, IsConst a, + IsPowerOf2 n, IsPrimitive a, IsSized a as, + TypeNum.Mul n as vas, TypeNum.Pos vas) => + C (Filt2.Parameter (Value a)) + (Value (Vector n a)) (Value (Vector n a)) where + process = Filt2.causalPackedP + +instance + (Ring.C a, IsPrimitive a, IsSized a as, IsConst a, + IsArithmetic a, TypeSet.Nat n, + TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize, + IsPowerOf2 d, TypeNum.Mul d as vas, TypeSet.Pos vas) => + C (Cascade.ParameterValue n a) + (Value (Vector d a)) (Value (Vector d a)) where + process = Cascade.causalPackedP + + +instance + (Ring.C a, IsFirstClass a, IsArithmetic a, IsConst a, + IsPowerOf2 n, IsPrimitive a, IsSized a as) => + C (Allpass.Parameter (Value a)) + (Value (Vector n a)) (Value (Vector n a)) where + process = Allpass.causalPackedP + +instance + (Field.C a, IsFirstClass a, IsArithmetic a, IsConst a, + IsPowerOf2 d, IsPrimitive a, IsSized a as, + TypeNum.Nat n) => + C (Allpass.CascadeParameter n (Value a)) + (Value (Vector d a)) (Value (Vector d a)) where + process = Allpass.cascadePackedP + + +instance + (Module.C a a, IsFirstClass a, IsArithmetic a, IsConst a, + LLVM.MakeValueTuple a (Value a), Storable a, + IsPowerOf2 d, IsPrimitive a, IsSized a as, + TypeNum.Nat n) => + C (Moog.Parameter n (Value a)) + (Value (Vector d a)) (Value (Vector d a)) where + process = + CausalPS.pack Moog.causalP <<< + first (CausalP.mapSimple Vector.replicate) + + +instance + (Field.C a, IsFirstClass a, IsArithmetic a, IsConst a, + IsPowerOf2 d, IsPrimitive a, IsSized a as) => + C (UniFilter.Parameter (Value a)) + (Value (Vector d a)) (UniFilter.Result (Value (Vector d a))) where + process = + CausalPS.pack UniFilter.causalP <<< + first (CausalP.mapSimple Vector.replicate) diff --git a/src/Synthesizer/LLVM/CausalParameterized/Process.hs b/src/Synthesizer/LLVM/CausalParameterized/Process.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/CausalParameterized/Process.hs @@ -0,0 +1,860 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.CausalParameterized.Process ( + T(Cons), simple, + mapAccum, map, mapSimple, + apply, compose, first, + feedFst, feedSnd, + take, integrate, + module Synthesizer.LLVM.CausalParameterized.Process + ) where + +import Synthesizer.LLVM.CausalParameterized.ProcessPrivate +import qualified Synthesizer.LLVM.Parameter as Param + +import Synthesizer.LLVM.Parameterized.Signal (($#), ) +import qualified Synthesizer.LLVM.Parameterized.Signal as Sig +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Sample as Sample +import qualified Synthesizer.LLVM.Execution as Exec +import qualified Synthesizer.LLVM.Simple.Value as Value + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB + +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.MaybeContinuation as Maybe +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Arithmetic as A + +import LLVM.Core as LLVM +import Data.TypeLevel.Num (D2, ) +import qualified Data.TypeLevel.Num as TypeNum +import qualified Data.TypeLevel.Num.Sets as Sets + +import qualified Control.Monad.HT as M +import qualified Control.Arrow as Arr +import qualified Control.Category as Cat +import Control.Monad.Trans.State (runState, state, evalState, ) +import Control.Arrow ((<<<), (>>>), (&&&), ) +import Control.Monad (liftM2, liftM3, ) +import Control.Applicative (liftA2, ) + +import System.Random (Random, RandomGen, randomR, ) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Data.Function.HT (nest, ) +import Data.Word (Word32, ) +import Foreign.Storable.Tuple () +import Foreign.Storable (Storable, poke, ) +import qualified Foreign.Marshal.Array as Array +import qualified Foreign.Marshal.Alloc as Alloc +import Foreign.ForeignPtr (withForeignPtr, ) +import Foreign.Ptr (FunPtr, ) +import Control.Exception (bracket, ) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) + +import qualified Data.List as List + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, ) + + +infixl 0 $<, $>, $*, $<#, $>#, $*# +-- infixr 0 $:* -- can be used together with $ + +applyFst, ($<) :: T p (a,b) c -> Sig.T p a -> T p b c +applyFst proc sig = + proc <<< feedFst sig + +applySnd, ($>) :: T p (a,b) c -> Sig.T p b -> T p a c +applySnd proc sig = + proc <<< feedSnd sig + +{- +These infix operators may become methods of a type class +that can also have synthesizer-core:Causal.Process as instance. +-} +($*) :: T p a b -> Sig.T p a -> Sig.T p b +($*) = apply +($<) = applyFst +($>) = applySnd + +{- | +provide constant input in a comfortable way +-} +($*#) :: + (Storable ah, MakeValueTuple ah a, + Rep.Memory a am, IsSized am as) => + T p a b -> ah -> Sig.T p b +proc $*# x = proc $* (Sig.constant $# x) + +($<#) :: + (Storable ah, MakeValueTuple ah a, + Rep.Memory a am, IsSized am as) => + T p (a,b) c -> ah -> T p b c +proc $<# x = proc $< (Sig.constant $# x) + +($>#) :: + (Storable bh, MakeValueTuple bh b, + Rep.Memory b bm, IsSized bm bs) => + T p (a,b) c -> bh -> T p a c +proc $># x = proc $> (Sig.constant $# x) + + +mapAccumSimple :: + (Rep.Memory s struct, IsSized struct sa) => + (forall r. a -> s -> CodeGenFunction r (b,s)) -> + (forall r. CodeGenFunction r s) -> + T p a b +mapAccumSimple f s = + mapAccum (\() -> f) (\() -> s) (return ()) (return ()) + +{- | +Not quite the loop of ArrowLoop +because we need a delay of one time step +and thus an initialization value. + +For a real ArrowLoop.loop, that is a zero-delay loop, +we would formally need a MonadFix instance of CodeGenFunction. +But this will not become reality, since LLVM is not able to re-order code +in a way that allows to access a result before creating the input. +-} +loop :: + (Storable ch, + MakeValueTuple ch c, + Rep.Memory c cp, + IsSized cp cs) => + Param.T p ch -> T p (a,c) (b,c) -> T p a b +loop initial (Cons next start createIOContext deleteIOContext) = + Cons + (\p a0 (c0,s0) -> do + ((b1,c1), s1) <- next p (a0,c0) s0 + return (b1,(c1,s1))) + (\(i,p) -> fmap ((,) (Param.value initial i)) $ start p) + (\p -> do + (ctx,(nextParam,startParam)) <- createIOContext p + return (ctx, + (nextParam, (Param.get initial p, startParam)))) + deleteIOContext + + +-- cf. synthesizer-core:Causal.Process, can be defined for any arrow +{-# INLINE replicateControlled #-} +replicateControlled :: Int -> T p (c,x) x -> T p (c,x) x +replicateControlled n p = + nest n + (Arr.arr fst &&& p >>> ) + (Arr.arr snd) + +-- cf. synthesizer-core:Causal.Process +{-# INLINE feedbackControlled #-} +feedbackControlled :: + (Storable ch, + MakeValueTuple ch c, + Rep.Memory c cp, + IsSized cp cs) => + Param.T p ch -> + T p ((ctrl,a),c) b -> T p (ctrl,b) c -> T p (ctrl,a) b +feedbackControlled initial forth back = + loop initial + (Arr.arr (fst.fst) &&& forth >>> Arr.arr snd &&& back) + + +fromModifier :: + (Value.Flatten ah al, Value.Flatten bh bl, Value.Flatten ch cl, + Value.Flatten sh sl, Rep.Memory sl sp, IsSized sp ss) => + Modifier.Simple sh ch ah bh -> T p (cl,al) bl +fromModifier (Modifier.Simple initial step) = + mapAccumSimple + (\(c,a) s -> + Value.flatten $ + runState + (step (Value.unfold c) (Value.unfold a)) + (Value.unfold s)) + (Value.flatten initial) + + +{- | +Run a causal process independently on each stereo channel. +-} +stereoFromMono :: + T p a b -> T p (Stereo.T a) (Stereo.T b) +stereoFromMono = + Stereo.arrowFromMono + +stereoFromMonoControlled :: + T p (c,a) b -> T p (c, Stereo.T a) (Stereo.T b) +stereoFromMonoControlled = + Stereo.arrowFromMonoControlled + +stereoFromChannels :: + T p a b -> T p a b -> T p (Stereo.T a) (Stereo.T b) +stereoFromChannels = + Stereo.arrowFromChannels + +{- +In order to let this work we have to give the disable-mmx option somewhere, +but where? +-} +stereoFromVector :: + (IsPrimitive a, IsPrimitive b) => + T p (Value (Vector D2 a)) (Value (Vector D2 b)) -> + T p (Stereo.T (Value a)) (Stereo.T (Value b)) +stereoFromVector proc = + mapSimple Sample.stereoFromVector <<< + proc <<< + mapSimple Sample.vectorFromStereo + + +vectorize :: + (Vector.Access n a va, Vector.Access n b vb) => + T p a b -> T p va vb +vectorize = vectorizeSize undefined + +{- +insert and extract instructions will be in opposite order, +no matter whether we use foldr or foldl +and independent from the order of proc and channel in replaceChannel. +However, LLVM neglects the order anyway. +-} +vectorizeSize :: + (Vector.Access n a va, Vector.Access n b vb) => + n -> T p a b -> T p va vb +vectorizeSize n proc = + foldl + (\acc i -> replaceChannel i proc acc) + (Arr.arr (const $ LLVM.undefTuple)) $ + List.take (TypeNum.toInt n) [0 ..] + +{- | +Given a vector process, replace the i-th output by output +that is generated by a scalar process from the i-th input. +-} +replaceChannel :: + (Vector.Access n a va, Vector.Access n b vb) => + Int -> T p a b -> T p va vb -> T p va vb +replaceChannel i channel proc = + let li = valueOf $ fromIntegral i + in mapSimple (uncurry (Vector.insert li)) <<< + (channel <<< mapSimple (Vector.extract li)) &&& + proc + + +zipWithSimple :: + (forall r. a -> b -> CodeGenFunction r c) -> + T p (a,b) c +zipWithSimple f = + mapSimple (uncurry f) + +mix :: + (IsArithmetic a) => + T p (Value a, Value a) (Value a) +mix = + zipWithSimple Sample.mixMono + +mixStereo :: + (IsArithmetic a) => + T p (Stereo.T (Value a), Stereo.T (Value a)) (Stereo.T (Value a)) +mixStereo = + zipWithSimple Sample.mixStereo + + +raise :: + (IsArithmetic a, Storable a, + MakeValueTuple a (Value a), IsSized a size) => + Param.T p a -> T p (Value a) (Value a) +raise = + map Sample.mixMono + + +envelope :: + (IsArithmetic a) => + T p (Value a, Value a) (Value a) +envelope = + zipWithSimple Sample.amplifyMono + +envelopeStereo :: + (IsArithmetic a) => + T p (Value a, Stereo.T (Value a)) (Stereo.T (Value a)) +envelopeStereo = + zipWithSimple Sample.amplifyStereo + +amplify :: + (IsArithmetic a, Storable a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) => + Param.T p a -> T p (Value a) (Value a) +amplify = + map Sample.amplifyMono + +amplifyStereo :: + (IsArithmetic a, Storable a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) => + Param.T p a -> T p (Stereo.T (Value a)) (Stereo.T (Value a)) +amplifyStereo = + map Sample.amplifyStereo + + + +mapLinear :: + (IsArithmetic a, Storable a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) => + Param.T p a -> Param.T p a -> T p (Value a) (Value a) +mapLinear depth center = + map + (\(d,c) x -> A.add c =<< A.mul d x) + (depth&&¢er) + +mapExponential :: + (Trans.C a, IsFloating a, IsConst a, Storable a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) => + Param.T p a -> Param.T p a -> T p (Value a) (Value a) +mapExponential depth center = + map + (\(d,c) x -> + A.mul c =<< A.exp =<< A.mul d x) + (log depth &&& center) + + +{- | +@quantizeLift k f@ applies the process @f@ to every @k@th sample +and repeats the result @k@ times. + +Like 'SigP.interpolateConstant' this function can be used +for computation of filter parameters at a lower rate. +This can be useful, if you have a frequency control signal at sample rate +that shall be used both for an oscillator and a frequency filter. +-} +quantizeLift :: + (Rep.Memory b struct, IsSized struct size, + Ring.C c, + IsFloating c, CmpRet c Bool, + Storable c, MakeValueTuple c (Value c), + IsConst c, IsFirstClass c, IsSized c sc) => + Param.T p c -> + T p a b -> + T p a b +quantizeLift k + (Cons next start createIOContext deleteIOContext) = Cons + (\(kl,parameter) a0 bState0 -> do + ((b1,state1), ss1) <- + Maybe.fromBool $ + C.whileLoop + (valueOf True, bState0) + (\(cont1, (_, ss1)) -> + and cont1 =<< A.fcmp FPOLE ss1 (value LLVM.zero)) + (\(_,((_,state01), ss1)) -> + Maybe.toBool $ liftM2 (,) + (next parameter a0 state01) + (Maybe.lift $ A.add ss1 (Param.value k kl))) + + ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.one) + return (b1, ((b1,state1),ss2))) + (fmap (\sa -> ((undefTuple, sa), value LLVM.zero)) . start) + (\p -> do + (ioContext, (nextParam, startParam)) <- createIOContext p + return (ioContext, ((Param.get k p, nextParam), startParam))) + deleteIOContext + + +{- | +Compute the phases from phase distortions and frequencies. + +It's like integrate but with wrap-around performed by @fraction@. +For FM synthesis we need also negative phase distortions, +thus we use 'SoV.addToPhase' which supports that. +-} +osciCore :: + (IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t, + Additive.C t) => + T p (Value t, Value t) (Value t) +osciCore = + mapSimple (uncurry SoV.addToPhase) <<< + Arr.second + (mapAccumSimple + (\a s -> do + b <- SoV.incPhase a s + return (s,b)) + (return (valueOf Additive.zero))) + +osciSimple :: + (IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t, + Additive.C t) => + (forall r. Value t -> CodeGenFunction r y) -> + T p (Value t, Value t) y +osciSimple wave = + mapSimple wave <<< osciCore + +shapeModOsci :: + (IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t, + Additive.C t) => + (forall r. c -> Value t -> CodeGenFunction r y) -> + T p (c, (Value t, Value t)) y +shapeModOsci wave = + mapSimple (uncurry wave) <<< Arr.second osciCore + + + +{- | +Delay time must be non-negative. + +The initial value is needed in order to determine the ring buffer element type. +-} +delay :: + (Storable a, + MakeValueTuple a al, + Rep.Memory al ap, + IsSized ap as) => + Param.T p a -> Param.T p Int -> T p al al +delay initial time = + let time32 = fmap (fromIntegral :: Int -> Word32) time in + Cons + (\(size,ptr) a0 (remain0,ptri0) -> Maybe.lift $ do + Rep.store a0 ptri0 + cont <- A.icmp IntNE remain0 (valueOf 0) + (remain1,ptri1) <- + C.ifThenSelect cont (Param.value time32 size, ptr) + (liftM2 (,) + (A.dec remain0) + (A.advanceArrayElementPtr ptri0)) + a1 <- Rep.load ptri1 + return (a1, (remain1,ptri1))) + (\(x, (size,ptr)) -> do + size1 <- A.inc (Param.value time32 size) + -- cf. LLVM.Storable.Signal.fill + C.arrayLoop size1 ptr () $ \ ptri () -> + Rep.store (Param.value initial x) ptri >> return () + return (size,ptr)) + (\p -> do + let size = Param.get time p + x = Param.get initial p + {- + We allocate one element more than necessary + in order to simplify handling of delay time zero + -} + ptr <- Array.mallocArray (size+1) + let param = + (fromIntegral size :: Word32, + Rep.castStorablePtr (ptrAsTypeOf ptr x)) + return (ptr, (param, (x, param)))) + Alloc.free + +ptrAsTypeOf :: Ptr a -> a -> Ptr a +ptrAsTypeOf p _ = p + +{- | +Delay by one sample. +For very small delay times (say up to 8) +it may be more efficient to apply 'delay1' several times +or to use a pipeline, +e.g. @pipeline (id :: T (Vector D4 Float) (Vector D4 Float))@ +delays by 4 samples in an efficient way. +In principle it would be also possible to use +@unpack (delay1 (const $ toVector (0,0,0,0)))@ +but 'unpack' causes an additional delay. +Thus @unpack (id :: T (Vector D4 Float) (Vector D4 Float))@ may do, +what you want. +-} +delay1 :: + (Storable a, + MakeValueTuple a al, + Rep.Memory al ap, + IsSized ap as) => + Param.T p a -> T p al al +delay1 initial = simple + (\() a s -> return (s,a)) + return + (return ()) + initial + + +{- | +Delay time must be greater than zero! +-} +comb :: + (Ring.C a, + Storable a, + IsArithmetic a, + MakeValueTuple a (Value a), + IsFirstClass a, + IsSized a as) => + Param.T p a -> Param.T p Int -> + T p (Value a) (Value a) +comb gain time = + let z = Additive.zero `asTypeOf` gain + in loop z (mix >>> (Cat.id &&& + (delay z (subtract 1 time) >>> amplify gain))) + +combStereo :: + (Ring.C a, + Storable a, + IsArithmetic a, + MakeValueTuple a (Value a), + IsFirstClass a, + IsSized a as) => + Param.T p a -> Param.T p Int -> + T p (Stereo.T (Value a)) (Stereo.T (Value a)) +combStereo gain time = + let z = Additive.zero `asTypeOf` (liftA2 Stereo.cons gain gain) + in loop z (mixStereo >>> (Cat.id &&& + (delay z (subtract 1 time) >>> amplifyStereo gain))) + +reverb :: + (Field.C a, Random a, + Storable a, IsArithmetic a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a as, + RandomGen g) => + g -> Int -> (a,a) -> (Int,Int) -> + T p (Value a) (Value a) +reverb rnd num gainRange timeRange = + amplify (return (recip (fromIntegral num))) <<< + (foldl (\proc chan -> mix <<< (proc &&& chan)) Cat.id $ + List.take num $ + List.map (\(g,t) -> comb $# g $# t) $ + flip evalState rnd $ + M.repeat $ + liftM2 (,) + (state (randomR gainRange)) + (state (randomR timeRange))) + + +{- | +This allows to compute a chain of equal processes efficiently, +if all of these processes can be bundled in one vectorial process. +Applications are an allpass cascade or an FM operator cascade. + +The function expects that the vectorial input process +works like parallel scalar processes. +The different pipeline stages may be controlled by different parameters, +but the structure of all pipeline stages must be equal. +Our function feeds the input of the pipelined process +to the zeroth element of the Vector. +The result of processing the i-th element (the i-th channel, so to speak) +is fed to the (i+1)-th element. +The (n-1)-th element of the vectorial process is emitted as output of pipelined process. + +The pipeline necessarily introduces a delay of (n-1) values. +For simplification we extend this to n values delay. +If you need to combine the resulting signal from the pipeline +with another signal in a 'zip'-like way, +you may delay that signal with @pipeline id@. +The first input values in later stages of the pipeline +are initialized with zero. +If this is not appropriate for your application, +then we may add a more sensible initialization. +-} +pipeline :: + (Vector.Access n a v, Class.Zero v, + Rep.Memory v vp, IsSized vp s) => + T p v v -> T p a a +pipeline (Cons next start createIOContext deleteIOContext) = Cons + (\param a0 (v0,s0) -> do + (a1,v1) <- Maybe.lift $ Vector.shiftUp a0 v0 + (v2,s2) <- next param v1 s0 + return (a1, (v2,s2))) + (\p -> do + s <- start p + return (Class.zeroTuple, s)) + createIOContext + deleteIOContext + + +linearInterpolation :: + (Ring.C a, IsArithmetic a, IsConst a) => + Value a -> (Value a, Value a) -> CodeGenFunction r (Value a) +linearInterpolation r (a,b) = do + ra <- A.mul a =<< A.sub (valueOf one) r + rb <- A.mul b r + A.add ra rb + + +{- | +> frequencyModulationLinear signal + +is a causal process mapping from a shrinking factor +to the modulated input @signal@. +Similar to 'Sig.interpolateConstant' +but the factor is reciprocal and controllable +and we use linear interpolation. +The shrinking factor must be non-negative. +-} +frequencyModulationLinear :: + (-- Rep.Memory a struct, IsSized struct size, + Ring.C a, + IsFloating a, CmpRet a Bool, + Storable a, MakeValueTuple a (Value a), + IsConst a, IsFirstClass a, IsSized a sa) => + Sig.T p (Value a) -> T p (Value a) (Value a) +frequencyModulationLinear + (Sig.Cons next start createIOContext deleteIOContext) = + Cons + (\parameter k yState0 -> do + (((y02,y12),state2), ss2) <- + Maybe.fromBool $ + C.whileLoop + (valueOf True, yState0) + (\(cont0, (_, ss0)) -> + and cont0 =<< A.fcmp FPOGE ss0 (valueOf Ring.one)) + (\(_,(((_,y01),state0), ss0)) -> + Maybe.toBool $ liftM2 (,) + (do (y11,state1) <- next parameter state0 + return ((y01,y11),state1)) + (Maybe.lift $ A.sub ss0 (valueOf Ring.one))) + + Maybe.lift $ do + y <- linearInterpolation ss2 (y02,y12) + ss3 <- A.add ss2 k + return (y, (((y02,y12),state2),ss3))) + (\p -> do + sa <- start p + return (((value undef, value undef), sa), valueOf 2)) + createIOContext + deleteIOContext + + +{- | +@trigger fill signal@ send @signal@ to the output +and restart it whenever the Boolean process input is 'True'. +Before the first occurrence of 'True' +and between instances of the signal the output is filled with the @fill@ value. + +Attention: +This function will crash if the input generator +uses fromStorableVectorLazy, piecewiseConstant or lazySize, +since these functions contain mutable references and in-place updates, +and thus they cannot read lazy Haskell data multiple times. +-} +trigger :: + (Storable a, MakeValueTuple a al, C.Select al, + Rep.Memory al as, IsSized as asize) => + Param.T p a -> + Sig.T p al -> + T p (Value Bool) al +trigger fill (Sig.Cons next start createIOContext deleteIOContext) = Cons + (\(nextParam, startParam, f) b0 (active0, s0) -> Maybe.lift $ do + (active1,s1) <- + C.ifThen b0 (active0,s0) + (fmap ((,) (valueOf False)) $ start startParam) + (active2,(a2,s2)) <- + Maybe.toBool $ Maybe.guard active1 >> next nextParam s1 + a3 <- C.select active2 a2 (Param.value fill f) + return (a3,(active2,s2))) + (\() -> return (valueOf False, undefTuple)) + (\p -> do + (context, (nextParam, startParam)) <- createIOContext p + return (context, ((nextParam, startParam, Param.get fill p), ()))) + deleteIOContext + + +{- | +On each restart the parameters of type @b@ are passed to the signal. + +triggerParam :: + (MakeValueTuple a al, + MakeValueTuple b bl) => + Param.T p a -> + (Param.T p b -> Sig.T p a) -> + T p (Value Bool, bl) al +triggerParam fill sig = +-} + + + +foreign import ccall safe "dynamic" derefFillPtr :: + Exec.Importer (Ptr param -> Word32 -> Ptr a -> Ptr b -> IO Word32) + +runStorable :: + (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA, + Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) => + T p valueA valueB -> + IO (p -> SV.Vector a -> SV.Vector b) +runStorable (Cons next start createIOContext deleteIOContext) = do + fill <- + fmap derefFillPtr $ + Exec.compileModule $ + createFunction ExternalLinkage $ + \paramPtr size alPtr blPtr -> do + (nextParam,startParam) <- Rep.load paramPtr + s <- start startParam + (pos,_) <- Maybe.arrayLoop2 size alPtr blPtr s $ + \ aPtri bPtri s0 -> do + a <- Maybe.lift $ Rep.load aPtri + (b,s1) <- next nextParam a s0 + Maybe.lift $ Rep.store b bPtri + return s1 + ret (pos :: Value Word32) + + return $ \p as -> + unsafePerformIO $ + bracket (createIOContext p) (deleteIOContext . fst) $ + \ (_,params) -> + SVB.withStartPtr as $ \ aPtr len -> + SVB.createAndTrim len $ \ bPtr -> + Alloc.alloca $ \paramPtr -> + poke paramPtr params >> + (fmap fromIntegral $ + fill (Rep.castStorablePtr paramPtr) + (fromIntegral len) + (Rep.castStorablePtr aPtr) + (Rep.castStorablePtr bPtr)) + +applyStorable :: + (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA, + Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) => + T p valueA valueB -> + p -> SV.Vector a -> SV.Vector b +applyStorable gen = unsafePerformIO $ runStorable gen + + + +foreign import ccall safe "dynamic" derefChunkPtr :: + Exec.Importer (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> + Ptr structA -> Ptr structB -> IO Word32) + + +compileChunky :: + (Rep.Memory valueA structA, + Rep.Memory valueB structB, + Rep.Memory state stateStruct, + IsSized stateStruct stateSize, + Rep.Memory startParamValue startParamStruct, + Rep.Memory nextParamValue nextParamStruct, + IsSized startParamStruct startParamSize, + IsSized nextParamStruct nextParamSize) => + (forall r. + nextParamValue -> + valueA -> state -> + Maybe.T r (Value Bool, (Value (Ptr structB), state)) (valueB, state)) -> + (forall r. + startParamValue -> + CodeGenFunction r state) -> + IO (FunPtr (Ptr startParamStruct -> IO (Ptr stateStruct)), + FunPtr (Ptr stateStruct -> IO ()), + FunPtr (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> + Ptr structA -> Ptr structB -> IO Word32)) +compileChunky next start = + Exec.compileModule $ + liftM3 (,,) + (createFunction ExternalLinkage $ + \paramPtr -> do + -- FIXME: size computation in LLVM currently does not work for structs! + pptr <- Rep.malloc + flip Rep.store pptr =<< start =<< Rep.load paramPtr + ret pptr) + (createFunction ExternalLinkage $ + \ pptr -> Rep.free pptr >> ret ()) + (createFunction ExternalLinkage $ + \ paramPtr sptr loopLen aPtr bPtr -> do + param <- Rep.load paramPtr + sInit <- Rep.load sptr + (pos,sExit) <- Maybe.arrayLoop2 loopLen aPtr bPtr sInit $ + \ aPtri bPtri s0 -> do + a <- Maybe.lift $ Rep.load aPtri + (b,s1) <- next param a s0 + Maybe.lift $ Rep.store b bPtri + return s1 + Rep.store sExit sptr + ret (pos :: Value Word32)) + + +runStorableChunky :: + (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA, + Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) => + T p valueA valueB -> + IO (p -> SVL.Vector a -> SVL.Vector b) +runStorableChunky proc = + fmap ($ const SVL.empty) $ + runStorableChunkyCont proc + +{- +I liked to write something with signature + +> import qualified Synthesizer.Causal.Process as Causal +> +> liftStorableChunk :: +> T p valueA valueB -> +> IO (p -> Causal.T (SV.Vector a) (SV.Vector b)) + +This could be used to convert a LLVM causal process +to something that works on Haskell values (here: strict storable vectors). +In a second step we could convert this to a processor of lazy lists, +and thus to a processor of chunky storable vectors. +Unfortunately @Causal.T@ uses an immutable state internally, +whereas @T@ uses mutable states. +In principle the immutable state of @Causal.T@ +could be used for breaking the processing of a stream +and continue it on two different streams in parallel. +I have no function that makes use of this feature, +and thus an @ST@ monad might be a way out. +-} + +{- | +This function should be used +instead of @StorableVector.Lazy.Pattern.splitAt@ and subsequent @append@, +because it does not have the risk of a memory leak. +-} +runStorableChunkyCont :: + (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA, + Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) => + T p valueA valueB -> + IO ((SVL.Vector a -> SVL.Vector b) -> + p -> + SVL.Vector a -> SVL.Vector b) +runStorableChunkyCont (Cons next start createIOContext deleteIOContext) = do + (startFunc, stopFunc, fill) <- compileChunky next start + return $ + \ procRest p sig -> + SVL.fromChunks $ unsafePerformIO $ do + (ioContext, (nextParam, startParam)) <- createIOContext p + + statePtr <- Rep.newForeignPtrParam stopFunc startFunc startParam + nextParamPtr <- + Rep.newForeignPtr (deleteIOContext ioContext) nextParam + + let go xt = + unsafeInterleaveIO $ + case xt of + [] -> return [] + x:xs -> SVB.withStartPtr x $ \aPtr size -> do + v <- + Rep.withForeignPtr nextParamPtr $ \nptr -> + withForeignPtr statePtr $ \sptr -> + SVB.createAndTrim size $ + fmap fromIntegral . + derefChunkPtr fill nptr sptr + (fromIntegral size) + (Rep.castStorablePtr aPtr) . + Rep.castStorablePtr + (if SV.length v > 0 + then fmap (v:) + else id) $ + (if SV.length v < size + then return $ SVL.chunks $ + procRest $ SVL.fromChunks $ + SV.drop (SV.length v) x : xs + else go xs) + go (SVL.chunks sig) + +applyStorableChunky :: + (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA, + Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) => + T p valueA valueB -> + p -> SVL.Vector a -> SVL.Vector b +applyStorableChunky gen = + unsafePerformIO (runStorableChunky gen) diff --git a/src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs b/src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.CausalParameterized.ProcessPacked where + +import Synthesizer.LLVM.CausalParameterized.Process (T(Cons), ) +import qualified Synthesizer.LLVM.CausalParameterized.Process as Causal +import qualified Synthesizer.LLVM.Parameter as Param +import qualified Synthesizer.LLVM.Sample as Sample +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.MaybeContinuation as Maybe +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Control as C +import LLVM.Extra.Control (whileLoop, ifThen, ) + +import LLVM.Core as LLVM + +import qualified Data.TypeLevel.Num as TypeNum +import qualified Data.TypeLevel.Num.Sets as TypeSet + +import qualified Control.Arrow as Arr +import Control.Arrow ((^<<), (<<<), ) + +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Data.Word (Word32, ) +import Foreign.Storable (Storable, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, ) + + + +{- | +Run a scalar process on packed data. +If the signal length is not divisible by the chunk size, +then the last chunk is dropped. +-} +pack :: + (Vector.Access n a va, Vector.Access n b vb) => + T p a b -> T p va vb +pack (Cons next start createIOContext deleteIOContext) = Cons + (\param a s -> do + ((_,b2),(_,s2)) <- + Maybe.fromBool $ + C.whileLoop + (valueOf True, + let b = undefTuple + in ((a,b), (valueOf $ (fromIntegral $ Vector.sizeInTuple b :: Word32), s))) + (\(cont,(_ab0,(i0,_s0))) -> + A.and cont =<< + A.icmp IntUGT i0 (value LLVM.zero)) + (\(_,((a0,b0),(i0,s0))) -> Maybe.toBool $ do + ai <- Maybe.lift $ Vector.extract (valueOf 0) a0 + (bi,s1) <- next param ai s0 + Maybe.lift $ do + a1 <- Vector.rotateDown a0 + b1 <- fmap snd $ Vector.shiftDown bi b0 + i1 <- A.dec i0 + return ((a1,b1),(i1,s1))) + return (b2, s2)) + start + createIOContext + deleteIOContext + +{- | +Like 'pack' but duplicates the code for the scalar process. +That is, for vectors of size n, +the code for the scalar causal process will be written n times. +This is efficient only for simple input processes. +-} +packSmall :: + (Vector.Access n a va, Vector.Access n b vb) => + T p a b -> T p va vb +packSmall (Cons next start createIOContext deleteIOContext) = Cons + (\param a s -> + let vundef = LLVM.undefTuple + in foldr + (\i rest (v0,s0) -> do + ai <- Maybe.lift $ Vector.extract (valueOf i) a + (bi,s1) <- next param ai s0 + v1 <- Maybe.lift $ Vector.insert (valueOf i) bi v0 + rest (v1,s1)) + return + (take (Vector.sizeInTuple vundef) [0..]) + (vundef, s)) + start + createIOContext + deleteIOContext + + +{- | +Run a packed process on scalar data. +If the signal length is not divisible by the chunk size, +then the last chunk is dropped. +In order to stay causal, we have to delay the output by @n@ samples. +-} +unpack :: + (Vector.Access n a va, Vector.Access n b vb, + Class.Zero va, LLVM.Undefined b, + Rep.Memory va vap, IsSized vap vas, + Rep.Memory vb vbp, IsSized vbp vbs) => + T p va vb -> T p a b +unpack (Cons next start createIOContext deleteIOContext) = Cons + (\param ai ((a0,b0),(i0,s0)) -> do + endOfVector <- Maybe.lift $ A.icmp IntEQ i0 (valueOf 0) + ((a2,b2),(i2,s2)) <- + Maybe.fromBool $ + C.ifThen endOfVector (valueOf True, ((a0,b0),(i0,s0))) $ do + (cont1, (b1,s1)) <- Maybe.toBool $ next param a0 s0 + return (cont1, + ((LLVM.undefTuple, b1), + (valueOf $ fromIntegral $ Vector.sizeInTuple a0, s1))) + Maybe.lift $ do + a3 <- fmap snd $ Vector.shiftDown ai a2 + (bi,b3) <- Vector.shiftDown (LLVM.undefTuple) b2 + i3 <- A.dec i2 + return (bi, ((a3,b3),(i3,s2)))) + (\p -> do + s <- start p + return ((Class.zeroTuple, LLVM.undefTuple), (valueOf (0::Word32), s))) + createIOContext + deleteIOContext + + +raise :: + (Storable a, IsArithmetic a, IsPrimitive a, IsConst a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size, + IsPowerOf2 n, TypeNum.Mul n size ps, TypeSet.Pos ps) => + Param.T p a -> + T p (Value (Vector n a)) (Value (Vector n a)) +raise x = + Causal.map Sample.mixMono (LLVM.vector . (:[]) ^<< x) + + +amplify :: + (Storable a, IsArithmetic a, IsPrimitive a, IsConst a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size, + IsPowerOf2 n, TypeNum.Mul n size ps, TypeSet.Pos ps) => + Param.T p a -> + T p (Value (Vector n a)) (Value (Vector n a)) +amplify p = + Causal.map Sample.amplifyMono (LLVM.vector . (:[]) ^<< p) + +amplifyStereo :: + (Storable a, IsArithmetic a, IsPrimitive a, IsConst a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size, + IsPowerOf2 n, TypeNum.Mul n size ps, TypeSet.Pos ps) => + Param.T p a -> + T p (Stereo.T (Value (Vector n a))) (Stereo.T (Value (Vector n a))) +amplifyStereo p = + Causal.map Sample.amplifyStereo (LLVM.vector . (:[]) ^<< p) + + +osciCore :: + (IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t, + Vector.Real t, IsPrimitive t, + IsPowerOf2 n, + Additive.C t) => + T p (Value (Vector n t), Value (Vector n t)) (Value (Vector n t)) +osciCore = + Causal.mapSimple (uncurry SoV.addToPhase) <<< + Arr.second + (Causal.mapAccumSimple + (\a phase0 -> do + (phase1,b1) <- Vector.cumulate phase0 a + phase2 <- SoV.signedFraction phase1 + return (b1,phase2)) + (return (valueOf Additive.zero))) + +osciSimple :: + (IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t, + Vector.Real t, IsPrimitive t, + IsPowerOf2 n, + Additive.C t) => + (forall r. Value (Vector n t) -> CodeGenFunction r y) -> + T p (Value (Vector n t), Value (Vector n t)) y +osciSimple wave = + Causal.mapSimple wave <<< osciCore + +shapeModOsci :: + (IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t, + Vector.Real t, IsPrimitive t, + IsPowerOf2 n, + Additive.C t) => + (forall r. c -> Value (Vector n t) -> CodeGenFunction r y) -> + T p (c, (Value (Vector n t), Value (Vector n t))) y +shapeModOsci wave = + Causal.mapSimple (uncurry wave) <<< Arr.second osciCore diff --git a/src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs b/src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.CausalParameterized.ProcessPrivate where + +import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as Sig +import qualified LLVM.Extra.MaybeContinuation as Maybe +import qualified Synthesizer.LLVM.Parameter as Param +import qualified LLVM.Extra.Representation as Rep + +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Util.Loop (Phi, ) +import LLVM.Core + (Value, valueOf, MakeValueTuple, + IsSized, IsFirstClass, IsArithmetic, CodeGenFunction, ) + +import qualified Control.Arrow as Arr +import qualified Control.Category as Cat +import Control.Arrow ((^<<), (<<<), (<<^), (&&&), ) +import Control.Monad (liftM2, ) + +import qualified Algebra.Ring as Ring + +import Data.Word (Word32, ) +import Foreign.Storable.Tuple () +import Foreign.Storable (Storable, ) + +import Data.Tuple.HT (swap, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, ) + + +data T p a b = + forall state packed size ioContext + startParamTuple startParamValue startParamPacked startParamSize + nextParamTuple nextParamValue nextParamPacked nextParamSize. + (Storable startParamTuple, + Storable nextParamTuple, + MakeValueTuple startParamTuple startParamValue, + MakeValueTuple nextParamTuple nextParamValue, + Rep.Memory startParamValue startParamPacked, + Rep.Memory nextParamValue nextParamPacked, + IsSized startParamPacked startParamSize, + IsSized nextParamPacked nextParamSize, + Rep.Memory state packed, + IsSized packed size) => + Cons + (forall r c. + (Phi c) => + nextParamValue -> + a -> state -> Maybe.T r c (b, state)) + -- compute next value + (forall r. + startParamValue -> + CodeGenFunction r state) + -- initial state + (p -> IO (ioContext, (nextParamTuple, startParamTuple))) + {- initialization from IO monad + This will be run within unsafePerformIO, + so no observable In/Out actions please! + -} + (ioContext -> IO ()) + -- finalization from IO monad, also run within unsafePerformIO + + +simple :: + (Storable startParamTuple, + Storable nextParamTuple, + MakeValueTuple startParamTuple startParamValue, + MakeValueTuple nextParamTuple nextParamValue, + Rep.Memory startParamValue startParamPacked, + Rep.Memory nextParamValue nextParamPacked, + IsSized startParamPacked startParamSize, + IsSized nextParamPacked nextParamSize, + Rep.Memory state packed, + IsSized packed size) => + (forall r c. + (Phi c) => + nextParamValue -> + a -> state -> Maybe.T r c (b, state)) -> + (forall r. + startParamValue -> + CodeGenFunction r state) -> + Param.T p nextParamTuple -> + Param.T p startParamTuple -> T p a b +simple f start selectParam initial = Cons + (f . Param.value selectParam) + (start . Param.value initial) + (return . (,) () . Param.get (selectParam &&& initial)) + (const $ return ()) + + +toSignal :: T p () a -> Sig.T p a +toSignal (Cons next start createIOContext deleteIOContext) = Sig.Cons + (\ioContext -> next ioContext ()) + start + createIOContext deleteIOContext + +fromSignal :: Sig.T p a -> T p () a +fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons + (\ioContext () -> next ioContext) + start + createIOContext deleteIOContext + + +mapAccum :: + (Storable pnh, MakeValueTuple pnh pnl, Rep.Memory pnl pnp, IsSized pnp pns, + Storable psh, MakeValueTuple psh psl, Rep.Memory psl psp, IsSized psp pss, + Rep.Memory s struct, IsSized struct sa) => + (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) -> + (forall r. psl -> CodeGenFunction r s) -> + Param.T p pnh -> + Param.T p psh -> + T p a b +mapAccum next start selectParamN selectParamS = + simple + (\p a s -> Maybe.lift $ next p a s) + start + selectParamN selectParamS + + +map :: + (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) => + (forall r. pl -> a -> CodeGenFunction r b) -> + Param.T p ph -> + T p a b +map f selectParamF = + mapAccum + (\p a s -> fmap (flip (,) s) $ f p a) + (const $ return ()) + selectParamF + (return ()) + +mapSimple :: + (forall r. a -> CodeGenFunction r b) -> + T p a b +mapSimple f = + map (const f) (return ()) + + +apply :: T p a b -> Sig.T p a -> Sig.T p b +apply proc sig = + toSignal (proc <<< fromSignal sig) + +feedFst :: Sig.T p a -> T p b (a,b) +feedFst sig = + first (fromSignal sig) <<^ (\b -> ((),b)) + +feedSnd :: Sig.T p a -> T p b (b,a) +feedSnd sig = + swap ^<< feedFst sig + + +{- +Very similar to 'apply', +since 'apply' can be considered being of type +@T p a b -> T p () a -> T p () b@. +-} +compose :: T p a b -> T p b c -> T p a c +compose + (Cons nextA startA createIOContextA deleteIOContextA) + (Cons nextB startB createIOContextB deleteIOContextB) = + Cons + (\(paramA, paramB) a (sa0,sb0) -> + do (b,sa1) <- nextA paramA a sa0 + (c,sb1) <- nextB paramB b sb0 + return (c, (sa1,sb1))) + (\(paramA, paramB) -> + liftM2 (,) + (startA paramA) + (startB paramB)) + (\p -> do + (ca,(nextParamA,startParamA)) <- createIOContextA p + (cb,(nextParamB,startParamB)) <- createIOContextB p + return ((ca,cb), + ((nextParamA, nextParamB), + (startParamA, startParamB)))) + (\(ca,cb) -> + deleteIOContextA ca >> + deleteIOContextB cb) + + +first :: T p b c -> T p (b, d) (c, d) +first (Cons next start createIOContext deleteIOContext) = Cons + (\ioContext (b,d) sa0 -> + do (c,sa1) <- next ioContext b sa0 + return ((c,d), sa1)) + start + createIOContext deleteIOContext + + +instance Cat.Category (T p) where + id = mapSimple return + (.) = flip compose + +instance Arr.Arrow (T p) where + arr f = mapSimple (return . f) + first = first + + +takeWhile :: + (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) => + (forall r. pl -> a -> CodeGenFunction r (Value Bool)) -> + Param.T p ph -> + T p a a +takeWhile check selectParam = simple + (\p a () -> do + Maybe.guard =<< Maybe.lift (check p a) + return (a, ())) + return + selectParam + (return ()) + + +take :: + Param.T p Int -> + T p a a +take len = + snd ^<< + takeWhile (const $ A.icmp LLVM.IntULT (valueOf 0) . fst) (return ()) <<< + feedFst + (Sig.iterate (const A.dec) (return ()) + ((fromIntegral :: Int -> Word32) . max 0 ^<< len)) + + +{- | +The first output value is the start value. +Thus 'integrate' delays by one sample compared with 'integrate0'. +-} +integrate :: + (Storable a, IsArithmetic a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) => + Param.T p a -> + T p (Value a) (Value a) +integrate = + mapAccum + (\() a s -> do + b <- A.add a s + return (s,b)) + return + (return ()) + +integrate0 :: + (Storable a, IsArithmetic a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) => + Param.T p a -> + T p (Value a) (Value a) +integrate0 = + mapAccum + (\() a s -> do + b <- A.add a s + return (b,b)) + return + (return ()) diff --git a/src/Synthesizer/LLVM/EventIterator.hs b/src/Synthesizer/LLVM/EventIterator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/EventIterator.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.EventIterator where + +import qualified Data.EventList.Relative.BodyTime as EventList +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import Data.Word (Word32, ) +import Foreign.Storable (Storable, poke, ) +import Foreign.Ptr (Ptr, castPtr, ) + +import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) +import Foreign.Ptr (FunPtr, ) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) + + +data T = + forall a. Storable a => + Cons (IORef (EventList.T NonNeg.Int a)) + +{- +For problems about Storable constraint, see ChunkIterator. +-} +foreign import ccall "&nextConstant" + nextCallBack :: + FunPtr ( + StablePtr T -> + Ptr a -> IO Word32 + ) + +foreign export ccall "nextConstant" + next :: + StablePtr T -> + Ptr a -> IO Word32 + + +{- | +Events with subsequent duration 0 are ignored +(and for performance reasons it should not contain too many small values, +say below 100). +-} +new :: + Storable a => + EventList.T NonNeg.Int a -> IO (StablePtr T) +new evs = + newStablePtr . Cons + =<< newIORef + (EventList.fromPairList $ + filter ((/=0) . snd) $ + EventList.toPairList evs) + +dispose :: + StablePtr T -> IO () +dispose = freeStablePtr + +next :: + StablePtr T -> + Ptr a -> IO Word32 +next stable eventPtr = + deRefStablePtr stable >>= \state -> + case state of + Cons listRef -> + readIORef listRef >>= + EventList.switchL + (return 0) + (\body time xs -> + writeIORef listRef xs >> + poke (castPtr eventPtr) body >> + return (fromIntegral time)) diff --git a/src/Synthesizer/LLVM/Execution.hs b/src/Synthesizer/LLVM/Execution.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Execution.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module Synthesizer.LLVM.Execution where + +import LLVM.Core + (CodeGenModule, newModule, defineModule, getGlobalMappings, Function, + writeBitcodeToFile, ) +import LLVM.ExecutionEngine + (EngineAccess, runEngineAccess, + Translatable, generateFunction, + addModule, getPointerToFunction, addGlobalMappings, ) +import LLVM.Util.Optimize (optimizeModule, ) + +import Foreign.Ptr (FunPtr, ) + +import Control.Monad (liftM2, liftM3, ) + +import qualified Data.List.HT as ListHT +import qualified Data.IORef as IORef +import System.IO.Unsafe (unsafePerformIO, ) + + +type Importer f = FunPtr f -> f + +class Compile externFunction llvmFunction | + externFunction -> llvmFunction, + llvmFunction -> externFunction where + compile :: llvmFunction -> EngineAccess externFunction + +instance Compile (FunPtr f) (Function f) where + compile = getPointerToFunction + +instance (Compile efa lfa, Compile efb lfb) => + Compile (efa,efb) (lfa,lfb) where + compile (fa,fb) = + liftM2 (,) + (compile fa) + (compile fb) + +instance (Compile efa lfa, Compile efb lfb, Compile efc lfc) => + Compile (efa,efb,efc) (lfa,lfb,lfc) where + compile (fa,fb,fc) = + liftM3 (,,) + (compile fa) + (compile fb) + (compile fc) + + +{- | +This is only for debugging purposes +and thus I felt free to use unsafePerformIO. +-} +counter :: IORef.IORef Int +counter = + unsafePerformIO $ IORef.newIORef 0 + + +assembleModule :: + (llvmFunction -> EngineAccess externFunction) -> + CodeGenModule llvmFunction -> + IO externFunction +assembleModule comp bld = do + m <- newModule + (funcs, mappings) <- + defineModule m (liftM2 (,) bld getGlobalMappings) + + -- write bitcode files for debugging + num <- fmap (ListHT.padLeft '0' 3 . show) (IORef.readIORef counter) + IORef.modifyIORef counter succ + + writeBitcodeToFile ("generator"++num++".bc") m + + optimizeModule 3 m + + writeBitcodeToFile ("generator"++num++"-opt.bc") m + + runEngineAccess $ + addModule m >> + addGlobalMappings mappings >> + comp funcs + + +-- this compiles once and is much faster than runFunction +compileModule :: + (Compile externFunction llvmFunction) => + CodeGenModule llvmFunction -> + IO externFunction +compileModule = + assembleModule compile + +runFunction :: + (Translatable f) => + CodeGenModule (Function f) -> IO f +runFunction = + assembleModule generateFunction diff --git a/src/Synthesizer/LLVM/Filter/Allpass.hs b/src/Synthesizer/LLVM/Filter/Allpass.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/Allpass.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Synthesizer.LLVM.Filter.Allpass ( + Parameter, parameter, + CascadeParameter, flangerParameter, flangerParameterPlain, + causalP, cascadeP, phaserP, + cascadePipelineP, phaserPipelineP, + causalPackedP, cascadePackedP, phaserPackedP, + ) where + +import Synthesizer.Plain.Filter.Recursive.Allpass (Parameter(Parameter), ) +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 + +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1L +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Representation as Rep +import qualified Synthesizer.LLVM.Simple.Value as Value + +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, valueOf, Vector, + IsPowerOf2, IsConst, IsArithmetic, IsPrimitive, IsFirstClass, IsFloating, IsSized, + Undefined, undefTuple, + CodeGenFunction, ) +import LLVM.Util.Loop (Phi, phis, addPhis, ) + +import qualified Data.TypeLevel.Num as TypeNum +import qualified Data.TypeLevel.Num.Sets as TypeSet + +import Foreign.Storable (Storable, ) + +import qualified Control.Category as Cat +import qualified Control.Applicative as App +import qualified Data.Foldable as Fold +import qualified Data.Traversable as Trav +import Control.Arrow ((<<<), (^<<), (<<^), (&&&), arr, first, second, ) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +instance (Phi a) => Phi (Parameter a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + +instance Undefined a => Undefined (Parameter a) where + undefTuple = Class.undefTuplePointed + +instance Class.Zero a => Class.Zero (Parameter a) where + zeroTuple = Class.zeroTuplePointed + +instance + (Rep.Memory a s, IsSized s ss) => + Rep.Memory (Parameter a) s where + load = Rep.loadNewtype Parameter + store = Rep.storeNewtype (\(Parameter k) -> k) + decompose = Rep.decomposeNewtype Parameter + compose = Rep.composeNewtype (\(Parameter k) -> k) + + +instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where + buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) + +instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where + tupleDesc = Class.tupleDescFoldable + +instance (LLVM.MakeValueTuple ah al) => + LLVM.MakeValueTuple (Parameter ah) (Parameter al) where + valueTupleOf = Class.valueTupleOfFunctor + + +instance (Value.Flatten ah al) => + Value.Flatten (Parameter ah) (Parameter al) where + flatten = Value.flattenTraversable + unfold = Value.unfoldFunctor + + +instance (Vector.ShuffleMatch n v) => + Vector.ShuffleMatch n (Parameter v) where + shuffleMatch = Vector.shuffleMatchTraversable + +instance (Vector.Access n a v) => + Vector.Access n (Parameter a) (Parameter v) where + insert = Vector.insertTraversable + extract = Vector.extractTraversable + + +parameter :: + (Trans.C a, IsConst a, IsFloating a) => + Value a -> Value a -> + CodeGenFunction r (Parameter (Value a)) +parameter phase freq = + Value.flatten $ + Allpass.parameter + (Value.constantValue phase) (Value.constantValue freq) + + +newtype CascadeParameter n a = + CascadeParameter (Allpass.Parameter a) + deriving + (Phi, Undefined, Class.Zero, Storable, + Functor, App.Applicative, Fold.Foldable, Trav.Traversable) + +instance + (Rep.Memory a s, IsSized s ss) => + Rep.Memory (CascadeParameter n a) s where + load = Rep.loadNewtype CascadeParameter + store = Rep.storeNewtype (\(CascadeParameter k) -> k) + decompose = Rep.decomposeNewtype CascadeParameter + compose = Rep.composeNewtype (\(CascadeParameter k) -> k) + + +instance LLVM.ValueTuple a => LLVM.ValueTuple (CascadeParameter n a) where + buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) + +instance LLVM.IsTuple a => LLVM.IsTuple (CascadeParameter n a) where + tupleDesc = Class.tupleDescFoldable + +instance (LLVM.MakeValueTuple ah al) => + LLVM.MakeValueTuple (CascadeParameter n ah) (CascadeParameter n al) where + valueTupleOf = Class.valueTupleOfFunctor + + +instance (Value.Flatten ah al) => + Value.Flatten (CascadeParameter n ah) (CascadeParameter n al) where + flatten = Value.flattenTraversable + unfold = Value.unfoldFunctor + + +instance (Vector.ShuffleMatch m v) => + Vector.ShuffleMatch m (CascadeParameter n v) where + shuffleMatch = Vector.shuffleMatchTraversable + +instance (Vector.Access m a v) => + Vector.Access m (CascadeParameter n a) (CascadeParameter n v) where + insert = Vector.insertTraversable + extract = Vector.extractTraversable + + +flangerParameter :: + (Trans.C a, IsConst a, IsFloating a, TypeNum.Nat n) => + n -> Value a -> + CodeGenFunction r (CascadeParameter n (Value a)) +flangerParameter order freq = + Value.flatten $ + CascadeParameter $ + Allpass.flangerParameter (TypeNum.toInt order) $ + Value.constantValue freq + +flangerParameterPlain :: + (Trans.C a, TypeNum.Nat n) => + n -> a -> CascadeParameter n a +flangerParameterPlain order freq = + CascadeParameter $ + Allpass.flangerParameter (TypeNum.toInt order) freq + + +modifier :: + (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) => + Modifier.Simple + -- (Allpass.State (Value.T v)) + (Value.T v, Value.T v) + (Parameter (Value.T a)) + (Value.T v) (Value.T v) +modifier = + Allpass.firstOrderModifier + +{- +For Allpass cascade you may use the 'CausalP.pipeline' function. +-} +causalP :: + (Field.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, + IsFirstClass v, IsSized v vs, IsConst v, + IsArithmetic a) => + CausalP.T p + (Parameter (Value a), Value v) (Value v) +causalP = + CausalP.fromModifier modifier + + +replicateStage :: + (TypeNum.Nat n) => + n -> + CausalP.T p (Parameter a, b) b -> + CausalP.T p (CascadeParameter n a, b) b +replicateStage order stg = + CausalP.replicateControlled + (TypeNum.toInt order) + (stg <<< first (arr (\(CascadeParameter p) -> p))) + +cascadeP :: + (Field.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, + IsFirstClass v, IsSized v vs, IsConst v, + IsArithmetic a, + TypeNum.Nat n) => + CausalP.T p + (CascadeParameter n (Value a), Value v) (Value v) +cascadeP = + replicateStage undefined causalP + +half :: + (Field.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, + IsFirstClass v, IsSized v vs, IsConst v, + IsFloating a, IsArithmetic v, + TypeNum.Nat n) => + CausalP.T p + (CascadeParameter n (Value a), Value v) (Value v) +half = + CausalP.mapSimple (\(p,x) -> + Value.decons + ((const :: Value.T a -> CascadeParameter n (Value a) -> Value.T a) 0.5 p *> + Value.constantValue x)) + +phaserP :: + (Field.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, + IsFirstClass v, IsSized v vs, IsConst v, + IsFloating a, IsArithmetic v, + TypeNum.Nat n) => + CausalP.T p + (CascadeParameter n (Value a), Value v) (Value v) +phaserP = + CausalP.mix <<< + cascadeP &&& arr snd <<< + (arr fst &&& half) + + +{- +It shouldn't be too hard to use vector operations for the code we generate, +but LLVM-2.6 does not yet do it. +-} +stage :: + (IsPowerOf2 n, IsPrimitive a, IsFirstClass a, + IsConst a, IsArithmetic a, Ring.C a, + IsSized a sa) => + n -> + CausalP.T p + (CascadeParameter n (Value (Vector n a)), Value (Vector n a)) + (CascadeParameter n (Value (Vector n a)), Value (Vector n a)) +stage _ = + CausalP.vectorize + (arr fst &&& + (CausalP.fromModifier modifier <<< + first (arr (\(CascadeParameter p) -> p)))) + +withSize :: + (n -> CausalP.T p (CascadeParameter n a, b) c) -> + CausalP.T p (CascadeParameter n a, b) c +withSize f = f undefined + +{- | +Fast implementation of 'cascadeP' using vector instructions. +However, we are currently limited to powers of two, +primitive element types +and we get a delay by the number of pipeline stages. +-} +cascadePipelineP :: + (Field.C a, IsFirstClass a, IsSized a as, + TypeNum.Mul n as vas, TypeSet.Pos vas, +-- IsSized (Vector n a) vas, + IsPowerOf2 n, + IsArithmetic a, IsPrimitive a, IsConst a) => + CausalP.T p + (CascadeParameter n (Value a), Value a) (Value a) +cascadePipelineP = withSize $ \order -> + snd ^<< CausalP.pipeline (stage order) + +vectorId :: + (Vector.Access n a v) => + n -> CausalP.T p v v +vectorId _ = Cat.id + +phaserPipelineP :: + (Field.C a, + IsFirstClass a, IsSized a as, + IsSized (Vector n a) vas, + TypeNum.Mul n as vas, + IsPowerOf2 n, + IsFloating a, IsPrimitive a, IsConst a) => + CausalP.T p + (CascadeParameter n (Value a), Value a) (Value a) +phaserPipelineP = withSize $ \order -> + CausalP.mix <<< + cascadePipelineP &&& + (CausalP.pipeline (vectorId order) <<^ snd) <<< +-- (CausalP.delay (const zero) (const $ TypeNum.toInt order) <<^ snd) <<< + (arr fst &&& half) + + +causalPackedP, + causalNonRecursivePackedP :: + (Ring.C a, + IsFirstClass a, IsArithmetic a, IsConst a, + IsPowerOf2 n, IsPrimitive a, IsSized a as) => + CausalP.T p + (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) +causalPackedP = + Filt1L.causalRecursivePackedP <<< + (CausalP.mapSimple + (\(Parameter k, _) -> + fmap Filt1.Parameter $ LLVM.neg k) &&& + causalNonRecursivePackedP) + +causalNonRecursivePackedP = + CausalP.mapAccumSimple + (\(Parameter k, v0) x1 -> do + (_,v1) <- Vector.shiftUp x1 v0 + y <- A.add v1 =<< A.mul v0 =<< SoV.replicate k + let size = fromIntegral $ Vector.sizeInTuple v0 + u0 <- Vector.extract (valueOf $ size - 1) v0 + return (y, u0)) + (return (LLVM.value LLVM.zero)) + +cascadePackedP, phaserPackedP :: + (Field.C a, + IsFirstClass a, IsArithmetic a, IsConst a, + IsPowerOf2 m, IsPrimitive a, IsSized a as, + TypeNum.Nat n) => + CausalP.T p + (CascadeParameter n (Value a), Value (Vector m a)) (Value (Vector m a)) +cascadePackedP = + replicateStage undefined causalPackedP + +phaserPackedP = + CausalP.mix <<< + cascadePackedP &&& arr snd <<< + second (CausalP.mapSimple (A.mul (SoV.replicateOf 0.5))) diff --git a/src/Synthesizer/LLVM/Filter/Butterworth.hs b/src/Synthesizer/LLVM/Filter/Butterworth.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/Butterworth.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.LLVM.Filter.Butterworth ( + parameter, Cascade.ParameterValue, + Cascade.causalP, Cascade.causalPackedP, + Cascade.fixSize, + ) where + +import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade + +import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butterworth +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +import Synthesizer.Plain.Filter.Recursive (Passband, ) + +import qualified LLVM.Extra.Control as U +import qualified LLVM.Extra.Representation as Rep +import qualified Synthesizer.LLVM.Simple.Value as Value + +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, valueOf, constOf, + IsConst, IsFloating, IsSized, + CodeGenFunction, ) +import Data.Word (Word32, ) + +import qualified Data.TypeLevel.Num as TypeNum +import qualified Data.TypeLevel.Num.Sets as TypeSet + +import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +parameter, parameterMalloc, _parameterAlloca :: + (Trans.C a, IsConst a, IsFloating a, IsSized a as, + TypeSet.Nat n, + TypeNum.Mul n as sineSize, + TypeSet.Pos sineSize, + IsSized (Cascade.Parameter n a) paramSize) => + n -> Passband -> Value a -> Value a -> + CodeGenFunction r (Cascade.ParameterValue n a) +parameter = parameterMalloc + +parameterMalloc n kind ratio freq = do + let order = 2 * TypeNum.toInt n + partialRatio <- + Value.decons (Butterworth.partialRatio order (Value.constantValue ratio)) + let sines = + (flip const :: n -> LLVM.Value (LLVM.Array n a) + -> LLVM.Value (LLVM.Array n a)) n $ + LLVM.value $ + LLVM.constArray $ + map constOf $ Butterworth.makeSines order + psine <- LLVM.malloc + LLVM.store sines psine + s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ()) + ps <- LLVM.malloc + p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ()) + let len = valueOf $ (fromIntegral $ TypeNum.toInt n :: Word32) + U.arrayLoop len p s $ \ptri si -> do + sinw <- LLVM.load si + flip Rep.store ptri =<< + Value.flatten + (Filt2.adjustPassband kind + (flip + (Butterworth.partialParameter + (Value.constantValue partialRatio)) + (Value.constantValue sinw)) + (Value.constantValue freq)) + A.advanceArrayElementPtr si + pv <- LLVM.load ps + LLVM.free psine + LLVM.free ps + return (Cascade.ParameterValue pv) + +_parameterAlloca n kind ratio freq = do + let order = 2 * TypeNum.toInt n + partialRatio <- + Value.decons (Butterworth.partialRatio order (Value.constantValue ratio)) + let sines = + (flip const :: n -> LLVM.Value (LLVM.Array n a) + -> LLVM.Value (LLVM.Array n a)) n $ + LLVM.value $ + LLVM.constArray $ + map constOf $ Butterworth.makeSines order + psine <- LLVM.alloca + LLVM.store sines psine + s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ()) + ps <- LLVM.alloca + p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ()) + let len = valueOf $ (fromIntegral $ TypeNum.toInt n :: Word32) + U.arrayLoop len p s $ \ptri si -> do + sinw <- LLVM.load si + flip Rep.store ptri =<< + Value.flatten + (Filt2.adjustPassband kind + (flip + (Butterworth.partialParameter + (Value.constantValue partialRatio)) + (Value.constantValue sinw)) + (Value.constantValue freq)) + A.advanceArrayElementPtr si + fmap Cascade.ParameterValue $ LLVM.load ps diff --git a/src/Synthesizer/LLVM/Filter/Chebyshev.hs b/src/Synthesizer/LLVM/Filter/Chebyshev.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/Chebyshev.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.LLVM.Filter.Chebyshev ( + parameterA, parameterB, Cascade.ParameterValue, + Cascade.causalP, Cascade.causalPackedP, + Cascade.fixSize, + ) where + +import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade + +import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Chebyshev +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +import Synthesizer.Plain.Filter.Recursive (Passband, ) + +import qualified Synthesizer.LLVM.Simple.Value as Value +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Control as U + +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, valueOf, ConstValue, + Struct, IsSized, IsConst, IsFloating, + CodeGenFunction, ) +import Data.Word (Word32, ) + +import qualified Data.TypeLevel.Num as TypeNum +import qualified Data.TypeLevel.Num.Sets as TypeSet + +import qualified Number.Complex as Complex + +import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +constComplexOf :: IsConst a => + Complex.T a -> ConstValue (Struct (a, (a, ()))) +constComplexOf x = + LLVM.constStruct + (LLVM.constOf $ Complex.real x, + (LLVM.constOf $ Complex.imag x, + ())) + +valueComplex :: + Value (Struct (a, (a, ()))) -> Complex.T (Value.T a) +valueComplex x = + Value.Cons (LLVM.extractvalue x TypeNum.d0) + Complex.+: + Value.Cons (LLVM.extractvalue x TypeNum.d1) + + +{- | +'n' must be at least one in order to allow amplification +by the first partial filter. +-} +parameterA, parameterB :: + (Trans.C a, IsConst a, IsFloating a, IsSized a as, + TypeSet.Pos n, + TypeNum.Mul n as sineSize, + TypeSet.Pos sineSize, + IsSized (Cascade.Parameter n a) paramSize, + TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) => + n -> Passband -> Value a -> Value a -> + CodeGenFunction r (Cascade.ParameterValue n a) +parameterA n kind ratio freq = do + pv <- parameter Chebyshev.partialParameterA n kind ratio freq + + -- adjust amplification of the first filter + filt0 <- + Rep.decompose =<< + LLVM.extractvalue pv (0::Word32) + fmap Cascade.ParameterValue $ + flip (LLVM.insertvalue pv) (0::Word32) =<< + Rep.compose =<< + Value.flatten + (Filt2.amplify (Value.constantValue ratio) (Value.unfold filt0)) + +parameterB n kind ratio freq = + fmap Cascade.ParameterValue $ + parameter Chebyshev.partialParameterB n kind ratio freq + + +parameter :: + (Trans.C a, IsConst a, IsFloating a, IsSized a as, + TypeSet.Pos n, + TypeNum.Mul n as sineSize, + TypeSet.Pos sineSize, + IsSized (Cascade.Parameter n a) paramSize, + TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) => + (Int -> Value.T a -> Value.T a -> + Complex.T (Value.T a) -> Filt2.Parameter (Value.T a)) -> + n -> Passband -> Value a -> Value a -> + CodeGenFunction r (Value (Cascade.Parameter n a)) +parameter partialParameter n kind ratio freq = do + let order = 2 * TypeNum.toInt n + let sines = + (flip const :: n -> LLVM.Value (LLVM.Array n a) + -> LLVM.Value (LLVM.Array n a)) n $ + LLVM.value $ + LLVM.constArray $ + map constComplexOf $ + Chebyshev.makeCirclePoints order + psine <- LLVM.malloc + LLVM.store sines psine + s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ()) + ps <- LLVM.malloc + p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ()) + let len = valueOf $ (fromIntegral $ TypeNum.toInt n :: Word32) + U.arrayLoop len p s $ \ptri si -> do + c <- LLVM.load si + flip Rep.store ptri =<< + Value.flatten + (Filt2.adjustPassband kind + (flip + (partialParameter order + (Value.constantValue ratio)) + (valueComplex c)) + (Value.constantValue freq)) + A.advanceArrayElementPtr si + + pv <- LLVM.load ps + LLVM.free psine + LLVM.free ps + return pv diff --git a/src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs b/src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Filter.ComplexFirstOrder ( + Parameter, parameter, + causal, causalP, + ) where + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified LLVM.Extra.Representation as Rep +import qualified Synthesizer.LLVM.Simple.Value as Value + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core + (value, valueOf, Value, Struct, + IsFirstClass, IsConst, IsArithmetic, IsFloating, IsSized, + Undefined, undefTuple, + CodeGenFunction, ) +import LLVM.Util.Loop (Phi, phis, addPhis, ) + +import Data.TypeLevel.Num (d0, d1, d2, ) + +import Control.Applicative (liftA3, ) + +import qualified Algebra.Transcendental as Trans + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +data Parameter a = + Parameter a (a,a) + +instance (Phi a) => Phi (Parameter a) where + phis bb (Parameter k (r,i)) = do + k' <- phis bb k + r' <- phis bb r + i' <- phis bb i + return (Parameter k' (r',i')) + addPhis bb + (Parameter k (r,i)) + (Parameter k' (r',i')) = do + addPhis bb k k' + addPhis bb r r' + addPhis bb i i' + +instance Undefined a => Undefined (Parameter a) where + undefTuple = Parameter undefTuple (undefTuple,undefTuple) + + +parameterMemory :: + (Rep.Memory l s, IsSized s ss) => + Rep.MemoryRecord r (Struct (s, (s, (s, ())))) (Parameter l) +parameterMemory = + liftA3 (\amp kr ki -> Parameter amp (kr,ki)) + (Rep.memoryElement (\(Parameter amp (_kr,_ki)) -> amp) d0) + (Rep.memoryElement (\(Parameter _amp ( kr,_ki)) -> kr) d1) + (Rep.memoryElement (\(Parameter _amp (_kr, ki)) -> ki) d2) + +instance (Rep.Memory l s, IsSized s ss) => + Rep.Memory (Parameter l) (Struct (s, (s, (s, ())))) where + load = Rep.loadRecord parameterMemory + store = Rep.storeRecord parameterMemory + decompose = Rep.decomposeRecord parameterMemory + compose = Rep.composeRecord parameterMemory + +parameter :: + (Trans.C a, + IsConst a, IsFloating a) => + Value a -> Value a -> CodeGenFunction r (Parameter (Value a)) +parameter reson freq = do + amp <- A.fdiv (valueOf 1) reson + k <- A.sub (valueOf 1) amp + w <- A.mul freq =<< Value.decons Value.twoPi + kr <- A.mul k =<< A.cos w + ki <- A.mul k =<< A.sin w + return (Parameter amp (kr,ki)) + + +next :: + (IsArithmetic a, IsConst a) => + (Parameter (Value a), Stereo.T (Value a)) -> + (Value a, Value a) -> + CodeGenFunction r (Stereo.T (Value a), (Value a, Value a)) +next (Parameter amp (kr,ki), x) (sr,si) = do + yr <- Value.decons $ + Value.Cons (A.mul (Stereo.left x) amp) + + Value.Cons (A.mul kr sr) - Value.Cons (A.mul ki si) + yi <- Value.decons $ + Value.Cons (A.mul (Stereo.right x) amp) + + Value.Cons (A.mul kr si) + Value.Cons (A.mul ki sr) + return (Stereo.cons yr yi, (yr, yi)) + +start :: + (LLVM.IsType a, IsConst a) => + CodeGenFunction r (Value a, Value a) +start = + return (value LLVM.zero, value LLVM.zero) + +causal :: + (IsFirstClass a, IsSized a sa, IsConst a, + IsFloating a) => + Causal.T + (Parameter (Value a), Stereo.T (Value a)) + (Stereo.T (Value a)) +causal = + Causal.mapAccum next start + +causalP :: + (IsFirstClass a, IsSized a sa, IsConst a, + IsFloating a) => + CausalP.T p + (Parameter (Value a), Stereo.T (Value a)) + (Stereo.T (Value a)) +causalP = + CausalP.mapAccumSimple next start diff --git a/src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs b/src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Filter.ComplexFirstOrderPacked ( + Parameter, parameter, + causal, causalP, + ) where + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified LLVM.Extra.Representation as Rep +import qualified Synthesizer.LLVM.Simple.Value as Value +import qualified LLVM.Extra.Vector as Vector + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, valueOf, value, Struct, + IsPrimitive, IsConst, IsFloating, IsSized, + Undefined, undefTuple, + Vector, insertelement, + neg, CodeGenFunction, ) +import LLVM.Util.Loop (Phi, phis, addPhis, ) + +import Data.TypeLevel.Num (Add, D4, d0, d1, ) +import qualified Data.TypeLevel.Num.Sets as Sets + +import Control.Applicative (liftA2, ) + +import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +-- the pair should also be replaced by a Vector +data Parameter a = + Parameter (Value (Vector D4 a)) (Value (Vector D4 a)) + +instance IsPrimitive a => Phi (Parameter a) where + phis bb (Parameter r i) = do + r' <- phis bb r + i' <- phis bb i + return (Parameter r' i') + addPhis bb + (Parameter r i) + (Parameter r' i') = do + addPhis bb r r' + addPhis bb i i' + +instance IsPrimitive a => Undefined (Parameter a) where + undefTuple = Parameter undefTuple undefTuple + + +parameterMemory :: + (IsPrimitive l, IsSized l s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) => + Rep.MemoryRecord r (Struct (Vector D4 l, (Vector D4 l, ()))) (Parameter l) +parameterMemory = + liftA2 Parameter + (Rep.memoryElement (\(Parameter kr _) -> kr) d0) + (Rep.memoryElement (\(Parameter _ ki) -> ki) d1) + +{- +The complicated Add constraints are caused by the IsType superclass of Memory. + +instance (IsPrimitive l, IsSized (Vector D4 l) ss) => + Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where + +Mul constraint seems to be not enough, GHC urges to give constraints in terms of Add +instance (IsPrimitive l, IsSized l s, Mul D4 s ss, Sets.Pos ss) => + Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where +-} +instance (IsPrimitive l, IsSized l s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) => + Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where + load = Rep.loadRecord parameterMemory + store = Rep.storeRecord parameterMemory + decompose = Rep.decomposeRecord parameterMemory + compose = Rep.composeRecord parameterMemory + +parameter :: + (Trans.C a, + IsPrimitive a, IsConst a, IsFloating a) => + Value a -> Value a -> CodeGenFunction r (Parameter a) +parameter reson freq = do + amp <- A.fdiv (valueOf 1) reson + k <- A.sub (valueOf 1) amp + w <- A.mul freq =<< Value.decons Value.twoPi + kr <- A.mul k =<< A.cos w + ki <- A.mul k =<< A.sin w + + kin <- neg ki + kvr <- Vector.assemble [kr,kin,amp, value LLVM.zero] + kvi <- Vector.assemble [ki,kr, amp, value LLVM.zero] + return (Parameter kvr kvi) + +{- +The handling of Vector D2 Float in LLVM-2.5 and LLVM-2.6 is at least unexpected. +Because of compatibility reasons, LLVM chooses MMX registers +which requires to call EMMS occasionally. +Thus I choose Vector D4 for Float computations. +Actually, I have now rearranged the data +such that we can make use of SSE4's dot product operation. +This would even require a vector of size 3. +-} +next :: + (Vector.Arithmetic a, IsConst a) => + (Parameter a, Stereo.T (Value a)) -> + (Value (Vector D4 a)) -> + CodeGenFunction r (Stereo.T (Value a), (Value (Vector D4 a))) +next (Parameter kr ki, x) s = do + sr <- insertelement s (Stereo.left x) (valueOf 2) + yr <- Vector.dotProduct kr sr + + si <- insertelement s (Stereo.right x) (valueOf 2) + yi <- Vector.dotProduct ki si + + sv <- Vector.assemble [yr,yi] + return (Stereo.cons yr yi, sv) + +start :: + (IsPrimitive a, IsConst a) => + CodeGenFunction r (Value (Vector D4 a)) +start = + return (value LLVM.zero) + +causal :: + (IsConst a, Vector.Arithmetic a, + IsSized (Vector D4 a) as) => + Causal.T + (Parameter a, Stereo.T (Value a)) + (Stereo.T (Value a)) +causal = + Causal.mapAccum next start + +causalP :: + (IsConst a, Vector.Arithmetic a, + IsSized (Vector D4 a) as) => + CausalP.T p + (Parameter a, Stereo.T (Value a)) + (Stereo.T (Value a)) +causalP = + CausalP.mapAccumSimple next start diff --git a/src/Synthesizer/LLVM/Filter/FirstOrder.hs b/src/Synthesizer/LLVM/Filter/FirstOrder.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/FirstOrder.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Synthesizer.LLVM.Filter.FirstOrder ( + Result(Result,lowpass_,highpass_), Parameter, parameter, + causalP, lowpassCausalP, highpassCausalP, + causalPackedP, lowpassCausalPackedP, highpassCausalPackedP, + causalRecursivePackedP, -- for Allpass + ) where + +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder +import Synthesizer.Plain.Filter.Recursive.FirstOrder + (Parameter(Parameter), Result(Result,lowpass_,highpass_)) + +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector +import qualified Synthesizer.LLVM.Simple.Value as Value + +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, valueOf, Vector, Undefined, undefTuple, + IsFirstClass, IsConst, IsArithmetic, IsFloating, + IsPrimitive, IsPowerOf2, IsSized, + CodeGenFunction, ) +import LLVM.Util.Loop (Phi, phis, addPhis, ) + +import Control.Arrow (arr, (&&&), (<<<), ) +import Control.Monad (liftM2, foldM, ) + +import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +instance (Phi a) => Phi (Parameter a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + +instance Undefined a => Undefined (Parameter a) where + undefTuple = Class.undefTuplePointed + +instance + (Rep.Memory a s, IsSized s ss) => + Rep.Memory (Parameter a) s where + load = Rep.loadNewtype Parameter + store = Rep.storeNewtype (\(Parameter k) -> k) + decompose = Rep.decomposeNewtype Parameter + compose = Rep.composeNewtype (\(Parameter k) -> k) + +instance (Value.Flatten ah al) => + Value.Flatten (Parameter ah) (Parameter al) where + flatten = Value.flattenTraversable + unfold = Value.unfoldFunctor + +instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where + buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) + +instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where + tupleDesc = Class.tupleDescFoldable + +instance (LLVM.MakeValueTuple ah al) => + LLVM.MakeValueTuple (Parameter ah) (Parameter al) where + valueTupleOf = Class.valueTupleOfFunctor + + +parameter :: + (Trans.C a, IsConst a, IsFloating a) => + Value a -> + CodeGenFunction r (Parameter (Value a)) +parameter reson = + Value.flatten $ + FirstOrder.parameter + (Value.constantValue reson) + + +lowpassModifier, highpassModifier :: + (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) => + Modifier.Simple +-- (FirstOrder.State (Value.T v)) + (Value.T v) + (Parameter (Value.T a)) + (Value.T v) (Value.T v) +lowpassModifier = FirstOrder.lowpassModifier +highpassModifier = FirstOrder.highpassModifier + +causalP :: + (Ring.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a, + IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) => + CausalP.T p + (Parameter (Value a), Value v) (Result (Value v)) +{- +in contrast to CausalP.fromModifier this allows for sharing +between lowpass and highpass channel +-} +causalP = + CausalP.mapSimple (\(l,x) -> do + h <- A.sub x l + return (Result{FirstOrder.lowpass_ = l, + FirstOrder.highpass_ = h})) + <<< (lowpassCausalP &&& arr snd) + +lowpassCausalP, highpassCausalP :: + (Ring.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, + IsFirstClass v, IsSized v vs, IsConst v, + IsArithmetic a) => + CausalP.T p + (Parameter (Value a), Value v) (Value v) +lowpassCausalP = CausalP.fromModifier lowpassModifier +highpassCausalP = CausalP.fromModifier highpassModifier + +lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP :: + (Ring.C a, + IsFirstClass a, IsConst a, IsSized a as, + IsPowerOf2 n, -- IsSized (Vector n a) vas, + IsArithmetic a, IsPrimitive a) => + CausalP.T p + (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) +highpassCausalPackedP = + CausalP.mapSimple (uncurry A.sub) <<< + (arr snd &&& lowpassCausalPackedP) +lowpassCausalPackedP = + causalRecursivePackedP <<< + (arr fst &&& + CausalP.mapSimple + (\(FirstOrder.Parameter k, x) -> + A.mul x =<< SoV.replicate =<< A.sub (valueOf 1) k)) + +{- +x = [x0, x1, x2, x3] + +filter k y1 x + = [x0 + k*y1, + x1 + k*x0 + k^2*y1, + x2 + k*x1 + k^2*x0 + k^3*y1, + x3 + k*x2 + k^2*x1 + k^3*x0 + k^4*y1, + ... ] + +f0x = insert 0 (k*y1) x +f1x = f0x + k * f0x->1 +f2x = f1x + k^2 * f1x->2 +-} +causalRecursivePackedP = + CausalP.mapAccumSimple + (\(FirstOrder.Parameter k, xk0) y1 -> do + y1k <- A.mul k y1 + xk1 <- Vector.modify (valueOf 0) (A.add y1k) xk0 + let size = Vector.sizeInTuple xk0 + kv <- SoV.replicate k + xk2 <- + fmap fst $ + foldM + (\(y,k0) d -> + liftM2 (,) + (A.add y =<< + Vector.shiftUpMultiZero d =<< + A.mul y k0) + (A.mul k0 k0)) + (xk1,kv) + (takeWhile (< size) $ iterate (2*) 1) +{- do replicate in the loop + xk2 <- + fmap fst $ + foldM + (\(y,k0) d -> + liftM2 (,) + (A.add y =<< + Vector.shiftUpMultiZero d =<< + A.mul y =<< + SoV.replicate k0) + (A.mul k0 k0)) + (xk1,k) + (takeWhile (< size) $ iterate (2*) 1) +-} + y0 <- Vector.extract (valueOf $ fromIntegral $ size - 1) xk2 + return (xk2, y0)) + (return (LLVM.value LLVM.zero)) + +{- +We can also optimize filtering with time-varying filter parameter. + +k = [k0, k1, k2, k3] +x = [x0, x1, x2, x3] + +filter k y1 x + = [x0 + k0*y1, + x1 + k1*x0 + k1*k0*y1, + x2 + k2*x1 + k2*k1*x0 + k2*k1*k0*y1, + x3 + k3*x2 + k3*k2*x1 + k3*k2*k1*x0 + k3*k2*k1*k0*y1, + ... ] + +f0x = insert 0 (k0*y1) x +f1x = f0x + k * f0x->1 k' = k * k->1 +f2x = f1x + k' * f1x->2 + + +We can even interpret vectorised first order filtering +as first order filtering with matrix coefficients. + +[x0 + k0*y1, + x1 + k1*x0 + k1*k0*y1, + x2 + k2*x1 + k2*k1*x0 + k2*k1*k0*y1, + x3 + k3*x2 + k3*k2*x1 + k3*k2*k1*x0 + k3*k2*k1*k0*y1] + = + / 1 \ /x0\ / k0 0 0 0 \ /y1\ + | k1 1 | . |x1| + | k1*k0 0 0 0 | . |y2| + | k2*k1 k2 1 | |x2| | k2*k1*k0 0 0 0 | |y3| + \ k3*k2*k1 k3*k2 k3 1 / \x3/ \ k3*k2*k1*k0 0 0 0 / \y4/ + + + / 1 \ / 1 \ / 1 \ + | k1 1 | = | 1 | . | k1 1 | + | k2*k1 k2 1 | | k2*k1 1 | | k2 1 | + \ k3*k2*k1 k3*k2 k3 1 / \ k3*k2 1 / \ k3 1 / +-} + + + +causalPackedP :: + (Ring.C a, IsArithmetic a, IsPrimitive a, + IsFirstClass a, IsConst a, IsSized a as, + IsPowerOf2 n) => + CausalP.T p + (Parameter (Value a), Value (Vector n a)) + (Result (Value (Vector n a))) +causalPackedP = + CausalP.mapSimple (\(l,x) -> do + h <- A.sub x l + return (Result{FirstOrder.lowpass_ = l, + FirstOrder.highpass_ = h})) + <<< (lowpassCausalPackedP &&& arr snd) diff --git a/src/Synthesizer/LLVM/Filter/Moog.hs b/src/Synthesizer/LLVM/Filter/Moog.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/Moog.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Synthesizer.LLVM.Filter.Moog + (Parameter, parameter, + causalP, + ) where + +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 + +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder +import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog +import Synthesizer.Plain.Filter.Recursive (Pole(..)) + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Simple.Value as Value + +import Foreign.Storable (Storable, ) + +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Vector as Vector + +import qualified LLVM.Core as LLVM +import LLVM.Core + (valueOf, Value, Struct, + IsFirstClass, IsConst, IsArithmetic, IsFloating, IsSized, + Undefined, undefTuple, + CodeGenFunction, ) +import LLVM.Util.Loop (Phi, phis, addPhis, ) + +import qualified Data.TypeLevel.Num as TypeNum +import Data.TypeLevel.Num (d0, d1, ) + +import qualified Control.Arrow as Arrow +import qualified Control.Applicative as App +import qualified Data.Foldable as Fold +import qualified Data.Traversable as Trav +import Control.Arrow ((>>>), (&&&), arr, ) +import Control.Applicative (liftA2, ) + +import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +newtype Parameter n a = Parameter {getParam :: Moog.Parameter a} + deriving (Functor, App.Applicative, Fold.Foldable, Trav.Traversable) + + +instance (Phi a, TypeNum.Nat n) => + Phi (Parameter n a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + +instance (Undefined a, TypeNum.Nat n) => + Undefined (Parameter n a) where + undefTuple = Class.undefTuplePointed + +instance (Class.Zero a, TypeNum.Nat n) => + Class.Zero (Parameter n a) where + zeroTuple = Class.zeroTuplePointed + +parameterMemory :: + (Rep.Memory a s, IsSized s ss, TypeNum.Nat n) => + Rep.MemoryRecord r (Struct (s, (s, ()))) (Parameter n a) +parameterMemory = + liftA2 (\f k -> Parameter (Moog.Parameter f k)) + (Rep.memoryElement (Moog.feedback . getParam) d0) + (Rep.memoryElement (Moog.lowpassParam . getParam) d1) + +instance + (Rep.Memory a s, IsSized s ss, TypeNum.Nat n) => + Rep.Memory (Parameter n a) (Struct (s, (s, ()))) where + load = Rep.loadRecord parameterMemory + store = Rep.storeRecord parameterMemory + decompose = Rep.decomposeRecord parameterMemory + compose = Rep.composeRecord parameterMemory + + +instance (Value.Flatten ah al, TypeNum.Nat n) => + Value.Flatten (Parameter n ah) (Parameter n al) where + flatten = Value.flattenTraversable + unfold = Value.unfoldFunctor + + +instance (Vector.ShuffleMatch m v, TypeNum.Nat n) => + Vector.ShuffleMatch m (Parameter n v) where + shuffleMatch = Vector.shuffleMatchTraversable + +instance (Vector.Access m a v, TypeNum.Nat n) => + Vector.Access m (Parameter n a) (Parameter n v) where + insert = Vector.insertTraversable + extract = Vector.extractTraversable + + +parameter :: + (Trans.C a, IsConst a, IsFloating a, TypeNum.Nat n) => + n -> Value a -> Value a -> + CodeGenFunction r (Parameter n (Value a)) +parameter order reson freq = + Value.flatten $ + Parameter $ Moog.parameter (TypeNum.toInt order) + (Pole (Value.constantValue reson) (Value.constantValue freq)) + +{- +infixr 1 ^>>, >>^ + +(>>^) :: + (Value.Flatten b bl, Value.Flatten c cl) => + CausalP.T p al bl -> (b -> c) -> CausalP.T p al cl +(>>^) a f = + a >>> CausalP.mapSimple (Value.flatten . f . Value.unfold) + +(^>>) :: + (Value.Flatten a al, Value.Flatten b bl) => + (a -> b) -> CausalP.T p bl cl -> CausalP.T p al cl +(^>>) f b = + CausalP.mapSimple (Value.flatten . f . Value.unfold) >>> b +-} + +merge :: + (Module.C (Value.T a) (Value.T v), + LLVM.MakeValueTuple v (Value v), IsConst v, + LLVM.MakeValueTuple a (Value a), IsConst a) => + (Parameter n (Value a), Value v) -> Value v -> + CodeGenFunction r (FirstOrder.Parameter (Value a), Value v) +merge (Parameter (Moog.Parameter f k), x) y0 = + let c :: (LLVM.MakeValueTuple a (Value a)) => Value a -> Value.T a + c = Value.constantValue + in Value.flatten (fmap c k, c x - c f *> c y0) + +amplify :: + (Module.C (Value.T a) (Value.T v)) => + Parameter n (Value a) -> + Value v -> + CodeGenFunction r (Value v) +amplify (Parameter (Moog.Parameter f _k)) y1 = + Value.decons $ + (1 + Value.constantValue f) *> Value.constantValue y1 + +causalP :: + (Module.C (Value.T a) (Value.T v), + Module.C a v, Storable v, + LLVM.MakeValueTuple v (Value v), + LLVM.MakeValueTuple a (Value a), + IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a, + IsFirstClass v, IsSized v vs, IsConst v, + TypeNum.Nat n) => + CausalP.T p + (Parameter n (Value a), Value v) (Value v) +causalP = + causalPSize undefined + +causalPSize :: + (Module.C (Value.T a) (Value.T v), + Module.C a v, Storable v, + LLVM.MakeValueTuple v (Value v), + LLVM.MakeValueTuple a (Value a), + IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a, + IsFirstClass v, IsSized v vs, IsConst v, + TypeNum.Nat n) => + n -> + CausalP.T p + (Parameter n (Value a), Value v) (Value v) +causalPSize n = + let order = TypeNum.toInt n + feedZero = zero + selectOutput = snd `asTypeOf` const (valueOf feedZero) + in Arrow.arr fst &&& + CausalP.feedbackControlled + (return feedZero) + (CausalP.mapSimple (uncurry merge) >>> + CausalP.replicateControlled order Filt1.lowpassCausalP) + (Arrow.arr selectOutput) + >>> CausalP.mapSimple (uncurry amplify) diff --git a/src/Synthesizer/LLVM/Filter/SecondOrder.hs b/src/Synthesizer/LLVM/Filter/SecondOrder.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/SecondOrder.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Synthesizer.LLVM.Filter.SecondOrder ( + Parameter, bandpassParameter, + ParameterStruct, -- for cascade + causalP, causalPackedP, + ) where + +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +import Synthesizer.Plain.Filter.Recursive.SecondOrder (Parameter(Parameter), ) + +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Simple.Value as Value + +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector + +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Monad as M + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, valueOf, Struct, Undefined, undefTuple, + IsFirstClass, IsConst, IsArithmetic, IsFloating, + Vector, IsPowerOf2, IsPrimitive, IsSized, + CodeGenFunction, ) +import LLVM.Util.Loop (Phi, phis, addPhis, ) + +import Data.TypeLevel.Num (d0, d1, d2, d3, d4, ) +import qualified Data.TypeLevel.Num as TypeNum + +import Control.Arrow (arr, (<<<), (&&&), ) +import Control.Monad (liftM2, foldM, ) +import Synthesizer.ApplicativeUtility (liftA4, liftA5, ) + +import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +instance (Phi a) => Phi (Parameter a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + +instance Undefined a => Undefined (Parameter a) where + undefTuple = Class.undefTuplePointed + +instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where + buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) + +instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where + tupleDesc = Class.tupleDescFoldable + +instance LLVM.MakeValueTuple h l => + LLVM.MakeValueTuple (Parameter h) (Parameter l) where + valueTupleOf = Class.valueTupleOfFunctor + + +type ParameterStruct a = Struct (a, (a, (a, (a, (a, ()))))) + +parameterMemory :: + (Rep.Memory a s, IsSized s ss) => + Rep.MemoryRecord r (ParameterStruct s) (Parameter a) +parameterMemory = + liftA5 Parameter + (Rep.memoryElement Filt2.c0 d0) + (Rep.memoryElement Filt2.c1 d1) + (Rep.memoryElement Filt2.c2 d2) + (Rep.memoryElement Filt2.d1 d3) + (Rep.memoryElement Filt2.d2 d4) + +instance + (Rep.Memory a s, IsSized s ss) => + Rep.Memory (Parameter a) (Struct (s, (s, (s, (s, (s, ())))))) where + load = Rep.loadRecord parameterMemory + store = Rep.storeRecord parameterMemory + decompose = Rep.decomposeRecord parameterMemory + compose = Rep.composeRecord parameterMemory + + +instance (Value.Flatten ah al) => + Value.Flatten (Parameter ah) (Parameter al) where + flatten = Value.flattenTraversable + unfold = Value.unfoldFunctor + + + +instance (Phi a) => Phi (Filt2.State a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + +instance Undefined a => Undefined (Filt2.State a) where + undefTuple = Class.undefTuplePointed + +stateMemory :: + (Rep.Memory a s, IsSized s ss) => + Rep.MemoryRecord r (Struct (s, (s, (s, (s, (s, ())))))) (Filt2.State a) +stateMemory = + liftA4 Filt2.State + (Rep.memoryElement Filt2.u1 d0) + (Rep.memoryElement Filt2.u2 d1) + (Rep.memoryElement Filt2.y1 d2) + (Rep.memoryElement Filt2.y2 d3) + + +instance + (Rep.Memory a s, IsSized s ss) => + Rep.Memory (Filt2.State a) (Struct (s, (s, (s, (s, (s, ())))))) where + load = Rep.loadRecord stateMemory + store = Rep.storeRecord stateMemory + decompose = Rep.decomposeRecord stateMemory + compose = Rep.composeRecord stateMemory + +instance (Value.Flatten ah al) => + Value.Flatten (Filt2.State ah) (Filt2.State al) where + flatten = Value.flattenTraversable + unfold = Value.unfoldFunctor + + +{-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-} +bandpassParameter :: + (Trans.C a, IsFloating a, IsConst a) => + Value a -> + Value a -> + CodeGenFunction r (Parameter (Value a)) +bandpassParameter reson cutoff = do + rreson <- A.fdiv (valueOf 1) reson + k <- A.sub (valueOf 1) rreson + k2 <- LLVM.neg =<< A.mul k k + kcos <- + A.mul (valueOf 2) =<< A.mul k =<< + A.cos =<< A.mul cutoff =<< + Value.decons Value.twoPi + return $ + Filt2.Parameter + rreson (valueOf zero) (valueOf zero) + kcos k2 + +modifier :: + (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) => + Modifier.Simple + (Filt2.State (Value.T v)) + (Parameter (Value.T a)) + (Value.T v) (Value.T v) +modifier = + Filt2.modifier + +causalP :: + (Ring.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, + IsFirstClass v, IsSized v vs, IsConst v, + IsArithmetic a) => + CausalP.T p + (Parameter (Value a), Value v) (Value v) +causalP = + CausalP.fromModifier modifier + + +{- | +Vector size must be at least D2. +-} +causalPackedP, + causalRecursivePackedP :: + (Ring.C a, + IsFirstClass a, IsArithmetic a, IsConst a, + IsPowerOf2 n, IsPrimitive a, IsSized a as, + TypeNum.Mul n as vas, TypeNum.Pos vas) => +-- IsPowerOf2 n, IsPrimitive a, IsSized (Vector n a) as) => + CausalP.T p + (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) +causalPackedP = + causalRecursivePackedP <<< + (arr fst &&& causalNonRecursivePackedP) + +_causalRecursivePackedPAlt, + causalNonRecursivePackedP :: + (Ring.C a, + IsFirstClass a, IsArithmetic a, IsConst a, + IsPowerOf2 n, IsPrimitive a, IsSized a as) => + CausalP.T p + (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) +causalNonRecursivePackedP = + CausalP.mapAccumSimple + (\(p, v0) (x1,x2) -> do + (_,v1) <- Vector.shiftUp x1 v0 + (_,v2) <- Vector.shiftUp x2 v1 + w0 <- A.mul v0 =<< SoV.replicate (Filt2.c0 p) + w1 <- A.mul v1 =<< SoV.replicate (Filt2.c1 p) + w2 <- A.mul v2 =<< SoV.replicate (Filt2.c2 p) + y <- A.add w0 =<< A.add w1 w2 + let size = fromIntegral $ Vector.sizeInTuple v0 + u0 <- Vector.extract (valueOf $ size - 1) v0 + u1 <- Vector.extract (valueOf $ size - 2) v0 + return (y, (u0,u1))) + (return (LLVM.value LLVM.zero, LLVM.value LLVM.zero)) + +{- +A filter of second order can be considered +as the convolution of two filters of first order. + +[1,r]*[1,0,r^2] = [1,r,r^2,r^3] +[1,r,r^2,r^3] * [1,s,s^2,s^3] + = [1,r]*[1,s]*[1,0,r^2]*[1,0,s^2] + with + a=r+s + b=r*s + = [1,a,b]*[1,0,r^2]*[1,0,s^2] + = [1,a,b]*[1,0,a^2-2*b,0,b^2] + +[1,0,0,0,r^4]*[1,0,0,0,s^4] + = [1,0,0,0,(a^2-2*b)^2-2*b^2,0,0,0,b^4] + = [1,0,0,0,a^4-4*a^2*b+2*b^2,0,0,0,b^4] +-} + +{- +x = [x0, x1, x2, x3] + +filter2 (a,-b) (y1,y2) x + = [x0 + a*y1 - b*y2, + x1 + a*x0 + (a^2-b)*y1 - a*b*y2, + x2 + a*x1 + (a^2-b)*x0 + (a^3-2*a*b)*y1 + (-a^2*b+b^2)*y2, + x3 + a*x2 + (a^2-b)*x1 + (a^3-2*a*b)*x0 + (a^4-3*a^2*b+b^2)*y1 + (-a^3*b+2*a*b^2)*y2] + +(f0x = insert 0 (k*y1) x) +f1x = f0x + a * f0x->1 + b * f0x->2 +f2x = f1x + (a^2-2*b) * f1x->2 + b^2 * f1x->4 +-} +causalRecursivePackedP = + CausalP.mapAccumSimple + (\(p, x0) y1v -> do + let size = Vector.sizeInTuple x0 + + d1v <- SoV.replicate (Filt2.d1 p) + d2v <- SoV.replicate (Filt2.d2 p) + d2vn <- LLVM.neg d2v + + y1 <- Vector.extract (valueOf $ fromIntegral size - 1) y1v + xk1 <- + Vector.modify (valueOf 0) + (\u0 -> A.add u0 =<< A.mul (Filt2.d1 p) y1) =<< + A.add x0 =<< A.mul d2v =<< + Vector.shiftDownMultiZero (size - 2) y1v + + -- let xk2 = xk1 + xk2 <- + fmap fst $ + foldM + (\(y,(a,b)) d -> + liftM2 (,) + (A.add y =<< + M.liftR2 A.add + {- + Possibility for optimization: + In the last step the second operand is a zero vector + (LLVM already optimizes this away) + and the first operand could be merged + with the second operand of the previous step. + -} + (Vector.shiftUpMultiZero d =<< A.mul y a) + (Vector.shiftUpMultiZero (2*d) =<< A.mul y b)) $ + liftM2 (,) + (M.liftR2 A.sub + (A.mul a a) + (A.mul b (SoV.replicateOf 2))) + (A.mul b b)) + (xk1,(d1v,d2vn)) + (takeWhile (< size) $ iterate (2*) 1) + + return (xk2, xk2)) + (return (LLVM.value LLVM.zero)) + +_causalRecursivePackedPAlt = + CausalP.mapAccumSimple + (\(p, x0) (x1,x2) -> do + let size = Vector.sizeInTuple x0 + -- let xk1 = x0 + xk1 <- + Vector.modify (valueOf 0) + (\u0 -> + A.add u0 =<< + M.liftR2 A.add (A.mul (Filt2.d2 p) x2) (A.mul (Filt2.d1 p) x1)) =<< + Vector.modify (valueOf 1) + (\u1 -> A.add u1 =<< A.mul (Filt2.d2 p) x1) + x0 + + -- let xk2 = xk1 + d1v <- SoV.replicate (Filt2.d1 p) + d2v <- SoV.replicate =<< LLVM.neg (Filt2.d2 p) + xk2 <- + fmap fst $ + foldM + (\(y,(a,b)) d -> + liftM2 (,) + (A.add y =<< + M.liftR2 A.add + (Vector.shiftUpMultiZero d =<< A.mul y a) + (Vector.shiftUpMultiZero (2*d) =<< A.mul y b)) $ + liftM2 (,) + (M.liftR2 A.sub + (A.mul a a) + (A.mul b (SoV.replicateOf 2))) + (A.mul b b)) + (xk1,(d1v,d2v)) + (takeWhile (< size) $ iterate (2*) 1) + + y0 <- Vector.extract (valueOf $ fromIntegral size - 1) xk2 + y1 <- Vector.extract (valueOf $ fromIntegral size - 2) xk2 + return (xk2, (y0,y1))) + (return (LLVM.value LLVM.zero, LLVM.value LLVM.zero)) + +{- +A filter of second order can also be represented +by a filter of first order with 2x2-matrix coefficients. + +filter1 ((d1,d2), (1,0)) (y1,y2) [(x0,0), (x1,0), (x2,0), (x3,0)] + +/d1i d2i\ . /d1j d2j\ = /d1i*d1j + d2i d1i*d2j\ +\ 1 0 / \ 1 0 / \ d1j d2j/ + + +With this representation we can also implement filters +with time-variant filter parameters +using time-variant first-order filter. +-} diff --git a/src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs b/src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Synthesizer.LLVM.Filter.SecondOrderCascade where + +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified LLVM.Extra.Representation as Rep +import qualified Synthesizer.LLVM.Simple.Value as Value + +import qualified LLVM.Extra.Class as Class + +import qualified LLVM.Core as LLVM +import LLVM.Util.Loop (Phi, phis, addPhis, ) +import LLVM.Core + (Value, valueOf, Vector, + IsPowerOf2, IsConst, IsArithmetic, IsPrimitive, IsFirstClass, IsSized, + CodeGenFunction, ) + +import qualified Data.TypeLevel.Num as TypeNum +import qualified Data.TypeLevel.Num.Sets as TypeSet + +import Data.Word (Word32, ) + +import qualified Control.Arrow as Arrow +import Control.Arrow ((>>>), (<<<), (&&&), arr, ) + +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +type Parameter n a = LLVM.Array n (Filt2.ParameterStruct a) + +newtype ParameterValue n a = + ParameterValue {parameterValue :: Value (Parameter n a)} +{- +Automatic deriving is not allowed even with GeneralizedNewtypeDeriving +because of IsSized constraint +and it would also be wrong for Functor and friends. + deriving + (Phi, LLVM.Undefined, Class.Zero, + Functor, App.Applicative, Fold.Foldable, Trav.Traversable) +-} + +instance (TypeNum.Nat n, IsSized a s) => + Phi (ParameterValue n a) where + phis bb (ParameterValue r) = + fmap ParameterValue $ phis bb r + addPhis bb + (ParameterValue r) + (ParameterValue r') = + addPhis bb r r' + +instance (TypeNum.Nat n, IsSized a s) => + LLVM.Undefined (ParameterValue n a) where + undefTuple = ParameterValue LLVM.undefTuple + +instance (TypeNum.Nat n, IsSized a s) => + Class.Zero (ParameterValue n a) where + zeroTuple = ParameterValue Class.zeroTuple + +instance + (TypeNum.Nat n, IsSized a s) => + Rep.Memory (ParameterValue n a) (Parameter n a) where + load = Rep.loadNewtype ParameterValue + store = Rep.storeNewtype (\(ParameterValue k) -> k) + decompose = Rep.decomposeNewtype ParameterValue + compose = Rep.composeNewtype (\(ParameterValue k) -> k) + + + +withSize :: + (n -> CausalP.T p (ParameterValue n a, x) y) -> + CausalP.T p (ParameterValue n a, x) y +withSize f = f undefined + +fixSize :: + n -> + CausalP.T p (ParameterValue n a, x) y -> + CausalP.T p (ParameterValue n a, x) y +fixSize _n = id + +causalP :: + (Ring.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, + IsFirstClass v, IsSized v vs, IsConst v, + IsArithmetic a, TypeSet.Nat n, + TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) => + CausalP.T p (ParameterValue n a, Value v) (Value v) +causalP = + withSize $ \n -> + foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $ + map + (\k -> + Filt2.causalP <<< + Arrow.first (CausalP.mapSimple + (\ps -> getStageParameter ps k))) + (take (TypeNum.toInt n) [0..]) + +causalPackedP :: + (Ring.C a, + IsPrimitive a, IsSized a as, IsConst a, + IsArithmetic a, TypeSet.Nat n, + TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize, + IsPowerOf2 d, TypeNum.Mul d as vas, TypeSet.Pos vas) => + CausalP.T p + (ParameterValue n a, Value (Vector d a)) (Value (Vector d a)) +causalPackedP = + withSize $ \n -> + foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $ + map + (\k -> + Filt2.causalPackedP <<< + Arrow.first (CausalP.mapSimple + (\ps -> getStageParameter ps k))) + (take (TypeNum.toInt n) [0..]) + +getStageParameter, getStageParameterMalloc, getStageParameterAlloca :: + (IsFirstClass a, TypeSet.Nat n, IsSized a sa, + TypeNum.Mul n LLVM.UnknownSize s, TypeSet.Pos s) => + ParameterValue n a -> + Word32 -> + CodeGenFunction r (Filt2Core.Parameter (Value a)) +getStageParameter ps k = + Rep.decompose =<< + LLVM.extractvalue (parameterValue ps) k + +{- +Expensive because we need a heap allocation for every sample. +However, we could allocate the memory once in the Causal initialization routine. +-} +getStageParameterMalloc ps k = do + ptr <- LLVM.malloc + LLVM.store (parameterValue ps) ptr + p <- Rep.load =<< LLVM.getElementPtr0 ptr (valueOf k, ()) + LLVM.free ptr + return p + +{- +With this implementation, LLVM-2.6 generates a stack variable layout +that requires non-aligned access to vector values. +The result is a crash at runtime. +-} +getStageParameterAlloca ps k = do + ptr <- LLVM.alloca + LLVM.store (parameterValue ps) ptr + Rep.load =<< LLVM.getElementPtr0 ptr (valueOf k, ()) diff --git a/src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs b/src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Synthesizer.LLVM.Filter.SecondOrderPacked ( + Parameter, bandpassParameter, State, causalP, + ) where + +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2L +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Vector as Vector + +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, valueOf, Struct, Undefined, undefTuple, + IsFirstClass, IsConst, IsFloating, + Vector, IsPrimitive, IsSized, + CodeGenFunction, ) +import LLVM.Util.Loop (Phi, phis, addPhis, ) + +import Data.TypeLevel.Num (Add, D4, d0, d1, ) +import qualified Data.TypeLevel.Num as TypeNum +import qualified Data.TypeLevel.Num.Sets as Sets + +import Control.Applicative (liftA2, ) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +{- | +Layout: + +> c0 [c1 d1 c2 d2] +-} +data Parameter a = + Parameter (Value a) (Value (Vector D4 a)) + +instance (IsFirstClass a, IsPrimitive a) => Phi (Parameter a) where + phis bb (Parameter r i) = do + r' <- phis bb r + i' <- phis bb i + return (Parameter r' i') + addPhis bb + (Parameter r i) + (Parameter r' i') = do + addPhis bb r r' + addPhis bb i i' + +instance (IsFirstClass a, IsPrimitive a) => Undefined (Parameter a) where + undefTuple = Parameter undefTuple undefTuple + + +parameterMemory :: + (IsPrimitive l, IsFirstClass l, IsSized l s, + Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) => + Rep.MemoryRecord r (Struct (l, (Vector D4 l, ()))) (Parameter l) +parameterMemory = + liftA2 Parameter + (Rep.memoryElement (\(Parameter c0 _) -> c0) d0) + (Rep.memoryElement (\(Parameter _ cd) -> cd) d1) + +instance (IsPrimitive l, IsFirstClass l, IsSized l s, + Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) => + Rep.Memory (Parameter l) (Struct (l, (Vector D4 l, ()))) where + load = Rep.loadRecord parameterMemory + store = Rep.storeRecord parameterMemory + decompose = Rep.decomposeRecord parameterMemory + compose = Rep.composeRecord parameterMemory + + +type State = Vector D4 + + +{-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-} +bandpassParameter :: + (Trans.C a, IsFloating a, IsConst a, IsPrimitive a) => + Value a -> + Value a -> + CodeGenFunction r (Parameter a) +bandpassParameter reson cutoff = do + p <- Filt2L.bandpassParameter reson cutoff + v <- Vector.assemble [Filt2.c1 p, Filt2.d1 p, Filt2.c2 p, Filt2.d2 p] + return $ Parameter (Filt2.c0 p) v + + +next :: + (Vector.Arithmetic a) => + (Parameter a, Value a) -> + Value (State a) -> + CodeGenFunction r (Value a, Value (State a)) +next (Parameter c0 k1, x0) y1 = do + s0 <- A.mul c0 x0 + s1 <- Vector.dotProduct k1 y1 + y0 <- A.add s0 s1 + x1new <- Vector.extract (valueOf 0) y1 + y1new <- Vector.extract (valueOf 1) y1 + yv <- Vector.assemble [x0, y0, x1new, y1new] + return (y0, yv) + +causalP :: + (Field.C a, Vector.Arithmetic a, IsSized (State a) as) => + CausalP.T p + (Parameter a, Value a) (Value a) +causalP = + CausalP.mapAccumSimple next + (return (LLVM.value LLVM.zero)) diff --git a/src/Synthesizer/LLVM/Filter/Universal.hs b/src/Synthesizer/LLVM/Filter/Universal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/Universal.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Synthesizer.LLVM.Filter.Universal ( + Result(Result, lowpass, highpass, bandpass, bandlimit), + Parameter, parameter, causalP, + ) where + +import qualified Synthesizer.Plain.Filter.Recursive.Universal as Universal +import Synthesizer.Plain.Filter.Recursive.Universal + (Parameter(Parameter), + Result(Result, lowpass, highpass, bandpass, bandlimit)) +import Synthesizer.Plain.Filter.Recursive (Pole(..)) + +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Simple.Value as Value + +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Vector as Vector + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, Struct, + IsFirstClass, IsConst, IsArithmetic, IsFloating, IsSized, + Undefined, undefTuple, + CodeGenFunction, ) +import LLVM.Util.Loop (Phi, phis, addPhis, ) + +import Data.TypeLevel.Num (d0, d1, d2, d3, d4, d5, ) + +import Synthesizer.ApplicativeUtility (liftA6, ) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Module as Module +-- import qualified Algebra.Ring as Ring + + +instance (Phi a) => Phi (Parameter a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + +instance Undefined a => Undefined (Parameter a) where + undefTuple = Class.undefTuplePointed + +parameterMemory :: + (Rep.Memory a s, IsSized s ss) => + Rep.MemoryRecord r (Struct (s, (s, (s, (s, (s, (s, ()))))))) (Parameter a) +parameterMemory = + liftA6 Parameter + (Rep.memoryElement Universal.k1 d0) + (Rep.memoryElement Universal.k2 d1) + (Rep.memoryElement Universal.ampIn d2) + (Rep.memoryElement Universal.ampI1 d3) + (Rep.memoryElement Universal.ampI2 d4) + (Rep.memoryElement Universal.ampLimit d5) + + +instance + (Rep.Memory a s, IsSized s ss) => + Rep.Memory (Parameter a) (Struct (s, (s, (s, (s, (s, (s, ()))))))) where + load = Rep.loadRecord parameterMemory + store = Rep.storeRecord parameterMemory + decompose = Rep.decomposeRecord parameterMemory + compose = Rep.composeRecord parameterMemory + + +instance LLVM.ValueTuple a => LLVM.ValueTuple (Result a) where + buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) + +instance LLVM.IsTuple a => LLVM.IsTuple (Result a) where + tupleDesc = Class.tupleDescFoldable + +instance (LLVM.MakeValueTuple ah al) => + LLVM.MakeValueTuple (Result ah) (Result al) where + valueTupleOf = Class.valueTupleOfFunctor + +instance (Value.Flatten ah al) => + Value.Flatten (Result ah) (Result al) where + flatten = Value.flattenTraversable + unfold = Value.unfoldFunctor + + +instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where + buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) + +instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where + tupleDesc = Class.tupleDescFoldable + +instance (LLVM.MakeValueTuple ah al) => + LLVM.MakeValueTuple (Parameter ah) (Parameter al) where + valueTupleOf = Class.valueTupleOfFunctor + +instance (Value.Flatten ah al) => + Value.Flatten (Parameter ah) (Parameter al) where + flatten = Value.flattenTraversable + unfold = Value.unfoldFunctor + + +instance (Vector.ShuffleMatch d v) => + Vector.ShuffleMatch d (Parameter v) where + shuffleMatch = Vector.shuffleMatchTraversable + +instance (Vector.Access d a v) => + Vector.Access d (Parameter a) (Parameter v) where + insert = Vector.insertTraversable + extract = Vector.extractTraversable + + +instance (Phi a) => Phi (Result a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + +instance Undefined a => Undefined (Result a) where + undefTuple = Class.undefTuplePointed + +instance (Vector.ShuffleMatch d v) => + Vector.ShuffleMatch d (Result v) where + shuffleMatch = Vector.shuffleMatchTraversable + +instance (Vector.Access d a v) => + Vector.Access d (Result a) (Result v) where + insert = Vector.insertTraversable + extract = Vector.extractTraversable + + +parameter :: + (Trans.C a, IsConst a, IsFloating a) => + Value a -> Value a -> + CodeGenFunction r (Parameter (Value a)) +parameter reson freq = + Value.flatten $ + Universal.parameter + (Pole (Value.constantValue reson) (Value.constantValue freq)) +-- (Pole (Value.unfold reson) (Value.unfold freq)) + + +modifier :: + (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) => + Modifier.Simple + (Universal.State (Value.T v)) + (Parameter (Value.T a)) + (Value.T v) (Result (Value.T v)) +modifier = + Universal.modifier + +causalP :: + (Field.C a, Module.C (Value.T a) (Value.T v), + IsFirstClass a, IsSized a as, IsConst a, + IsFirstClass v, IsSized v vs, IsConst v, + IsArithmetic a) => + CausalP.T p + (Parameter (Value a), Value v) (Result (Value v)) +causalP = + CausalP.fromModifier modifier diff --git a/src/Synthesizer/LLVM/Frame/Stereo.hs b/src/Synthesizer/LLVM/Frame/Stereo.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/Stereo.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | +Re-export functions from "Sound.Frame.Stereo" +and add (orphan) instances for various LLVM type classes. +If you want to use the Stereo datatype with synthesizer-llvm +we recommend to import this module instead of +"Sound.Frame.Stereo" or "Sound.Frame.NumericPrelude.Stereo". +-} +module Synthesizer.LLVM.Frame.Stereo ( + Stereo.T, Stereo.cons, Stereo.left, Stereo.right, + Stereo.arrowFromMono, + Stereo.arrowFromMonoControlled, + Stereo.arrowFromChannels, + interleave, + ) where + +import qualified Synthesizer.Frame.Stereo as Stereo + +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Core as LLVM +import LLVM.Core + (ValueTuple, buildTuple, + Undefined, undefTuple, + IsTuple, tupleDesc, + MakeValueTuple, valueTupleOf, + Struct, IsSized, ) +import LLVM.Util.Loop (Phi, phis, addPhis, ) + +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Vector as Vector +import Data.TypeLevel.Num (d0, d1, ) + +import Control.Monad (liftM2, ) +import Control.Applicative (liftA2, ) +import qualified Control.Applicative as App + + +-- if it turns out to be useful, we may move it to sample-frame package +interleave :: (Stereo.T a, Stereo.T b) -> Stereo.T (a,b) +interleave (p,f) = + Stereo.cons + (Stereo.left p, Stereo.left f) + (Stereo.right p, Stereo.right f) + + +instance (Class.Zero a) => Class.Zero (Stereo.T a) where + zeroTuple = Stereo.cons Class.zeroTuple Class.zeroTuple + +instance ValueTuple a => ValueTuple (Stereo.T a) where + buildTuple f = + liftM2 Stereo.cons (buildTuple f) (buildTuple f) + +instance (Undefined a) => Undefined (Stereo.T a) where + undefTuple = Stereo.cons undefTuple undefTuple + +instance (C.Select a) => C.Select (Stereo.T a) where + select = C.selectTraversable + +instance LLVM.CmpRet a b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where + +instance MakeValueTuple h l => + MakeValueTuple (Stereo.T h) (Stereo.T l) where + valueTupleOf s = + Stereo.cons + (LLVM.valueTupleOf $ Stereo.left s) + (LLVM.valueTupleOf $ Stereo.right s) + +instance IsTuple a => IsTuple (Stereo.T a) where + tupleDesc s = + tupleDesc (Stereo.left s) ++ + tupleDesc (Stereo.right s) + +instance (Phi a) => Phi (Stereo.T a) where + phis bb v = + liftM2 Stereo.cons + (phis bb (Stereo.left v)) + (phis bb (Stereo.right v)) + addPhis bb x y = do + addPhis bb (Stereo.left x) (Stereo.left y) + addPhis bb (Stereo.right x) (Stereo.right y) + + +instance (Vector.ShuffleMatch n v) => Vector.ShuffleMatch n (Stereo.T v) where + shuffleMatch = Vector.shuffleMatchTraversable + +instance (Vector.Access n a v) => Vector.Access n (Stereo.T a) (Stereo.T v) where + insert = Vector.insertTraversable + extract = Vector.extractTraversable + + +memory :: + (Rep.Memory l s, IsSized s ss) => + Rep.MemoryRecord r (Struct (s, (s, ()))) (Stereo.T l) +memory = + liftA2 Stereo.cons + (Rep.memoryElement Stereo.left d0) + (Rep.memoryElement Stereo.right d1) + +instance + (Rep.Memory l s, IsSized s ss) => + Rep.Memory (Stereo.T l) (Struct (s, (s, ()))) where + load = Rep.loadRecord memory + store = Rep.storeRecord memory + decompose = Rep.decomposeRecord memory + compose = Rep.composeRecord memory + + +{- +instance + (Memory l s, IsSized s ss) => + Memory (Stereo.T l) (Struct (s, (s, ()))) where + load ptr = + liftM2 Stereo.cons + (load =<< getElementPtr0 ptr (d0, ())) + (load =<< getElementPtr0 ptr (d1, ())) + store y ptr = do + store (Stereo.left y) =<< getElementPtr0 ptr (d0, ()) + store (Stereo.right y) =<< getElementPtr0 ptr (d1, ()) +-} diff --git a/src/Synthesizer/LLVM/Generator/Exponential2.hs b/src/Synthesizer/LLVM/Generator/Exponential2.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Generator/Exponential2.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{- | +Exponential curve with controllable delay. +-} +module Synthesizer.LLVM.Generator.Exponential2 ( + Parameter, + parameter, + parameterPlain, + causalP, + + ParameterPacked, + parameterPacked, + parameterPackedPlain, + causalPackedP, + ) where + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Simple.Value as Value +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Representation as Rep + +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, valueOf, Vector, + IsPowerOf2, IsConst, IsArithmetic, IsPrimitive, IsFirstClass, IsFloating, IsSized, + Undefined, undefTuple, + CodeGenFunction, ) +import LLVM.Util.Loop (Phi, phis, addPhis, ) + +import qualified Data.TypeLevel.Num as TypeNum +import qualified Data.TypeLevel.Num.Sets as TypeSet + +import Foreign.Storable (Storable, ) + +import qualified Control.Applicative as App +import qualified Data.Foldable as Fold +import qualified Data.Traversable as Trav +import Control.Applicative (liftA2, (<*>), ) +import Control.Arrow ((^<<), ) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +newtype Parameter a = + Parameter a + + +instance Functor Parameter where + {-# INLINE fmap #-} + fmap f (Parameter k) = Parameter (f k) + +instance App.Applicative Parameter where + {-# INLINE pure #-} + pure x = Parameter x + {-# INLINE (<*>) #-} + Parameter f <*> Parameter k = + Parameter (f k) + +instance Fold.Foldable Parameter where + {-# INLINE foldMap #-} + foldMap = Trav.foldMapDefault + +instance Trav.Traversable Parameter where + {-# INLINE sequenceA #-} + sequenceA (Parameter k) = + fmap Parameter k + + +instance (Phi a) => Phi (Parameter a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + +instance Undefined a => Undefined (Parameter a) where + undefTuple = Class.undefTuplePointed + +instance Class.Zero a => Class.Zero (Parameter a) where + zeroTuple = Class.zeroTuplePointed + +instance + (Rep.Memory a s, IsSized s ss) => + Rep.Memory (Parameter a) s where + load = Rep.loadNewtype Parameter + store = Rep.storeNewtype (\(Parameter k) -> k) + decompose = Rep.decomposeNewtype Parameter + compose = Rep.composeNewtype (\(Parameter k) -> k) + + +instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where + buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) + +instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where + tupleDesc = Class.tupleDescFoldable + +instance (LLVM.MakeValueTuple ah al) => + LLVM.MakeValueTuple (Parameter ah) (Parameter al) where + valueTupleOf = Class.valueTupleOfFunctor + + +instance (Value.Flatten ah al) => + Value.Flatten (Parameter ah) (Parameter al) where + flatten = Value.flattenTraversable + unfold = Value.unfoldFunctor + + +instance (Vector.ShuffleMatch n v) => + Vector.ShuffleMatch n (Parameter v) where + shuffleMatch = Vector.shuffleMatchTraversable + +instance (Vector.Access n a v) => + Vector.Access n (Parameter a) (Parameter v) where + insert = Vector.insertTraversable + extract = Vector.extractTraversable + + +parameter :: + (Trans.C a, IsConst a, IsFloating a) => + Value a -> + CodeGenFunction r (Parameter (Value a)) +parameter halfLife = + Value.flatten $ parameterPlain $ + Value.constantValue halfLife + +parameterPlain :: + (Trans.C a) => + a -> Parameter a +parameterPlain halfLife = + Parameter $ 0.5 ** recip halfLife + + +causalP :: + (IsFirstClass a, IsSized a size, + IsArithmetic a, IsConst a, + Storable a, LLVM.MakeValueTuple a (Value a)) => + Param.T p a -> + CausalP.T p (Parameter (Value a)) (Value a) +causalP initial = + CausalP.mapAccum + (\() (Parameter a) s -> do + b <- A.mul a s + return (s,b)) + return + (return ()) + initial + + +data ParameterPacked a = + ParameterPacked {ppFeedback, ppCurrent :: a} + + +instance Functor ParameterPacked where + {-# INLINE fmap #-} + fmap f p = ParameterPacked + (f $ ppFeedback p) (f $ ppCurrent p) + +instance App.Applicative ParameterPacked where + {-# INLINE pure #-} + pure x = ParameterPacked x x + {-# INLINE (<*>) #-} + f <*> p = ParameterPacked + (ppFeedback f $ ppFeedback p) + (ppCurrent f $ ppCurrent p) + +instance Fold.Foldable ParameterPacked where + {-# INLINE foldMap #-} + foldMap = Trav.foldMapDefault + +instance Trav.Traversable ParameterPacked where + {-# INLINE sequenceA #-} + sequenceA p = + liftA2 ParameterPacked + (ppFeedback p) (ppCurrent p) + + +instance (Phi a) => Phi (ParameterPacked a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + +instance Undefined a => Undefined (ParameterPacked a) where + undefTuple = Class.undefTuplePointed + +instance Class.Zero a => Class.Zero (ParameterPacked a) where + zeroTuple = Class.zeroTuplePointed + + +memory :: + (Rep.Memory l s, IsSized s ss) => + Rep.MemoryRecord r (LLVM.Struct (s, (s, ()))) (ParameterPacked l) +memory = + liftA2 ParameterPacked + (Rep.memoryElement ppFeedback TypeNum.d0) + (Rep.memoryElement ppCurrent TypeNum.d1) + +instance + (Rep.Memory l s, IsSized s ss) => + Rep.Memory (ParameterPacked l) (LLVM.Struct (s, (s, ()))) where + load = Rep.loadRecord memory + store = Rep.storeRecord memory + decompose = Rep.decomposeRecord memory + compose = Rep.composeRecord memory + + +instance LLVM.ValueTuple a => LLVM.ValueTuple (ParameterPacked a) where + buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) + +instance LLVM.IsTuple a => LLVM.IsTuple (ParameterPacked a) where + tupleDesc = Class.tupleDescFoldable + +instance (LLVM.MakeValueTuple ah al) => + LLVM.MakeValueTuple (ParameterPacked ah) (ParameterPacked al) where + valueTupleOf = Class.valueTupleOfFunctor + + +instance (Value.Flatten ah al) => + Value.Flatten (ParameterPacked ah) (ParameterPacked al) where + flatten = Value.flattenTraversable + unfold = Value.unfoldFunctor + + +instance (Vector.ShuffleMatch m v) => + Vector.ShuffleMatch m (ParameterPacked v) where + shuffleMatch = Vector.shuffleMatchTraversable + +instance (Vector.Access m a v) => + Vector.Access m (ParameterPacked a) (ParameterPacked v) where + insert = Vector.insertTraversable + extract = Vector.extractTraversable + + + +withSize :: + (n -> m (param (Value (Vector n a)))) -> + m (param (Value (Vector n a))) +withSize f = f undefined + +parameterPacked :: + (Trans.C a, IsConst a, IsFloating a, + IsPrimitive a, IsPowerOf2 n) => + Value a -> + CodeGenFunction r (ParameterPacked (Value (Vector n a))) +parameterPacked halfLife = withSize $ \n -> do + feedback <- + SoV.replicate =<< + A.pow (valueOf 0.5) =<< + A.fdiv (valueOf $ fromIntegral $ TypeNum.toInt n) halfLife + k <- + A.pow (valueOf 0.5) =<< + A.fdiv (valueOf 1) halfLife + current <- + Vector.iterate (A.mul k) (valueOf 1) + return $ ParameterPacked feedback current +{- + Value.flatten $ parameterPackedPlain $ + Value.constantValue halfLife +-} + +withSizePlain :: + (n -> param (Vector n a)) -> + param (Vector n a) +withSizePlain f = f undefined + +parameterPackedPlain :: + (Trans.C a, + IsPowerOf2 n) => + a -> ParameterPacked (Vector n a) +parameterPackedPlain halfLife = + withSizePlain $ \n -> + ParameterPacked + (LLVM.vector [0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife)]) + (LLVM.vector $ iterate (0.5 ** recip halfLife *) one) + + +causalPackedP :: + (IsFirstClass a, IsSized a size, + IsArithmetic a, IsConst a, + Storable a, LLVM.MakeValueTuple a (Value a), + IsPrimitive a, IsPowerOf2 n, + TypeNum.Mul n size pss, TypeNum.Pos pss) => + Param.T p a -> + CausalP.T p (ParameterPacked (Value (Vector n a))) (Value (Vector n a)) +causalPackedP initial = + CausalP.mapAccum + (\() p s0 -> do + s1 <- A.mul (ppFeedback p) s0 + b <- A.mul (ppCurrent p) s0 + return (b,s1)) + return + (return ()) + (LLVM.vector . (:[]) ^<< initial) diff --git a/src/Synthesizer/LLVM/Parameter.hs b/src/Synthesizer/LLVM/Parameter.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Parameter.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.LLVM.Parameter where + +import qualified LLVM.Core as LLVM + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Control.Category as Cat +import qualified Control.Arrow as Arr +import qualified Control.Applicative as App +import Control.Applicative (pure, liftA2, ) + +import Data.Tuple.HT (mapFst, ) + +import NumericPrelude.Numeric +import Prelude (fmap, error, (.), const, id, Functor, Monad, ) +import qualified Prelude as P + + +{- | +This data type is for parameters of parameterized signal generators and causal processes. +It is better than using plain functions of type @p -> a@ +since it allows for numeric instances +and we can make explicit, +whether a parameter is constant. + +We recommend to use parameters for atomic types. +Although a parameter of type @T p (a,b)@ is possible, +it means that the whole parameter is variable +if only one of the pair elements is variable. +This way you may miss optimizations. +-} +data T p a = + Constant a | + Variable (p -> a) + + +get :: T p a -> (p -> a) +get (Constant a) = const a +get (Variable f) = f + + +{- | +The call @value param v@ requires +that @v@ represents the same value as @valueTupleOf (get param p)@ for some @p@. +However @v@ might be the result of a load operation +and @param@ might be a constant. +In this case it is more efficient to use @valueTupleOf (get param undefined)@ +since the constant is translated to an LLVM constant +that allows for certain optimizations. + +This is the main function for taking advantage of a constant parameter +in low-level implementations. +For simplicity we do not omit constant parameters in the parameter struct +since this would mean to construct types at runtime and might become ugly. +Instead we just check using 'value' at the according places in LLVM code +whether a parameter is constant +and ignore the parameter from the struct in this case. +In many cases there will be no speed benefit +because the parameter will be loaded to a register anyway. +It can only lead to speed-up if subsequent optimizations +can precompute constant expressions. +Another example is 'drop' where a loop with constant loop count can be generated. +For small loop counts and simple loop bodies the loop might get unrolled. +-} +value :: + LLVM.MakeValueTuple tuple value => + T p tuple -> value -> value +value (Constant a) _ = LLVM.valueTupleOf a +value (Variable _) v = v + + +{- | +@.@ can be used for fetching a parameter from a super-parameter. +-} +instance Cat.Category T where + id = Variable id + Constant f . _ = Constant f + Variable f . Constant a = Constant (f a) + Variable f . Variable g = Variable (f . g) + +{- | +@arr@ is useful for lifting parameter selectors to our parameter type +without relying on the constructor. +-} +instance Arr.Arrow T where + arr = Variable + first f = Variable (mapFst (get f)) + + + +{- | +Useful for splitting @T p (a,b)@ into @T p a@ and @T p b@ +using @fmap fst@ and @fmap snd@. +-} +instance Functor (T p) where + fmap f (Constant a) = Constant (f a) + fmap f (Variable g) = Variable (f . g) + +{- | +Useful for combining @T p a@ and @T p b@ to @T p (a,b)@ +using @liftA2 (,)@. +However, we do not recommend to do so +because the result parameter can only be constant +if both operands are constant. +-} +instance App.Applicative (T p) where + pure a = Constant a + Constant f <*> Constant a = Constant (f a) + f <*> a = Variable (\p -> get f p (get a p)) + +instance Monad (T p) where + return = pure + Constant x >>= f = f x + Variable x >>= f = + Variable (\p -> get (f (x p)) p) + + +instance Additive.C a => Additive.C (T p a) where + zero = pure zero + negate = fmap negate + (+) = liftA2 (+) + (-) = liftA2 (-) + +instance Ring.C a => Ring.C (T p a) where + one = pure one + (*) = liftA2 (*) + x^n = fmap (^n) x + fromInteger = pure . fromInteger + +instance Field.C a => Field.C (T p a) where + (/) = liftA2 (/) + recip = fmap recip + fromRational' = pure . fromRational' + +instance Algebraic.C a => Algebraic.C (T p a) where + x ^/ r = fmap (^/ r) x + sqrt = fmap sqrt + root n = fmap (Algebraic.root n) + +instance Trans.C a => Trans.C (T p a) where + pi = pure pi + exp = fmap exp + log = fmap log + logBase = liftA2 logBase + (**) = liftA2 (**) + sin = fmap sin + tan = fmap tan + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + tanh = fmap tanh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + + +{- +Instances for Haskell98 numeric type classes +that are useful when working together with other libraries on fixed types. +-} +instance P.Eq a => P.Eq (T p a) where + (==) = error "Synthesizer.LLVM.Parameter: Num instance requires Eq but we cannot define that" + +instance P.Show a => P.Show (T p a) where + show _ = "Synthesizer.LLVM.Parameter" + +instance P.Num a => P.Num (T p a) where + (+) = liftA2 (P.+) + (-) = liftA2 (P.-) + (*) = liftA2 (P.*) + negate = fmap P.negate + abs = fmap P.abs + signum = fmap P.signum + fromInteger = pure . P.fromInteger + +instance P.Fractional a => P.Fractional (T p a) where + (/) = liftA2 (P./) + fromRational = pure . P.fromRational diff --git a/src/Synthesizer/LLVM/Parameterized/Signal.hs b/src/Synthesizer/LLVM/Parameterized/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Parameterized/Signal.hs @@ -0,0 +1,819 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.Parameterized.Signal ( + T(Cons), simple, map, mapSimple, iterate, + module Synthesizer.LLVM.Parameterized.Signal + ) where + +import Synthesizer.LLVM.Parameterized.SignalPrivate +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as Causal +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified Synthesizer.LLVM.Random as Rnd +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.Sample as Sample +import qualified Synthesizer.LLVM.Execution as Exec +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.MaybeContinuation as Maybe +import qualified LLVM.Extra.Representation as Rep +import LLVM.Extra.Control (whileLoop, ifThen, ) + +import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt +import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt +import qualified Data.StorableVector.Lazy.Pattern as SVP +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB + +import qualified Synthesizer.LLVM.EventIterator as EventIt +import qualified Data.EventList.Relative.BodyTime as EventList +import qualified Numeric.NonNegative.Chunky as Chunky +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.ScalarOrVector as SoV +import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) + +import LLVM.Core as LLVM +import qualified LLVM.Util.Loop as Loop +import qualified Data.TypeLevel.Num as TypeNum + +import Control.Monad (liftM2, liftM3, ) +import Control.Arrow ((^<<), ) +import Control.Applicative (liftA2, ) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Data.Word (Word32, ) +import Foreign.Storable.Tuple () +import Foreign.Storable (Storable, poke, ) +import Foreign.Marshal.Array (advancePtr, ) +import qualified Foreign.Marshal.Array as Array +import qualified Foreign.Marshal.Alloc as Alloc +import Foreign.ForeignPtr + (unsafeForeignPtrToPtr, touchForeignPtr, withForeignPtr, ) +import Foreign.Ptr (FunPtr, nullPtr, ) +import Control.Exception (bracket, ) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) + +import Data.Tuple.HT (swap, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, ) + + +infixl 0 $# + +($#) :: (Param.T p a -> b) -> (a -> b) +($#) f a = f (return a) + + +mapAccum :: + (Storable pnh, MakeValueTuple pnh pnl, Rep.Memory pnl pnp, IsSized pnp pns, + Storable psh, MakeValueTuple psh psl, Rep.Memory psl psp, IsSized psp pss, + Rep.Memory s struct, IsSized struct sa) => + (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) -> + (forall r. psl -> CodeGenFunction r s) -> + Param.T p pnh -> + Param.T p psh -> + T p a -> T p b +mapAccum f startS selectParamF selectParamS + (Cons next start createIOContext deleteIOContext) = + Cons + (\(parameterF, parameter) (sa0,ss0) -> do + (a,sa1) <- next parameter sa0 + (b,ss1) <- Maybe.lift $ f (Param.value selectParamF parameterF) a ss0 + return (b, (sa1,ss1))) + (\(parameterF, parameter) -> + liftM2 (,) (start parameter) (startS (Param.value selectParamS parameterF))) + (\p -> do + (ioContext, (nextParam, startParam)) <- createIOContext p + return (ioContext, ((Param.get selectParamF p, nextParam), + (Param.get selectParamS p, startParam)))) + deleteIOContext + + +zipWith :: + (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) => + (forall r. pl -> a -> b -> CodeGenFunction r c) -> + Param.T p ph -> + T p a -> T p b -> T p c +zipWith f selectParamF + (Cons nextA startA createIOContextA deleteIOContextA) + (Cons nextB startB createIOContextB deleteIOContextB) = + Cons + (\(parameterF, (parameterA, parameterB)) (sa0,sb0) -> do + (a,sa1) <- nextA parameterA sa0 + (b,sb1) <- nextB parameterB sb0 + c <- Maybe.lift $ f (Param.value selectParamF parameterF) a b + return (c, (sa1,sb1))) + (\(parameterA, parameterB) -> + liftM2 (,) + (startA parameterA) + (startB parameterB)) + (\p -> do + (ca,(nextParamA,startParamA)) <- createIOContextA p + (cb,(nextParamB,startParamB)) <- createIOContextB p + return ((ca,cb), + ((Param.get selectParamF p, (nextParamA, nextParamB)), + (startParamA, startParamB)))) + (\(ca,cb) -> + deleteIOContextA ca >> + deleteIOContextB cb) + +zipWithSimple :: + (forall r. a -> b -> CodeGenFunction r c) -> + T p a -> T p b -> T p c +zipWithSimple f = + zipWith (const f) (return ()) + +zip :: T p a -> T p b -> T p (a,b) +zip = zipWithSimple (\a b -> return (a,b)) + + +-- * timeline edit + +{- | +@tail empty@ generates the empty signal. +-} +tail :: + T p a -> T p a +tail (Cons next start createIOContext deleteIOContext) = Cons + next + (\(nextParameter, startParameter) -> do + s0 <- start startParameter + Maybe.resolve (next nextParameter s0) + (return s0) + (\(_a,s1) -> return s1)) + (\p -> do + (ioContext, (nextParam, startParam)) <- createIOContext p + return (ioContext, (nextParam, (nextParam, startParam)))) + deleteIOContext + +drop :: + Param.T p Int -> + T p a -> T p a +drop n (Cons next start createIOContext deleteIOContext) = + let n32 = fmap (fromIntegral :: Int -> Word32) n in Cons + next + (\(nextParameter, i0, startParameter) -> do + s0 <- start startParameter + (_, _, s3) <- + whileLoop (valueOf True, Param.value n32 i0, s0) + (\(cont,i1,_s1) -> + A.and cont =<< + A.icmp IntUGT i1 (value LLVM.zero)) + (\(_cont,i1,s1) -> do + (cont, s2) <- + Maybe.resolve (next nextParameter s1) + (return (valueOf False, s1)) + (\(_a,s) -> return (valueOf True, s)) + i2 <- A.dec i1 + return (cont, i2, s2)) + return s3) + (\p -> do + (ioContext, (nextParam, startParam)) <- createIOContext p + return (ioContext, (nextParam, + (nextParam, Param.get n32 p, startParam)))) + deleteIOContext + +{- | +Appending many signals is inefficient, +since in cascadingly appended signals the parts are counted in an unary way. +Concatenating infinitely many signals is impossible. +If you want to concatenate a lot of signals, +please render them to lazy storable vectors first. +-} +{- +We might save a little space by using a union +for the states of the first and the second signal generator. +-} +append :: + (Loop.Phi a) => + T p a -> T p a -> T p a +append + (Cons nextA startA createIOContextA deleteIOContextA) + (Cons nextB startB createIOContextB deleteIOContextB) = + Cons + (\(parameterA, parameterB) (firstPart,(sa0,sb0)) -> + Maybe.fromBool $ do + (contA, (a,sa1)) <- + ifThen firstPart (valueOf False, (undefTuple,sa0)) + (Maybe.toBool $ nextA parameterA sa0) + secondPart <- inv contA + (contB, (b,sb1)) <- + ifThen secondPart (valueOf True, (a,sb0)) + (Maybe.toBool $ nextB parameterB sb0) + return (contB, (b, (contA, (sa1,sb1))))) + (\(parameterA, parameterB) -> + fmap ((,) (valueOf True)) $ + liftM2 (,) + (startA parameterA) + (startB parameterB)) + (\p -> do + (ca,(nextParamA,startParamA)) <- createIOContextA p + (cb,(nextParamB,startParamB)) <- createIOContextB p + return ((ca,cb), + ((nextParamA, nextParamB), + (startParamA, startParamB)))) + (\(ca,cb) -> + deleteIOContextA ca >> + deleteIOContextB cb) + + +-- * signal modifiers + +{- | +Stretch signal in time by a certain factor. + +This can be used for doing expensive computations +of filter parameters at a lower rate. +Alternatively, we could provide an adaptive @map@ +that recomputes output values only if the input value changes, +or if the input value differs from the last processed one by a certain amount. +-} +interpolateConstant :: + (Rep.Memory a struct, IsSized struct size, + Ring.C b, + IsFloating b, CmpRet b Bool, + Storable b, MakeValueTuple b (Value b), + IsConst b, IsFirstClass b, IsSized b sb) => + Param.T p b -> T p a -> T p a +interpolateConstant k + (Cons next start createIOContext deleteIOContext) = + Cons + (\(kl,parameter) yState0 -> do + ((y1,state1), ss1) <- + Maybe.fromBool $ + whileLoop + (valueOf True, yState0) + (\(cont1, (_, ss1)) -> + and cont1 =<< A.fcmp FPOLE ss1 (value LLVM.zero)) + (\(_,((_,state01), ss1)) -> + Maybe.toBool $ liftM2 (,) + (next parameter state01) + (Maybe.lift $ A.add ss1 (Param.value k kl))) + + ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.one) + return (y1, ((y1,state1),ss2))) + +{- using this initialization code we would not need undefined values + (do sa <- start + (a,_) <- next sa + return (sa, a, valueOf 0)) +-} + (fmap (\sa -> ((undefTuple, sa), value LLVM.zero)) . start) + (\p -> do + (ioContext, (nextParam, startParam)) <- createIOContext p + return (ioContext, ((Param.get k p, nextParam), startParam))) + deleteIOContext + + + +mix :: + (IsArithmetic a) => + T p (Value a) -> T p (Value a) -> T p (Value a) +mix = + zipWithSimple Sample.mixMono + +mixStereo :: + (IsArithmetic a) => + T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a)) +mixStereo = + zipWithSimple Sample.mixStereo + + +envelope :: + (IsArithmetic a) => + T p (Value a) -> T p (Value a) -> T p (Value a) +envelope = + zipWithSimple Sample.amplifyMono + +envelopeStereo :: + (IsArithmetic a) => + T p (Value a) -> T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a)) +envelopeStereo = + zipWithSimple Sample.amplifyStereo + +amplify :: + (IsArithmetic a, Storable a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) => + Param.T p a -> T p (Value a) -> T p (Value a) +amplify = + map Sample.amplifyMono + +amplifyStereo :: + (IsArithmetic a, Storable a, + MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) => + Param.T p a -> T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a)) +amplifyStereo = + map Sample.amplifyStereo + + +-- * signal generators + +constant :: + (Storable a, MakeValueTuple a al, + Rep.Memory al packed, IsSized packed s) => + Param.T p a -> T p al +constant x = + simple + (\pl () -> return (pl, ())) + return + x + (return ()) + + +exponentialCore :: + (Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) => + Param.T p a -> Param.T p a -> T p (Value a) +exponentialCore = + iterate A.mul + +exponential2 :: + (Trans.C a, Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) => + Param.T p a -> Param.T p a -> T p (Value a) +exponential2 halfLife = + exponentialCore (0.5 ** recip halfLife) + + +exponentialBoundedCore :: + (Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a s, SoV.Real a, IsConst a) => + Param.T p a -> Param.T p a -> Param.T p a -> + T p (Value a) +exponentialBoundedCore bound decay = + iterate + (\(b,k) y -> SoV.max b =<< A.mul k y) + (liftA2 (,) bound decay) + +{- | +Exponential curve that remains at the bound value +if it would fall below otherwise. +This way you can avoid extremal values, e.g. denormalized ones. +The initial value and the bound value must be positive. +-} +exponentialBounded2 :: + (Trans.C a, Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a s, SoV.Real a, IsConst a) => + Param.T p a -> Param.T p a -> Param.T p a -> + T p (Value a) +exponentialBounded2 bound halfLife = + exponentialBoundedCore bound (0.5 ** recip halfLife) + + +osciCore :: + (Storable t, MakeValueTuple t (Value t), + IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t) => + Param.T p t -> Param.T p t -> T p (Value t) +osciCore phase freq = + iterate SoV.incPhase freq phase + +osci :: + (Storable t, MakeValueTuple t (Value t), + Storable c, MakeValueTuple c cl, + IsFirstClass t, IsSized t size, + Rep.Memory cl cp, IsSized cp cs, + SoV.Fraction t, IsConst t) => + (forall r. cl -> Value t -> CodeGenFunction r y) -> + Param.T p c -> + Param.T p t -> Param.T p t -> T p y +osci wave waveParam phase freq = + map wave waveParam $ + osciCore phase freq + +osciSimple :: + (Storable t, MakeValueTuple t (Value t), + IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t) => + (forall r. Value t -> CodeGenFunction r y) -> + Param.T p t -> Param.T p t -> T p y +osciSimple wave = + osci (const wave) (return ()) + +osciSaw :: + (Ring.C a0, IsConst a0, SoV.Replicate a0 a, + Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a size, + SoV.Fraction a, IsPrimitive a, IsConst a) => + Param.T p a -> Param.T p a -> T p (Value a) +osciSaw = + osciSimple Wave.saw + + + +rampCore :: + (Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) => + Param.T p a -> Param.T p a -> T p (Value a) +rampCore = iterate A.add + +parabolaCore :: + (Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) => + Param.T p a -> Param.T p a -> Param.T p a -> T p (Value a) +parabolaCore d2 d1 start = + Causal.apply (Causal.integrate start) $ + rampCore d2 d1 + + + +rampInf, rampSlope, + parabolaFadeInInf, parabolaFadeOutInf :: + (Field.C a, Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) => + Param.T p a -> T p (Value a) +rampSlope slope = rampCore slope Additive.zero +rampInf dur = rampSlope (recip dur) + +{- +t*(2-t) = 1 - (t-1)^2 + +(t+d)*(2-t-d) - t*(2-t) + = d*(2-t) - d*t - d^2 + = 2*d*(1-t) - d^2 + = d*(2*(1-t) - d) + +2*d*(1-t-d) + d^2 - (2*d*(1-t) + d^2) + = -2*d^2 +-} +parabolaFadeInInf dur = + parabolaCore + (fmap (\d -> -2*d*d) $ recip dur) + (fmap (\d -> d*(2-d)) $ recip dur) + Additive.zero + +{- +1-t^2 +-} +parabolaFadeOutInf dur = + parabolaCore + (fmap (\d -> -2*d*d) $ recip dur) + (fmap (\d -> -d*d) $ recip dur) + one + +ramp, + parabolaFadeIn, parabolaFadeOut, + parabolaFadeInMap, parabolaFadeOutMap :: + (RealField.C a, Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) => + Param.T p a -> T p (Value a) + +ramp dur = + Causal.apply (Causal.take (fmap round dur)) $ + rampInf dur + +parabolaFadeIn dur = + Causal.apply (Causal.take (fmap round dur)) $ + parabolaFadeInInf dur + +parabolaFadeOut dur = + Causal.apply (Causal.take (fmap round dur)) $ + parabolaFadeOutInf dur + +parabolaFadeInMap dur = + -- t*(2-t) + Causal.apply (Causal.mapSimple (\t -> A.mul t =<< A.sub (valueOf 2) t)) $ + ramp dur + +parabolaFadeOutMap dur = + -- 1-t^2 + Causal.apply (Causal.mapSimple (\t -> A.sub (valueOf 1) =<< A.mul t t)) $ + ramp dur + + +{- | +@noise seed rate@ + +The @rate@ parameter is for adjusting the amplitude +such that it is uniform across different sample rates +and after frequency filters. +The @rate@ is the ratio of the current sample rate to the default sample rate, +where the variance of the samples would be one. +If you want that at sample rate 22050 the variance is 1, +then in order to get a consistent volume at sample rate 44100 +you have to set @rate = 2@. + +I use the variance as quantity and not the amplitude, +because the amplitude makes only sense for uniformly distributed samples. +However, frequency filters transform the probabilistic density of the samples +towards the normal distribution according to the central limit theorem. +-} +noise :: + (Algebraic.C a, IsFloating a, IsConst a, + NumberOfElements TypeNum.D1 a, + IsSized a ps, MakeValueTuple a (Value a), Storable a) => + Param.T p Word32 -> + Param.T p a -> + T p (Value a) +noise seed rate = + let m2 = fromInteger $ div Rnd.modulus 2 + in map (\r y -> + A.mul r + =<< flip A.sub (valueOf $ m2+1) + {- + In principle it must be uitofp, + but sitofp is a single instruction on x86 + and our numbers are below 2^31. + -} + =<< sitofp y) + (sqrt (3 * rate) / return m2) $ + noiseCore seed + +noiseCore, noiseCoreAlt :: + Param.T p Word32 -> + T p (Value Word32) +noiseCore seed = + iterate (const Rnd.nextCG) + (return ()) ((+1) . flip mod (Rnd.modulus-1) ^<< seed) + +noiseCoreAlt seed = + iterate (const Rnd.nextCG32) + (return ()) ((+1) . flip mod (Rnd.modulus-1) ^<< seed) + + +-- * conversion from and to storable vectors + +fromStorableVector :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + Param.T p (SV.Vector a) -> + T p value +fromStorableVector selectVec = + Cons + (\() (p0,l0) -> do + cont <- Maybe.lift $ A.icmp IntUGT l0 (valueOf 0) + Maybe.withBool cont $ do + y1 <- Rep.load p0 + p1 <- advanceArrayElementPtr p0 + l1 <- A.dec l0 + return (y1,(p1,l1))) + return + (\p -> + let (fp,s,l) = SVB.toForeignPtr $ Param.get selectVec p + in return (fp, + ((), + (Rep.castStorablePtr $ unsafeForeignPtrToPtr fp `advancePtr` s, + fromIntegral l :: Word32)))) + -- keep the foreign ptr alive + touchForeignPtr + +{- +This function calls back into the Haskell function 'ChunkIt.next' +that returns a pointer to the data of the next chunk +and advances to the next chunk in the sequence. +-} +fromStorableVectorLazy :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + Param.T p (SVL.Vector a) -> + T p value +fromStorableVectorLazy sig = + Cons + (\(stable, lenPtr) (buffer0,length0) -> do + (buffer1,length1) <- Maybe.lift $ do + nextChunkFn <- staticFunction ChunkIt.nextCallBack + needNext <- A.icmp IntEQ length0 (valueOf 0) + ifThen needNext (buffer0,length0) + (liftM2 (,) + (call nextChunkFn stable lenPtr) + (load lenPtr)) + valid <- Maybe.lift $ A.icmp IntNE buffer1 (valueOf nullPtr) + Maybe.withBool valid $ do + x <- Rep.load buffer1 + buffer2 <- advanceArrayElementPtr buffer1 + length2 <- A.dec length1 + return (x, (buffer2,length2))) + (\() -> return (valueOf nullPtr, valueOf 0)) + (\p -> do + s <- liftM2 (,) (ChunkIt.new (Param.get sig p)) Alloc.malloc + return (s, (s,()))) + (\(stable,lenPtr) -> do + ChunkIt.dispose stable + Alloc.free lenPtr) + + +piecewiseConstant :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct, IsSized struct size) => + Param.T p (EventList.T NonNeg.Int a) -> + T p value +piecewiseConstant evs = + Cons + (\(stable, yPtr) (y0,length0) -> do + (y1,length1) <- Maybe.lift $ do + nextFn <- staticFunction EventIt.nextCallBack + needNext <- A.icmp IntEQ length0 (valueOf 0) + ifThen needNext (y0,length0) + (fmap swap $ + liftM2 (,) + (call nextFn stable yPtr) + (Rep.load yPtr)) + Maybe.guard =<< + Maybe.lift (A.icmp IntNE length1 (valueOf 0)) + length2 <- Maybe.lift (A.dec length1) + return (y1, (y1,length2))) + (\() -> return (undefTuple, valueOf 0)) + (\p -> do + stable <- EventIt.new (Param.get evs p) + yPtr <- Alloc.malloc + return ((stable, asTypeOfEventListElement yPtr evs), + ((stable, Rep.castStorablePtr yPtr), ()))) + (\(stable,yPtr) -> do + EventIt.dispose stable + Alloc.free yPtr) + +asTypeOfEventListElement :: + Ptr a -> + Param.T p (EventList.T NonNeg.Int a) -> + Ptr a +asTypeOfEventListElement ptr _ = ptr + + + +{- | +Turns a lazy chunky size into a signal generator with unit element type. +The signal length is the only information that the generator provides. +Using 'zipWith' you can use this signal as a lazy 'take'. +-} +lazySize :: + Param.T p SVP.LazySize -> + T p () +lazySize size = + Cons + (\stable length0 -> do + length1 <- Maybe.lift $ do + nextFn <- staticFunction SizeIt.nextCallBack + needNext <- A.icmp IntEQ length0 (valueOf 0) + ifThen needNext length0 + (call nextFn stable) + Maybe.guard =<< + Maybe.lift (A.icmp IntNE length1 (valueOf 0)) + length2 <- Maybe.lift (A.dec length1) + return ((), length2)) + (\() -> return (valueOf 0)) + (\p -> do + stable <- SizeIt.new (Param.get size p) + return (stable, (stable, ()))) + (\stable -> + SizeIt.dispose stable) + + +foreign import ccall safe "dynamic" derefFillPtr :: + Exec.Importer (Ptr param -> Word32 -> Ptr a -> IO Word32) + +run :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + T p value -> + IO (Int -> p -> SV.Vector a) +run (Cons next start createIOContext deleteIOContext) = + do -- this compiles once and is much faster than simpleFunction + fill <- + fmap derefFillPtr . + Exec.compileModule . + createFunction ExternalLinkage $ + \paramPtr size bPtr -> do + (nextParam,startParam) <- Rep.load paramPtr + s <- start startParam + (pos,_) <- Maybe.arrayLoop size bPtr s $ \ ptri s0 -> do + (y,s1) <- next nextParam s0 + Maybe.lift $ Rep.store y ptri + return s1 + ret (pos :: Value Word32) + + return $ \len p -> + unsafePerformIO $ + bracket (createIOContext p) (deleteIOContext . fst) $ + \ (_,params) -> + SVB.createAndTrim len $ \ ptr -> + Alloc.alloca $ \paramPtr -> + poke paramPtr params >> + (fmap fromIntegral $ + fill (Rep.castStorablePtr paramPtr) + (fromIntegral len) (Rep.castStorablePtr ptr)) + +{- | +This is not really a function, see 'renderChunky'. +-} +render :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + T p value -> Int -> p -> SV.Vector a +render gen = unsafePerformIO $ run gen + + +foreign import ccall safe "dynamic" derefChunkPtr :: + Exec.Importer (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32) + + +compileChunky :: + (Rep.Memory value struct, + Rep.Memory state stateStruct, + IsSized stateStruct stateSize, + Rep.Memory startParamValue startParamStruct, + Rep.Memory nextParamValue nextParamStruct, + IsSized startParamStruct startParamSize, + IsSized nextParamStruct nextParamSize) => + (forall r. + nextParamValue -> + state -> Maybe.T r (Value Bool, state) (value, state)) -> + (forall r. + startParamValue -> + CodeGenFunction r state) -> + IO (FunPtr (Ptr startParamStruct -> IO (Ptr stateStruct)), + FunPtr (Ptr stateStruct -> IO ()), + FunPtr (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)) +compileChunky next start = + Exec.compileModule $ + liftM3 (,,) + (createFunction ExternalLinkage $ + \paramPtr -> do + -- danger: size computation in LLVM currently does not work for structs! + pptr <- Rep.malloc + flip Rep.store pptr =<< start =<< Rep.load paramPtr + ret pptr) + (createFunction ExternalLinkage $ + \ pptr -> Rep.free pptr >> ret ()) + (createFunction ExternalLinkage $ + \ paramPtr sptr loopLen ptr -> do + param <- Rep.load paramPtr + sInit <- Rep.load sptr + (pos,sExit) <- Maybe.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do + (y,s1) <- next param s0 + Maybe.lift $ Rep.store y ptri + return s1 + Rep.store sExit sptr + ret (pos :: Value Word32)) + + +{- | +Renders a signal generator to a chunky storable vector with given pattern. +If the pattern is shorter than the generated signal +this means that the signal is shortened. +-} +runChunkyPattern :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + T p value -> + IO (SVP.LazySize -> p -> SVL.Vector a) +runChunkyPattern (Cons next start createIOContext deleteIOContext) = do + (startFunc, stopFunc, fill) <- compileChunky next start + return $ + \ lazysize p -> SVL.fromChunks $ unsafePerformIO $ do + (ioContext, (nextParam, startParam)) <- createIOContext p + + statePtr <- Rep.newForeignPtrParam stopFunc startFunc startParam + nextParamPtr <- Rep.newForeignPtr (deleteIOContext ioContext) nextParam + + let go cs = + unsafeInterleaveIO $ + case cs of + [] -> return [] + SVL.ChunkSize size : rest -> do + v <- + withForeignPtr statePtr $ \sptr -> + Rep.withForeignPtr nextParamPtr $ \nptr -> + SVB.createAndTrim size $ + fmap fromIntegral . + derefChunkPtr fill nptr sptr (fromIntegral size) . + Rep.castStorablePtr + (if SV.length v > 0 + then fmap (v:) + else id) $ + (if SV.length v < size + then return [] + else go rest) + go (Chunky.toChunks lazysize) + +runChunky :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + T p value -> + IO (SVL.ChunkSize -> p -> SVL.Vector a) +runChunky sig = + flip fmap (runChunkyPattern sig) $ \f size p -> + f (Chunky.fromChunks (repeat size)) p + +{- | +This looks like a function, +but it is not a function since it depends on LLVM being initialized +with LLVM.initializeNativeTarget before. +It is also problematic since you cannot control when and how often +the underlying LLVM code is compiled. +The compilation cannot be observed, thus it is referential transparent. +But this influences performance considerably +and I assume that you use this package exclusively for performance reasons. +-} +renderChunky :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + SVL.ChunkSize -> T p value -> + p -> SVL.Vector a +renderChunky size gen = + unsafePerformIO (runChunky gen) size diff --git a/src/Synthesizer/LLVM/Parameterized/SignalPacked.hs b/src/Synthesizer/LLVM/Parameterized/SignalPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Parameterized/SignalPacked.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{- | +Signal generators that generate the signal in chunks +that can be processed natively by the processor. +Some of the functions for plain signals can be re-used without modification. +E.g. rendering a signal and reading from and to signals work +because the vector type as element type warrents correct alignment. +We can convert between atomic and chunked signals. + +The article + +explains the difference between Vector and SIMD computing. +According to that the SSE extensions in Intel processors +must be called Vector computing. +But since we use the term Vector already in the mathematical sense, +I like to use the term "packed" that is used in Intel mnemonics like mulps. +-} +module Synthesizer.LLVM.Parameterized.SignalPacked where + +import Synthesizer.LLVM.Parameterized.Signal (T(Cons), ) +import qualified Synthesizer.LLVM.Parameterized.Signal as Sig +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified Synthesizer.LLVM.Random as Rnd +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.MaybeContinuation as Maybe +import qualified LLVM.Extra.Control as U +import LLVM.Extra.Control (whileLoop, ) + +import qualified Data.TypeLevel.Num as TypeNum + +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Arithmetic as A + +import LLVM.Core as LLVM + +-- we can also use <$> for parameters +import Control.Arrow ((^<<), ) +import Control.Applicative (liftA2, ) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import Data.Word (Word32, ) +import Foreign.Storable (Storable, ) + +import qualified Data.List as List + +import NumericPrelude.Numeric as NP +import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, ) + + + +{- | +Convert a signal of scalar values into one using processor vectors. +If the signal length is not divisible by the chunk size, +then the last chunk is dropped. +-} +pack, packRotate, packIndex :: + (Vector.Access n a v) => + T p a -> T p v +pack = packRotate + +packRotate (Cons next start createIOContext deleteIOContext) = Cons + (\param s -> do + (v2,_,s2) <- + Maybe.fromBool $ + U.whileLoop + (valueOf True, + let v = undefTuple + in (v, valueOf $ (fromIntegral $ Vector.sizeInTuple v :: Word32), s)) + (\(cont,(_v0,i0,_s0)) -> + A.and cont =<< + A.icmp IntUGT i0 (value LLVM.zero)) + (\(_,(v0,i0,s0)) -> Maybe.toBool $ do + (a,s1) <- next param s0 + Maybe.lift $ do + v1 <- fmap snd $ Vector.shiftDown a v0 + i1 <- A.dec i0 + return (v1,i1,s1)) + return (v2, s2)) + start + createIOContext + deleteIOContext + +packIndex (Cons next start createIOContext deleteIOContext) = Cons + (\param s -> do + (v2,_,s2) <- + Maybe.fromBool $ + U.whileLoop + (valueOf True, (undefTuple, value LLVM.zero, s)) + (\(cont,(v0,i0,_s0)) -> + A.and cont =<< + A.icmp IntULT i0 + (valueOf $ fromIntegral $ Vector.sizeInTuple v0)) + (\(_,(v0,i0,s0)) -> Maybe.toBool $ do + (a,s1) <- next param s0 + Maybe.lift $ do + v1 <- Vector.insert i0 a v0 + i1 <- A.inc i0 + return (v1,i1,s1)) + return (v2, s2)) + start + createIOContext + deleteIOContext + + +{- | +Like 'pack' but duplicates the code for creating elements. +That is, for vectors of size n, the code of the input signal +will be emitted n times. +This is efficient only for simple input generators. +-} +packSmall :: + (Vector.Access n a v, Class.Zero v) => + T p a -> T p v +packSmall (Cons next start createIOContext deleteIOContext) = Cons + (\param s -> + let vundef = undefTuple + in foldr + (\i rest (v0,s0) -> do + (a,s1) <- next param s0 + v1 <- Maybe.lift $ Vector.insert (valueOf i) a v0 + rest (v1,s1)) + return + (take (Vector.sizeInTuple vundef) [0..]) + (vundef, s)) + start + createIOContext + deleteIOContext + + +unpack, unpackRotate, unpackIndex :: + (Vector.Access n a v, Rep.Memory v vp, IsSized vp vs) => + T p v -> T p a +unpack = unpackRotate + +unpackRotate (Cons next start createIOContext deleteIOContext) = Cons + (\param (i0,v0,s0) -> do + endOfVector <- + Maybe.lift $ A.icmp IntEQ i0 (valueOf 0) + (i2,v2,s2) <- + Maybe.fromBool $ + U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do + (cont1, (v1,s1)) <- Maybe.toBool $ next param s0 + return (cont1, (valueOf $ fromIntegral $ Vector.sizeInTuple v0, v1, s1)) + Maybe.lift $ do + a <- Vector.extract (valueOf 0 `asTypeOf` i0) v2 + v3 <- Vector.rotateDown v2 + i3 <- A.dec i2 + return (a, (i3,v3,s2))) + (\p -> do + s <- start p + return (valueOf 0, undefTuple, s)) + createIOContext + deleteIOContext + +unpackIndex (Cons next start createIOContext deleteIOContext) = Cons + (\param (i0,v0,s0) -> do + endOfVector <- + Maybe.lift $ A.icmp IntUGE i0 + (valueOf $ fromIntegral $ Vector.sizeInTuple v0) + (i2,v2,s2) <- + Maybe.fromBool $ + U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do + (cont1, (v1,s1)) <- Maybe.toBool $ next param s0 + return (cont1, (value LLVM.zero, v1, s1)) + Maybe.lift $ do + a <- Vector.extract i2 v2 + i3 <- A.inc i2 + return (a, (i3,v2,s2))) + (\p -> do + s <- start p + let v = undefTuple + return (valueOf $ fromIntegral $ Vector.sizeInTuple v, v, s)) + createIOContext + deleteIOContext + + +withSize :: + (n -> T p (Value (Vector n a))) -> + T p (Value (Vector n a)) +withSize f = f undefined + + +constant :: + (Storable a, MakeValueTuple a (Value a), + IsConst a, IsPrimitive a, + IsPowerOf2 n, IsSized (Vector n a) s) => +-- IsPowerOf2 n, IsSized a s, TypeNum.Pos vs, TypeNum.Mul n s vs) => + Param.T p a -> T p (Value (Vector n a)) +constant x = + Sig.constant (LLVM.vector . (:[]) ^<< x) + + +exponential2 :: + (Trans.C a, Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a s, IsSized (Vector n a) vs, + IsPrimitive a, IsArithmetic a, IsConst a, + IsPowerOf2 n) => + Param.T p a -> Param.T p a -> T p (Value (Vector n a)) +exponential2 halfLife start = withSize $ \n -> + Sig.exponentialCore + (LLVM.vector . (:[]) ^<< + 0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife)) + (liftA2 + (\h -> LLVM.vector . List.iterate (0.5 ** recip h *)) + halfLife start) + +exponentialBounded2 :: + (Trans.C a, Storable a, MakeValueTuple a (Value a), + IsFirstClass a, IsSized a s, IsSized (Vector n a) vs, + IsPrimitive a, Vector.Real a, IsConst a, + IsPowerOf2 n) => + Param.T p a -> Param.T p a -> Param.T p a -> + T p (Value (Vector n a)) +exponentialBounded2 bound halfLife start = withSize $ \n -> + Sig.exponentialBoundedCore + (fmap (LLVM.vector . (:[])) bound) + (LLVM.vector . (:[]) ^<< + 0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife)) + (liftA2 + (\h -> LLVM.vector . List.iterate (0.5 ** recip h *)) + halfLife start) + + +osciCore :: + (Storable t, MakeValueTuple t (Value t), + IsFirstClass t, IsSized t size, IsSized (Vector n t) vsize, + Vector.Real t, IsFloating t, RealField.C t, IsConst t, + IsPowerOf2 n) => + Param.T p t -> Param.T p t -> T p (Value (Vector n t)) +osciCore phase freq = withSize $ \n -> + Sig.osciCore + (liftA2 + (\f -> LLVM.vector . List.iterate (fraction . (f +))) + freq phase) + (fmap + (\f -> LLVM.vector [fraction (fromIntegral (TypeNum.toInt n) * f)]) + freq) + +osci :: + (Storable t, MakeValueTuple t (Value t), + Storable c, MakeValueTuple c cl, + IsFirstClass t, IsSized t size, IsSized (Vector n t) vsize, + Rep.Memory cl cp, IsSized cp cs, + Vector.Real t, IsFloating t, RealField.C t, IsConst t, + IsPowerOf2 n) => + (forall r. cl -> Value (Vector n t) -> CodeGenFunction r y) -> + Param.T p c -> + Param.T p t -> Param.T p t -> T p y +osci wave waveParam phase freq = + Sig.map wave waveParam $ + osciCore phase freq + +osciSimple :: + (Storable t, MakeValueTuple t (Value t), + IsFirstClass t, IsSized t size, IsSized (Vector n t) vsize, + Vector.Real t, IsFloating t, RealField.C t, IsConst t, + IsPowerOf2 n) => + (forall r. Value (Vector n t) -> CodeGenFunction r y) -> + Param.T p t -> Param.T p t -> T p y +osciSimple wave = + osci (const wave) (return ()) + + +rampInf, rampSlope, + parabolaFadeInInf, parabolaFadeOutInf :: + (RealField.C a, Storable a, MakeValueTuple a (Value a), + IsPrimitive a, IsArithmetic a, IsConst a, + IsPowerOf2 n, IsSized (Vector n a) s) => + Param.T p a -> T p (Value (Vector n a)) +rampSlope slope = withSize $ \n -> + Sig.rampCore + (fmap (\s -> LLVM.vector [fromIntegral (TypeNum.toInt n) * s]) slope) + (fmap (\s -> LLVM.vector (List.iterate (s +) 0)) slope) +rampInf dur = rampSlope (recip dur) + +parabolaFadeInInf dur = withSize $ \ni -> + let n = fromIntegral (TypeNum.toInt ni) + in Sig.parabolaCore + (fmap + (\dr -> + let d = n / dr + in LLVM.vector [-2*d*d]) dur) + (fmap + (\dr -> + let d = n / dr + in LLVM.vector $ List.iterate (subtract $ 2 / dr ^ 2) (d*(2-d))) + dur) + (fmap + (\dr -> + LLVM.vector $ List.map (\t -> t*(2-t)) $ List.iterate (recip dr +) 0) + dur) + +parabolaFadeOutInf dur = withSize $ \ni -> + let n = fromIntegral (TypeNum.toInt ni) + in Sig.parabolaCore + (fmap + (\dr -> + let d = n / dr + in LLVM.vector [-2*d*d]) dur) + (fmap + (\dr -> + let d = n / dr + in LLVM.vector $ List.iterate (subtract $ 2 / dr ^ 2) (-d*d)) + dur) + (fmap + (\dr -> + LLVM.vector $ List.map (\t -> 1-t*t) $ List.iterate (recip dr +) 0) + dur) + + +{- | +For the mysterious rate parameter see 'Sig.noise'. +-} +noise :: + (Algebraic.C a, IsFloating a, IsConst a, IsPrimitive a, + IsPowerOf2 n, IsSized (Vector n Word32) s, + IsSized a as, TypeNum.Mul n as vas, TypeNum.Pos vas, + MakeValueTuple a (Value a), Storable a) => + Param.T p Word32 -> + Param.T p a -> + T p (Value (Vector n a)) +noise seed rate = + let m2 = fromInteger $ div Rnd.modulus 2 + in Sig.map (\r y -> + A.mul r + =<< flip A.sub (SoV.replicateOf $ m2+1) + {- + In principle it must be uitofp, + but sitofp is a single instruction on x86 + and our numbers are below 2^31. + -} + =<< sitofp y) + (LLVM.vector . (:[]) ^<< sqrt (3 * rate) / return m2) $ + noiseCore seed + +noiseCore, noiseCoreAlt :: + (IsPowerOf2 n, IsSized (Vector n Word32) s) => + Param.T p Word32 -> + T p (Value (Vector n Word32)) +noiseCore seed = + Sig.iterate (const Rnd.nextVector) + (return ()) + (Rnd.vectorSeed . (+1) . flip mod (Rnd.modulus-1) ^<< seed) + +noiseCoreAlt seed = + Sig.iterate (const Rnd.nextVector64) + (return ()) + (Rnd.vectorSeed . (+1) . flip mod (Rnd.modulus-1) ^<< seed) diff --git a/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs b/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Parameterized.SignalPrivate where + +import qualified Synthesizer.LLVM.Parameter as Param +import qualified LLVM.Extra.MaybeContinuation as Maybe +import qualified LLVM.Extra.Representation as Rep + +import LLVM.Core (MakeValueTuple, IsSized, CodeGenFunction, ) +import LLVM.Util.Loop (Phi, ) + +import Control.Arrow ((&&&), ) + +import Foreign.Storable (Storable, ) + +import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, ) + + +{- +In this attempt we use a Haskell value as parameter supply. +This is okay, since the Haskell value will be converted to internal parameters +and then to LLVM values only once. +We can even have a storable vector as parameter. +However, this way we cannot easily implement +the Vanilla signal using Parameterized.Value as element type. + +This separation is nice for maximum efficiency, +but it cannot be utilized by Generic.Signal methods. +Consider an expression like @iterate ((0.5 ** recip halfLife) *) 1@. +How shall we know, that the sub-expression @(0.5 ** recip halfLife)@ +needs to be computated only once? +I do not try to do such optimization, instead I let LLVM do it. +However, this means that parameter initialization +will be performed (unnecessarily) at the beginning of every chunk. +For Generic.Signal method instances +we will always set the @(p -> paramTuple)@ to 'id'. + +Could we drop parameterized signals at all +and rely entirely on Causal processes? +Unfortunately 'interpolateConstant' does not fit into the Causal process scheme. +(... although it would be causal for stretching factor being at least one. +It would have to maintain the waiting signal as state, +i.e. the state would grow linearly with time.) +Consider a signal algorithm, where the LFO frequency is a parameter. +-} +data T p a = + forall state packed size ioContext + startParamTuple startParamValue startParamPacked startParamSize + nextParamTuple nextParamValue nextParamPacked nextParamSize. + (Storable startParamTuple, + Storable nextParamTuple, + MakeValueTuple startParamTuple startParamValue, + MakeValueTuple nextParamTuple nextParamValue, + Rep.Memory startParamValue startParamPacked, + Rep.Memory nextParamValue nextParamPacked, + IsSized startParamPacked startParamSize, + IsSized nextParamPacked nextParamSize, + Rep.Memory state packed, + IsSized packed size) => + Cons + (forall r c. + (Phi c) => + nextParamValue -> + state -> Maybe.T r c (a, state)) + -- compute next value + (forall r. + startParamValue -> + CodeGenFunction r state) + -- initial state + (p -> IO (ioContext, (nextParamTuple, startParamTuple))) + {- initialization from IO monad + This will be run within unsafePerformIO, + so no observable In/Out actions please! + -} + (ioContext -> IO ()) + -- finalization from IO monad, also run within unsafePerformIO + +simple :: + (Storable startParamTuple, + Storable nextParamTuple, + MakeValueTuple startParamTuple startParamValue, + MakeValueTuple nextParamTuple nextParamValue, + Rep.Memory startParamValue startParamPacked, + Rep.Memory nextParamValue nextParamPacked, + IsSized startParamPacked startParamSize, + IsSized nextParamPacked nextParamSize, + Rep.Memory state packed, + IsSized packed size) => + (forall r c. + (Phi c) => + nextParamValue -> + state -> Maybe.T r c (al, state)) -> + (forall r. + startParamValue -> + CodeGenFunction r state) -> + Param.T p nextParamTuple -> + Param.T p startParamTuple -> T p al +simple f start selectParam initial = Cons + (f . Param.value selectParam) + (start . Param.value initial) + (return . (,) () . Param.get (selectParam &&& initial)) + (const $ return ()) + + +map :: + (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) => + (forall r. pl -> a -> CodeGenFunction r b) -> + Param.T p ph -> + T p a -> T p b +map f selectParamF + (Cons next start createIOContext deleteIOContext) = + Cons + (\(parameterF, parameter) sa0 -> do + (a,sa1) <- next parameter sa0 + b <- Maybe.lift $ f (Param.value selectParamF parameterF) a + return (b, sa1)) + start + (\p -> do + (ioContext, (nextParam, startParam)) <- createIOContext p + return (ioContext, ((Param.get selectParamF p, nextParam), startParam))) + deleteIOContext + +mapSimple :: + (forall r. a -> CodeGenFunction r b) -> + T p a -> T p b +mapSimple f = map (const f) (return ()) + + +instance Functor (T p) where + fmap f = mapSimple (return . f) + + +iterate :: + (Storable ph, MakeValueTuple ph pl, + Rep.Memory pl pp, IsSized pp ps, + Storable a, MakeValueTuple a al, + Rep.Memory al packed, IsSized packed s) => + (forall r. pl -> al -> CodeGenFunction r al) -> + Param.T p ph -> + Param.T p a -> T p al +iterate f selectParam initial = simple + (\pl al0 -> + Maybe.lift $ fmap (\al1 -> (al0,al1)) (f pl al0)) + return + selectParam + initial diff --git a/src/Synthesizer/LLVM/Parameterized/Value.hs b/src/Synthesizer/LLVM/Parameterized/Value.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Parameterized/Value.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module Synthesizer.LLVM.Parameterized.Value where + +import qualified Synthesizer.LLVM.Simple.Value as Value + +import LLVM.Core hiding (zero, ) +import LLVM.Util.Arithmetic (TValue, ) +import qualified LLVM.Util.Arithmetic as Arith + +{- +import qualified Synthesizer.Basic.Phase as Phase +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import Control.Monad (liftM2, liftM3, ) +-} + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +-- import qualified Algebra.RealRing as RealRing +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (map, zipWith, writeFile, ) + + +newtype T p a = Cons {decons :: forall r. p -> TValue r a} + +instance (Additive.C a, IsArithmetic a, IsConst a) => + Additive.C (T p a) where + zero = lift0 zero + (+) = lift2 (+) + (-) = lift2 (-) + negate = lift1 negate + +instance (Ring.C a, IsArithmetic a, IsConst a) => + Ring.C (T p a) where + one = lift0 one + (*) = lift2 (*) + fromInteger = constant . fromInteger + +instance (Ring.C a, IsArithmetic a, IsConst a) => Enum (T p a) where + succ x = x + one + pred x = x - one + fromEnum _ = error "CodeGenFunction Value: fromEnum" + toEnum = fromIntegral + +{- +instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (T p a) where + toRational _ = error "CodeGenFunction Value: toRational" + +instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (T p a) where + quot = binop (if (isSigned (undefined :: a)) then sdiv else udiv) + rem = binop (if (isSigned (undefined :: a)) then srem else urem) + quotRem x y = (quot x y, rem x y) + toInteger _ = error "CodeGenFunction Value: toInteger" +-} + +instance (Field.C a, IsConst a, IsFloating a) => Field.C (T p a) where + (/) = lift2 (/) + fromRational' = constant . fromRational' + +{- +instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (T p a) where + properFraction _ = error "CodeGenFunction Value: properFraction" +-} + +instance (Algebraic.C a, IsConst a, IsFloating a) => Algebraic.C (T p a) where + sqrt = lift1 sqrt + +instance (Trans.C a, IsConst a, IsFloating a) => Trans.C (T p a) where + pi = constant pi + sin = lift1 sin + cos = lift1 cos + tan = lift1 tan + + asin = lift1 asin + acos = lift1 acos + atan = lift1 atan + + sinh = lift1 sinh + cosh = lift1 cosh + asinh = lift1 asinh + acosh = lift1 acosh + atanh = lift1 atanh + + (**) = lift2 (**) + exp = lift1 exp + log = lift1 log + + +twoPi :: + (Trans.C a, IsConst a, IsFloating a) => + T p a +twoPi = 2*pi +{- +twoPi :: + (Cmp a b, P.Floating a, IsConst a, IsFloating a) => + TValue r a +twoPi = P.fromInteger 2 P.* P.pi +-} + + +lift0 :: Value.T a -> T p a +lift0 x = + Cons $ const $ Value.decons x + +lift1 :: (Value.T a -> Value.T b) -> (T p a -> T p b) +lift1 f x = + Cons (\p -> Value.decons $ f (Value.Cons $ decons x p)) + +lift2 :: (Value.T a -> Value.T b -> Value.T c) -> (T p a -> T p b -> T p c) +lift2 f x y = + Cons $ \p -> Value.decons $ + f (Value.Cons $ decons x p) (Value.Cons $ decons y p) + + +constantValue :: Value a -> T p a +constantValue x = + Cons (const $ return x) + +constant :: (IsConst a) => a -> T p a +constant = constantValue . valueOf + +choose :: (IsConst a) => (p -> a) -> T p a +choose x = + Cons (return . valueOf . x) diff --git a/src/Synthesizer/LLVM/Random.hs b/src/Synthesizer/LLVM/Random.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Random.hs @@ -0,0 +1,379 @@ +{- | +Very simple random number generator according to Knuth +which should be fast and should suffice for generating just noise. + +-} +module Synthesizer.LLVM.Random where + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector + +import qualified LLVM.Extra.Extension.X86 as X86 +import qualified LLVM.Extra.Extension as Ext + +import qualified LLVM.Extra.Arithmetic as A + +import LLVM.Core as LLVM +import qualified Data.TypeLevel.Num as TypeNum + +import Data.Function.HT (nest, ) + +import Data.Word (Word32, Word64, ) + + +factor :: Integral a => a +factor = 40692 + +modulus :: Integral a => a +modulus = 2147483399 -- 2^31-249 + +{- +We have to split the 32 bit integer in order to avoid overflow on multiplication. +'split' must be chosen, such that 'splitRem' is below 2^16. +-} +split :: Word32 +split = succ $ div modulus factor + +splitRem :: Word32 +splitRem = split * factor - modulus + + +{- | +efficient computation of @mod (s*factor) modulus@ +without Integer or Word64, as in 'next64'. +-} +next :: Word32 -> Word32 +next s = + let (sHigh, sLow) = divMod s split + in flip mod modulus $ + splitRem*sHigh + factor*sLow + +next64 :: Word32 -> Word32 +next64 s = + fromIntegral $ + flip mod modulus $ + factor * (fromIntegral s :: Word64) + +nextCG32 :: Value Word32 -> CodeGenFunction r (Value Word32) +nextCG32 s = do + sHigh <- A.mul (valueOf splitRem) =<< udiv s split + sLow <- A.mul (valueOf factor) =<< urem s split + flip A.urem (valueOf modulus) =<< A.add sHigh sLow + +nextCG64 :: Value Word32 -> CodeGenFunction r (Value Word32) +nextCG64 s = + trunc =<< + {- + This is slow on x86 since the native @div@ is not used + since LLVM wants to prevent overflow. + We know that there cannot be an overflow, + but I do not know how to tell LLVM. + -} + flip A.urem (valueOf (modulus :: Word64)) =<< + A.mul (valueOf factor) =<< + zext s + +nextCG :: Value Word32 -> CodeGenFunction r (Value Word32) +nextCG s = do + x <- A.mul (valueOf $ factor :: Value Word64) =<< zext s + {- + split 64 result between bit 30 and bit 31 + we cannot split above bit 31, + since then 'low' can be up to 2^32-1 + and then later addition overflows. + -} + let p2e31 = 2^(31::Int) + low <- A.and (valueOf $ p2e31-1) =<< trunc x + high <- trunc =<< flip lshr (valueOf (31 :: Word64)) x + -- fac = mod (2^31) modulus + let fac = p2e31 - modulus + {- + fac < 250 + high < factor + fac*high < factor*250 + low < 2^31 + low + fac*high + < 2^31 + factor*250 + < 2*modulus + Thus modulo by modulus needs at most one subtraction. + -} + prodMod <- A.add low =<< A.mul (valueOf fac) high + prodModS <- A.sub prodMod (valueOf modulus) + b <- A.icmp IntSLT prodModS (value zero) + select b prodMod prodModS + + +{- +How to vectorise? +E.g. by repeated distribution of modulus and split at bit 31. +Can we replace div by modulus by mul with (2^31+249) ? +-} +vectorParameter :: + Integral a => + Int -> a +vectorParameter n = + fromIntegral $ nest n next 1 + +vectorSeed :: + (IsPowerOf2 n) => + Word32 -> Vector n Word32 +vectorSeed seed = + let n = Vector.size $ valueOf v + v = vector $ take n $ iterate next seed + in v + +vector64 :: Value (Vector n Word64) -> Value (Vector n Word64) +vector64 = id + +nextVector :: + (IsPowerOf2 n) => + Value (Vector n Word32) -> + CodeGenFunction r (Value (Vector n Word32)) +nextVector s = + Ext.run (nextVectorGeneric s) $ + Ext.with nextVector4X86 $ \nextChunk -> + Vector.mapChunks (nextChunk (Vector.size s)) s + +{- | +This needs only a third of the code of nextVectorGeneric for Vector D4 +(37 instructions vs. 110 instructions) +because it arranges data more sensibly: +It de-interleaves the vector and truncates from 64 bit to 32 bit in-place. +-} +nextVector4X86 :: + Ext.T + (Int -> + Value (Vector TypeNum.D4 Word32) -> + CodeGenFunction r (Value (Vector TypeNum.D4 Word32))) +nextVector4X86 = + Ext.with X86.pmuludq $ \muludq n s -> do + let prepConstFactor x = + value $ constVector [constOf x, undef] + + fac = 2^(31::Int) - modulus + + mulAndReduce x = do + (low0, high0) <- + splitVector31to64 =<< + muludq (prepConstFactor (vectorParameter n)) x + + splitVector31to64 =<< + A.add low0 =<< + muludq (prepConstFactor fac) =<< + bitcast high0 + + (lowEven, highEven) <- + mulAndReduce =<< + shufflevector s (value undef) + (constVector [constOf 0, undef, constOf 2, undef]) + + (lowOdd, highOdd) <- + mulAndReduce =<< + shufflevector s (value undef) + (constVector [constOf 1, undef, constOf 3, undef]) + + low <- truncAndInterleave2x64to4x32 lowEven lowOdd + high <- truncAndInterleave2x64to4x32 highEven highOdd + + prodMod <- + A.add low =<< + -- more efficient for Word32 on x86 than LLVM-2.6's mul + Vector.mul (SoV.replicateOf fac) high + prodModS <- A.sub prodMod (SoV.replicateOf modulus) + + {- + An element should become smaller by subtraction. + If it becomes greater, then there was an overflow + and 'min' chooses the value before subtraction. + -} + Vector.min prodModS prodMod + +truncAndInterleave2x64to4x32 :: + Value (Vector TypeNum.D2 Word64) -> + Value (Vector TypeNum.D2 Word64) -> + CodeGenFunction r (Value (Vector TypeNum.D4 Word32)) +truncAndInterleave2x64to4x32 even2x64 odd2x64 = do + even4x32 <- bitcast even2x64 + odd4x32 <- bitcast odd2x64 + LLVM.shufflevector even4x32 odd4x32 + (constVector [constOf 0, constOf 4, constOf 2, constOf 6]) + + +{- +This will access MMX registers. +-} +nextVector2X86 :: + Ext.T + (Int -> + Value (Vector TypeNum.D2 Word32) -> + CodeGenFunction r (Value (Vector TypeNum.D2 Word32))) +nextVector2X86 = + Ext.with X86.pmuludq $ \muludq n s -> do + let prepConstFactor x = + value $ constVector [constOf x, undef] + (low0, high0) <- + splitVector31to64 =<< + muludq (prepConstFactor (vectorParameter n)) =<< + Vector.shuffle s + (constVector [constOf 0, undef, constOf 1, undef]) + -- fac = mod (2^31) modulus + let fac = 2^(31::Int) - modulus + (low1, high1) <- + splitVector31to64 =<< + A.add low0 =<< + muludq (prepConstFactor fac) =<< + bitcast high0 + + prodMod64 <- + A.add low1 =<< + muludq (prepConstFactor fac) =<< + bitcast high1 + +-- prodMod <- Vector.map trunc prodMod64 +-- prodModS <- A.sub prodMod (SoV.replicateOf modulus) +-- Vector.min prodModS prodMod + +{- + prodMod64as32 <- bitcast prodMod64 + prodMod <- Vector.shuffle + (prodMod64as32 :: Value (Vector TypeNum.D4 Word32)) + (constVector $ map constOf [0,2]) + + prodModS <- A.sub prodMod (SoV.replicateOf modulus) +-} + + prodMod <- bitcast prodMod64 + prodModS <- A.sub prodMod (prepConstFactor modulus) + + {- + An element should become smaller by subtraction. + If it becomes greater, then there was an overflow + and 'min' chooses the value before subtraction. + -} + result <- Vector.min prodModS prodMod + Vector.shuffle + (result :: Value (Vector TypeNum.D4 Word32)) + (constVector $ map constOf [0,2]) + +splitVector31to64 :: + (IsPowerOf2 n) => + Value (Vector n Word64) -> + CodeGenFunction r (Value (Vector n Word64), Value (Vector n Word64)) +splitVector31to64 x = do + low <- A.and (SoV.replicateOf (2^(31::Int)-1)) x + high <- flip lshr (SoV.replicateOf 31 `asTypeOf` x) x + return (low, high) + +{- +In case of a vector random generator the factor depends on the vector size +and thus we cannot do optimizations on a constant factor as in nextCG. +Thus we just compute the product @factor*seed@ as is +(this is of type @Word32 -> Word32 -> Word64@) +and try to compute @urem@ without using LLVM's @urem@ +that calls __umoddi3 on every element. +Instead we optimize on the constant modulus +and utilize that is slightly smaller than 2^31. + +We split the product: + factor*seed = high0*2^31 + low0 + +Now it is +mod (factor*seed) modulus + = mod (high0*2^31 + low0) modulus + = mod (high0 * mod (2^31) modulus + low0) modulus + = mod (high0 * 249 + low0) modulus + +However, high0 * 249 + low0 is still too big, +it can be up to (excluding) 2^31 * 250. +Thus we repeat the split +high0 * 249 + low0 = high1 * 2^31 + low1 + +It is high1 < 250, and thus high1*249 < 62500, +high1 * 249 + low1 < 2*modulus. +With x = high1 * 249 + low1 +we have +mod (factor*seed) modulus + = if x + Value (Vector n Word32) -> + CodeGenFunction r (Value (Vector n Word32)) +nextVectorGeneric s = do + {- + It seems that LLVM-2.6 on x86 does not make use of the fact, + that the upper doublewords are zero. + It seems to implement a full 64x64 multiplication in terms of pmuludq. + -} + (low0, high0) <- + splitVector31 =<< + Vector.umul32to64 (SoV.replicateOf (vectorParameter (Vector.size s))) s + -- fac = mod (2^31) modulus + let fac :: Integral a => a + fac = 2^(31::Int) - modulus + (low1, high1) <- + splitVector31 =<< + (\x -> A.add x =<< Vector.map zext low0) =<< + Vector.umul32to64 (SoV.replicateOf fac) high0 + + prodMod <- + A.add low1 =<< + Vector.mul (SoV.replicateOf fac) high1 + prodModS <- A.sub prodMod (SoV.replicateOf modulus) + + {- + An element should become smaller by subtraction. + If it becomes greater, then there was an overflow + and 'min' chooses the value before subtraction. + -} + Vector.min prodModS prodMod + -- alternatively (slower): + -- selectNonNegativeGeneric prodModS prodMod + +{- | +Select non-negative elements from the first vector, +otherwise select corresponding elements from the second vector. +-} +selectNonNegativeGeneric :: + (IsPowerOf2 n) => + Value (Vector n Word32) -> + Value (Vector n Word32) -> + CodeGenFunction r (Value (Vector n Word32)) +selectNonNegativeGeneric x y = do + b <- A.icmp IntSGE x (value zero) + Vector.select b x y + + +splitVector31 :: + (IsPowerOf2 n) => + Value (Vector n Word64) -> + CodeGenFunction r (Value (Vector n Word32), Value (Vector n Word32)) +splitVector31 x = do + low <- A.and (SoV.replicateOf (2^(31::Int)-1)) =<< Vector.map trunc x + high <- Vector.map trunc =<< flip lshr (SoV.replicateOf (31 :: Word64) `asTypeOf` x) x + return (low, high) + +{- | +This is the most obvious implementation +but unfortunately calls the expensive __umoddi3. +-} +nextVector64 :: + (IsPowerOf2 n) => + Value (Vector n Word32) -> + CodeGenFunction r (Value (Vector n Word32)) +nextVector64 s = + Vector.map trunc =<< + flip A.urem (SoV.replicateOf modulus) =<< + Vector.umul32to64 (SoV.replicateOf (vectorParameter (Vector.size s))) s diff --git a/src/Synthesizer/LLVM/Sample.hs b/src/Synthesizer/LLVM/Sample.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Sample.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.LLVM.Sample where + +import qualified LLVM.Extra.Vector as Vector + +import Foreign.Storable.Tuple () + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, valueOf, value, undef, + Vector, insertelement, extractelement, + IsPrimitive, IsPowerOf2, IsArithmetic, + CodeGenFunction, ) +import Data.TypeLevel.Num (D2, D4, ) + +import Data.Word (Word32, ) + +import Control.Monad (liftM2, ) + +import NumericPrelude.Numeric hiding (zero, ) +import NumericPrelude.Base + + +{- | +Copy mono signal to both stereo channels. +-} +stereoFromMono :: + Value a -> + CodeGenFunction r (Stereo.T (Value a)) +stereoFromMono x = + return $ Stereo.cons x x + +mixMonoFromStereo :: + (IsArithmetic a) => + Stereo.T (Value a) -> + CodeGenFunction r (Value a) +mixMonoFromStereo s = + mixMono (Stereo.left s) (Stereo.right s) + +zipStereo :: + Value a -> Value a -> + CodeGenFunction r (Stereo.T (Value a)) +zipStereo l r = + return (Stereo.cons l r) + + +stereoFromVector :: + (IsPrimitive a) => + Value (Vector D2 a) -> + CodeGenFunction r (Stereo.T (Value a)) +stereoFromVector x = + liftM2 Stereo.cons + (extractelement x (valueOf 0)) + (extractelement x (valueOf 1)) + +vectorFromStereo :: + (IsPrimitive a) => + Stereo.T (Value a) -> + CodeGenFunction r (Value (Vector D2 a)) +vectorFromStereo s = do + x <- insertelement (value undef) (Stereo.left s) (valueOf 0) + insertelement x (Stereo.right s) (valueOf 1) + + +quadroFromVector :: + (IsPrimitive a) => + Value (Vector D4 a) -> + CodeGenFunction r (Stereo.T (Stereo.T (Value a))) +quadroFromVector x = + liftM2 Stereo.cons + (liftM2 Stereo.cons + (extractelement x (valueOf 0)) + (extractelement x (valueOf 1))) + (liftM2 Stereo.cons + (extractelement x (valueOf 2)) + (extractelement x (valueOf 3))) + +vectorFromQuadro :: + (IsPrimitive a) => + Stereo.T (Stereo.T (Value a)) -> + CodeGenFunction r (Value (Vector D4 a)) +vectorFromQuadro s = do + let x0 = value undef + sl = Stereo.left s + sr = Stereo.right s + x1 <- insertelement x0 (Stereo.left sl) (valueOf 0) + x2 <- insertelement x1 (Stereo.right sl) (valueOf 1) + x3 <- insertelement x2 (Stereo.left sr) (valueOf 2) + insertelement x3 (Stereo.right sr) (valueOf 3) + + +mixMono :: + (IsArithmetic a) => + Value a -> Value a -> + CodeGenFunction r (Value a) +mixMono = A.add + +mixStereo :: + (IsArithmetic a) => + Stereo.T (Value a) -> Stereo.T (Value a) -> + CodeGenFunction r (Stereo.T (Value a)) +mixStereo x y = + liftM2 Stereo.cons + (A.add (Stereo.left x) (Stereo.left y)) + (A.add (Stereo.right x) (Stereo.right y)) + + +class Additive a where + zero :: a + add :: a -> a -> CodeGenFunction r a + +instance (IsArithmetic a) => Additive (Value a) where + zero = LLVM.value LLVM.zero + add = A.add + +instance (Additive a) => Additive (Stereo.T a) where + zero = Stereo.cons zero zero + add x y = + liftM2 Stereo.cons + (add (Stereo.left x) (Stereo.left y)) + (add (Stereo.right x) (Stereo.right y)) + + + +{- | +This may mean more shuffling and is not necessarily better than mixStereo. +-} +mixStereoV :: + (IsArithmetic a, IsPrimitive a) => + Stereo.T (Value a) -> Stereo.T (Value a) -> + CodeGenFunction r (Stereo.T (Value a)) +mixStereoV x y = + do xv <- vectorFromStereo x + yv <- vectorFromStereo y + stereoFromVector =<< A.add xv yv + +mixVector :: + (Vector.Arithmetic a, IsPowerOf2 n) => + Value (Vector n a) -> + CodeGenFunction r (Value a) +mixVector = Vector.sum + +mixVectorToStereo :: + (Vector.Arithmetic a, IsPowerOf2 n) => + Value (Vector n a) -> + CodeGenFunction r (Stereo.T (Value a)) +mixVectorToStereo = + fmap (uncurry Stereo.cons) . + Vector.sumInterleavedToPair + +{- | +Mix components with even index to the left channel +and components with odd index to the right channel. +-} +mixInterleavedVectorToStereo :: + (Vector.Arithmetic a, IsPowerOf2 n) => + Value (Vector n a) -> + CodeGenFunction r (Stereo.T (Value a)) +mixInterleavedVectorToStereo = + fmap (uncurry Stereo.cons) . + Vector.sumInterleavedToPair + + +amplifyMono :: + (IsArithmetic a) => + Value a -> Value a -> + CodeGenFunction r (Value a) +amplifyMono = A.mul + +amplifyStereo :: + (IsArithmetic a) => + Value a -> Stereo.T (Value a) -> + CodeGenFunction r (Stereo.T (Value a)) +amplifyStereo x y = + liftM2 Stereo.cons + (A.mul x (Stereo.left y)) + (A.mul x (Stereo.right y)) + +subsampleVector :: + (Vector.Access n a v) => + v -> CodeGenFunction r a +subsampleVector = + Vector.extract (LLVM.value LLVM.zero :: Value Word32) diff --git a/src/Synthesizer/LLVM/Server.hs b/src/Synthesizer/LLVM/Server.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server.hs @@ -0,0 +1,57 @@ +module Main where + +import qualified Synthesizer.LLVM.Server.Packed.Test as ServerPackedTest +import qualified Synthesizer.LLVM.Server.Packed.Run as ServerPacked +import qualified Synthesizer.LLVM.Server.Scalar.Test as ServerScalarTest +import qualified Synthesizer.LLVM.Server.Scalar.Run as ServerScalar + +import qualified LLVM.Core as LLVM + +import Control.Monad (when, ) + + +part :: Int +part = 106 + +main :: IO () +main = + when (part<200) + (putStrLn "run 'aconnect' to connect to the MIDI controller") >> + LLVM.initializeNativeTarget >> + case part of + 000 -> ServerScalar.pitchBend + 001 -> ServerScalar.frequencyModulation + 002 -> ServerScalar.keyboard + 003 -> ServerScalar.keyboardStereo + 004 -> ServerScalar.keyboardMulti + 005 -> ServerScalar.keyboardStereoMulti + 100 -> ServerPacked.frequencyModulation + 101 -> ServerPacked.keyboard + 102 -> ServerPacked.keyboardStereo + 103 -> ServerPacked.keyboardFM + 104 -> ServerPacked.keyboardFMMulti + 105 -> ServerPacked.keyboardDetuneFM + 106 -> ServerPacked.keyboardFilter + 200 -> ServerScalarTest.pitchBend0 + 201 -> ServerScalarTest.pitchBend1 + 202 -> ServerScalarTest.pitchBend2 + 203 -> ServerScalarTest.sequencePress + 300 -> ServerPackedTest.adsr + 301 -> ServerPackedTest.sequencePlain + 302 -> ServerPackedTest.sequenceLLVM + 303 -> ServerPackedTest.sequencePitchBendCycle + 304 -> ServerPackedTest.sequencePitchBendSimple + 305 -> ServerPackedTest.sequencePitchBend + 306 -> ServerPackedTest.sequenceModulated + 307 -> ServerPackedTest.sequencePress + 308 -> ServerPackedTest.sequenceModulatedLong + 309 -> ServerPackedTest.sequenceModulatedLongFM + 310 -> ServerPackedTest.sequenceModulatedRepeat + 311 -> ServerPackedTest.sequenceSample + 312 -> ServerPackedTest.sequenceSample1 -- leak +-- 313 -> ServerPackedTest.testSequenceSample1a -- leak + 320 -> ServerPackedTest.sequenceSample2 -- leak + 321 -> ServerPackedTest.sequenceSample3 -- leak + 322 -> ServerPackedTest.sequenceSample4 -- leak + 323 -> ServerPackedTest.sequenceFM1 -- leak + _ -> error "not implemented server part" diff --git a/src/Synthesizer/LLVM/Server/Common.hs b/src/Synthesizer/LLVM/Server/Common.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Common.hs @@ -0,0 +1,153 @@ +module Synthesizer.LLVM.Server.Common where + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.ALSA.Sequencer.Address as Addr +import qualified Sound.ALSA.Sequencer.Client as Client +import qualified Sound.ALSA.Sequencer.Port as Port +import qualified Sound.ALSA.Sequencer.Queue as Queue +import qualified Sound.ALSA.Sequencer.RealTime as RealTime +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified Sound.ALSA.PCM as ALSA +import qualified Synthesizer.Storable.ALSA.Play as Play +import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC +import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS + +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Core as LLVM + +import qualified Data.EventList.Relative.BodyTime as EventListBT + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import Foreign.Storable (Storable, ) + +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified Sound.Sox.Frame as SoxFrame + +import Control.Arrow ((^<<), ) + +import qualified Numeric.NonNegative.Wrapper as NonNegW + +import qualified Algebra.RealRing as RealRing +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.Additive as Additive + +import Data.Word (Word8, ) + +import NumericPrelude.Numeric (zero, round, ) +import Prelude hiding (Real, round, break, ) + + + +channel :: ChannelMsg.Channel +channel = ChannelMsg.toChannel 0 + +sampleRate :: Num a => a +-- sampleRate = 24000 +-- sampleRate = 48000 +sampleRate = 44100 + +latency :: Int +latency = 0 +-- latency = 256 +-- latency = 480 + +chunkSize :: SVL.ChunkSize +chunkSize = Play.defaultChunkSize + + +lazySize :: SigG.LazySize +lazySize = + let (SVL.ChunkSize size) = chunkSize + in SigG.LazySize size + +periodTime :: Field.C t => t +periodTime = + let (SVL.ChunkSize size) = chunkSize + in ToInteger.fromIntegral size Field./ Ring.fromInteger sampleRate + + +type Real = Float + + +($/) :: (Functor f) => f (a -> b) -> a -> f b +f $/ x = fmap ($x) f + + +{-# INLINE play #-} +play :: + (RealRing.C t, Additive.C y, ALSA.SampleFmt y) => + t -> t -> SigSt.T y -> IO () +play period rate = + Play.auto period (round rate) . + SigSt.append (SigSt.replicate chunkSize latency zero) +-- FiltG.delayPosLazySize chunkSize latency +-- FiltG.delayPos latency + +-- ToDo: do not record the empty chunk that is inserted for latency +{-# INLINE playAndRecord #-} +playAndRecord :: + (RealRing.C t, Additive.C y, ALSA.SampleFmt y, SoxFrame.C y) => + FilePath -> t -> t -> SigSt.T y -> IO () +playAndRecord fileName period rate = + Play.autoAndRecord period fileName (round rate) . + SigSt.append (SigSt.replicate chunkSize latency zero) + + +piecewiseConstant :: + (Storable a, + LLVM.MakeValueTuple a al, + Rep.Memory al am, + LLVM.IsSized am as) => + Param.T p (PC.T a) -> SigP.T p al +piecewiseConstant pc = + SigP.piecewiseConstant + (EventListBT.mapTime + (NonNegW.fromNumber . fromIntegral . NonNegW.toNumber) ^<< pc) +-- SigP.piecewiseConstant (PC.subdivideInt ^<< pc) + +transposeModulation :: + (Functor stream) => + Real -> + stream (PC.BendModulation Real) -> + stream (PC.BendModulation Real) +transposeModulation freq = + fmap (PC.shiftBendModulation (freq/sampleRate)) + + +{-# INLINE amplitudeFromVelocity #-} +amplitudeFromVelocity :: Real -> Real +amplitudeFromVelocity vel = 4**vel + + +-- cf. synthesizer-alsa:Synthesizer.Storable.ALSA.Server.Test +makeNote :: Event.NoteEv -> Word8 -> Event.T +makeNote typ pit = + Event.Cons + { Event.highPriority = False + , Event.tag = 0 + , Event.queue = Queue.direct + , Event.timestamp = + Event.RealTime $ RealTime.fromInteger 0 + , Event.source = Addr.Cons { + Addr.client = Client.subscribers, + Addr.port = Port.unknown + } + , Event.dest = Addr.Cons { + Addr.client = Client.subscribers, + Addr.port = Port.unknown + } + , Event.body = + Event.NoteEv typ + (Event.simpleNote 0 pit 64) + } diff --git a/src/Synthesizer/LLVM/Server/Packed/Instrument.hs b/src/Synthesizer/LLVM/Server/Packed/Instrument.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Packed/Instrument.hs @@ -0,0 +1,1494 @@ +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Server.Packed.Instrument where + +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.EventList.ALSA.MIDI as Ev +import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Sound.Sox.Read as SoxRead +import qualified Sound.Sox.Option.Format as SoxOption + +import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, ) + +import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.Moog as MoogL +import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Sample as Sample +import qualified Synthesizer.LLVM.Wave as WaveL +import qualified Synthesizer.LLVM.Parameter as Param +import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Monad as LM +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Core as LLVM +import qualified Data.TypeLevel.Num as TypeNum + +import Control.Arrow.Monad ((=<<<), listen, ) +import qualified Data.HList as HL + +import qualified Synthesizer.Generic.Cut as CutG +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SVP +import qualified Data.StorableVector.Lazy as SVL + +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter + +import Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second, ) +import Control.Applicative (liftA2, liftA3, ) + +import Data.Tuple.HT (mapPair, fst3, snd3, thd3, ) + +import Data.Int (Int32, ) + +{- +import qualified Numeric.NonNegative.Class as NonNeg +import qualified Numeric.NonNegative.Wrapper as NonNegW +-} +import qualified Numeric.NonNegative.Chunky as NonNegChunky + +import qualified Algebra.RealRing as RealRing +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric (zero, round, (^?), ) +import Prelude hiding (Real, round, break, ) + + + +type Vector = LLVM.Vector VectorSize Real +type VectorSize = TypeNum.D4 + + +vectorSize :: Int +vectorSize = TypeNum.toInt (undefined :: VectorSize) + +vectorChunkSize :: SVL.ChunkSize +vectorChunkSize = + let (SVL.ChunkSize size) = chunkSize + in SVL.ChunkSize (div size vectorSize) + +vectorRate :: Fractional a => a +vectorRate = sampleRate / fromIntegral vectorSize + + +frequencyFromBendModulation :: +{- + (Storable a, + LLVM.MakeValueTuple a (Value a)) => +-} + Param.T p Real -> + Param.T p (PC.T (PC.BendModulation Real), Real) -> + SigP.T p (LLVM.Value Vector) +frequencyFromBendModulation speed fmFreq = + MIDIL.frequencyFromBendModulationPacked (speed/sampleRate) + $* piecewiseConstant + (fmap (\(fm,freq) -> transposeModulation freq fm) fmFreq) + +stereoFrequenciesFromDetuneBendModulation :: + Param.T p Real -> + Param.T p (PC.T Real, PC.T (PC.BendModulation Real), Real) -> + SigP.T p (Stereo.T (LLVM.Value Vector)) +stereoFrequenciesFromDetuneBendModulation speed detFmFreq = + (CausalP.envelopeStereo + $< frequencyFromBendModulation speed + (fmap (\(_det,fm,freq) -> (fm,freq)) detFmFreq)) + <<< + CausalP.zipWithSimple Sample.zipStereo + <<< + CausalPS.raise 1 &&& + (CausalPS.raise 1 <<< CausalP.mapSimple LLVM.neg) + $* piecewiseConstantVector + (fmap (\(det,_fm,_freq) -> det) detFmFreq) + + +pingReleaseEnvelope :: + IO (Real -> Real -> Real -> Ev.LazyTime -> SigSt.T Vector) +pingReleaseEnvelope = + liftA2 + (\pressed release decay rel vel dur -> + SigStL.continuePacked + (pressed (chunkSizesFromLazyTime dur) (decay,vel)) + (\x -> release vectorChunkSize (rel,x))) + (SigP.runChunkyPattern $ + let decay = arr fst + velocity = arr snd + in SigPS.exponential2 (decay*sampleRate) + (amplitudeFromVelocity ^<< velocity)) + (SigP.runChunky $ + let release = arr fst + amplitude = arr snd + in (CausalP.take (round ^<< (release*5*vectorRate)) $* + SigPS.exponential2 (release*sampleRate) amplitude)) + +pingRelease :: + IO (Real -> Real -> Instrument Real Vector) +pingRelease = + liftA2 + (\osc env dec rel vel freq dur -> + osc freq (env dec rel vel dur)) + (CausalP.runStorableChunky + (let freq = arr id + in CausalP.envelope $> + SigPS.osciSimple WaveL.saw zero (freq/sampleRate))) + pingReleaseEnvelope + +pingStereoRelease :: + IO (Real -> Real -> Instrument Real (Stereo.T Vector)) +pingStereoRelease = + liftA2 + (\osc env dec rel vel freq dur -> + osc freq (env dec rel vel dur)) + (CausalP.runStorableChunky + (let freq = arr id + in CausalP.envelopeStereo $> + SigP.zipWithSimple Sample.zipStereo + (SigPS.osciSimple WaveL.saw zero + (0.999*freq/sampleRate)) + (SigPS.osciSimple WaveL.saw zero + (1.001*freq/sampleRate)))) + pingReleaseEnvelope + +pingStereoReleaseFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> + Real -> Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +pingStereoReleaseFM = + liftA2 + (\osc env dec rel detune shape phase phaseDecay fm vel freq dur -> + osc + ((phase, phaseDecay), shape, (detune,fm,freq)) + (env dec rel vel dur)) + (CausalP.runStorableChunky + (let phs = arr (fst.fst3) + dec = arr (snd.fst3) + shp = arr snd3 + fm = arr thd3 + in CausalP.envelopeStereo $> + ((CausalP.stereoFromMonoControlled + (CausalPS.shapeModOsci WaveL.rationalApproxSine1) + $< piecewiseConstantVector shp) + <<^ Stereo.interleave + $< (CausalP.zipWithSimple Sample.zipStereo + <<< + arr id &&& CausalP.mapSimple LLVM.neg + $* SigPS.exponential2 (dec*sampleRate) phs) + $* stereoFrequenciesFromDetuneBendModulation 10 fm))) + pingReleaseEnvelope + +{- | +Square like wave constructed as difference +of two phase shifted sawtooth like oscillations. +-} +squareStereoReleaseFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> + PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +squareStereoReleaseFM = + liftA2 + (\osc env dec rel detune shape phase fm vel freq dur -> + osc + ((phase, shape), (detune,fm,freq)) + (env dec rel vel dur)) + (CausalP.runStorableChunky + (let phs = arr (fst.fst) + shp = arr (snd.fst) + fm = arr snd + chanOsci = + CausalP.mix + <<< + (CausalPS.shapeModOsci WaveL.rationalApproxSine1 + <<< + second (first (CausalP.mapSimple LLVM.neg))) + &&& + (CausalP.mapSimple LLVM.neg + <<< + CausalPS.shapeModOsci WaveL.rationalApproxSine1) + <<^ + (\((p,s),f) -> (s,(p,f))) + in CausalP.envelopeStereo $> + ((CausalP.stereoFromMonoControlled chanOsci + $< SigP.zip + (piecewiseConstantVector phs) + (piecewiseConstantVector shp)) + $* stereoFrequenciesFromDetuneBendModulation 10 fm))) + pingReleaseEnvelope + +bellStereoFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +bellStereoFM = + liftA2 + (\osc env dec rel detune fm vel freq dur -> + osc ((detune, fm, freq), vel, + (env (dec/4) rel vel dur, + env (dec/7) rel vel dur)) + (env dec rel vel dur)) + (CausalP.runStorableChunky + (let fm = arr fst3 + vel = arr snd3 + env4 = arr (fst.thd3) + env7 = arr (snd.thd3) + mix x y = CausalP.mixStereo <<< x&&&y + osci sel v d = + CausalP.envelopeStereo + <<< + (arr sel *** + (CausalPS.amplifyStereo v + <<< + CausalP.stereoFromMono + (CausalPS.osciSimple WaveL.approxSine4 + $< SigPS.constant zero) + <<< + CausalPS.amplifyStereo d)) + in (osci fst3 0.6 1 `mix` + osci snd3 (0.02 * 50^?vel) 4 `mix` + osci thd3 (0.02 * 100^?vel) 7) + <<< + CausalP.feedSnd (stereoFrequenciesFromDetuneBendModulation 5 fm) + <<< + arr (\(e1,(e4,e7)) -> (e1,e4,e7)) + $> {- + Be careful, those storable vectors shorten the whole sound + if they have shorter release than the main envelope. + -} + SigP.zip + (SigP.fromStorableVectorLazy env4) + (SigP.fromStorableVectorLazy env7))) + pingReleaseEnvelope + +bellNoiseStereoFM :: + IO (Real -> Real -> + PC.T Real -> PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +bellNoiseStereoFM = + liftA2 + (\osc env dec rel noiseAmp noiseReson fm vel freq dur -> + osc ((fm, freq), + (noiseAmp,noiseReson), + (vel, + env (dec/4) rel vel dur, + env (dec/7) rel vel dur)) + (env dec rel vel dur)) + (CausalP.runStorableChunky + (let fm = arr fst3 + noiseAmp = arr (fst.snd3) + noiseReson = arr (snd.snd3) + vel = arr (fst3.thd3) + env4 = arr (snd3.thd3) + env7 = arr (thd3.thd3) + mix x y = CausalP.mix <<< x&&&y + osci sel v d = + CausalP.envelope + <<< + (arr sel *** + (CausalPS.amplify v + <<< + (CausalPS.osciSimple WaveL.approxSine4 + $< SigPS.constant zero) + <<< + CausalPS.amplify d)) + noise sel d = + (CausalP.envelope $< + piecewiseConstantVector noiseAmp) + <<< + CausalP.envelope + <<< + (arr sel *** + ({- UniFilter.lowpass + ^<< -} + (CtrlPS.process + $> SigPS.noise 12 (sampleRate/20000)) + <<< +-- CausalP.zipWithSimple UniFilterL.parameter + CausalP.zipWithSimple (MoogL.parameter TypeNum.d8) +{- +FIXME: +This leads to a run-time crash even without LLVM optimizations. +However, I cannot reproduce this in the Test module. + (CausalP.quantizeLift $# (1 :: Real)) (arr id) + + (CausalP.quantizeLift + $# (128 / fromIntegral vectorSize :: Real)) + (CausalP.zipWithSimple UniFilterL.parameter) + + (CausalP.quantizeLift + $# (128 / fromIntegral vectorSize :: Real)) + (CausalP.zipWithSimple (MoogL.parameter TypeNum.d8)) +-} + <<< + CausalP.feedFst (piecewiseConstant noiseReson) + <<< + CausalP.mapSimple Sample.subsampleVector + <<< + CausalPS.amplify d)) + in CausalP.zipWithSimple Sample.zipStereo + <<< + (osci fst3 0.6 (1*0.999) `mix` + osci snd3 (0.02 * 50^?vel) (4*0.999) `mix` + osci thd3 (0.02 * 100^?vel) (7*0.999) `mix` + noise fst3 0.999) &&& + (osci fst3 0.6 (1*1.001) `mix` + osci snd3 (0.02 * 50^?vel) (4*1.001) `mix` + osci thd3 (0.02 * 100^?vel) (7*1.001) `mix` + noise fst3 1.001) + <<< + CausalP.feedSnd (frequencyFromBendModulation 5 fm) + <<< + arr (\(e1,(e4,e7)) -> (e1,e4,e7)) + $> {- + Be careful, those storable vectors shorten the whole sound + if they have shorter release than the main envelope. + -} + SigP.zip + (SigP.fromStorableVectorLazy env4) + (SigP.fromStorableVectorLazy env7))) + pingReleaseEnvelope + + +tine :: IO (Real -> Real -> Instrument Real Vector) +tine = + liftA2 + (\osc env dec rel vel freq dur -> + osc (vel,freq) (env dec rel 0 dur)) + (CausalP.runStorableChunky + (let freq = arr snd + vel = arr fst + in CausalP.envelope $> + (CausalPS.osciSimple WaveL.approxSine2 + $> (SigPS.constant (freq/sampleRate)) + $* (CausalP.envelope + $< SigPS.exponential2 (1*sampleRate) (vel+1) + $* SigPS.osciSimple WaveL.approxSine2 zero + (2*freq/sampleRate))))) + pingReleaseEnvelope + +tineStereo :: IO (Real -> Real -> Instrument Real (Stereo.T Vector)) +tineStereo = + liftA2 + (\osc env dec rel vel freq dur -> + osc (vel,freq) (env dec rel 0 dur)) + (CausalP.runStorableChunky + (let freq = arr snd + vel = arr fst + chanOsci d = + CausalPS.osciSimple WaveL.approxSine2 + $> SigPS.constant (freq*d/sampleRate) + in CausalP.envelopeStereo $> + ((CausalP.zipWithSimple Sample.zipStereo <<< + (chanOsci 0.995 &&& chanOsci 1.005)) + $* SigP.envelope + (SigPS.exponential2 (1*sampleRate) (vel+1)) + (SigPS.osciSimple WaveL.approxSine2 zero + (2*freq/sampleRate))))) + pingReleaseEnvelope + + +softStringReleaseEnvelope :: + IO (Real -> Real -> Ev.LazyTime -> SigSt.T Vector) +softStringReleaseEnvelope = + liftA2 + (\rev env attackTime vel dur -> + let attackTimeVector = + div (round (attackTime*sampleRate)) vectorSize + amp = amplitudeFromVelocity vel + {- + release <- take attackTime beginning + would yield a space leak, thus we first split 'beginning' + and then concatenate it again + -} + {- + We can not easily generate attack and sustain separately, + because we want to use the chunk structure implied by 'dur'. + -} + (attack, sustain) = + SigSt.splitAt attackTimeVector $ + env (chunkSizesFromLazyTime dur) (amp, attackTimeVector) + release = rev attack + in attack `SigSt.append` sustain `SigSt.append` release) + SigStL.makeReversePacked + (let amp = arr fst + attackTimeVector = arr snd + in SigP.runChunkyPattern $ + flip SigP.append (SigPS.constant amp) $ + (CausalPS.amplify amp <<< + CausalP.take attackTimeVector + $* SigPS.parabolaFadeInInf + (fmap fromIntegral attackTimeVector * + fromIntegral vectorSize))) + +softString :: IO (Instrument Real (Stereo.T Vector)) +softString = + liftA2 + (\osc env vel freq dur -> + osc freq (env 1 vel dur)) + (let freq = arr id + osci d = + SigPS.osciSimple WaveL.saw zero (d * freq / sampleRate) + in CausalP.runStorableChunky $ + (CausalP.envelopeStereo $> + (SigP.zipWithSimple Sample.zipStereo + (SigP.mix + (osci 1.005) + (osci 0.998)) + (SigP.mix + (osci 1.002) + (osci 0.995))))) + softStringReleaseEnvelope + + +softStringFM :: + IO (PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +softStringFM = + liftA2 + (\osc env fm vel freq dur -> + osc (fm,freq) (env 1 vel dur)) + (let fm = arr id + osci :: + Param.T fm Real -> + CausalP.T fm (LLVM.Value Vector) (LLVM.Value Vector) + osci d = + (CausalPS.osciSimple WaveL.saw $< + (SigPS.constant $# (zero::Real))) <<< + CausalPS.amplify d + in CausalP.runStorableChunky $ + (CausalP.envelopeStereo $> + (CausalP.zipWithSimple Sample.zipStereo + <<< + (CausalP.mix <<< osci 1.005 &&& osci 0.998) &&& + (CausalP.mix <<< osci 1.002 &&& osci 0.995) + $* frequencyFromBendModulation 5 fm))) + softStringReleaseEnvelope + + +tineStereoFM :: + IO (Real -> Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +tineStereoFM = + liftA2 + (\osc env dec rel fm vel freq dur -> + osc (vel,(fm,freq)) (env dec rel 0 dur)) + (CausalP.runStorableChunky + (let vel = arr fst + fm = arr snd + chanOsci d = + CausalPS.osciSimple WaveL.approxSine2 + <<< second (CausalPS.amplify d) + in CausalP.envelopeStereo $> + ((CausalP.zipWithSimple Sample.zipStereo <<< + chanOsci 0.995 &&& chanOsci 1.005) + <<< + (((CausalP.envelope + $< SigPS.exponential2 (1*sampleRate) (vel+1)) + <<< (CausalPS.osciSimple WaveL.approxSine2 + $< (SigPS.constant $# (zero::Real))) + <<< CausalPS.amplify 2) + &&& arr id) + $* frequencyFromBendModulation 5 fm))) + pingReleaseEnvelope + + +tineControlledProc, tineControlledFnProc :: + Param.T p (PC.T Real) -> + Param.T p (PC.T Real) -> + Param.T p Real -> + CausalP.T p + (Stereo.T (LLVM.Value Vector)) + (Stereo.T (LLVM.Value Vector)) +tineControlledProc index depth vel = + CausalP.stereoFromMono + (CausalPS.osciSimple WaveL.approxSine2) + <<< + Stereo.interleave + ^<< + ((CausalP.envelopeStereo + $< SigP.envelope + (piecewiseConstantVector depth) + (SigPS.exponential2 (1*sampleRate) (vel+1))) + <<< + CausalP.stereoFromMono + (CausalPS.osciSimple WaveL.approxSine2 + $< (SigPS.constant $# (zero::Real))) + <<< + (CausalP.envelopeStereo + $< piecewiseConstantVector index)) + &&& arr id + +tineControlledFnProc index depth vel = + ((\freq -> + CausalP.stereoFromMono + (CausalPS.osciSimple WaveL.approxSine2) + <<< + Stereo.interleave + ^<< + ((CausalP.envelopeStereo + $< SigP.envelope + (piecewiseConstantVector depth) + (SigPS.exponential2 (1*sampleRate) (vel+1))) + <<< + CausalP.stereoFromMono + (CausalPS.osciSimple WaveL.approxSine2 + $< (SigPS.constant $# (zero::Real))) + <<< + (CausalP.envelopeStereo + $< piecewiseConstantVector index) + <<< + listen freq) + &&& + listen freq) +-- =<<< listen HL.hNil + =<<< arr HL.hHead) + <<< arr (\freq -> HL.hCons freq HL.hNil) + +tineControlledFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +tineControlledFM = + liftA2 + (\osc env dec rel detune index depth fm vel freq dur -> + osc + ((index, depth), vel, (detune,fm,freq)) + (env dec rel 0 dur)) + (CausalP.runStorableChunky + (let index = arr (fst.fst3) + depth = arr (snd.fst3) + vel = arr snd3 + fm = arr thd3 + in CausalP.envelopeStereo $> + (tineControlledFnProc index depth vel $* + stereoFrequenciesFromDetuneBendModulation 5 fm))) + pingReleaseEnvelope + + +fenderProc :: + Param.T p (PC.T Real) -> + Param.T p (PC.T Real) -> + Param.T p (PC.T Real) -> + Param.T p Real -> + CausalP.T p + (Stereo.T (LLVM.Value Vector)) + (Stereo.T (LLVM.Value Vector)) +fenderProc fade index depth vel = + ((\stereoFreq -> + let channel_n_1 freq = + CausalPS.osciSimple WaveL.approxSine2 + <<< + ((CausalP.envelope + $< SigP.envelope + (piecewiseConstantVector depth) + (SigPS.exponential2 (1*sampleRate) (vel+1))) + <<< + (CausalPS.osciSimple WaveL.approxSine2 + $< (SigPS.constant $# (zero::Real))) + <<< + (CausalP.envelope + $< piecewiseConstantVector index) + <<< + freq) + &&& + freq + channel_1_2 freq = + CausalPS.osciSimple WaveL.approxSine2 + <<< + ((CausalP.envelope + $< SigP.envelope + (piecewiseConstantVector depth) + (SigPS.exponential2 (1*sampleRate) (vel+1))) + <<< + (CausalPS.osciSimple WaveL.approxSine2 + $< (SigPS.constant $# (zero::Real))) + <<< + freq) + &&& + (CausalPS.amplify 2 <<< freq) + in (CausalP.stereoFromMonoControlled + (fadeProcess + (channel_n_1 (arr id)) + (channel_1_2 (arr id))) + $< piecewiseConstantVector fade) + <<< + listen stereoFreq) + =<<< arr HL.hHead) + <<< arr (\freq -> HL.hCons freq HL.hNil) + +fenderFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> PC.T Real -> PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +fenderFM = + liftA2 + (\osc env dec rel detune index depth fade fm vel freq dur -> + osc + (((index, depth), fade), vel, (detune,fm,freq)) + (env dec rel 0 dur)) + (CausalP.runStorableChunky + (let index = arr (fst.fst.fst3) + depth = arr (snd.fst.fst3) + fade = arr (snd.fst3) + vel = arr snd3 + fm = arr thd3 + in CausalP.envelopeStereo $> + (fenderProc fade index depth vel $* + stereoFrequenciesFromDetuneBendModulation 5 fm))) + pingReleaseEnvelope + + +tineModulatorBankFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +tineModulatorBankFM = + liftA2 + (\osc env + dec rel detune + depth1 depth2 depth3 depth4 + fm vel freq dur -> + osc + ((depth1,(depth2,(depth3,(depth4,())))), vel, (detune,fm,freq)) + (env dec rel 0 dur)) + (CausalP.runStorableChunky + (let depth1 = arr (fst.fst3) + depth2 = arr (fst.snd.fst3) + depth3 = arr (fst.snd.snd.fst3) + depth4 = arr (fst.snd.snd.snd.fst3) + vel = arr snd3 + fm = arr thd3 + mix x y = CausalP.mixStereo <<< x&&&y + modulator n depth = + (CausalP.envelopeStereo + $< SigP.envelope + (piecewiseConstantVector depth) + (SigPS.exponential2 (1*sampleRate) (vel+1))) + <<< + CausalP.stereoFromMono + (CausalPS.osciSimple WaveL.approxSine2 + $< (SigPS.constant $# (zero::Real))) + <<< + CausalP.amplifyStereo n + in CausalP.envelopeStereo $> + (CausalP.stereoFromMono + (CausalPS.osciSimple WaveL.approxSine2) + <<< + Stereo.interleave + ^<< + (modulator 1 depth1 `mix` + modulator 2 depth2 `mix` + modulator 3 depth3 `mix` + modulator 4 depth4) + &&& arr id + $* + stereoFrequenciesFromDetuneBendModulation 5 fm))) + pingReleaseEnvelope + +tineBankFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> + PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +tineBankFM = + liftA2 + (\osc env + dec rel detune + depth1 depth2 depth3 depth4 + partial1 partial2 partial3 partial4 + fm vel freq dur -> + osc + ((depth1,(depth2,(depth3,(depth4,())))), + (partial1,(partial2,(partial3,(partial4,())))), + (vel, (detune,fm,freq))) + (env dec rel 0 dur)) + (CausalP.runStorableChunky + (let depth1 = arr (fst.fst3) + depth2 = arr (fst.snd.fst3) + depth3 = arr (fst.snd.snd.fst3) + depth4 = arr (fst.snd.snd.snd.fst3) + partial1 = arr (fst.snd3) + partial2 = arr (fst.snd.snd3) + partial3 = arr (fst.snd.snd.snd3) + partial4 = arr (fst.snd.snd.snd.snd3) + vel = arr (fst.thd3) + fm = arr (snd.thd3) + mixStereo x y = CausalP.mixStereo <<< x&&&y + modulator n depth = + (CausalP.envelopeStereo + $< SigP.envelope + (piecewiseConstantVector depth) + (SigPS.exponential2 (1*sampleRate) (vel+1))) + <<< + CausalP.stereoFromMono + (CausalPS.osciSimple WaveL.approxSine2 + $< (SigPS.constant $# (zero::Real))) + <<< + CausalP.amplifyStereo n + partial :: + LLVM.Value Vector -> Int32 -> LLVM.Value Vector -> + LLVM.CodeGenFunction r (LLVM.Value Vector) + partial amp n t = + A.mul amp =<< + WaveL.partial WaveL.approxSine2 (LLVM.valueOf n) t + in CausalP.envelopeStereo $> + (CausalP.stereoFromMono + (CausalPS.shapeModOsci + (\(p1,(p2,(p3,p4))) t -> do + y1 <- A.mul p1 =<< WaveL.approxSine2 t + y2 <- partial p2 2 t + y3 <- partial p3 3 t + y4 <- partial p4 4 t + A.add y1 =<< A.add y2 =<< A.add y3 y4) + $< + (SigP.zip (piecewiseConstantVector partial1) $ + SigP.zip (piecewiseConstantVector partial2) $ + SigP.zip (piecewiseConstantVector partial3) + (piecewiseConstantVector partial4))) + <<< + Stereo.interleave + ^<< + (modulator 1 depth1 `mixStereo` + modulator 2 depth2 `mixStereo` + modulator 3 depth3 `mixStereo` + modulator 4 depth4) + &&& arr id + $* + stereoFrequenciesFromDetuneBendModulation 5 fm))) + pingReleaseEnvelope + + +{- | +FM synthesis where the modulator is a resonantly filtered sawtooth. +This way we get a sinus-like modulator where the sine frequency +(that is, something like the modulation index) can be controlled continously. +-} +resonantFMSynthProc :: + Param.T p (PC.T Real) -> + Param.T p (PC.T Real) -> + Param.T p (PC.T Real) -> + Param.T p Real -> + CausalP.T p + (Stereo.T (LLVM.Value Vector)) + (Stereo.T (LLVM.Value Vector)) +resonantFMSynthProc reson index depth vel = + ((\stereoFreq -> + let chan freq = + CausalPS.osciSimple WaveL.approxSine2 + <<< + ((CausalP.envelope + $< SigP.envelope + (piecewiseConstantVector depth) + (SigPS.exponential2 (1*sampleRate) (vel+1))) + <<< + UniFilter.lowpass + ^<< + CtrlPS.process + <<< + (CausalP.zipWithSimple UniFilterL.parameter + <<< + CausalP.feedFst (piecewiseConstant reson) + <<< + (CausalP.envelope $< piecewiseConstant index) + <<< + CausalP.mapSimple Sample.subsampleVector + <<< + freq) + &&& + ((CausalPS.osciSimple WaveL.saw + $< (SigPS.constant $# (zero::Real))) + <<< + freq)) + &&& + freq + in CausalP.stereoFromMono (chan (arr id)) + <<< + listen stereoFreq) + =<<< arr HL.hHead) + <<< arr (\freq -> HL.hCons freq HL.hNil) + +resonantFMSynth :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> PC.T Real -> PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +resonantFMSynth = + liftA2 + (\osc env dec rel detune reson index depth fm vel freq dur -> + osc + ((reson, index, depth), vel, (detune,fm,freq)) + (env dec rel 0 dur)) + (CausalP.runStorableChunky + (let reson = arr (fst3.fst3) + index = arr (snd3.fst3) + depth = arr (thd3.fst3) + vel = arr snd3 + fm = arr thd3 + in CausalP.envelopeStereo $> + (resonantFMSynthProc reson index depth vel $* + stereoFrequenciesFromDetuneBendModulation 5 fm))) + pingReleaseEnvelope + + +piecewiseConstantVector :: + Param.T p (PC.T Real) -> SigP.T p (LLVM.Value Vector) +{- + (Storable a, + LLVM.MakeValueTuple a al, + Rep.Memory al am, + LLVM.IsSized am as) => + Param.T p (PC.T a) -> SigP.T p (LLVM.Vector n al) +-} +piecewiseConstantVector pc = + SigP.mapSimple SoV.replicate $ + piecewiseConstant pc + + +softStringDetuneFM :: + IO (Real -> + PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +softStringDetuneFM = + liftA2 + (\osc env att det fm vel freq dur -> + osc (det, (fm,freq)) (env att vel dur)) + (let det = arr fst + fm = arr snd + mix x y = CausalP.mix <<< x&&&y + osci :: + Param.T (det,fm) Real -> + CausalP.T (det,fm) + (LLVM.Value Vector, LLVM.Value Vector) + (LLVM.Value Vector) + osci d = + (CausalPS.osciSimple WaveL.saw $< + (SigPS.constant $# (zero::Real))) + <<< + CausalP.envelope + <<< + first (CausalPS.raise 1 <<< CausalPS.amplify d) + in CausalP.runStorableChunky $ + (CausalP.envelopeStereo $> + (CausalPS.amplifyStereo 0.25 + <<< + CausalP.zipWithSimple Sample.zipStereo + <<< + ((osci 1.0 `mix` osci (-0.4)) `mix` + (osci 0.5 `mix` osci (-0.7))) &&& + ((osci 0.4 `mix` osci (-1.0)) `mix` + (osci 0.7 `mix` osci (-0.5))) + <<< + CausalP.feedFst (piecewiseConstantVector det) + $* frequencyFromBendModulation 5 fm))) + softStringReleaseEnvelope + +{- +We might decouple the frequency of the enveloped tone +from the frequency of the envelope, +in order to get something like formants. +-} +softStringShapeFM, cosineStringStereoFM, + arcSineStringStereoFM, arcTriangleStringStereoFM, + arcSquareStringStereoFM, arcSawStringStereoFM :: + IO (Real -> + PC.T Real -> + PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +softStringShapeFM = + softStringShapeCore WaveL.rationalApproxSine1 +cosineStringStereoFM = + softStringShapeCore + (\k p -> WaveL.approxSine2 =<< WaveL.replicate k p) +arcSawStringStereoFM = arcStringStereoFM WaveL.saw +arcSineStringStereoFM = arcStringStereoFM WaveL.approxSine2 +arcSquareStringStereoFM = arcStringStereoFM WaveL.square +arcTriangleStringStereoFM = arcStringStereoFM WaveL.triangle + +arcStringStereoFM :: + (forall r. + LLVM.Value Vector -> + LLVM.CodeGenFunction r (LLVM.Value Vector)) -> + IO (Real -> + PC.T Real -> + PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +arcStringStereoFM wave = + softStringShapeCore + (\k p -> + LM.liftR2 Sample.amplifyMono + (WaveL.approxSine4 =<< WaveL.halfEnvelope p) + (wave =<< WaveL.replicate k p)) + +softStringShapeCore :: + (forall r. + LLVM.Value Vector -> + LLVM.Value Vector -> + LLVM.CodeGenFunction r (LLVM.Value Vector)) -> + IO (Real -> + PC.T Real -> + PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +softStringShapeCore wave = + liftA2 + (\osc env att det dist fm vel freq dur -> + osc ((det, dist), (fm,freq)) (env att vel dur)) + (let det = arr (fst.fst) + dist = arr (snd.fst) + fm = arr snd + mix x y = CausalP.mix <<< x&&&y + osci :: + Param.T (mod,fm) Real -> + CausalP.T (mod,fm) + (LLVM.Value Vector, + {- wave shape parameter -} + (LLVM.Value Vector, LLVM.Value Vector) + {- detune, frequency modulation -}) + (LLVM.Value Vector) + osci d = + CausalPS.shapeModOsci wave + <<< + second + (CausalP.feedFst (SigPS.constant $# (zero::Real)) + <<< + CausalP.envelope + <<< + first (CausalPS.raise 1 <<< CausalPS.amplify d)) + in CausalP.runStorableChunky $ + (CausalP.envelopeStereo $> + (CausalPS.amplifyStereo 0.25 + <<< + CausalP.zipWithSimple Sample.zipStereo + <<< + ((osci 1.0 `mix` osci (-0.4)) `mix` + (osci 0.5 `mix` osci (-0.7))) &&& + ((osci 0.4 `mix` osci (-1.0)) `mix` + (osci 0.7 `mix` osci (-0.5))) + $< piecewiseConstantVector dist + $< piecewiseConstantVector det + $* frequencyFromBendModulation 5 fm))) + softStringReleaseEnvelope + +fmStringStereoFM :: + IO (Real -> + PC.T Real -> + PC.T Real -> + PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +fmStringStereoFM = + liftA2 + (\osc env att det depth dist fm vel freq dur -> + osc ((det, depth, dist), (fm, freq)) (env att vel dur)) + (let det = arr (fst3.fst) + depth = arr (snd3.fst) + dist = arr (thd3.fst) + fm = arr snd + mix x y = CausalP.mix <<< x&&&y + osci :: + Param.T (mod,fm) Real -> + CausalP.T (mod,fm) + ((LLVM.Value Vector, LLVM.Value Vector) + {- phase modulation depth, modulator distortion -}, + (LLVM.Value Vector, LLVM.Value Vector) + {- detune, frequency modulation -}) + (LLVM.Value Vector) + osci d = + CausalPS.osciSimple WaveL.approxSine2 + <<< + (CausalP.envelope + <<< + second + (CausalPS.shapeModOsci WaveL.rationalApproxSine1 + <<< second (CausalP.feedFst (SigPS.constant 0))) + <<^ + (\((dp, ds), f) -> (dp, (ds, f)))) + &&& arr snd + <<< + second + (CausalP.envelope <<< + first (CausalPS.raise 1 <<< CausalPS.amplify d)) + in CausalP.runStorableChunky + (CausalP.envelopeStereo <<< + (arr id &&& + (CausalPS.amplifyStereo 0.25 + <<< + CausalP.zipWithSimple Sample.zipStereo + <<< + ((osci 1.0 `mix` osci (-0.4)) `mix` + (osci 0.5 `mix` osci (-0.7))) &&& + ((osci 0.4 `mix` osci (-1.0)) `mix` + (osci 0.7 `mix` osci (-0.5))) + <<< + CausalP.feedSnd + (SigP.zip + (piecewiseConstantVector det) + (frequencyFromBendModulation 5 fm)) + <<< + CausalP.feedSnd (piecewiseConstantVector dist) + <<< + (CausalP.envelope + $< piecewiseConstantVector depth))))) + softStringReleaseEnvelope + + +wind :: + IO (Real -> + PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +wind = + liftA2 + (\osc env att reson fm vel freq dur -> + osc (reson, (fm,freq)) (env att vel dur)) + (let reson = arr fst + fm = arr snd + in CausalP.runStorableChunky $ + (CausalP.envelopeStereo $> + (CausalP.stereoFromMonoControlled CtrlPS.process + $< SigP.zipWithSimple + (MoogL.parameter TypeNum.d8) + (piecewiseConstant reson) + (SigP.mapSimple Sample.subsampleVector + (frequencyFromBendModulation 0.2 fm)) + $* SigP.zipWithSimple Sample.zipStereo + (SigPS.noise 13 (sampleRate/20000)) + (SigPS.noise 14 (sampleRate/20000) + :: SigP.T p (LLVM.Value Vector))))) + softStringReleaseEnvelope + + +fadeProcess :: + (Num b, LLVM.IsConst b, + LLVM.IsArithmetic v, SoV.Replicate b v) => + CausalP.T p a (LLVM.Value v) -> + CausalP.T p a (LLVM.Value v) -> + CausalP.T p (LLVM.Value v, a) (LLVM.Value v) +fadeProcess proc0 proc1 = + CausalP.mapSimple + (\(k,(a0,a1)) -> do + b0 <- A.mul a0 =<< A.sub (SoV.replicateOf 1) k + b1 <- A.mul a1 k + A.add b0 b1) + <<< + second (proc0 &&& proc1) + +windPhaser :: + IO (Real -> + PC.T Real -> + PC.T Real -> + PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +windPhaser = + liftA2 + (\osc env att phaserMix phaserFreq reson fm vel freq dur -> + osc ((phaserMix,phaserFreq), reson, (fm,freq)) (env att vel dur)) + (let phaserMix = arr (fst.fst3) + phaserFreq = arr (snd.fst3) + reson = arr snd3 + fm = arr thd3 + in CausalP.runStorableChunky $ + (CausalP.envelopeStereo $> + ((CausalP.stereoFromMonoControlled + (fadeProcess (arr snd) CtrlPS.process + <<< + first (CausalP.mapSimple SoV.replicate) + <<^ + (\((k,p),x) -> (k,(p,x)))) + $< SigP.zip + (piecewiseConstant phaserMix) + (piecewiseConstant + (fmap + (Allpass.flangerParameterPlain TypeNum.d8 . + (/sampleRate)) + ^<< phaserFreq))) + <<< + CausalP.stereoFromMonoControlled CtrlPS.process + $< SigP.zipWithSimple + (MoogL.parameter TypeNum.d8) + (piecewiseConstant reson) + (SigP.mapSimple Sample.subsampleVector + (frequencyFromBendModulation 0.2 fm)) + $* SigP.zipWithSimple Sample.zipStereo + (SigPS.noise 13 (sampleRate/20000)) + (SigPS.noise 14 (sampleRate/20000) + :: SigP.T p (LLVM.Value Vector))))) + softStringReleaseEnvelope + + +filterSawStereoFM :: + IO (Real -> Real -> + PC.T Real -> + Real -> Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +filterSawStereoFM = + liftA2 + (\osc env dec rel detune bright brightDecay fm vel freq dur -> + osc ((bright, brightDecay), (detune,fm,freq)) (env dec rel vel dur)) + (CausalP.runStorableChunky + (let bright = arr (fst.fst) + brightDec = arr (snd.fst) + fm = arr snd + in CausalP.envelopeStereo $> + (CausalP.stereoFromMono + (UniFilter.lowpass + ^<< + (CtrlPS.processCtrlRate $# (100::Real)) + (\k -> SigP.mapSimple + (UniFilterL.parameter (LLVM.valueOf 10)) + {- bound control in order to avoid too low resonant frequency, + which makes the filter instable -} + (SigP.exponentialBounded2 + (100/sampleRate) + (brightDec*sampleRate/k) + (bright/sampleRate))) + <<< + CausalPS.osciSimple WaveL.saw $< SigPS.constant zero) + $* stereoFrequenciesFromDetuneBendModulation 10 fm))) + pingReleaseEnvelope + + +{- | +The ADSR curve is composed from three parts: +Attack, Decay(+Sustain), Release. +Attack starts when the key is pressed +and lasts attackTime seconds +where it reaches height attackPeak*amplitudeOfVelocity. +It should be attackPeak>1 because in the following phase +we want to approach 1 from above. +Say the curve would approach the limit value L +if it would continue after the end of the attack phase, +the slope is determined by the halfLife with respect to this upper bound. +That is, attackHalfLife is the time in seconds where the attack curve +reaches or would reach L/2. +After Attack the Decay part starts at the same level +and decays to amplitudeOfVelocity. +The slope is again a halfLife, +that is, decayHalfLife is the time where the curve +drops from attackPeak*amplitudeOfVelocity to (attackPeak+1)/2*amplitudeOfVelocity. +This phase lasts as long as the key is pressed. +If the key is released the curve decays with half life releaseHalfLife. +-} +{- +1 - 2^(-attackTime/attackHalfLife) = peak +-} +adsr :: + IO (Real -> Real -> Real -> + Real -> Real -> + Real -> Ev.LazyTime -> SigSt.T Vector) +adsr = + liftA3 + (\attack decay release + attackTime attackPeak attackHalfLife + decayHalfLife releaseHalfLife vel dur -> + let amp = amplitudeFromVelocity vel + (attackDur, decayDur) = + CutG.splitAt (round (attackTime*vectorRate)) dur + in SigStL.continuePacked + (attack (chunkSizesFromLazyTime attackDur) + (attackHalfLife, + attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife))) + `SigSt.append` + decay (chunkSizesFromLazyTime decayDur) + (decayHalfLife, + ((attackPeak-1)*amp, amp))) + (\x -> release vectorChunkSize (releaseHalfLife,x))) + (SigP.runChunkyPattern $ + let halfLife = arr fst + amplitude = arr snd + in SigP.zipWithSimple A.sub + (SigPS.constant amplitude) + (SigPS.exponential2 (halfLife*sampleRate) amplitude)) + (SigP.runChunkyPattern $ + let halfLife = arr fst + amplitude = arr (fst.snd) + saturation = arr (snd.snd) + in SigP.mix (SigPS.constant saturation) $ + SigPS.exponential2 (halfLife*sampleRate) amplitude) + (SigP.runChunky $ + let release = arr fst + amplitude = arr snd + in (CausalP.take (round ^<< (release*5*vectorRate)) $* + SigPS.exponential2 (release*sampleRate) amplitude)) + +brass :: + IO (Real -> Real -> + Real -> Real -> Real -> Real -> + PC.T Real -> + PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +brass = + liftA2 + (\osc env attTime attPeak attHL dec rel emph det dist fm vel freq dur -> + osc + ((det, dist), (fm,freq), + env attTime emph attHL dec rel vel dur) + (env attTime attPeak attHL dec rel vel dur)) + (let det = arr (fst.fst3) + dist = arr (snd.fst3) + fm = arr snd3 + emph = arr thd3 + mix x y = CausalP.mix <<< x&&&y + osci :: + Param.T p Real -> + CausalP.T p + (LLVM.Value Vector, + {- wave shrink/replication factor -} + (LLVM.Value Vector, LLVM.Value Vector) + {- detune, frequency modulation -}) + (LLVM.Value Vector) + osci d = + CausalPS.shapeModOsci WaveL.rationalApproxSine1 + <<< + second + (CausalP.feedFst (SigPS.constant $# (zero::Real)) + <<< + CausalP.envelope + <<< + first (CausalPS.raise 1 <<< CausalPS.amplify d)) + in CausalP.runStorableChunky $ + (CausalP.envelopeStereo $> + (CausalPS.amplifyStereo 0.25 + <<< + CausalP.zipWithSimple Sample.zipStereo + <<< + ((osci 1.0 `mix` osci (-0.4)) `mix` + (osci 0.5 `mix` osci (-0.7))) &&& + ((osci 0.4 `mix` osci (-1.0)) `mix` + (osci 0.7 `mix` osci (-0.5))) + <<< + CausalP.feedFst (piecewiseConstantVector dist) + <<< + CausalP.feedSnd (frequencyFromBendModulation 5 fm) + <<< + (CausalP.envelope $< piecewiseConstantVector det) + $* + SigP.fromStorableVectorLazy emph))) + adsr + + +data SamplePositions = + SamplePositions { + sampleStart, sampleLength, + sampleLoopStart, sampleLoopLength :: Int + } + +data SampledSound = + SampledSound { + sampleData :: SigSt.T Real, + samplePositions :: SamplePositions, + samplePeriod :: Real + } + + +sampledSound :: + IO (SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSound = + liftA2 + (\osc freqMod smp fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let fmSig = + freqMod + (chunkSizesFromLazyTime (PC.duration fm)) + (fm, freq*samplePeriod smp) :: SigSt.T Vector + pos = samplePositions smp + amp = 2 * amplitudeFromVelocity vel + (attack,sustain) = + mapPair + (SigSt.drop (sampleStart pos), + SigSt.take (sampleLoopLength pos)) $ + SigSt.splitAt (sampleLoopStart pos) $ + sampleData smp + release = + SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ + SigSt.take (sampleStart pos + sampleLength pos) $ + sampleData smp + in (\cont -> osc cont + (amp, + attack `SigSt.append` + SVL.cycle (SigSt.take (sampleLoopLength pos) sustain), + chunkSizesFromLazyTime dur) + fmSig) + (osc (const SigSt.empty) + (amp, release, NonNegChunky.fromChunks (repeat 1000)))) + (CausalP.runStorableChunkyCont + (let amp = arr fst3 + smp = arr snd3 + dur = arr thd3 + in CausalPS.amplifyStereo amp + <<< + CausalP.stereoFromMono + (CausalPS.pack + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy smp))) + <<< + CausalP.zipWithSimple Sample.zipStereo + <<< + CausalPS.amplify 0.999 &&& + CausalPS.amplify 1.001 + <<< + arr fst + <<< + CausalP.feedSnd (SigP.lazySize dur))) + (SigP.runChunkyPattern + (frequencyFromBendModulation 3 (arr id))) + + +sampledSoundLeaky :: + IO (SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundLeaky = + liftA2 + (\osc freqMod smp fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (freqMod + (chunkSizesFromLazyTime (PC.duration fm)) + (fm, freq*samplePeriod smp) :: SigSt.T Vector) + pos = samplePositions smp + amp = 2 * amplitudeFromVelocity vel + (attack,sustain) = + mapPair + (SigSt.drop (sampleStart pos), + SigSt.take (sampleLoopLength pos)) $ + SigSt.splitAt (sampleLoopStart pos) $ + sampleData smp + release = + SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ + SigSt.take (sampleStart pos + sampleLength pos) $ + sampleData smp + in osc + (amp, + attack `SigSt.append` + SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)) + sustainFM + `SigSt.append` + osc (amp,release) releaseFM) + (CausalP.runStorableChunky + (let smp = arr snd + amp = arr fst + in CausalPS.amplifyStereo amp + <<< + CausalP.stereoFromMono + (CausalPS.pack + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy smp))) + <<< + CausalP.zipWithSimple Sample.zipStereo + <<< + CausalPS.amplify 0.999 &&& + CausalPS.amplify 1.001)) + (SigP.runChunkyPattern + (frequencyFromBendModulation 3 (arr id))) + + +type SampleInfo = (FilePath, [SamplePositions], Real) + +makeSampledSounds :: + SampleInfo -> + IO [-- PC.T Real -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)] +makeSampledSounds (path, positions, period) = do +{- + sound <- + (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<< + SoxRead.open SoxOption.none "speech/tomatensalat2.wav") + play (44100::Real) (sound::SVL.Vector Real) +-} + liftA2 + (\makeSmp smp -> + map (\pos -> makeSmp (SampledSound smp pos period)) + positions) + sampledSound + (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<< + SoxRead.open SoxOption.none path) + + +tomatensalatPositions :: [SamplePositions] +tomatensalatPositions = + SamplePositions 0 29499 12501 15073 : + SamplePositions 29499 31672 38163 17312 : + SamplePositions 67379 28610 81811 10667 : + SamplePositions 95989 31253 106058 16111 : + SamplePositions 127242 38596 136689 11514 : + [] + +tomatensalat :: SampleInfo +tomatensalat = + ("speech/tomatensalat2.wav", tomatensalatPositions, 324.5) + + +halPositions :: [SamplePositions] +halPositions = +-- SamplePositions 2371 25957 7362 6321 : + SamplePositions 2371 25957 (2371+25957) 1 : + SamplePositions 40546 34460 63540 9546 : + SamplePositions 79128 32348 94367 14016 : + SamplePositions 112027 21227 125880 5500 : + SamplePositions 146057 23235 168941 352 : + [] + +hal :: SampleInfo +hal = + ("speech/haskell-in-leipzig2.wav", halPositions, 316) + + +graphentheoriePositions :: [SamplePositions] +graphentheoriePositions = + SamplePositions 0 29524 13267 14768 : + SamplePositions 29524 35333 47624 9968 : + SamplePositions 64857 31189 73818 16408 : + SamplePositions 96046 31312 106206 18504 : + SamplePositions 127358 32127 132469 16530 : + [] + +graphentheorie :: SampleInfo +graphentheorie = + ("speech/graphentheorie0.wav", graphentheoriePositions, 301.15) diff --git a/src/Synthesizer/LLVM/Server/Packed/Run.hs b/src/Synthesizer/LLVM/Server/Packed/Run.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Packed/Run.hs @@ -0,0 +1,422 @@ +module Synthesizer.LLVM.Server.Packed.Run where + +import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr +import Synthesizer.LLVM.Server.Packed.Instrument + (Vector, vectorSize, vectorChunkSize, ) +import Synthesizer.LLVM.Server.Common + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Synthesizer.EventList.ALSA.MIDI as Ev +import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC +import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS +import qualified Synthesizer.Generic.ALSA.MIDI as Gen + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($<), ($*), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import qualified LLVM.Core as LLVM + +import qualified Synthesizer.Storable.Signal as SigSt + +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.MixedTime as EventListMT + +import Synthesizer.ApplicativeUtility (liftA4, liftA5, liftA6, ) +import Control.Arrow ((<<<), (^<<), {- (<<^), -} (&&&), {- (***), -} arr, first, {- second, -} ) +import Control.Applicative (pure, {- liftA, -} liftA2, liftA3, (<*>), ) +import Control.Monad.Trans.State (evalState, ) + +{- +import Data.Tuple.HT (mapPair, fst3, snd3, thd3, ) + +import qualified Numeric.NonNegative.Class as NonNeg +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Chunky as NonNegChunky +-} + +-- import qualified Algebra.RealRing as RealRing +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric (zero, round, ) +import Prelude hiding (Real, round, break, ) + + + +{-# INLINE withMIDIEventsMono #-} +withMIDIEventsMono :: + (Double -> Double -> SigSt.T Real -> IO b) -> + (EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO b +withMIDIEventsMono action proc = + let rate = sampleRate + per = periodTime + in Ev.withMIDIEvents per (rate / fromIntegral vectorSize) $ + action per rate . SigStL.unpack . proc + +{-# INLINE withMIDIEventsStereo #-} +withMIDIEventsStereo :: + (Double -> Double -> SigSt.T (Stereo.T Real) -> IO b) -> + (EventList.T Ev.StrictTime [Event.T] -> SigSt.T (Stereo.T Vector)) -> + IO b +withMIDIEventsStereo action proc = + let rate = sampleRate + per = periodTime + in do unpack <- SigStL.makeUnpackGeneric + Ev.withMIDIEvents per (rate / fromIntegral vectorSize) $ + action per rate . unpack . proc + + +-- maybe this can be merged into a PCS.controllerDiscrete +stair :: Real -> Real +stair i = + let n = fromIntegral (round i :: Int) + r = i - n + in n + 0.01*r + + +frequencyModulation :: IO () +frequencyModulation = do + osc <- + SigP.runChunky + ((CausalPS.osciSimple WaveL.triangle $<# (LLVM.vector [zero] :: Vector)) + $* Instr.frequencyFromBendModulation 10 (arr id &&& pure 880)) + withMIDIEventsMono play $ + osc vectorChunkSize . + evalState (PC.bendWheelPressure channel 2 0.04 (0.03::Real)) + + + +keyboard :: IO () +keyboard = do + sound <- Instr.pingRelease $/ 0.4 $/ 0.1 + amp <- CausalP.runStorableChunky (CausalPS.amplify $# 0.2) + arrange <- SigStL.makeArranger + withMIDIEventsMono play $ + (amp () :: SigSt.T Vector -> SigSt.T Vector) . + evalState (Gen.sequence (arrange vectorChunkSize) channel sound) + +keyboardStereo :: IO () +keyboardStereo = do + sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 + amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2) + arrange <- SigStL.makeArranger + withMIDIEventsStereo play $ + (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) . + evalState (Gen.sequence (arrange vectorChunkSize) channel sound) + + +keyboardFM :: IO () +keyboardFM = do + str <- Instr.softStringFM + amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2) + arrange <- SigStL.makeArranger + withMIDIEventsStereo play $ + (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) . + evalState + (do fm <- PC.bendWheelPressure channel 2 0.04 0.03 + Gen.sequenceModulated (arrange vectorChunkSize) fm channel str) + +keyboardFMMulti :: IO () +keyboardFMMulti = do + str <- Instr.softStringFM + tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1 + amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2) + arrange <- SigStL.makeArranger + withMIDIEventsStereo play $ + (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) . + evalState + (do fm <- PC.bendWheelPressure channel 2 0.04 0.03 + Gen.sequenceModulatedMultiProgram + (arrange vectorChunkSize) fm channel + (VoiceMsg.toProgram 1) + [str, tin]) + + +controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1, + controllerFilterCutoff, controllerFilterResonance, + controllerGlobal, controllerVolume :: VoiceMsg.Controller +[controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1, + controllerFilterCutoff, controllerFilterResonance, + controllerGlobal, controllerVolume] = + map VoiceMsg.toController [21, 22, 23, 24, 91, 93, 82, 83] + +controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4, + controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4 + :: VoiceMsg.Controller +[controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4, + controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4] = + map VoiceMsg.toController [25, 26, 27, 28, 70, 71, 72, 73] + +keyboardDetuneFMCore :: + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + Ev.Filter (SigSt.T (Stereo.T Vector))) +keyboardDetuneFMCore = do + str0 <- Instr.softStringDetuneFM + ssh0 <- Instr.softStringShapeFM + css0 <- Instr.cosineStringStereoFM + asw0 <- Instr.arcSawStringStereoFM + asn0 <- Instr.arcSineStringStereoFM + asq0 <- Instr.arcSquareStringStereoFM + atr0 <- Instr.arcTriangleStringStereoFM + wnd0 <- Instr.wind + wnp0 <- Instr.windPhaser + fms0 <- Instr.fmStringStereoFM + tin0 <- Instr.tineStereoFM + tnc0 <- Instr.tineControlledFM + fnd0 <- Instr.fenderFM + tnb0 <- Instr.tineBankFM + rfm0 <- Instr.resonantFMSynth + png0 <- Instr.pingStereoRelease + pngFM0 <- Instr.pingStereoReleaseFM + sqr0 <- Instr.squareStereoReleaseFM + bel0 <- Instr.bellStereoFM + ben0 <- Instr.bellNoiseStereoFM + flt0 <- Instr.filterSawStereoFM + brs0 <- Instr.brass + tmt0 <- Instr.makeSampledSounds Instr.tomatensalat + hal0 <- Instr.makeSampledSounds Instr.hal + grp0 <- Instr.makeSampledSounds Instr.graphentheorie + + let evHead = + fmap (EventListMT.switchBodyL + (error "empty controller stream") const) + flt = evalState $ + liftA5 (\rel -> flt0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (evHead $ + PCS.controllerExponential controllerTimbre0 (100,10000) 1000) + (evHead $ + PCS.controllerExponential controllerTimbre1 (0.1,1) 0.1) + (PCS.bendWheelPressure 2 0.04 0.03) + png = + (\rel -> png0 (4*rel) rel) . + evalState + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + pngFM = evalState $ + liftA5 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (evHead $ + PCS.controllerLinear controllerTimbre0 (0,1) 1) + (PCS.controllerExponential controllerTimbre1 (0.3,0.001) 0.05) + (PCS.bendWheelPressure 2 0.04 0.03) + sqr = evalState $ + liftA5 (\rel -> sqr0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05) + (PCS.controllerLinear controllerTimbre1 (0,0.25) 0.25) + (PCS.bendWheelPressure 2 0.04 0.03) + tin = evalState $ + liftA2 (\rel -> tin0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.bendWheelPressure 2 0.04 0.03) + tnc = evalState $ + liftA5 (\rel -> tnc0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (fmap (fmap stair) $ + PCS.controllerLinear controllerTimbre0 (0.5,6.5) 2) + (PCS.controllerLinear controllerTimbre1 (0,1.5) 1) + (PCS.bendWheelPressure 2 0.04 0.03) + fnd = evalState $ + liftA6 (\rel -> fnd0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (fmap (fmap stair) $ + PCS.controllerLinear controllerTimbre0 (0.5,20.5) 14) + (PCS.controllerLinear controllerTimbre1 (0,1.5) 0.3) + (PCS.controllerLinear controllerFMDepth1 (0,1) 0.25) + (PCS.bendWheelPressure 2 0.04 0.03) + tnb = evalState $ + pure (\rel -> tnb0 (4*rel) rel) + <*> (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + <*> (PCS.controllerLinear controllerFMDepth1 (0,2) 0) + <*> (PCS.controllerLinear controllerFMDepth2 (0,2) 0) + <*> (PCS.controllerLinear controllerFMDepth3 (0,2) 0) + <*> (PCS.controllerLinear controllerFMDepth4 (0,2) 0) + <*> (PCS.controllerLinear controllerFMPartial1 (0,1) 1) + <*> (PCS.controllerLinear controllerFMPartial2 (0,1) 0) + <*> (PCS.controllerLinear controllerFMPartial3 (0,1) 0) + <*> (PCS.controllerLinear controllerFMPartial4 (0,1) 0) + <*> (PCS.bendWheelPressure 2 0.04 0.03) + rfm = evalState $ + liftA6 (\rel -> rfm0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (PCS.controllerExponential controllerTimbre1 (1,100) 30) + (PCS.controllerLinear controllerTimbre0 (1,15) 3) + (PCS.controllerExponential controllerFMDepth1 (0.005,0.5) 0.1) + (PCS.bendWheelPressure 2 0.04 0.03) + bel = evalState $ + liftA3 (\rel -> bel0 (2*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (PCS.bendWheelPressure 2 0.05 0.02) + ben = evalState $ + liftA4 (\rel -> ben0 (2*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) + (PCS.controllerLinear controllerTimbre0 (0,1) 0.3) + (PCS.controllerExponential controllerTimbre1 (1,1000) 100) + (PCS.bendWheelPressure 2 0.05 0.02) + str = evalState $ + liftA3 str0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.bendWheelPressure 2 0.04 0.03) + ssh = evalState $ + liftA4 ssh0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05) + (PCS.bendWheelPressure 2 0.04 0.03) + makeArc gen = evalState $ + liftA4 gen + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5) + (PCS.bendWheelPressure 2 0.04 0.03) + css = makeArc css0 + asw = makeArc asw0 + asn = makeArc asn0 + asq = makeArc asq0 + atr = makeArc atr0 + fms = evalState $ + liftA5 fms0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerLinear controllerTimbre0 (0,0.5) 0.2) + (PCS.controllerExponential controllerTimbre1 (0.001,10) 0.1) + (PCS.bendWheelPressure 2 0.04 0.03) + wnd = evalState $ + liftA3 wnd0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerExponential controllerTimbre1 (1,1000) 100) + (PCS.bendWheelPressure 12 0.8 0) + wnp = evalState $ + liftA5 wnp0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerTimbre0 (0,1) 0.5) + (PCS.controllerExponential controllerDetune (50,5000) 500) + (PCS.controllerExponential controllerTimbre1 (1,1000) 100) + (PCS.bendWheelPressure 12 0.8 0) + brs = evalState $ + liftA5 + (\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0) + (evHead $ + PCS.controllerExponential controllerAttack (0.01,0.1) 0.01) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05) + (evHead $ + PCS.controllerLinear controllerTimbre1 (1,5) 3) + (PCS.bendWheelPressure 2 0.04 0.03) + freqMod = + evalState + (PCS.bendWheelPressure 2 0.04 0.03) + + arrange <- SigStL.makeArranger + amp <- + CausalP.runStorableChunky + (CausalP.envelopeStereo $< + Instr.piecewiseConstantVector (arr id)) + return + (\chan pgm -> do + volume <- + PC.controllerExponential chan + controllerVolume + (0.001, 1) 0.2 + + ctrls <- PCS.fromChannel chan + + fmap (amp volume) $ + Gen.sequenceModulatedMultiProgram + (arrange vectorChunkSize) ctrls chan pgm + ([tnc, fnd, pngFM, flt, bel, ben, sqr, brs, + ssh, fms, css, asn, atr, asq, asw, wnp] ++ + map (.freqMod) tmt0 ++ + map (.freqMod) hal0 ++ + map (.freqMod) grp0 ++ + [str, wnd, png, rfm, tin, tnb])) + + +keyboardDetuneFM :: IO () +keyboardDetuneFM = do + proc <- keyboardDetuneFMCore + withMIDIEventsStereo play $ + evalState (proc channel (VoiceMsg.toProgram 0)) + +keyboardFilter :: IO () +keyboardFilter = do + proc <- keyboardDetuneFMCore + mix <- CausalP.runStorableChunky + (CausalP.mixStereo <<< first (CausalPS.amplifyStereo 0.5) + $< SigP.fromStorableVectorLazy (arr id)) + + lowpass0 <- + CausalP.runStorableChunky $ +-- CausalPS.amplifyStereo 0.1 <<< + CausalPS.pack + (CausalP.stereoFromMonoControlled + (UniFilter.lowpass ^<< UniFilterL.causalP) $< + (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real)) + (piecewiseConstant (arr id))) + let lowpass :: + PC.T Real -> PC.T Real -> + SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector) + lowpass resons freqs = + lowpass0 (fmap UniFilter.parameter + (PC.zipWith FiltR.Pole resons (fmap (/sampleRate) freqs))) + + withMIDIEventsStereo (playAndRecord "/gentoo/server-llvm.f32") $ +-- withMIDIEventsStereo play $ + evalState + (do {- + It is important to retrieve the global controllers + before they are filtered out by PCS.fromChannel. + -} + let altChannel = (ChannelMsg.toChannel 1) + freq <- + PC.controllerExponential altChannel + controllerFilterCutoff + (100, 5000) 5000 + resonance <- + PC.controllerExponential altChannel + controllerFilterResonance + (1, 100) 1 + filterMusic <- proc altChannel (VoiceMsg.toProgram 8) + pureMusic <- proc channel (VoiceMsg.toProgram 0) + return + (pureMusic `mix` + lowpass resonance freq filterMusic)) diff --git a/src/Synthesizer/LLVM/Server/Packed/Test.hs b/src/Synthesizer/LLVM/Server/Packed/Test.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Packed/Test.hs @@ -0,0 +1,680 @@ +module Synthesizer.LLVM.Server.Packed.Test where + +import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr +import Synthesizer.LLVM.Server.Packed.Instrument + (Vector, vectorChunkSize, + sampleStart, sampleLength, + sampleLoopStart, sampleLoopLength, + samplePositions, sampleData, samplePeriod, ) +import Synthesizer.LLVM.Server.Common + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC +import qualified Synthesizer.Generic.ALSA.MIDI as Gen + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, ) + +import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Sample as Sample +import Synthesizer.LLVM.CausalParameterized.Process (($*), ) + +import qualified LLVM.Core as LLVM + +import qualified Synthesizer.Storable.Cut as CutSt +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SVP +import qualified Data.StorableVector.Lazy as SVL +-- import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT + +import Control.Arrow ((<<<), (&&&), arr, ) +import Control.Applicative (pure, liftA, liftA2, ) +import Control.Monad.Trans.State (evalState, ) + +import Data.Tuple.HT (mapPair, ) + +{- +import qualified Numeric.NonNegative.Class as NonNeg +-} +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Chunky as NonNegChunky + +{- +import qualified Algebra.RealRing as RealRing +import qualified Algebra.Additive as Additive +-} + +-- import NumericPrelude.Numeric (zero, round, (^?), ) +import Prelude hiding (Real, round, break, ) + + +{- | +try to reproduce a space leak +-} +sequencePlain :: IO () +sequencePlain = + SVL.writeFile "test.f32" $ +-- print $ last $ SVL.chunks $ + evalState (Gen.sequence (CutSt.arrange chunkSize) channel (error "no sound" :: Instrument Real Real)) $ + let evs = EventList.cons 10 [] evs + in evs + +sequenceLLVM :: IO () +sequenceLLVM = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ +-- print $ last $ SVL.chunks $ + evalState (Gen.sequence (arrange vectorChunkSize) channel (error "no sound" :: Instrument Real Vector)) $ + let evs = EventList.cons 10 [] evs + in evs + +sequencePitchBendCycle :: IO () +sequencePitchBendCycle = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + evalState + (let -- fm = error "undefined pitch bend" + fm = EventListBT.cons 1 10 fm + in Gen.sequenceModulated (arrange vectorChunkSize) fm channel + (error "no sound" :: + PC.T Real -> Instrument Real Vector)) $ + let evs = EventList.cons 10 [] evs + in evs + +sequencePitchBendSimple :: IO () +sequencePitchBendSimple = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + evalState + (let fm y = EventListBT.cons y 10 (fm (2-y)) + in Gen.sequenceModulated (arrange vectorChunkSize) (fm 1) channel + (error "no sound" :: + PC.T Real -> Instrument Real Vector)) $ + let evs = EventList.cons 10 [] evs + in evs + +sequencePitchBend :: IO () +sequencePitchBend = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + evalState + (do fm <- PC.pitchBend channel 2 0.01 + Gen.sequenceModulated (arrange vectorChunkSize) fm channel + (error "no sound" :: + PC.T Real -> Instrument Real Vector)) $ + let evs = EventList.cons 10 [] evs + in evs + +sequenceModulated :: IO () +sequenceModulated = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + evalState + (do fm <- PC.bendWheelPressure channel 2 0.04 0.03 + Gen.sequenceModulated (arrange vectorChunkSize) fm channel + (error "no sound" :: + PC.T (MIDIL.BendModulation Real) -> + Instrument Real Vector)) $ + let evs = EventList.cons 10 [] evs + in evs + +sequenceModulatedLong :: IO () +sequenceModulatedLong = do + arrange <- SigStL.makeArranger +-- sound <- Instr.softStringReleaseEnvelope + sound <- Instr.softString -- space leak +-- sound <- Instr.pingReleaseEnvelope $/ 1 -- no space leak +-- sound <- Instr.pingRelease $/ 1 $/ 1 -- no space leak + SVL.writeFile "test.f32" $ + evalState + (Gen.sequence (arrange vectorChunkSize) channel sound) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + EventList.cons 10 [makeNote Event.NoteOn 64] $ + evs 10 + +sequenceModulatedLongFM :: IO () +sequenceModulatedLongFM = do + arrange <- SigStL.makeArranger + sound <- Instr.softStringFM + SVL.writeFile "test.f32" $ + evalState + (do fm <- PC.bendWheelPressure channel 2 0.04 0.03 + Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + EventList.cons 10 [makeNote Event.NoteOn 64] $ + evs 10 + +sequenceModulatedRepeat :: IO () +sequenceModulatedRepeat = do + arrange <- SigStL.makeArranger + sound <- Instr.softStringFM + SVL.writeFile "test.f32" $ + evalState + (do fm <- PC.bendWheelPressure channel 2 0.04 0.03 + Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $ + let evs t = + EventList.cons t [makeNote Event.NoteOn 60] $ + EventList.cons t [makeNote Event.NoteOff 60] $ + evs (20-t) + in evs 10 + +sequencePress :: IO () +sequencePress = do + arrange <- SigStL.makeArranger +-- sound <- Instr.softString +-- sound <- Instr.softStringReleaseEnvelope + sound <- Instr.pingReleaseEnvelope $/ 1 + SVL.writeFile "test.f32" $ + evalState + (do Gen.sequence (arrange vectorChunkSize) channel sound) $ + let evs t = + EventList.cons t [makeNote Event.NoteOn 60] $ + EventList.cons t [makeNote Event.NoteOff 60] $ + evs (20-t) + in evs 10 + + +sampledSoundTest0 :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest0 = + liftA + (\osc smp _fm _vel _freq _dur -> + osc chunkSize (sampleData smp)) + (SigP.runChunky + (let smp = arr id + in fmap (\x -> Stereo.cons x x) $ + SigPS.pack $ + SigP.fromStorableVectorLazy smp)) + +sampledSoundTest1 :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest1 = + liftA + (\osc smp _fm _vel _freq _dur -> + osc chunkSize (sampleData smp)) + (SigP.runChunky + (let smp = arr id + in CausalP.stereoFromMono + (CausalPS.pack + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy smp))) + $* SigP.zipWithSimple Sample.zipStereo + (SigPS.constant 0.999) + (SigPS.constant 1.001))) +-- $* (SigPS.constant $# Stereo.cons 0.999 1.001))) + +sampledSoundTest2 :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest2 = + liftA + (\osc smp fm _vel freq dur -> + let pos = samplePositions smp + body = + SigSt.take (sampleLength pos) $ + SigSt.drop (sampleStart pos) $ + sampleData smp + in SVP.take (chunkSizesFromLazyTime dur) $ + osc chunkSize (body, (fm, freq * samplePeriod smp))) + (SigP.runChunky + (let smp = arr fst + fm = arr snd + in (CausalP.stereoFromMono + (CausalPS.pack + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy smp))) + <<< + CausalP.zipWithSimple Sample.zipStereo + <<< + CausalPS.amplify 0.999 &&& + CausalPS.amplify 1.001) + $* Instr.frequencyFromBendModulation 3 fm)) + +sampledSoundTest3SpaceLeak :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest3SpaceLeak = + liftA + (\osc smp _fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat chunkSize + (LLVM.vector [freq*samplePeriod smp/sampleRate]) + :: SigSt.T Vector) + pos = samplePositions smp + amp = 2 * amplitudeFromVelocity vel + (attack,sustain) = + mapPair + (SigSt.drop (sampleStart pos), + SigSt.take (sampleLoopLength pos)) $ + SigSt.splitAt (sampleLoopStart pos) $ + sampleData smp + release = + SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ + SigSt.take (sampleStart pos + sampleLength pos) $ + sampleData smp + in osc + (amp, + attack `SigSt.append` + SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)) + sustainFM + `SigSt.append` + osc (amp,release) releaseFM) + (CausalP.runStorableChunky + (let smp = arr snd + amp = arr fst + in CausalPS.amplifyStereo amp + <<< + CausalP.stereoFromMono + (CausalPS.pack + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy smp))) + <<< + CausalP.zipWithSimple Sample.zipStereo + <<< + CausalPS.amplify 0.999 &&& + CausalPS.amplify 1.001)) + +sampledSoundTest4NoSpaceLeak :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest4NoSpaceLeak = + liftA + (\freqMod smp fm _vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (freqMod + (chunkSizesFromLazyTime (PC.duration fm)) + (fm, freq*samplePeriod smp) :: SigSt.T Vector) + in SigSt.map + (\x -> Stereo.cons x x) + (sustainFM `SigSt.append` releaseFM)) + (SigP.runChunkyPattern + (Instr.frequencyFromBendModulation 3 (arr id))) + +sampledSoundTest5LargeSpaceLeak :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest5LargeSpaceLeak = + liftA2 + (\osc freqMod smp fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (freqMod + (chunkSizesFromLazyTime (PC.duration fm)) + (fm, freq*samplePeriod smp) :: SigSt.T Vector) + pos = samplePositions smp + amp = 2 * amplitudeFromVelocity vel + (attack,sustain) = + mapPair + (SigSt.drop (sampleStart pos), + SigSt.take (sampleLoopLength pos)) $ + SigSt.splitAt (sampleLoopStart pos) $ + sampleData smp + release = + SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ + SigSt.take (sampleStart pos + sampleLength pos) $ + sampleData smp + in osc + (amp, + attack `SigSt.append` + SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)) + sustainFM + `SigSt.append` + osc (amp,release) releaseFM) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + (SigP.runChunkyPattern + (Instr.frequencyFromBendModulation 3 (arr id))) + + +sampledSoundSmallSpaceLeak4 :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak4 = + liftA + (\osc smp _fm _vel freq dur -> + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat chunkSize + (LLVM.vector [freq*samplePeriod smp/sampleRate]) + :: SigSt.T Vector) + in osc () sustainFM + `SigSt.append` + SigSt.map (\x -> Stereo.cons x x) releaseFM) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + +sampledSoundSmallSpaceLeak4a :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak4a = + liftA + (\osc smp _fm _vel freq dur -> + case SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat chunkSize + (LLVM.vector [freq*samplePeriod smp/sampleRate]) + :: SigSt.T Vector) of + (sustainFM, releaseFM) -> + osc () sustainFM + `SigSt.append` + SigSt.map (\x -> Stereo.cons x x) releaseFM) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + +sampledSoundNoSmallSpaceLeak3 :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundNoSmallSpaceLeak3 = + pure + (\smp _fm _vel freq dur -> + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat chunkSize + (LLVM.vector [freq*samplePeriod smp/sampleRate]) + :: SigSt.T Vector) + in SigSt.map (\x -> Stereo.cons x x) sustainFM + `SigSt.append` + SigSt.map (\x -> Stereo.cons x x) releaseFM) + +{-# NOINLINE amplifySVL #-} +amplifySVL :: SVL.Vector Vector -> SVL.Vector Vector +amplifySVL = SigSt.map (2*) + +sampledSoundNoSmallSpaceLeak2 :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundNoSmallSpaceLeak2 = + liftA + (\osc smp _fm _vel freq dur -> + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat chunkSize + (LLVM.vector [freq*samplePeriod smp/sampleRate]) + :: SigSt.T Vector) + in osc () + (amplifySVL sustainFM + `SigSt.append` + amplifySVL releaseFM)) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + +sampledSoundSmallSpaceLeak1 :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak1 = + liftA + (\osc smp _fm _vel freq dur -> + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat chunkSize + (LLVM.vector [freq*samplePeriod smp/sampleRate]) + :: SigSt.T Vector) + in osc () sustainFM + `SigSt.append` + osc () releaseFM) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + +sampledSoundSmallSpaceLeak0 :: + IO (Instr.SampledSound -> + PC.T (PC.BendModulation Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak0 = + liftA + (\osc smp _fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat chunkSize + (LLVM.vector [freq*samplePeriod smp/sampleRate]) + :: SigSt.T Vector) + pos = samplePositions smp + amp = 2 * amplitudeFromVelocity vel + (attack,sustain) = + mapPair + (SigSt.drop (sampleStart pos), + SigSt.take (sampleLoopLength pos)) $ + SigSt.splitAt (sampleLoopStart pos) $ + sampleData smp + release = + SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ + SigSt.take (sampleStart pos + sampleLength pos) $ + sampleData smp + in osc + (amp, + attack `SigSt.append` + SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)) + sustainFM + `SigSt.append` + osc (amp,release) releaseFM) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + + + +sequenceSample :: IO () +sequenceSample = do + arrange <- SigStL.makeArranger + sampler <- sampledSoundTest2 + let sound = + sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0) + (Instr.SamplePositions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + evalState + (do fm <- PC.bendWheelPressure channel 2 0.04 0.03 + Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + evs 10 + +{- +sequenceSample1 :: IO () +sequenceSample1 = do + sampler <- Instr.sampledSound + let sound = + sampler (SampledSound (SigSt.replicate chunkSize 100000 0) + (SamplePositions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + sound +{- + (let evs f = + EventListBT.cons (MIDIL.BendModulation 0.001 f) 10 (evs (0.02-f)) + in evs 0.01) +-} + (let evs t = + EventListBT.cons (MIDIL.BendModulation 0.01 0.001) t (evs (20-t)) + in evs 10) +{- + (PCS.Cons + (Map.singleton + (PC.Controller VoiceMsg.modulation) 1) + (let evs t = EventList.cons t [] (evs (20-t)) + in EventListMT.consTime 10 $ evs 10)) +-} + 0.01 1 +-- (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10) + (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10) +-} + +sequenceSample1 :: IO () +sequenceSample1 = do + sampler <- sampledSoundSmallSpaceLeak4a + let sound = + sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0) + (Instr.SamplePositions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + sound + (let evs = EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 1 evs + in evs) + 0.01 1 + (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10) + +{- +sequenceSample1a :: IO () +sequenceSample1a = do +{- + makeStereoLLVM <- + CausalP.runStorableChunky2 -- NoSpaceLeak + (arr (\x -> Stereo.cons x x)) + let stereoLLVM = makeStereoLLVM () +-} + stereoLLVM <- CausalP.runStorableChunky3 + let stereoPlain = SigSt.map (\x -> Stereo.cons x x) + SVL.writeFile "test.f32" $ + let dur = NonNegChunky.fromChunks $ repeat $ SVL.chunkSize 10 + !(sustainFM, releaseFM) = + SVP.splitAt dur $ + (SigSt.repeat chunkSize (LLVM.vector [1]) + :: SigSt.T Vector) + in case 3::Int of + -- no leak + 0 -> stereoLLVM $ sustainFM `SigSt.append` releaseFM + -- no leak + 1 -> stereoPlain $ sustainFM `SigSt.append` releaseFM + -- no leak + 2 -> stereoPlain sustainFM `SigSt.append` stereoPlain releaseFM + -- leak + 3 -> stereoLLVM sustainFM `SigSt.append` stereoPlain releaseFM + -- no leak + 4 -> stereoPlain sustainFM `SigSt.append` stereoLLVM releaseFM + -- leak + 5 -> stereoLLVM sustainFM `SigSt.append` stereoLLVM releaseFM +-} + +sequenceSample2 :: IO () +sequenceSample2 = do + arrange <- SigStL.makeArranger + sampler <- sampledSoundTest2 + let sound = + sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0) + (Instr.SamplePositions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + evalState + (do bend <- PC.pitchBend channel 2 0.01 + let fm = fmap (\t -> MIDIL.BendModulation t t) bend + Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + evs 10 + +{- +Interestingly, when the program aborts because of heap exhaustion, +then the generated file has size 137MB independent of the heap size +(I tried sizes from 1MB to 64MB). +-} +sequenceSample3 :: IO () +sequenceSample3 = do + arrange <- SigStL.makeArranger + sampler <- sampledSoundTest2 + let sound = + sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0) + (Instr.SamplePositions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + evalState + (let evs = + EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 10 evs + in Gen.sequence (arrange vectorChunkSize) channel (sound evs)) $ + let evs = EventList.cons 10 [] evs + in EventList.cons 10 [makeNote Event.NoteOn 60] evs + +sequenceSample4 :: IO () +sequenceSample4 = do + arrange <- SigStL.makeArranger + sampler <- Instr.sampledSound +-- sampler <- sampledSoundTest2 + let sound = + sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0) + (Instr.SamplePositions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + evalState + (let evs = + EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 10 evs + in Gen.sequenceCore + (arrange vectorChunkSize) channel Gen.errorNoProgram + (Gen.Modulator () return + (return . Gen.renderInstrumentIgnoreProgram (sound evs)))) $ + let evs = EventList.cons 10 [] evs + in EventList.cons 10 [makeNote Event.NoteOn 60] evs + +sequenceFM1 :: IO () +sequenceFM1 = do + arrange <- SigStL.makeArranger + sound <- Instr.softStringFM $/ + let evs = + EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 10 evs + in evs +-- sound <- Instr.softStringReleaseEnvelope + SVL.writeFile "test.f32" $ + evalState + (Gen.sequenceCore + (arrange vectorChunkSize) channel Gen.errorNoProgram + (Gen.Modulator () return + (return . Gen.renderInstrumentIgnoreProgram sound))) $ + let evs = EventList.cons 10 [] evs + in EventList.cons 10 [makeNote Event.NoteOn 60] evs +{- + sound + 0.01 1 + (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10) +-} + + +adsr :: IO () +adsr = do + env <- Instr.adsr + SVL.writeFile "adsr.f32" $ + env 0.2 2 0.15 0.3 0.5 (-0.5) 88200 diff --git a/src/Synthesizer/LLVM/Server/Scalar/Instrument.hs b/src/Synthesizer/LLVM/Server/Scalar/Instrument.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Scalar/Instrument.hs @@ -0,0 +1,199 @@ +module Synthesizer.LLVM.Server.Scalar.Instrument where + +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.EventList.ALSA.MIDI as Ev + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, ) + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Sample as Sample +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import qualified LLVM.Core as LLVM + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SigStV +import qualified Data.StorableVector.Lazy as SVL + +import Control.Arrow ((<<<), (^<<), (&&&), arr, ) +import Control.Applicative (pure, liftA, liftA2, ) + +import qualified Algebra.RealRing as RealRing +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric (zero, round, ) +import Prelude hiding (Real, round, break, ) + + +pingSig :: SigP.T (Real, Real) (LLVM.Value Real) +pingSig = + let vel = arr fst + freq = arr snd + in CausalP.envelope + $< SigP.exponential2 (pure (0.2*sampleRate)) + (fmap amplitudeFromVelocity vel) + $* SigP.osciSimple WaveL.saw zero (freq/sampleRate) + +ping :: IO (Real -> Real -> SigSt.T Real) +ping = + fmap curry $ fmap ($chunkSize) $ SigP.runChunky pingSig + +pingDur :: IO (Instrument Real Real) +pingDur = + fmap + (\sound vel freq dur -> + sound (chunkSizesFromLazyTime dur) (vel, freq)) $ + SigP.runChunkyPattern pingSig + +pingDurTake :: IO (Instrument Real Real) +pingDurTake = + fmap (\sound vel freq dur -> + SigStV.take (chunkSizesFromLazyTime dur) $ + sound vel freq) ping + +dummy :: Instrument Real Real +dummy = + \vel freq dur -> + SigStV.take (chunkSizesFromLazyTime dur) $ + SigSt.repeat chunkSize (vel + 1e-3*freq) + + + +pingReleaseEnvelope :: + IO (Real -> Real -> Real -> Ev.LazyTime -> SigSt.T Real) +pingReleaseEnvelope = + liftA2 + (\pressed release decay rel vel dur -> + SigStL.continue + (pressed (chunkSizesFromLazyTime dur) (decay,vel)) + (\x -> release chunkSize (rel,x))) + (SigP.runChunkyPattern $ + let decay = arr fst + velocity = arr snd + in SigP.exponential2 (decay*sampleRate) + (amplitudeFromVelocity ^<< velocity)) + (SigP.runChunky $ + let release = arr fst + amplitude = arr snd + in (CausalP.take (round ^<< (release*3*sampleRate)) $* + SigP.exponential2 (release*sampleRate) amplitude)) + +pingRelease :: IO (Real -> Real -> Instrument Real Real) +pingRelease = + liftA2 + (\osc env dec rel vel freq dur -> + osc freq (env dec rel vel dur)) + (CausalP.runStorableChunky + (let freq = arr id + in CausalP.envelope $> + SigP.osciSimple WaveL.saw zero (freq/sampleRate))) + pingReleaseEnvelope + +pingStereoRelease :: IO (Real -> Real -> Instrument Real (Stereo.T Real)) +pingStereoRelease = + liftA2 + (\osc env dec rel vel freq dur -> + osc freq (env dec rel vel dur)) + (CausalP.runStorableChunky + (let freq = arr id + in CausalP.envelopeStereo $> + SigP.zipWithSimple Sample.zipStereo + (SigP.osciSimple WaveL.saw zero + (0.999*freq/sampleRate)) + (SigP.osciSimple WaveL.saw zero + (1.001*freq/sampleRate)))) + pingReleaseEnvelope + + + +tine :: IO (Real -> Real -> Instrument Real Real) +tine = + liftA2 + (\osc env dec rel vel freq dur -> + osc (vel,freq) (env dec rel 0 dur)) + (CausalP.runStorableChunky + (let freq = arr snd + vel = arr fst + in CausalP.envelope $> + (CausalP.osciSimple WaveL.approxSine2 + $> (SigP.constant (freq/sampleRate)) + $* (CausalP.envelope + $< SigP.exponential2 (1*sampleRate) (vel+1) + $* SigP.osciSimple WaveL.approxSine2 zero + (2*freq/sampleRate))))) + pingReleaseEnvelope + +tineStereo :: IO (Real -> Real -> Instrument Real (Stereo.T Real)) +tineStereo = + liftA2 + (\osc env dec rel vel freq dur -> + osc (vel,freq) (env dec rel 0 dur)) + (CausalP.runStorableChunky + (let freq = arr snd + vel = arr fst + chanOsci d = + CausalP.osciSimple WaveL.approxSine2 + $> SigP.constant (freq*d/sampleRate) + in CausalP.envelopeStereo $> + ((CausalP.zipWithSimple Sample.zipStereo <<< + chanOsci 0.995 &&& chanOsci 1.005) + $* SigP.envelope + (SigP.exponential2 (1*sampleRate) (vel+1)) + (SigP.osciSimple WaveL.approxSine2 zero + (2*freq/sampleRate))))) + pingReleaseEnvelope + + + +softStringReleaseEnvelope :: + IO (Real -> Ev.LazyTime -> SigSt.T Real) +softStringReleaseEnvelope = + let attackTime = sampleRate + in liftA + (\env vel dur -> + let amp = amplitudeFromVelocity vel + {- + release <- take attackTime beginning + would yield a space leak, thus we first split 'beginning' + and then concatenate it again + -} + {- + We can not easily generate attack and sustain separately, + because we want to use the chunk structure implied by 'dur'. + -} + (attack, sustain) = + SigSt.splitAt attackTime $ + env (chunkSizesFromLazyTime dur) amp + release = SigSt.reverse attack + in attack `SigSt.append` sustain `SigSt.append` release) + (let amp = arr id + in SigP.runChunkyPattern $ + flip SigP.append (SigP.constant amp) $ + SigP.amplify amp $ + (SigP.parabolaFadeIn $# fromIntegral attackTime)) + +softString :: IO (Instrument Real (Stereo.T Real)) +softString = + liftA2 + (\osc env vel freq dur -> + osc freq (env vel dur)) + (let freq = arr id + osci d = + SigP.osciSimple WaveL.saw zero (d * freq / sampleRate) + in CausalP.runStorableChunky $ + (CausalP.envelopeStereo $> + (SigP.zipWithSimple Sample.zipStereo + (SigP.mix + (osci 1.005) + (osci 0.998)) + (SigP.mix + (osci 1.002) + (osci 0.995))))) + softStringReleaseEnvelope diff --git a/src/Synthesizer/LLVM/Server/Scalar/Run.hs b/src/Synthesizer/LLVM/Server/Scalar/Run.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Scalar/Run.hs @@ -0,0 +1,123 @@ +module Synthesizer.LLVM.Server.Scalar.Run where + +import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr +import Synthesizer.LLVM.Server.Common + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Data.EventList.Relative.TimeBody as EventList + +import qualified Synthesizer.EventList.ALSA.MIDI as Ev +import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC +import qualified Synthesizer.Generic.ALSA.MIDI as Gen + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($*), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import Control.Arrow ((<<<), arr, ) +import Control.Monad.Trans.State (evalState, ) + +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric (zero, (*>), ) +import Prelude hiding (Real, break, ) + + +{-# INLINE withMIDIEvents #-} +withMIDIEvents :: + (Double -> Double -> a -> IO b) -> + (EventList.T Ev.StrictTime [Event.T] -> a) -> IO b +withMIDIEvents action proc = + let rate = sampleRate + per = periodTime + in Ev.withMIDIEvents per rate $ + action per rate . proc + + + +pitchBend :: IO () +pitchBend = do + osc <- + SigP.runChunky + ((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) + $* piecewiseConstant (arr id)) + withMIDIEvents play $ + (id :: SigSt.T Real -> SigSt.T Real) . + osc chunkSize . + evalState (PC.pitchBend channel 2 (880/sampleRate::Real)) + + +frequencyModulation :: IO () +frequencyModulation = do + osc <- + SigP.runChunky + (((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) + <<< (MIDIL.frequencyFromBendModulation $# (10/sampleRate::Real))) + $* piecewiseConstant (arr (transposeModulation 880))) + withMIDIEvents play $ + (id :: SigSt.T Real -> SigSt.T Real) . + osc chunkSize . + evalState (PC.bendWheelPressure channel 2 0.04 (0.03::Real)) + + + +keyboard :: IO () +keyboard = do +-- sound <- Instr.pingDur +{- + sound <- + fmap (\s vel _freq dur -> s vel dur) $ + (Instr.pingReleaseEnvelope $/ 0.4 $/ 0.1) +-} + sound <- Instr.pingRelease $/ 0.4 $/ 0.1 + amp <- CausalP.runStorableChunky (CausalP.amplify $# 0.2) + arrange <- SigStL.makeArranger + withMIDIEvents play $ + (amp () :: SigSt.T Real -> SigSt.T Real) . + evalState (Gen.sequence (arrange chunkSize) channel sound) + +keyboardStereo :: IO () +keyboardStereo = do + sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 + amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2) + arrange <- SigStL.makeArranger + withMIDIEvents play $ + (amp () :: SigSt.T (Stereo.T Real) -> SigSt.T (Stereo.T Real)) . + evalState (Gen.sequence (arrange chunkSize) channel sound) + +keyboardMulti :: IO () +keyboardMulti = do + png <- Instr.pingDur + pngRel <- Instr.pingRelease $/ 0.4 $/ 0.1 + tin <- Instr.tine $/ 0.4 $/ 0.1 + arrange <- SigStL.makeArranger + withMIDIEvents play $ +-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) . + SigSt.map (0.2*) . + evalState (Gen.sequenceMultiProgram (arrange chunkSize) channel + (VoiceMsg.toProgram 2) + [png, pngRel, tin]) + +keyboardStereoMulti :: IO () +keyboardStereoMulti = do + png <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 + tin <- Instr.tineStereo $/ 0.4 $/ 0.1 + str <- Instr.softString + arrange <- SigStL.makeArranger + withMIDIEvents play $ +-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) . + SigSt.map ((0.2::Real)*>) . + evalState (Gen.sequenceMultiProgram (arrange chunkSize) channel + (VoiceMsg.toProgram 1) + [png, tin, str]) diff --git a/src/Synthesizer/LLVM/Server/Scalar/Test.hs b/src/Synthesizer/LLVM/Server/Scalar/Test.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Scalar/Test.hs @@ -0,0 +1,78 @@ +module Synthesizer.LLVM.Server.Scalar.Test where + +import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr +import Synthesizer.LLVM.Server.Scalar.Run (withMIDIEvents, ) +import Synthesizer.LLVM.Server.Common + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC +import qualified Synthesizer.Generic.ALSA.MIDI as Gen + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($*), ) + +import qualified Synthesizer.Storable.Cut as CutSt +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import qualified Data.EventList.Relative.TimeBody as EventList + +import Control.Arrow (arr, ) +import Control.Monad.Trans.State (evalState, ) + +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric (zero, ) +import Prelude hiding (Real, ) + + +pitchBend0 :: IO () +pitchBend0 = do + osc <- + SigP.runChunky + ((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) + $* piecewiseConstant (arr id)) + SVL.writeFile "test.f32" $ + (id :: SigSt.T Real -> SigSt.T Real) . + osc chunkSize . + evalState (PC.pitchBend channel 2 (880/sampleRate::Real)) $ + let evs = EventList.cons 100 [] evs + in EventList.cons 0 [] evs + +pitchBend1 :: IO () +pitchBend1 = do + osc <- + SigP.runChunky + ((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) + $* piecewiseConstant (arr id)) + withMIDIEvents (\ _period _rate -> SVL.writeFile "test.f32") $ + (id :: SigSt.T Real -> SigSt.T Real) . + osc chunkSize . + evalState (PC.pitchBend channel 2 (880/sampleRate::Real)) + +pitchBend2 :: IO () +pitchBend2 = + withMIDIEvents (\ _period _rate -> print) id + + + +sequencePress :: IO () +sequencePress = do +-- arrange <- SigStL.makeArranger +-- sound <- Instr.softString +-- sound <- Instr.softStringReleaseEnvelope +-- sound <- Instr.pingReleaseEnvelope $/ 1 +-- sound <- Instr.pingDur +-- sound <- Instr.pingDurTake + let sound = Instr.dummy + SVL.writeFile "test.f32" $ + evalState + (do Gen.sequence (CutSt.arrange chunkSize) channel sound) $ + let evs t = + EventList.cons t [makeNote Event.NoteOn 60] $ + EventList.cons t [makeNote Event.NoteOff 60] $ + evs (20-t) + in evs 10 + diff --git a/src/Synthesizer/LLVM/Simple/Signal.hs b/src/Synthesizer/LLVM/Simple/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Simple/Signal.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.Simple.Signal where + +import qualified LLVM.Extra.Representation as Rep +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.Sample as Sample +import qualified Synthesizer.LLVM.Execution as Exec +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.MaybeContinuation as Maybe + +import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified LLVM.Extra.Arithmetic as A +import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) +import LLVM.Extra.Control (whileLoop, ifThen, ) + +import LLVM.Core +import LLVM.Util.Loop (Phi, ) + +import Control.Monad (liftM2, liftM3, ) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import Data.Word (Word32, ) +import Foreign.Storable.Tuple () +import Foreign.Storable (Storable, ) +import Foreign.Marshal.Array (advancePtr, ) +import qualified Foreign.Marshal.Array as Array +import qualified Foreign.Marshal.Alloc as Alloc +import Foreign.ForeignPtr + (unsafeForeignPtrToPtr, touchForeignPtr, withForeignPtr, ) +import Foreign.Ptr (FunPtr, nullPtr, ) +import Control.Exception (bracket, ) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, ) + + +{- +We need the forall quantification for 'CodeGenFunction's @r@ parameter. +This type parameter will be unified with the result type of the final function. +Since one piece of code can be used in multiple functions +we cannot yet fix the type @r@ here. + +We might avoid code duplication by defining + +> newtype T a = Cons (Causal.T () a) +-} +data T a = + forall state packed size ioContext. + (Rep.Memory state packed, IsSized packed size) => + Cons (forall r c. + (Phi c) => + ioContext -> + state -> Maybe.T r c (a, state)) + -- compute next value + (forall r. + ioContext -> + CodeGenFunction r state) + -- initial state + (IO ioContext) + {- initialization from IO monad + This will be run within unsafePerformIO, + so no observable In/Out actions please! + -} + (ioContext -> IO ()) + -- finalization from IO monad, also run within unsafePerformIO + +simple :: + (Rep.Memory state packed, IsSized packed size) => + (forall r c. + state -> Maybe.T r c (a, state)) -> + (forall r. CodeGenFunction r state) -> + T a +simple next start = + Cons + (const next) + (const start) + (return ()) + (const $ return ()) + + +map :: + (forall r. a -> CodeGenFunction r b) -> T a -> T b +map f (Cons next start createIOContext deleteIOContext) = + Cons + (\ioContext sa0 -> do + (a,sa1) <- next ioContext sa0 + b <- Maybe.lift $ f a + return (b, sa1)) + start + createIOContext deleteIOContext + +mapAccum :: + (Rep.Memory s struct, IsSized struct sa) => + (forall r. a -> s -> CodeGenFunction r (b,s)) -> + (forall r. CodeGenFunction r s) -> + T a -> T b +mapAccum f startS + (Cons next start createIOContext deleteIOContext) = + Cons + (\ioContext (sa0,ss0) -> do + (a,sa1) <- next ioContext sa0 + (b,ss1) <- Maybe.lift $ f a ss0 + return (b, (sa1,ss1))) + (\ioContext -> + liftM2 (,) (start ioContext) startS) + createIOContext deleteIOContext + + +zipWith :: + (forall r. a -> b -> CodeGenFunction r c) -> T a -> T b -> T c +zipWith f + (Cons nextA startA createIOContextA deleteIOContextA) + (Cons nextB startB createIOContextB deleteIOContextB) = + Cons + (\(ioContextA, ioContextB) (sa0,sb0) -> do + (a,sa1) <- nextA ioContextA sa0 + (b,sb1) <- nextB ioContextB sb0 + c <- Maybe.lift $ f a b + return (c, (sa1,sb1))) + (\(ioContextA, ioContextB) -> + liftM2 (,) + (startA ioContextA) + (startB ioContextB)) + (liftM2 (,) + createIOContextA + createIOContextB) + (\(ca,cb) -> + deleteIOContextA ca >> + deleteIOContextB cb) + +zip :: + T a -> T b -> T (a,b) +zip = zipWith (\a b -> return (a,b)) + + +{- | +Stretch signal in time by a certain factor. +-} +interpolateConstant :: + (Rep.Memory a struct, IsSized struct size, + Ring.C b, + IsFloating b, CmpRet b Bool, + IsConst b, IsFirstClass b, IsSized b sb) => + b -> T a -> T a +interpolateConstant k + (Cons next start createIOContext deleteIOContext) = + Cons + (\ioContext ((y0,state0),ss0) -> + do ((y1,state1), ss1) <- + Maybe.fromBool $ + whileLoop + (valueOf True, ((y0,state0), ss0)) + (\(cont1, (_, ss1)) -> + and cont1 =<< A.fcmp FPOLE ss1 (valueOf 0)) + (\(_, ((_,state01), ss1)) -> + Maybe.toBool $ liftM2 (,) + (next ioContext state01) + (Maybe.lift $ A.add ss1 (valueOf k))) + + ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.one) + return (y1, ((y1,state1),ss2))) + +{- using this initialization code we would not need undefined values + (do sa <- start + (a,_) <- next sa + return (sa, a, valueOf 0)) +-} + (fmap (\sa -> ((undefTuple, sa), valueOf 0)) . start) + createIOContext deleteIOContext + + +mix :: + (IsArithmetic a) => + T (Value a) -> T (Value a) -> T (Value a) +mix = zipWith Sample.mixMono + +mixStereo :: + (IsArithmetic a) => + T (Stereo.T (Value a)) -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a)) +mixStereo = zipWith Sample.mixStereo + + +envelope :: + (IsArithmetic a) => + T (Value a) -> T (Value a) -> T (Value a) +envelope = zipWith Sample.amplifyMono + +envelopeStereo :: + (IsArithmetic a) => + T (Value a) -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a)) +envelopeStereo = zipWith Sample.amplifyStereo + +amplify :: + (IsArithmetic a, IsConst a) => + a -> T (Value a) -> T (Value a) +amplify x = + map (Sample.amplifyMono (valueOf x)) + +amplifyStereo :: + (IsArithmetic a, IsConst a) => + a -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a)) +amplifyStereo x = + map (Sample.amplifyStereo (valueOf x)) + + + +iterate :: + (IsFirstClass a, IsSized a s, IsConst a) => + (forall r. Value a -> CodeGenFunction r (Value a)) -> + Value a -> T (Value a) +iterate f initial = + simple + (\y -> Maybe.lift $ fmap (\y1 -> (y,y1)) (f y)) + (return initial) + +exponential2 :: + (Trans.C a, + IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) => + a -> a -> T (Value a) +exponential2 halfLife = + iterate (\y -> A.mul y (valueOf (0.5 ** recip halfLife))) . valueOf + + +osciPlain :: + (IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t) => + (forall r. Value t -> CodeGenFunction r y) -> + Value t -> Value t -> T y +osciPlain wave phase freq = + map wave $ + iterate (SoV.incPhase freq) $ + phase + +osci :: + (IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t) => + (forall r. Value t -> CodeGenFunction r y) -> + t -> t -> T y +osci wave phase freq = + osciPlain wave (valueOf phase) (valueOf freq) + +osciSaw :: + (Ring.C a0, IsConst a0, SoV.Replicate a0 a, + IsFirstClass a, IsSized a size, + SoV.Fraction a, IsConst a) => + a -> a -> T (Value a) +osciSaw = osci Wave.saw + + + +fromStorableVector :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + SV.Vector a -> + T value +fromStorableVector xs = + let (fp,s,l) = SVB.toForeignPtr xs + in Cons + (\_ (p0,l0) -> do + cont <- Maybe.lift $ A.icmp IntUGT l0 (valueOf 0) + Maybe.withBool cont $ do + y1 <- Rep.load p0 + p1 <- advanceArrayElementPtr p0 + l1 <- A.dec l0 + return (y1,(p1,l1))) + (const $ return + (valueOf (Rep.castStorablePtr $ unsafeForeignPtrToPtr fp `advancePtr` s), + valueOf (fromIntegral l :: Word32))) + -- keep the foreign ptr alive + (return fp) + touchForeignPtr + +{- +This function calls back into the Haskell function 'nextChunk' +that returns a pointer to the data of the next chunk +and advances to the next chunk in the sequence. +-} +fromStorableVectorLazy :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + SVL.Vector a -> + T value +fromStorableVectorLazy sig = + Cons + (\(stable, lenPtr) (buffer0,length0) -> do + (buffer1,length1) <- Maybe.lift $ do + nextChunkFn <- staticFunction ChunkIt.nextCallBack + needNext <- A.icmp IntEQ length0 (valueOf 0) + ifThen needNext (buffer0,length0) + (liftM2 (,) + (call nextChunkFn (valueOf stable) (valueOf lenPtr)) + (load (valueOf lenPtr))) + valid <- Maybe.lift $ A.icmp IntNE buffer1 (valueOf nullPtr) + Maybe.withBool valid $ do + x <- Rep.load buffer1 + buffer2 <- advanceArrayElementPtr buffer1 + length2 <- A.dec length1 + return (x, (buffer2,length2))) + (const $ return (valueOf nullPtr, valueOf 0)) + (liftM2 (,) (ChunkIt.new sig) Alloc.malloc) + (\(stable,lenPtr) -> do + ChunkIt.dispose stable + Alloc.free lenPtr) + + +{- +compile :: + (Rep.Memory value struct) => + T value -> + CodeGenModule (Function (Word32 -> Ptr struct -> IO Word32)) +-} + +{- +We could also implement that in terms of getPointerToFunction +as done in Parameterized.Signal. +However, since the 'fill' function will be called only once, +it does not matter whether we use the Just-In-Time compiler +or compile once. +-} +render :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + Int -> T value -> SV.Vector a +render len (Cons next start createIOContext deleteIOContext) = + unsafePerformIO $ + bracket createIOContext deleteIOContext $ \ ioContext -> + SVB.createAndTrim len $ \ ptr -> + do fill <- + Exec.runFunction $ + createFunction ExternalLinkage $ \ size bPtr -> do + s <- start ioContext + (pos,_) <- Maybe.arrayLoop size bPtr s $ \ ptri s0 -> do + (y,s1) <- next ioContext s0 + Maybe.lift $ Rep.store y ptri + return s1 + ret (pos :: Value Word32) + fmap (fromIntegral :: Word32 -> Int) $ + fill (fromIntegral len) (Rep.castStorablePtr ptr) + + +foreign import ccall safe "dynamic" derefChunkPtr :: + Exec.Importer (Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32) + + +compileChunky :: + (Rep.Memory value struct, + Rep.Memory state stateStruct, + IsSized stateStruct stateSize) => + (forall r. + state -> Maybe.T r (Value Bool, state) (value, state)) -> + (forall r. + CodeGenFunction r state) -> + IO (FunPtr (IO (Ptr stateStruct)), + FunPtr (Ptr stateStruct -> IO ()), + FunPtr (Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)) +compileChunky next start = + Exec.compileModule $ + liftM3 (,,) + (createFunction ExternalLinkage $ + do + -- FIXME: size computation in LLVM currently does not work for structs! + pptr <- Rep.malloc + flip Rep.store pptr =<< start + ret pptr) +{- for debugging: allocation with initialization makes type inference difficult + (createFunction ExternalLinkage $ + do + pptr <- malloc + let retn :: CodeGenFunction r state -> Value (Ptr state) -> CodeGenFunction (Ptr state) () + retn _ ptr = ret ptr + retn undefined pptr) +-} + (createFunction ExternalLinkage $ + \ pptr -> Rep.free pptr >> ret ()) + (createFunction ExternalLinkage $ + \ sptr loopLen ptr -> do + sInit <- Rep.load sptr + (pos,sExit) <- Maybe.arrayLoop loopLen ptr sInit $ + \ ptri s0 -> do + (y,s1) <- next s0 + Maybe.lift $ Rep.store y ptri + return s1 + Rep.store sExit sptr + ret (pos :: Value Word32)) + + +runChunky :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + SVL.ChunkSize -> T value -> IO (SVL.Vector a) +runChunky (SVL.ChunkSize size) + (Cons next start createIOContext deleteIOContext) = do + ioContext <- createIOContext + (startFunc, stopFunc, fill) <- + compileChunky (next ioContext) (start ioContext) + + statePtr <- Rep.newForeignPtrInit stopFunc startFunc + -- for explanation see Causal.Process + ioContextPtr <- Rep.newForeignPtr (deleteIOContext ioContext) False + + let go = + unsafeInterleaveIO $ do + v <- + withForeignPtr statePtr $ \sptr -> + SVB.createAndTrim size $ + fmap (fromIntegral :: Word32 -> Int) . + derefChunkPtr fill sptr (fromIntegral size) . + Rep.castStorablePtr + touchForeignPtr ioContextPtr + (if SV.length v > 0 + then fmap (v:) + else id) $ + (if SV.length v < size + then return [] + else go) + fmap SVL.fromChunks go + +renderChunky :: + (Storable a, MakeValueTuple a value, Rep.Memory value struct) => + SVL.ChunkSize -> T value -> SVL.Vector a +renderChunky size sig = + unsafePerformIO (runChunky size sig) diff --git a/src/Synthesizer/LLVM/Simple/Value.hs b/src/Synthesizer/LLVM/Simple/Value.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Simple/Value.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module Synthesizer.LLVM.Simple.Value where + +import qualified LLVM.Extra.ScalarOrVector as SoV + +import qualified LLVM.Extra.Arithmetic as A + +import LLVM.Core hiding (zero, ) +import qualified LLVM.Core as LLVM +import qualified LLVM.Util.Arithmetic as Arith + +import qualified Synthesizer.Basic.Phase as Phase + +import Control.Monad (liftM2, liftM3, ) + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.RealRing as RealRing +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Data.Traversable as Trav + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +{- +The @r@ type parameter must be hidden and forall-quantified +because otherwise we would need an impossible type +where we have to quantify for @r@ and @t@ in different scopes +while having a class constraint that involves both of them. + +> osci :: +> (RealRing.C (Value.T r t), +> IsFirstClass t, IsSized t size, IsFloating t, +> IsPrimitive t, IsConst t) => +> (forall r. Wave.T (Value.T r t) (Value.T r y)) -> +> t -> t -> T (Value y) + +-} +newtype T a = Cons {decons :: forall r. Arith.TValue r a} + +{- | +We do not require a numeric prelude superclass, +thus also LLVM only types like vectors are instances. +-} +instance (IsArithmetic a, IsConst a) => Additive.C (T a) where + zero = constantValue (value LLVM.zero) + (+) = binop add + (-) = binop sub + negate (Cons x) = Cons (neg =<< x) + +instance (Ring.C a, IsArithmetic a, IsConst a) => + Ring.C (T a) where + one = constant one + (*) = binop mul + fromInteger = constant . fromInteger + +{- +Two instance declarations are enough for Module here. +The difference to Module instances on Haskell tuples is, +that LLVM vectors cannot be nested. +-} +instance (Ring.C a, IsArithmetic a, IsConst a) => + Module.C (T a) (T a) where + (*>) = (*) + +instance (Ring.C a, IsArithmetic a, IsConst a, IsPrimitive a, IsPowerOf2 n) => + Module.C (T a) (T (Vector n a)) where + (Cons a) *> (Cons v) = Cons (do + a0 <- a + a1 <- SoV.replicate a0 + A.mul a1 =<< v + ) + +instance (Ring.C a, IsArithmetic a, IsConst a) => Enum (T a) where + succ x = x + one + pred x = x - one + fromEnum _ = error "CodeGenFunction Value: fromEnum" + toEnum = fromIntegral + +{- +instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (T a) where + toRational _ = error "CodeGenFunction Value: toRational" + +instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (T a) where + quot = binop (if (isSigned (undefined :: a)) then sdiv else udiv) + rem = binop (if (isSigned (undefined :: a)) then srem else urem) + quotRem x y = (quot x y, rem x y) + toInteger _ = error "CodeGenFunction Value: toInteger" +-} + +instance (Field.C a, IsConst a, IsFloating a) => Field.C (T a) where + (/) = binop fdiv + fromRational' = constant . fromRational' + +{- +instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (T a) where + properFraction _ = error "CodeGenFunction Value: properFraction" +-} + +instance (Algebraic.C a, IsConst a, IsFloating a) => Algebraic.C (T a) where + sqrt = lift1 A.sqrt + +instance (Trans.C a, IsConst a, IsFloating a) => Trans.C (T a) where + pi = constant pi + sin = lift1 A.sin + cos = lift1 A.cos + (**) = lift2 A.pow + exp = lift1 A.exp + log = lift1 A.log + + asin _ = error "LLVM missing intrinsic: asin" + acos _ = error "LLVM missing intrinsic: acos" + atan _ = error "LLVM missing intrinsic: atan" + +{- + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x + exp (-x)) / 2 + asinh x = log (x + sqrt (x*x + 1)) + acosh x = log (x + sqrt (x*x - 1)) + atanh x = (log (1 + x) - log (1 - x)) / 2 +-} + + +twoPi :: + (Trans.C a, IsConst a, IsFloating a) => + T a +twoPi = 2*pi +{- +twoPi :: + (Cmp a b, P.Floating a, IsConst a, IsFloating a) => + Arith.TValue r a +twoPi = P.fromInteger 2 P.* P.pi +-} + + +lift1 :: + (forall r. Value a -> CodeGenFunction r (Value b)) -> + T a -> T b +lift1 f x = + Cons $ f =<< decons x + +lift2 :: + (forall r. Value a -> Value b -> CodeGenFunction r (Value c)) -> + T a -> T b -> T c +lift2 f x y = + Cons $ uncurry f =<< liftM2 (,) (decons x) (decons y) + + +constantValue :: Value a -> T a +constantValue x = + Cons (return x) + +constant :: (IsConst a) => a -> T a +constant = constantValue . valueOf + +binop :: + (forall r. Value a -> Value b -> Arith.TValue r c) -> + T a -> T b -> T c +binop op x y = Cons (do + x' <- decons x + y' <- decons y + op x' y') + + +class Flatten value register | value -> register where + flatten :: value -> CodeGenFunction r register + unfold :: register -> value + +flattenTraversable :: + (Flatten value register, Trav.Traversable f) => + f value -> CodeGenFunction r (f register) +flattenTraversable = + Trav.mapM flatten + +unfoldFunctor :: + (Flatten value register, Functor f) => + f register -> f value +unfoldFunctor = + fmap unfold + + +instance (Flatten ah al, Flatten bh bl) => + Flatten (ah,bh) (al,bl) where + flatten (a,b) = + liftM2 (,) (flatten a) (flatten b) + unfold (a,b) = + (unfold a, unfold b) + +instance (Flatten ah al, Flatten bh bl, Flatten ch cl) => + Flatten (ah,bh,ch) (al,bl,cl) where + flatten (a,b,c) = + liftM3 (,,) (flatten a) (flatten b) (flatten c) + unfold (a,b,c) = + (unfold a, unfold b, unfold c) + +instance Flatten v r => + Flatten (Stereo.T v) (Stereo.T r) where + flatten s = + liftM2 Stereo.cons + (flatten $ Stereo.left s) + (flatten $ Stereo.right s) + unfold s = + Stereo.cons + (unfold $ Stereo.left s) + (unfold $ Stereo.right s) + +instance + (RealRing.C v, Flatten v r) => + Flatten (Phase.T v) r where + flatten s = + flatten $ Phase.toRepresentative s + unfold s = + -- could also be unsafeFromRepresentative + Phase.fromRepresentative $ unfold s + + +instance (IsConst a) => Flatten (T a) (Value a) where + flatten = decons + unfold = constantValue +instance Flatten () () where + flatten = return + unfold = id diff --git a/src/Synthesizer/LLVM/Simple/Vanilla.hs b/src/Synthesizer/LLVM/Simple/Vanilla.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Simple/Vanilla.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Simple.Vanilla where + +import qualified Synthesizer.LLVM.Simple.Signal as Sig +import qualified LLVM.Extra.Representation as Rep +import qualified Synthesizer.LLVM.Simple.Value as Value +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.MaybeContinuation as Maybe + +import qualified Synthesizer.Basic.Phase as Phase +import qualified Synthesizer.Basic.Wave as Wave + +{- +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB +-} + +-- import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import LLVM.Core + +-- import Control.Monad (liftM2, liftM3, ) + +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealRing as RealRing +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +-- import NumericPrelude.Numeric +import NumericPrelude.Base hiding (and, iterate, map, zipWith, ) + + +iterateVal :: + (IsFirstClass a, IsSized a size) => + (Value.T a -> Value.T a) -> + Value.T a -> Sig.T (Value.T a) +iterateVal f initial = + Sig.simple + (\y -> + Maybe.lift $ + fmap (\y1 -> (Value.constantValue y, y1)) + (Value.decons (f (Value.constantValue y)))) + (Value.decons initial) + +iterate :: + (Value.Flatten a reg, Rep.Memory reg packed, IsSized packed size) => + (a -> a) -> + (a -> Sig.T a) +iterate f initial = + Sig.simple + (\y -> + Maybe.lift $ + fmap (\y1 -> (Value.unfold y, y1)) + (Value.flatten (f (Value.unfold y)))) + (Value.flatten initial) + + + +map :: + (a -> b) -> + Sig.T a -> Sig.T b +map f = Sig.map (return . f) + + +osciReg :: + (RealRing.C (Value.T t), + IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t, + IsFirstClass y) => + Wave.T (Value.T t) (Value.T y) -> + Value t -> Value t -> Sig.T (Value y) +osciReg wave phase freq = + Sig.map + (Value.decons . Wave.apply wave . + Phase.fromRepresentative . Value.constantValue) $ + Sig.iterate (SoV.incPhase freq) phase + +osciVal :: + (RealRing.C (Value.T t), + IsFirstClass t, IsSized t size, + SoV.Fraction t, IsConst t) => + Wave.T (Value.T t) y -> + Value.T t -> Value.T t -> Sig.T y +osciVal wave phase freq = + map (Wave.apply wave . Phase.fromRepresentative) $ + iterateVal (incPhaseVal freq) phase + +incPhaseVal :: + (SoV.Fraction a, IsArithmetic a) => + Value.T a -> Value.T a -> Value.T a +incPhaseVal = Value.binop SoV.incPhase + +osci :: + (RealRing.C t, + Value.Flatten t reg, + Rep.Memory reg struct, IsSized struct size, + SoV.Fraction t, IsConst t) => + Wave.T t y -> + Phase.T t -> t -> Sig.T y +osci wave phase freq = + map (Wave.apply wave) $ + iterate (Phase.increment freq) phase diff --git a/src/Synthesizer/LLVM/Storable/ChunkIterator.hs b/src/Synthesizer/LLVM/Storable/ChunkIterator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Storable/ChunkIterator.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.Storable.ChunkIterator where + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector.Base as SVB + +import Data.Word (Word32, ) +import Foreign.Storable (Storable, poke, ) +import Foreign.Ptr (FunPtr, Ptr, nullPtr, castPtr, ) + +import Control.Monad (liftM2, ) + +import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) + + +data T = + forall a. Storable a => + Cons (IORef [SVB.Vector a]) (IORef (SVB.Vector a)) + +{- +I do not see a way, +how to bind the result type @Ptr a@ +to the input type @SV.Vector a@. +We cannot make the element type of the storable vector +a type parameter of 'T' +since then we would also need to make Storable +a constraint of the FFI interface, +and this is forbidden. +-} +foreign import ccall "&nextChunk" + nextCallBack :: + FunPtr ( + StablePtr T -> + Ptr Word32 -> IO (Ptr a) + ) + +foreign export ccall "nextChunk" + next :: + StablePtr T -> + Ptr Word32 -> IO (Ptr a) + + +new :: + Storable a => + SVL.Vector a -> IO (StablePtr T) +new sig = + newStablePtr =<< + liftM2 Cons + (newIORef (SVL.chunks sig)) + (newIORef + (error "first chunk must be fetched with nextChunk")) + +dispose :: + StablePtr T -> IO () +dispose = freeStablePtr + +next :: + StablePtr T -> + Ptr Word32 -> IO (Ptr a) +next stable lenPtr = + deRefStablePtr stable >>= \state -> + case state of + Cons listRef chunkRef -> do + xt <- readIORef listRef + case xt of + [] -> return nullPtr + (x:xs) -> + {- We have to maintain a pointer to the current chunk + in order to protect it against garbage collection -} + writeIORef chunkRef x >> + writeIORef listRef xs >> + SVB.withStartPtr x (\p l -> + poke lenPtr (fromIntegral l) >> return (castPtr p)) diff --git a/src/Synthesizer/LLVM/Storable/LazySizeIterator.hs b/src/Synthesizer/LLVM/Storable/LazySizeIterator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Storable/LazySizeIterator.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.Storable.LazySizeIterator where + +import qualified Numeric.NonNegative.Chunky as Chunky +import qualified Data.StorableVector.Lazy.Pattern as SVP +import qualified Data.StorableVector.Lazy as SVL + +import Data.Word (Word32, ) + +import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) +import Foreign.Ptr (FunPtr, ) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) +import qualified Data.List.HT as ListHT + + +newtype T = Cons (IORef [SVL.ChunkSize]) + +{- +For problems about Storable constraint, see ChunkIterator. +-} +foreign import ccall "&nextSize" + nextCallBack :: + FunPtr (StablePtr T -> IO Word32) + +foreign export ccall "nextSize" + next :: StablePtr T -> IO Word32 + + +new :: + SVP.LazySize -> IO (StablePtr T) +new ls = + newStablePtr . Cons =<< newIORef (Chunky.toChunks (Chunky.normalize ls)) + +dispose :: + StablePtr T -> IO () +dispose = freeStablePtr + +{- | +Zero pieces are filtered out. +If 'next' returns 0 then the end of the lazy size is reached. +-} +next :: + StablePtr T -> IO Word32 +next stable = + deRefStablePtr stable >>= \state -> + case state of + Cons listRef -> + readIORef listRef >>= + ListHT.switchL + (return 0) + (\(SVL.ChunkSize time) xs -> + writeIORef listRef xs >> + return (fromIntegral time)) diff --git a/src/Synthesizer/LLVM/Storable/Signal.hs b/src/Synthesizer/LLVM/Storable/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Storable/Signal.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{- | +Functions on lazy storable vectors that are implemented using LLVM. +-} +module Synthesizer.LLVM.Storable.Signal ( + unpackStrict, unpack, + makeUnpackGenericStrict, makeUnpackGeneric, + makeReversePackedStrict, makeReversePacked, + continue, continuePacked, continuePackedGeneric, + makeMixer, + makeArranger, arrange, + ) where + +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS + +import qualified Synthesizer.LLVM.Execution as Exec +import qualified Synthesizer.LLVM.Sample as Sample +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Vector as Vector +import LLVM.Extra.Control (arrayLoop, ) + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Data.EventList.Absolute.TimeBody as AbsEventList +import qualified Number.NonNegative as NonNeg + +import qualified Algebra.Additive as Additive + +import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) + +import LLVM.Core + (Linkage(ExternalLinkage), createFunction, ret, + MakeValueTuple, IsSized, IsPrimitive, getElementPtr, + Vector, IsPowerOf2, ) +import qualified Data.TypeLevel.Num as TypeNum + +import qualified Control.Category as Cat + +import qualified Data.List.HT as ListHT +import Data.Word (Word32, ) +import Data.Int (Int32, ) +import Foreign.Ptr (Ptr, ) +import Foreign.ForeignPtr (castForeignPtr, ) +import Foreign.Storable (Storable, ) +import Foreign.Marshal.Array (advancePtr, ) +import qualified Foreign.Marshal.Array as Array + +import System.IO.Unsafe (unsafePerformIO, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +{- | +This function needs only constant time +in contrast to 'Synthesizer.LLVM.Parameterized.SignalPacked.unpack'. + +We cannot provide a 'pack' function +since the array size may not line up. +It would also need copying since the source data may not be aligned properly. +-} +unpackStrict :: + (Storable a, IsPrimitive a, IsPowerOf2 n) => + SV.Vector (Vector n a) -> SV.Vector a +unpackStrict v = + let getDim :: (TypeNum.Nat n) => SV.Vector (Vector n a) -> n -> Int + getDim _ = TypeNum.toInt + d = getDim v undefined + (fptr,s,l) = SVB.toForeignPtr v + in SVB.SV (castForeignPtr fptr) (s*d) (l*d) + +unpack :: + (Storable a, IsPrimitive a, IsPowerOf2 n) => + SVL.Vector (Vector n a) -> SVL.Vector a +unpack = + SVL.fromChunks . map unpackStrict . SVL.chunks + +{- | +This is similar to 'unpackStrict' but performs rearrangement of data. +This is for instance necessary for stereo signals +where the data layout of packed and unpacked data is different, +thus simple casting of the data is not possible. +-} +makeUnpackGenericStrict :: + (Vector.Access n va vv, + Storable a, MakeValueTuple a va, Rep.Memory va as, IsSized as asize, + Storable v, MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) => + IO (SV.Vector v -> SV.Vector a) +makeUnpackGenericStrict = + let vectorSize :: + (Vector.Access n al vl, Storable v, MakeValueTuple v vl) => + SV.Vector v -> n + vectorSize _ = undefined + in fmap (\f v -> f (TypeNum.toInt (vectorSize v) * SV.length v) v) $ + SigP.run (SigPS.unpack $ SigP.fromStorableVector Cat.id) + +makeUnpackGeneric :: + (Vector.Access n va vv, + Storable a, MakeValueTuple a va, Rep.Memory va as, IsSized as asize, + Storable v, MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) => + IO (SVL.Vector v -> SVL.Vector a) +makeUnpackGeneric = + fmap (\f -> SVL.fromChunks . map f . SVL.chunks) $ + makeUnpackGenericStrict + + +makeReverser :: + (Storable a, Vector.ShuffleMatch n value, + MakeValueTuple a value, Rep.Memory value struct) => + value -> IO (Word32 -> Ptr a -> Ptr a -> IO ()) +-- (Rep.Memory a struct, Vector.ShuffleMatch n a) => +-- IO (Word32 -> Ptr struct -> Ptr struct -> IO ()) +makeReverser dummy = + fmap (\f len srcPtr dstPtr -> + f len (Rep.castStorablePtr srcPtr) (Rep.castStorablePtr dstPtr)) $ + fmap derefMixPtr $ + Exec.compileModule $ + createFunction ExternalLinkage $ \ size ptrA ptrB -> do + ptrAEnd <- getElementPtr ptrA (size, ()) + arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do + ptrAj1 <- getElementPtr ptrAj0 (-1 :: Int32, ()) + flip Rep.store ptrBi + =<< Vector.reverse + . flip asTypeOf dummy + =<< Rep.load ptrAj1 + return ptrAj1 + ret () + +makeReversePackedStrict :: + (Storable v, Vector.Access n va vv, + MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) => + IO (SV.Vector v -> SV.Vector v) +makeReversePackedStrict = do + rev <- makeReverser undefined + return $ \v -> + unsafePerformIO $ + SVB.withStartPtr v $ \ptrA len -> + SVB.create len $ \ptrB -> + rev (fromIntegral len) ptrA ptrB + +makeReversePacked :: + (Storable v, Vector.Access n va vv, + MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) => + IO (SVL.Vector v -> SVL.Vector v) +makeReversePacked = + fmap (\f -> SVL.fromChunks . reverse . map f . SVL.chunks) $ + makeReversePackedStrict + + +{- | +Append two signals where the second signal +gets the last value of the first signal as parameter. +If the first signal is empty +then there is no parameter for the second signal +and thus we simply return an empty signal in that case. +-} +continue :: + (Storable a) => + SVL.Vector a -> (a -> SVL.Vector a) -> SVL.Vector a +continue x y = + SVL.fromChunks $ + withLast SV.empty + (SVL.chunks x) + (SV.switchR [] $ \_ -> SVL.chunks . y) + +_continueNeglectLast :: + (Storable a) => + SVL.Vector a -> (a -> SVL.Vector a) -> SVL.Vector a +_continueNeglectLast x y = + SVL.switchR SVL.empty + (\body l -> SVL.append body (y l)) x + +continuePacked :: + (IsPowerOf2 n, Storable a, IsPrimitive a) => + SVL.Vector (Vector n a) -> + (a -> SVL.Vector (Vector n a)) -> + SVL.Vector (Vector n a) +continuePacked x y = + SVL.fromChunks $ + withLast SV.empty + (SVL.chunks x) + (SV.switchR [] (\_ -> SVL.chunks . y) . + unpackStrict) + +{- +This function reduces the last chunk to size one, repacks that +and takes the last value. +It would be certainly more efficient to use +a single @Rep.load@, @extractelement@ and @store@ +instead of a loop of count 1. +However, this implementation is the simplest one, so far. +-} +{- | +Use this like + +> do unpackGeneric <- makeUnpackGenericStrict +> return (continuePackedGeneric unpackGeneric x y) +-} +continuePackedGeneric :: +{- + (Storable v, Vector.Access n a v, + MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) => +-} + (Storable v, Storable a) => + (SV.Vector v -> SV.Vector a) -> + SVL.Vector v -> (a -> SVL.Vector v) -> SVL.Vector v +continuePackedGeneric unpackGeneric x y = + SVL.fromChunks $ + withLast SV.empty + (SVL.chunks x) + (\lastChunk -> + SV.switchR [] (\_ -> SVL.chunks . y) $ unpackGeneric $ + SV.drop (SV.length lastChunk - 1) $ lastChunk) + + +-- candidate for utility-ht +withLast :: a -> [a] -> (a -> [a]) -> [a] +withLast deflt x y = + foldr + (\a cont _ -> a : cont a) + y x deflt + +{- +This version is too strict, since it looks one element ahead. +-} +_withLast :: [a] -> (a -> [a]) -> [a] +_withLast x y = + ListHT.switchR [] + (\body end -> body ++ end : y end) + x + + + +foreign import ccall safe "dynamic" derefFillPtr :: + Exec.Importer (Word32 -> Ptr a -> IO ()) + +{- | +'fillBuffer' is not only more general than filling with zeros, +it also simplifies type inference. +-} +fillBuffer :: + (MakeValueTuple a value, Rep.Memory value struct) => + value -> IO (Word32 -> Ptr a -> IO ()) +fillBuffer x = + fmap (\f len ptr -> f len (Rep.castStorablePtr ptr)) $ + fmap derefFillPtr $ + Exec.compileModule $ + createFunction ExternalLinkage $ \ size ptr -> do + arrayLoop size ptr () $ \ ptri () -> do + Rep.store x ptri + return () + ret () + + +foreign import ccall safe "dynamic" derefMixPtr :: + Exec.Importer (Word32 -> Ptr a -> Ptr a -> IO ()) + +makeMixer :: + (Storable a, Sample.Additive value, + MakeValueTuple a value, Rep.Memory value struct) => + value -> IO (Word32 -> Ptr a -> Ptr a -> IO ()) +makeMixer dummy = + fmap (\f len srcPtr dstPtr -> + f len (Rep.castStorablePtr srcPtr) (Rep.castStorablePtr dstPtr)) $ + fmap derefMixPtr $ + Exec.compileModule $ + createFunction ExternalLinkage $ \ size srcPtr dstPtr -> do + arrayLoop size srcPtr dstPtr $ \ srcPtri dstPtri -> do + y <- Rep.load srcPtri + Rep.modify (Sample.add (y `asTypeOf` dummy)) dstPtri + advanceArrayElementPtr dstPtri + ret () + + +addToBuffer :: + (Storable a) => + (Word32 -> Ptr a -> Ptr a -> IO ()) -> + Int -> Ptr a -> Int -> SVL.Vector a -> IO (Int, SVL.Vector a) +addToBuffer addChunkToBuffer len v start xs = + let (now,future) = SVL.splitAt (len - start) xs + go i [] = return i + go i (c:cs) = + SVB.withStartPtr c (\ptr l -> + addChunkToBuffer (fromIntegral l) ptr (advancePtr v i)) >> + go (i + SV.length c) cs + in fmap (flip (,) future) . go start . SVL.chunks $ now + + +{- +Same algorithm as in Synthesizer.Storable.Cut.arrangeEquidist +-} +makeArranger :: + (Storable a, Sample.Additive value, + MakeValueTuple a value, Rep.Memory value struct) => + IO (SVL.ChunkSize -> + EventList.T NonNeg.Int (SVL.Vector a) -> + SVL.Vector a) +makeArranger = do + mixer <- makeMixer undefined + fill <- fillBuffer Sample.zero + return $ \ (SVL.ChunkSize sz) -> + let sznn = NonNeg.fromNumberMsg "arrange" sz + go acc evs = + let (now,future) = EventListTM.splitAtTime sznn evs + xs = + AbsEventList.toPairList $ + EventList.toAbsoluteEventList 0 $ + EventListTM.switchTimeR const now + (chunk,newAcc) = + unsafePerformIO $ + SVB.createAndTrim' sz $ \ptr -> do + fill (fromIntegral sz) ptr + newAcc0 <- flip mapM acc $ addToBuffer mixer sz ptr 0 + newAcc1 <- flip mapM xs $ \(i,s) -> + addToBuffer mixer sz ptr (NonNeg.toNumber i) s + let (ends, suffixes) = unzip $ newAcc0++newAcc1 + {- if there are more events to come, + we must pad with zeros -} + len = + if EventList.null future + then foldl max 0 ends + else sz + return (0, len, + filter (not . SVL.null) suffixes) + in if SV.null chunk + then [] + else chunk : go newAcc future + in SVL.fromChunks . go [] + +{- | +This is unsafe since it relies on the prior initialization of the LLVM JIT. +Better use 'makeArranger'. +-} +arrange :: + (Storable a, Sample.Additive value, + MakeValueTuple a value, Rep.Memory value struct) => + SVL.ChunkSize + -> EventList.T NonNeg.Int (SVL.Vector a) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> SVL.Vector a + {-^ The mixed signal. -} +arrange = + unsafePerformIO makeArranger diff --git a/src/Synthesizer/LLVM/Test.hs b/src/Synthesizer/LLVM/Test.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Test.hs @@ -0,0 +1,1288 @@ +{-# LANGUAGE Rank2Types #-} +module Main where + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth +import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP +import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Simple.Signal as Sig +import qualified Synthesizer.LLVM.Storable.Signal as SigLSt +import qualified Synthesizer.LLVM.Sample as Sample +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Extra.Arithmetic as A +import LLVM.Core (Value, value, valueOf, Vector, constVector, constOf, ) +import LLVM.Util.Arithmetic () -- Floating instance for TValue +import qualified LLVM.Core as LLVM +import Data.TypeLevel.Num (D4, D8, D16, ) +import qualified Data.TypeLevel.Num as TypeNum + +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core + +import Control.Arrow (Arrow, arr, (&&&), (^<<), ) +import Control.Category ((<<<), (.), id, ) + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.EventList.Relative.MixedTime as EventListMT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import qualified Sound.Sox.Option.Format as SoxOption +import qualified Sound.Sox.Play as SoxPlay +-- import qualified Synthesizer.Storable.ALSA.Play as Play + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import Data.Word (Word32, ) +-- import qualified Data.Function.HT as F +import Data.List (genericLength, ) +import System.Random (randomRs, mkStdGen, ) + +import qualified System.IO as IO +import System.Exit (ExitCode, ) + +import Prelude hiding (fst, snd, id, (.), ) +import qualified Prelude as P + + +asMono :: vector Float -> vector Float +asMono = id + +asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float) +asStereo = id + +asMonoPacked :: vector (LLVM.Vector D4 Float) -> vector (LLVM.Vector D4 Float) +asMonoPacked = id + +asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float) +asMonoPacked16 = id + +asWord32 :: vector Word32 -> vector Word32 +asWord32 = id + +asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32) +asWord32Packed = id + + +{- | +> playStereo (Sig.amplifyStereo 0.3 $ stereoOsciSaw 0.01) + +Unfortunately: If you call :reload, +then the next attempt to play something will be answered by: + +ghci: JITEmitter.cpp:110: ::JITResolver::JITResolver(llvm::JIT&): Assertion `TheJITResolver == 0 && "Multiple JIT resolvers?"' failed. +-} +playStereo :: Sig.T (Stereo.T (Value Float)) -> IO ExitCode +playStereo = + playStereoVector . + Sig.renderChunky (SVL.chunkSize 100000) + +playStereoVector :: SVL.Vector (Stereo.T Float) -> IO ExitCode +playStereoVector = + SoxPlay.simple SVL.hPut SoxOption.none 44100 + +playMono :: Sig.T (Value Float) -> IO ExitCode +playMono = + playMonoVector . + Sig.renderChunky (SVL.chunkSize 100000) + +playMonoVector :: SVL.Vector Float -> IO ExitCode +playMonoVector = + SoxPlay.simple SVL.hPut SoxOption.none 44100 + + +playFileMono :: FilePath -> IO () +playFileMono fileName = do + IO.withFile fileName IO.ReadMode $ \h -> + playStereo . + Sig.fromStorableVectorLazy . + asStereo . snd + =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h + return () + + +saw :: IO () +saw = + SV.writeFile "speedtest.f32" $ + asMono $ + Sig.render 10000000 $ + Sig.osciSaw 0 0.01 + +exponential :: IO () +exponential = + SV.writeFile "speedtest.f32" $ + asMono $ + Sig.render 10000000 $ + Sig.exponential2 50000 1 + +triangle :: IO () +triangle = + SV.writeFile "speedtest.f32" $ + asMono $ + Sig.render 10000000 $ + Sig.osci Wave.triangle 0.25 0.01 + +trianglePack :: IO () +trianglePack = + SV.writeFile "speedtest.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + SigP.mapSimple Wave.triangle $ + SigPS.packSmall $ + SigP.osciCore 0.25 0.01 + +trianglePacked :: IO () +trianglePacked = + SV.writeFile "speedtest.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + (CausalPS.osciSimple Wave.triangle + $< SigPS.constant 0.25 + $* SigPS.constant 0.01) + +triangleReplicate :: IO () +triangleReplicate = + SV.writeFile "speedtest.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + (CausalPS.shapeModOsci + (\k p -> do + x <- Wave.triangle =<< Wave.replicate k p + y <- Wave.approxSine4 =<< Wave.halfEnvelope p + A.mul x y) + $< SigPS.rampInf 1000000 + $< SigPS.constant 0 + $* SigPS.constant 0.01) + +rationalSine :: IO () +rationalSine = + SV.writeFile "speedtest.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + (CausalPS.shapeModOsci Wave.rationalApproxSine1 + $< SigP.mapSimple (A.add (valueOf 0.001)) (SigPS.rampInf 10000000) + $< SigPS.constant 0 + $* SigPS.constant 0.01) + + +pingSig :: Float -> Sig.T (Value Float) +pingSig freq = + Sig.envelope + (Sig.exponential2 50000 1) + (Sig.osciSaw 0.5 freq) + +pingSigP :: SigP.T Float (Value Float) +pingSigP = + let freq = id + in SigP.envelope + (SigP.exponential2 50000 1) + (SigP.osciSaw 0.5 freq) + +ping :: IO () +ping = + SV.writeFile "speedtest.f32" $ + asMono $ + Sig.render 10000000 $ + pingSig 0.01 + +pingSigPacked :: SigP.T Float (Value (Vector D4 Float)) +pingSigPacked = + let freq = id + in SigP.envelope + (SigPS.exponential2 50000 1) + (SigPS.osciSimple Wave.saw 0 freq) + +pingPacked :: IO () +pingPacked = + SV.writeFile "speedtest.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) 0.01) $ + pingSigPacked + +pingUnpack :: IO () +pingUnpack = + SV.writeFile "speedtest.f32" $ + asMono $ + (\xs -> SigP.render xs 10000000 0.01) $ + SigPS.unpack $ + pingSigPacked + +pingSmooth :: IO () +pingSmooth = + SV.writeFile "speedtest-scalar.f32" $ + asMono $ + (\xs -> SigP.render xs 10000000 ()) $ + (Filt1.lowpassCausalP + $< (fmap Filt1Core.Parameter $ + SigP.mapSimple (A.sub (valueOf 1)) + (SigP.exponential2 50000 $# (1::Float))) + $* SigP.osciSimple Wave.triangle 0 0.01) + +pingSmoothPacked :: IO () +pingSmoothPacked = + SV.writeFile "speedtest-vector.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + (Filt1.lowpassCausalPackedP + $< (fmap Filt1Core.Parameter $ + SigP.mapSimple (A.sub (valueOf 1)) + (SigP.exponential2 (50000/4) $# (1::Float))) + $* SigPS.osciSimple Wave.triangle 0 0.01) + +stereoOsciSaw :: Float -> Sig.T (Stereo.T (Value Float)) +stereoOsciSaw freq = + Sig.zipWith Sample.zipStereo + (Sig.osciSaw 0.0 (freq*1.001) `Sig.mix` + Sig.osciSaw 0.2 (freq*1.003) `Sig.mix` + Sig.osciSaw 0.1 (freq*0.995)) + (Sig.osciSaw 0.1 (freq*1.005) `Sig.mix` + Sig.osciSaw 0.7 (freq*0.997) `Sig.mix` + Sig.osciSaw 0.5 (freq*0.999)) + +stereoOsciSawPacked :: Float -> Sig.T (Stereo.T (Value Float)) +stereoOsciSawPacked freq = + let mix4 = + Sample.mixVector . + flip asTypeOf (undefined :: Value (Vector D4 Float)) + in Sig.zipWith Sample.zipStereo + (Sig.map mix4 $ + Sig.osciPlain Wave.saw + (value $ constVector $ map constOf [0.0, 0.2, 0.1, 0.4]) + (value $ constVector $ + map (constOf . (freq*)) [1.001, 1.003, 0.995, 0.996])) + (Sig.map mix4 $ + Sig.osciPlain Wave.saw + (value $ constVector $ map constOf [0.1, 0.7, 0.5, 0.7]) + (value $ constVector $ + map (constOf . (freq*)) [1.005, 0.997, 0.999, 1.001])) + +stereoOsciSawPacked2 :: Float -> Sig.T (Stereo.T (Value Float)) +stereoOsciSawPacked2 freq = + Sig.map (Sample.mixVectorToStereo . + flip asTypeOf (undefined :: Value (Vector D8 Float))) $ + Sig.osciPlain (Wave.trapezoidSkew (SoV.replicateOf 0.2)) + (valueOf $ + LLVM.toVector (0.0, 0.2, 0.1, 0.4, 0.1, 0.7, 0.5, 0.7)) + (value $ constVector $ + map (constOf . (freq*)) $ + [1.001, 1.003, 0.995, 0.996, 1.005, 0.997, 0.999, 1.001]) + +stereo :: IO () +stereo = + SV.writeFile "speedtest.f32" $ + asStereo $ + Sig.render 10000000 $ + Sig.amplifyStereo 0.25 $ + stereoOsciSawPacked2 0.01 + +lazy :: IO () +lazy = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + Sig.renderChunky (SVL.chunkSize 100000) + {- SVL.defaultChunkSize - too slow -} $ + Sig.envelope + (Sig.exponential2 50000 1) + (Sig.osci Wave.sine 0.5 0.01 :: Sig.T (Value Float)) + +lazyStereo :: IO () +lazyStereo = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asStereo $ + Sig.renderChunky (SVL.chunkSize 100000) $ + Sig.amplifyStereo 0.25 $ + stereoOsciSawPacked 0.01 + +packTake :: IO () +packTake = + SVL.writeFile "speedtest.f32" $ + asMonoPacked $ + flip (SigP.renderChunky (SVL.chunkSize 1000)) () $ + SigPS.packRotate $ + (CausalP.take 5 $* + SigP.osciSimple Wave.saw 0 0.01) + +chord :: Float -> Sig.T (Stereo.T (Value Float)) +chord base = + {- + This exceeds available vector registers + and thus needs more stack accesses. + Thus it needs twice as much time as the simple mixing. + However doing all 32 oscillators in parallel + and mix them in one go might be still faster. + + foldl1 (Sig.zipWith Sample.mixStereoV) $ + -} + foldl1 Sig.mixStereo $ + map (\f -> stereoOsciSawPacked2 (base*f)) $ + 0.25 : 1.00 : 1.25 : 1.50 : [] + +lazyChord :: IO () +lazyChord = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asStereo $ + Sig.renderChunky (SVL.chunkSize 100000) $ + Sig.amplifyStereo 0.1 $ + chord 0.005 + +filterSweepComplex :: IO () +filterSweepComplex = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asStereo $ + Sig.renderChunky (SVL.chunkSize 100000) $ + Sig.amplifyStereo 0.3 $ + Causal.apply BandPass.causal $ + Sig.zip + (Sig.map (BandPass.parameter (valueOf 100)) $ + Sig.map (\x -> 0.01 * exp (2 * return x)) $ + Sig.osci Wave.sine 0 (0.1/44100)) $ + chord 0.005 + +lfoSine :: + (Rep.Memory a ap, LLVM.IsSized ap asize) => + (forall r. Value Float -> LLVM.CodeGenFunction r a) -> + Param.T p Float -> + SigP.T p a +lfoSine f reduct = + SigP.mapSimple f $ + SigP.mapSimple (\x -> 0.01 * exp (2 * return x)) $ + SigP.osciSimple Wave.sine 0 (reduct * 0.1/44100) + +filterSweep :: IO () +filterSweep = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (CausalP.amplify 0.2 . + CtrlP.processCtrlRate 128 + (lfoSine (Filt2.bandpassParameter (valueOf 100))) + $* SigP.osciSimple Wave.saw 0 0.01) + +filterSweepPacked :: IO () +filterSweepPacked = + SVL.writeFile "speedtest.f32" $ + SVL.take (div 10000000 4) $ + asMonoPacked $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (CausalP.amplify 0.2 . + CtrlPS.processCtrlRate 128 + (lfoSine (Filt2.bandpassParameter (valueOf 100))) + $* SigPS.osciSimple Wave.saw 0 0.01) + +exponentialFilter2Packed :: IO () +exponentialFilter2Packed = + SVL.writeFile "speedtest.f32" $ + SVL.take (div 10000000 16) $ + asMonoPacked16 $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (Filt2.causalPackedP + $< (SigP.constant $# + Filt2Core.Parameter (1::Float) 0 0 0 0.99) + $* ( +-- (CausalP.delay1 $# LLVM.vector [0.1,0.01,0.001,0.0001::Float]) +-- (CausalP.delay1 $# LLVM.vector [1::Float]) + (CausalP.delay1 $# LLVM.vector ((1::Float):repeat 0)) + $* (SigP.constant $# LLVM.vector [0::Float]))) + +filterSweepPacked2 :: IO () +filterSweepPacked2 = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (CausalP.amplify 0.2 . + CtrlP.processCtrlRate 128 + (lfoSine (Filt2P.bandpassParameter (valueOf 100))) + $* SigP.osciSimple Wave.saw 0 0.01) + +butterworthNoisePacked :: IO () +butterworthNoisePacked = + SVL.writeFile "speedtest.f32" $ + SVL.take (div 10000000 4) $ + asMonoPacked $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (CausalPS.amplify 0.2 . + CtrlPS.processCtrlRate 128 + (lfoSine (Butterworth.parameter TypeNum.d3 FiltR.Lowpass (valueOf 0.5))) + $* SigPS.noise 0 0.3) + +chebyshevNoisePacked :: IO () +chebyshevNoisePacked = + SVL.writeFile "speedtest.f32" $ + SVL.take (div 10000000 4) $ + asMonoPacked $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (CausalPS.amplify 0.2 . + CtrlPS.processCtrlRate 128 + (lfoSine (Chebyshev.parameterA TypeNum.d5 FiltR.Lowpass (valueOf 0.5))) + $* SigPS.noise 0 0.3) + +{- +Provoke non-aligned vector accesses by calling alloca for a record of 5 floats +in LLVM-2.6. +However, the vector accesses are those of noise. +Using scalar Noise there is no problem. +-} +noiseAllocaBug :: IO () +noiseAllocaBug = + SVL.writeFile "speedtest.f32" $ + SVL.take (div 10000000 4) $ + asMonoPacked $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (CausalPS.amplify 0.2 . Filt2.causalPackedP + $< (SigP.mapSimple (const $ Rep.load =<< LLVM.alloca) $ + (SigP.constant $# (0::Float))) + $* SigPS.noise 0 0.3) + +noiseAllocaScalar :: IO () +noiseAllocaScalar = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (CausalP.amplify 0.2 . Filt2.causalP + $< (SigP.mapSimple (const $ + (Rep.load =<< LLVM.alloca :: + LLVM.CodeGenFunction r (Filt2.Parameter (Value Float)))) $ + (SigP.constant $# (0::Float))) + $* SigP.noise 0 0.3) + + +upsample :: IO () +upsample = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + Sig.renderChunky (SVL.chunkSize 100000) $ + (let reduct = 128 :: Float + in Sig.interpolateConstant reduct $ + Sig.osci Wave.sine 0 (reduct*0.1/44100)) + + +filterSweepControlRateCausal :: + Causal.T + (Stereo.T (Value Float)) + (Stereo.T (Value Float)) +filterSweepControlRateCausal = + Causal.amplifyStereo 0.3 <<< + BandPass.causal <<< + Causal.feedFst + (let reduct = 128 + in Sig.interpolateConstant reduct $ + Sig.map (BandPass.parameter (valueOf 100)) $ + Sig.map (\x -> 0.01 * exp (2 * return x)) $ + Sig.osci Wave.sine 0 (reduct*0.1/44100)) + +filterSweepControlRateProc :: + Sig.T (Stereo.T (Value Float)) -> + Sig.T (Stereo.T (Value Float)) +filterSweepControlRateProc = + Causal.apply filterSweepControlRateCausal + +{- | +Trigonometric functions are very slow in LLVM +because they are translated to calls to C's math library. +Thus it is advantageous to compute filter parameters +at a lower rate and interpolate constantly. +-} +filterSweepControlRate :: IO () +filterSweepControlRate = + SVL.writeFile "speedtest.f32" $ + asStereo $ + SVL.take 10000000 $ + Sig.renderChunky (SVL.chunkSize 100000) $ + filterSweepControlRateProc $ + chord 0.005 + + +filterSweepMusic :: IO () +filterSweepMusic = + do music <- SV.readFile "lichter.f32" + SVL.writeFile "speedtest.f32" $ + asStereo $ + Sig.renderChunky (SVL.chunkSize 100000) $ + Sig.amplifyStereo 20 $ + filterSweepControlRateProc $ + Sig.fromStorableVector $ + (music :: SV.Vector (Stereo.T Float)) + + +playFilterSweepMusicLazy :: IO () +playFilterSweepMusicLazy = do + IO.withFile "lichter.f32" IO.ReadMode $ \h -> + playStereo . +-- Sig.amplifyStereo 1.125 . + Sig.amplifyStereo 20 . + filterSweepControlRateProc . + Sig.fromStorableVectorLazy . + asStereo . snd + =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h + return () + +playFilterSweepMusicCausal :: IO () +playFilterSweepMusicCausal = do + do music <- SV.readFile "lichter.f32" + SoxPlay.simple SV.hPut SoxOption.none 44100 $ + asStereo $ + Causal.applyStorable + (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) $ + (music :: SV.Vector (Stereo.T Float)) + return () + +playFilterSweepMusicCausalLazy :: IO () +playFilterSweepMusicCausalLazy = do + IO.withFile "lichter.f32" IO.ReadMode $ \h -> + playStereoVector . + Causal.applyStorableChunky + (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) . + asStereo . snd + =<< SVL.hGetContentsAsync (SVL.chunkSize 43210) h + return () + +arrangeLazy :: IO () +arrangeLazy = do + IO.hSetBuffering IO.stdout IO.NoBuffering + print $ + SigLSt.arrange (SVL.chunkSize 2) $ + EventList.fromPairList $ + (0, SVL.pack (SVL.chunkSize 2) [1,2::Double]) : + (0, SVL.pack (SVL.chunkSize 2) [3,4,5,6]) : + (2, SVL.pack (SVL.chunkSize 2) [7,8,9,10]) : + -- repeat (2, SVL.empty) +-- (2, SVL.empty) : +-- (2, SVL.empty) : +-- (2::NonNeg.Int, error "undefined sound") : + error "end of list" + -- [] + + +{- | +This is inefficient because pingSig is compiled by LLVM +for every occurence of the sound! + +randomTones :: IO () +randomTones = do + playMonoVector $ + SigLSt.arrange (SVL.chunkSize 12345) $ + EventList.fromPairList $ zip + (cycle $ map (flip div 16 . (44100*)) [1,2,3]) + (cycle $ map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 54321) . + pingSig . (0.01*)) + [1,1.25,1.5,2]) + return () +-} + +{- | +So far we have not managed to compile signals +that depend on parameters. +Thus in order to avoid much recompilation, +we compile and render a few sounds in advance. +-} +pingTones :: [SVL.Vector Float] +pingTones = + map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 4321) . + pingSig . (0.01*)) + [1,1.25,1.5,2] + +pingTonesIO :: IO [SVL.Vector Float] +pingTonesIO = + fmap + (\pingVec -> + map + (SVL.take 44100 . + pingVec (SVL.chunkSize 4321) . + (0.01*)) + [1,1.25,1.5,2]) + (SigP.runChunky pingSigP) + +{- +Arrange itself does not seem to have a space leak with temporary data. +However it may leak sound data. +This is not very likely because this would result in a large memory leak. + +Generate random tones in order to see whether generated sounds leak. +How does 'arrange' compare with 'concat'? +-} + +cycleTones :: IO () +cycleTones = do +-- playMono $ + pings <- pingTonesIO + SVL.writeFile "test.f32" $ +-- Play.auto (0.01::Double) 44100 $ + asMono $ +{- +after 13min runtime memory consumption increased from 2.5 to 3.9 +and we get lot of buffer underruns with this implementation of amplification +(renderChunky . amplify . fromStorableVector) +-} + Sig.renderChunky (SVL.chunkSize 432109) $ + Sig.amplify 0.1 $ + Sig.fromStorableVectorLazy $ +{- +after 20min memory consumption increased from 2.5 to 3.4 +and we get lot of buffer underruns with applyStorableChunky +-} +{- +applyStorableChunky applied to concatenated zero vectors +starts with memory consumption 1.0 and after an hour, it's still 1.1 +without buffer underruns. +-} +{- + CausalP.applyStorableChunky (CausalP.amplify $# (0.1::Float)) () $ + asMono $ +-} +{- +with chunksize 12345678 +after 50min runtime the memory consumption increased from 12.0 to 26.2 + +with chunksize 123 +after 25min runtime the memory consumption is constant 7.4 +however at start time there 5 buffer underruns, but no more +probably due to initial LLVM compilation + +with chunksize 1234567 and SVL.replicate instead of pingTones +we get memory consumption from 1.3 to 3.2 in 15min, +while producing lots of buffer underruns. +After 45min in total, it is still 3.2 of memory consumption. +Is this a memory leak, or isn't it? + +with chunksize 12345678 and SVL.replicate +we get from 5.6 to 10.2 in 3min +to 14.9 after total 13min. +-} +{- + SigLSt.arrange (SVL.chunkSize 12345678) $ + EventList.fromPairList $ zip + (repeat (div 44100 8)) +-- (cycle $ map (flip div 4 . (44100*)) [1,2,3]) +-} +{- +With plain concatenation of those zero vectors +we stay constantly at 0.4 memory consumption and no buffer underruns over 30min. +-} + SVL.concat + (cycle pings) +-- (repeat $ SVL.replicate (SVL.chunkSize 44100) 44100 0) + return () + + +tonesChunkSize :: SVL.ChunkSize +numTones :: Int + +{- +For one-time-compiled fill functions, +larger chunks have no relevant effect on the processing speed. +-} +(tonesChunkSize, numTones) = + (SVL.chunkSize 441, 200) +-- (SVL.chunkSize 44100, 200) + +fst :: Arrow arrow => arrow (a,b) a +fst = arr P.fst + +snd :: Arrow arrow => arrow (a,b) b +snd = arr P.snd + + +{-# NOINLINE makePing #-} +makePing :: IO ((Float,Float) -> SVL.Vector Float) +makePing = + let freq = snd + halfLife = fst + in fmap ($tonesChunkSize) $ + SigP.runChunky + (SigP.envelope + (SigP.exponential2 halfLife 1) + (SigP.osciSaw 0.5 freq)) + +tonesDown :: IO () +tonesDown = do + let dist = div 44100 10 + pingp <- makePing + playMonoVector $ + CausalP.applyStorableChunky (CausalP.amplify id) 0.03 $ + SigLSt.arrange tonesChunkSize $ + EventList.fromPairList $ zip + (repeat (NonNeg.fromNumber dist)) + (map (SVL.take (numTones * dist) . curry pingp 50000) $ + iterate (0.999*) 0.01) + return () + + +vibes :: SigP.T (Float,Float) (Value Float) +vibes = + let freq = snd + modDepth = fst + halfLife = 5000 + -- sine = Wave.sine + sine = Wave.approxSine4 + in CausalP.envelope + $< SigP.exponential2 halfLife 1 + $* (((CausalP.osciSimple sine + $< (CausalP.envelope + $< SigP.exponential2 halfLife modDepth + $* (CausalP.osciSimple sine + $* SigP.constant (return (0::Float) &&& (2*freq))))) + <<< + CausalP.mapLinear (0.01*freq) freq + <<< + CausalP.osciSimple sine) + $* SigP.constant (return (0::Float, 0.0001::Float))) + +makeVibes :: IO ((Float,Float) -> SVL.Vector Float) +makeVibes = + fmap ($tonesChunkSize) $ + SigP.runChunky vibes + +vibesCycleVector :: ((Float,Float) -> SVL.Vector Float) -> SVL.Vector Float +vibesCycleVector pingp = + SigLSt.arrange tonesChunkSize $ + EventList.fromPairList $ zip + (repeat 5000) + (map (SVL.take 50000 . pingp) $ + zip + (map (\k -> 0.5 * (1 - cos k)) $ iterate (0.05+) 0) + (cycle $ map (0.01*) [1, 1.25, 1.5, 2])) + +vibesCycle :: IO () +vibesCycle = do + pingp <- makeVibes + playMonoVector $ + CausalP.applyStorableChunky (CausalP.amplify id) 0.2 $ + vibesCycleVector pingp + return () + +vibesEcho :: IO () +vibesEcho = do + pingp <- makeVibes + playMonoVector $ + CausalP.applyStorableChunky + (CausalP.amplify id <<< + CausalP.comb 0.5 7000) + 0.2 $ + vibesCycleVector pingp + return () + +vibesReverb :: IO () +vibesReverb = do + pingp <- makeVibes + playMonoVector $ + CausalP.applyStorableChunky + (CausalP.amplify id <<< + CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000)) + 0.3 $ + vibesCycleVector pingp + return () + +vibesReverbStereo :: IO () +vibesReverbStereo = do + pingp <- makeVibes + playStereoVector $ + CausalP.applyStorableChunky + (CausalP.amplifyStereo id <<< + CausalP.stereoFromChannels + (CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000)) + (CausalP.reverb (mkStdGen 857) 16 (0.9,0.97) (400,1000)) <<< + CausalP.mapSimple Sample.stereoFromMono) + 0.3 $ + vibesCycleVector pingp + return () + + + +stair :: IO () +stair = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + flip (SigP.renderChunky tonesChunkSize) () $ + SigP.piecewiseConstant $ + return $ + EventListBT.fromPairList $ + zip + (iterate (/2) (1::Float)) + (iterate (2*) (1::NonNeg.Int)) + + +filterBass :: IO () +filterBass = do + playStereoVector $ + asStereo $ + flip (SigP.renderChunky tonesChunkSize) () $ + CausalP.apply + (BandPass.causalP + <<< + CausalP.feedSnd + (SigP.zipWithSimple Sample.zipStereo + (SigP.osciSimple Wave.saw 0 0.001499) + (SigP.osciSimple Wave.saw 0 0.001501)) + <<< + CausalP.mapSimple (BandPass.parameter (valueOf (100::Float)))) $ + SigP.piecewiseConstant $ + return $ EventListBT.fromPairList $ + zip + (map (((0.03::Float)*) . (2**) . (/12) . fromInteger) $ + randomRs (0,12) (mkStdGen 998)) + (repeat (10000::NonNeg.Int)) + + return () + + +{- | +This function is not very efficient, +since it compiles an LLVM mixing routine +for every pair of mixer inputs. +-} +mixVectorRecompile :: + SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float +mixVectorRecompile xs ys = + Sig.renderChunky tonesChunkSize $ + Sig.mix + (Sig.fromStorableVectorLazy xs) + (Sig.fromStorableVectorLazy ys) + +mixVectorParamIO :: + IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float) +mixVectorParamIO = + fmap curry $ + fmap ($tonesChunkSize) $ + SigP.runChunky + (SigP.mix + (SigP.fromStorableVectorLazy fst) + (SigP.fromStorableVectorLazy snd)) + +mixVectorCausalIO :: + IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float) +mixVectorCausalIO = + CausalP.runStorableChunky + (CausalP.mix $< + SigP.fromStorableVectorLazy id) + +mixVectorCausal :: + SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float +mixVectorCausal = + CausalP.applyStorableChunky + (CausalP.mix $< + SigP.fromStorableVectorLazy id) + +mixVectorStereo :: + SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float) +mixVectorStereo = + CausalP.applyStorableChunky + (CausalP.mixStereo $< + SigP.fromStorableVectorLazy id) + +mixVectorStereoIO :: + IO (SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float)) +mixVectorStereoIO = + CausalP.runStorableChunky + (CausalP.mixStereo $< + SigP.fromStorableVectorLazy id) + +{- +slightly slower than mixVectorParam +-} +mixVectorHaskell :: + SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float +mixVectorHaskell = SVL.zipWith (+) + +toneMix :: IO () +toneMix = do + pingp <- makePing + mix <- mixVectorCausalIO + playMonoVector $ + Causal.applyStorableChunky (Causal.amplify 0.1) $ + foldl1 mix $ + map (curry pingp 1000000) $ + take numTones $ + iterate (*(2/3)) 0.01 + return () + +fadeEnvelope :: SigP.T (Int, Int) (Value Float) +fadeEnvelope = + SigP.parabolaFadeIn (fmap fromIntegral fst) + `SigP.append` + (CausalP.take snd $* (SigP.constant $# (1::Float))) + `SigP.append` + SigP.parabolaFadeOut (fmap fromIntegral fst) + +fadeEnvelopeWrite :: IO () +fadeEnvelopeWrite = + SVL.writeFile "speedtest.f32" $ + asMono $ + SigP.renderChunky (SVL.chunkSize 1234) + fadeEnvelope (100000, 200000) + + +-- | normalize a list of numbers, such that they have a specific average +-- Cf. haskore-supercollider/src/Haskore/Interface/SuperCollider/Example.hs +normalizeLevel :: Fractional a => a -> [a] -> [a] +normalizeLevel newAvrg xs = + let avrg = sum xs / genericLength xs + in map ((newAvrg-avrg)+) xs + +stereoOsciSawP :: SigP.T Float (Stereo.T (Value Float)) +stereoOsciSawP = + let freq = id + n = 5 + volume = 1 / sqrt (fromIntegral n) + detunes = + normalizeLevel 1 $ take (2*n) $ + randomRs (0,0.03) $ mkStdGen 912 + phases = + randomRs (0,1) $ mkStdGen 54 + tones = + zipWith + (\phase detune -> + (SigP.osciSaw $# phase) (fmap (detune*) freq)) + phases detunes + (tonesLeft,tonesRight) = splitAt n tones + in SigP.zipWithSimple + (\l r -> + Sample.amplifyStereo (valueOf volume) + =<< Sample.zipStereo l r) + (foldl1 SigP.mix tonesLeft) + (foldl1 SigP.mix tonesRight) + +stereoOsciSawVector :: Float -> SVL.Vector (Stereo.T Float) +stereoOsciSawVector = + SigP.renderChunky tonesChunkSize stereoOsciSawP + +stereoOsciSawChord :: [Float] -> SVL.Vector (Stereo.T Float) +stereoOsciSawChord = + foldl1 mixVectorStereo . map stereoOsciSawVector + +stereoOsciSawPad :: Int -> [Float] -> SVL.Vector (Stereo.T Float) +stereoOsciSawPad dur pitches = + let attack = 20000 + in CausalP.applyStorableChunky + (CausalP.envelopeStereo $< fadeEnvelope) + (attack, dur-attack) + (stereoOsciSawChord pitches) + +a0, as0, b0, c1, cs1, d1, ds1, e1, f1, fs1, g1, gs1, + a1, as1, b1, c2, cs2, d2, ds2, e2, f2, fs2, g2, gs2, + a2, as2, b2, c3, cs3, d3, ds3, e3, f3, fs3, g3, gs3, + a3, as3, b3, c4, cs4, d4, ds4, e4, f4, fs4, g4, gs4 :: Float +a0 : as0 : b0 : c1 : cs1 : d1 : ds1 : e1 : f1 : fs1 : g1 : gs1 : + a1 : as1 : b1 : c2 : cs2 : d2 : ds2 : e2 : f2 : fs2 : g2 : gs2 : + a2 : as2 : b2 : c3 : cs3 : d3 : ds3 : e3 : f3 : fs3 : g3 : gs3 : + a3 : as3 : b3 : c4 : cs4 : d4 : ds4 : e4 : f4 : fs4 : g4 : gs4 : _ = + iterate ((2 ** recip 12) *) (55/44100) + + +chordSequence :: [(Int, [Float])] +chordSequence = + (2, [f1, f2, a2, c3]) : + (1, [g1, g2, b2, d3]) : + (2, [c2, g2, c3, e3]) : + (1, [f1, a2, c3, f3]) : + (2, [g1, g2, b2, d3]) : + (1, [gs1, gs2, b2, e3]) : + (2, [a1, e2, a2, c3]) : + (1, [g1, g2, b2, d3]) : + (3, [c2, g2, c3, e3]) : + + (2, [f1, f2, a2, c3]) : + (1, [g1, g2, b2, d3]) : + (2, [c2, g2, c3, e3]) : + (1, [f1, a2, c3, f3]) : + (2, [g1, g2, b2, d3]) : + (1, [gs1, gs2, b2, e3]) : + (2, [a1, e2, a2, c3]) : + (1, [g1, g2, b2, e3]) : + (3, [c2, e2, g2, c3]) : + [] + + +withDur :: (Int -> a -> v) -> Int -> a -> (v, NonNeg.Int) +withDur f d ps = + let dur = d*30000 + in (f dur ps, NonNeg.fromNumber dur) + + +padMusic :: IO () +padMusic = do + playStereoVector $ + CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.1 $ + SigLSt.arrange tonesChunkSize $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (\(d,ps) -> withDur stereoOsciSawPad d ps) + chordSequence + return () + + +lowpassSweepControlRateCausal :: + CausalP.T p + (Stereo.T (Value Float)) + (Stereo.T (Value Float)) +lowpassSweepControlRateCausal = +-- CausalP.stereoFromVector $ + CausalP.stereoFromMono $ + UniFilter.lowpass ^<< + CtrlP.processCtrlRate 128 + (lfoSine (UniFilter.parameter (valueOf (10::Float)))) + + +moogSweepControlRateCausal :: + CausalP.T p + (Stereo.T (Value Float)) + (Stereo.T (Value Float)) +moogSweepControlRateCausal = +-- CausalP.stereoFromVector $ + CausalP.stereoFromMono $ + CtrlP.processCtrlRate 128 + (lfoSine (Moog.parameter TypeNum.d8 (valueOf (10::Float)))) + + +filterMusic :: IO () +filterMusic = do + playStereoVector $ + CausalP.applyStorableChunky + (CausalP.amplifyStereo id <<< + moogSweepControlRateCausal) 0.05 $ + SigLSt.arrange tonesChunkSize $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (\(d,ps) -> withDur stereoOsciSawPad d ps) + chordSequence + return () + + + +stereoOsciSawVectorIO :: IO (Float -> SVL.Vector (Stereo.T Float)) +stereoOsciSawVectorIO = + fmap ($tonesChunkSize) $ + SigP.runChunky $ + stereoOsciSawP + +applyFadeEnvelopeIO :: + IO (Int -> SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float)) +applyFadeEnvelopeIO = + fmap + (\envelope dur sig -> + let attack = 20000 + in envelope (attack, dur-attack) sig) + (CausalP.runStorableChunky + (CausalP.envelopeStereo $< fadeEnvelope)) + +stereoOsciSawChordIO :: IO ([Float] -> SVL.Vector (Stereo.T Float)) +stereoOsciSawChordIO = do + sawv <- stereoOsciSawVectorIO + mix <- mixVectorStereoIO + return (foldl1 mix . map sawv) + +stereoOsciSawPadIO :: IO (Int -> [Float] -> SVL.Vector (Stereo.T Float)) +stereoOsciSawPadIO = do + chrd <- stereoOsciSawChordIO + envelope <- applyFadeEnvelopeIO + return $ + \ dur pitches -> envelope dur (chrd pitches) + +padMusicIO :: IO () +padMusicIO = do + pad <- stereoOsciSawPadIO + playStereoVector $ + CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.08 $ + SigLSt.arrange tonesChunkSize $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (uncurry (withDur pad)) $ + chordSequence + return () + +{- +Apply the envelope separately to each tone of the chord +and mix all tones by 'arrange'. +-} +padMusicSeparate :: IO () +padMusicSeparate = do + osci <- stereoOsciSawVectorIO + env <- applyFadeEnvelopeIO + playStereoVector $ + CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.08 $ + SigLSt.arrange tonesChunkSize $ + EventList.flatten $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (uncurry (withDur (\d ps -> map (\p -> env d (osci p)) ps))) $ + chordSequence + return () + + +delay :: IO () +delay = + SVL.writeFile "speedtest.f32" $ + asMono $ + flip (SigP.renderChunky tonesChunkSize) (0, 10000) $ + CausalP.apply + ((CausalP.delay $# (0::Float)) fst + <<< CausalP.take snd) $ + SigP.osciSaw 0 0.01 + + + +allpassControl :: + (TypeNum.Nat n) => + n -> + SigP.T Float (Allpass.CascadeParameter n (Value Float)) +allpassControl order = + let reduct = id + in SigP.interpolateConstant reduct $ + lfoSine (Allpass.flangerParameter order) reduct + +allpassPhaserCausal, allpassPhaserPipeline :: + SigP.T Float (Value Float) -> + SigP.T Float (Value Float) +allpassPhaserCausal = + let order = TypeNum.d16 + in CausalP.apply $ + CausalP.amplify 0.5 <<< + Allpass.phaserP <<< + CausalP.feedFst (allpassControl order) + +allpassPhaserPipeline = + let order = TypeNum.d16 + in -- (F.nest (TypeNum.toInt order) SigP.tail .) $ + (SigP.drop (return $ TypeNum.toInt order) .) $ + CausalP.apply $ + CausalP.amplify 0.5 <<< + Allpass.phaserPipelineP <<< + CausalP.feedFst (allpassControl order) + +allpassPhaser :: IO () +allpassPhaser = + SVL.writeFile "speedtest.f32" $ + asMono $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) 128 $ + allpassPhaserPipeline $ + (SigP.osciSaw 0 0.01) + +noise :: IO () +noise = + SVL.writeFile "speedtest.f32" $ + asMono $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (SigP.noise 0 0.3) + +noisePacked :: IO () +noisePacked = + SVL.writeFile "speedtest.f32" $ + asMonoPacked $ + SVL.take (div 10000000 4) $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (SigPS.noise 0 0.3) +-- (SigPS.pack (SigP.noise 0 0.3)) +-- (SigPS.packSmall (SigP.noise 0 0.3)) + +frequencyModulationStorable :: IO () +frequencyModulationStorable = do + smp <- SigP.runChunky (SigP.osciSaw 0 0.01) + SVL.writeFile "speedtest.f32" $ + asMono $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy $# + (SVL.take 1000000 $ asMono $ + smp (SVL.chunkSize 1000) ())) + $*# (0.3::Float)) + +frequencyModulation :: IO () +frequencyModulation = + SVL.writeFile "speedtest.f32" $ + asMono $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (CausalP.frequencyModulationLinear + (SigP.osciSaw 0 0.01) + $* SigP.exponential2 500000 1) + +frequencyModulationStereo :: IO () +frequencyModulationStereo = do + smp <- SigP.runChunky (SigP.osciSaw 0 0.01) + SVL.writeFile "speedtest.f32" $ + asStereo $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (CausalP.stereoFromMono + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy $# + (SVL.take 1000000 $ asMono $ + smp (SVL.chunkSize 1000) ()))) + $*# Stereo.cons (0.2999::Float) 0.3001) + + +quantize :: IO () +quantize = +{- + SV.writeFile "speedtest.f32" $ + asMono $ + (\xs -> SigP.render xs 10000000 ()) $ +-} + SVL.writeFile "speedtest.f32" $ + asMono $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + ((CausalP.quantizeLift $# (5.5::Float)) id $* + SigP.osciSaw 0 0.01) + +quantizedFilterControl :: IO () +quantizedFilterControl = + SVL.writeFile "speedtest.f32" $ + asMono $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + CausalP.apply (CausalP.amplify 0.3 <<< UniFilter.lowpass ^<< CtrlP.process) $ + SigP.zip + ((CausalP.quantizeLift $# (128::Float)) + (CausalP.mapSimple (UniFilter.parameter (valueOf 100)) <<< +-- (CausalP.mapSimple (Moog.parameter TypeNum.d8 (valueOf 100)) <<< + CausalP.mapSimple (\x -> 0.01 * exp (2 * return x))) + $* (SigP.osciSimple Wave.approxSine2 $# (0::Float)) (0.1/44100)) $ + (SigP.osciSaw $# (0::Float)) 0.01 + + +main :: IO () +main = do + LLVM.initializeNativeTarget + frequencyModulationStereo diff --git a/src/Synthesizer/LLVM/Wave.hs b/src/Synthesizer/LLVM/Wave.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Wave.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.LLVM.Wave where + +import qualified Synthesizer.LLVM.Simple.Value as Value +import qualified LLVM.Extra.ScalarOrVector as SoV + +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Monad as M + +import qualified LLVM.Core as LLVM +import LLVM.Core + (Value, CodeGenFunction, + IsFloating, IsArithmetic, IsConst, ) + +import Control.Monad.HT ((<=<), ) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (replicate, ) + + + +saw :: + (Ring.C a, IsConst a, SoV.Replicate a v, IsArithmetic v) => + Value v -> CodeGenFunction r (Value v) +saw = + A.sub (SoV.replicateOf 1) <=< + A.mul (SoV.replicateOf 2) + +square :: + (Ring.C a, IsConst a, + SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => + Value v -> CodeGenFunction r (Value v) +square = + A.sub (SoV.replicateOf 1) <=< + A.mul (SoV.replicateOf 2) <=< + SoV.truncate <=< + A.mul (SoV.replicateOf 2) + +triangle :: + (Field.C a, IsConst a, + SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => + Value v -> CodeGenFunction r (Value v) +triangle = + flip A.sub (SoV.replicateOf 1) <=< + SoV.abs <=< + flip A.sub (SoV.replicateOf 2) <=< + A.mul (SoV.replicateOf 4) <=< + SoV.incPhase (SoV.replicateOf 0.75) + +approxSine2 :: + (Ring.C a, IsConst a, SoV.Replicate a v, SoV.Real v) => + Value v -> CodeGenFunction r (Value v) +approxSine2 t = do + x <- saw t + A.mul (SoV.replicateOf 4) =<< + A.mul x =<< + A.sub (SoV.replicateOf 1) =<< + SoV.abs x + +approxSine3 :: + (Field.C a, IsConst a, + SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => + Value v -> CodeGenFunction r (Value v) +approxSine3 t = do + x <- triangle t + A.mul (SoV.replicateOf 0.5) =<< + A.mul x =<< + A.sub (SoV.replicateOf 3) =<< + A.mul x x + +approxSine4 :: + (Field.C a, IsConst a, SoV.Replicate a v, SoV.Real v) => + Value v -> CodeGenFunction r (Value v) +approxSine4 t = do + x <- saw t + ax <- SoV.abs x + sax <- A.sub (SoV.replicateOf 1) ax + A.mul (SoV.replicateOf (16/5)) =<< + A.mul x =<< + A.mul sax =<< + A.add (SoV.replicateOf 1) =<< + A.mul sax ax + +{- | +For the distortion factor @recip pi@ you get the closest approximation +to an undistorted cosine or sine. +We have chosen this scaling in order to stay with field operations. +-} +rationalApproxCosine1, rationalApproxSine1 :: + (Field.C a, IsConst a, SoV.Replicate a v, SoV.Real v, IsFloating v) => + Value v -> Value v -> CodeGenFunction r (Value v) +rationalApproxCosine1 k t = do + num2 <- + A.square =<< + A.mul k =<< + A.add (SoV.replicateOf (-1)) =<< + A.mul (SoV.replicateOf 2) t + den2 <- + A.square =<< + A.mul t =<< + A.sub (SoV.replicateOf 1) t + M.liftR2 A.fdiv + (A.sub num2 den2) + (A.add num2 den2) + +rationalApproxSine1 k t = do + num <- + A.mul k =<< + A.add (SoV.replicateOf (-1)) =<< + A.mul (SoV.replicateOf 2) t + den <- + A.mul t =<< + A.sub (SoV.replicateOf 1) t + M.liftR2 A.fdiv + (A.mul (SoV.replicateOf (-2)) =<< A.mul num den) + (M.liftR2 A.add (A.square num) (A.square den)) + + +trapezoidSkew :: + (Field.C a, IsConst a, + SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => + Value v -> Value v -> CodeGenFunction r (Value v) +trapezoidSkew p = + SoV.max (SoV.replicateOf (-1)) <=< + SoV.min (SoV.replicateOf 1) <=< + flip A.fdiv p <=< + A.sub (SoV.replicateOf 1) <=< + A.mul (SoV.replicateOf 2) + +sine :: + (Trans.C a, IsFloating a, IsConst a) => +-- Value a -> TValue r a + Value a -> CodeGenFunction r (Value a) +sine t = + A.sin =<< A.mul t =<< Value.decons Value.twoPi + + + +{- | +This can be used for preprocessing the phase +in order to generate locally faster oscillating waves. +For example + +> triangle <=< replicate (valueOf 2.5) + +shrinks a triangle wave such that 2.5 periods fit into one. +-} +replicate :: + (Field.C a, IsConst a, + SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => + Value v -> Value v -> CodeGenFunction r (Value v) +replicate k = + SoV.fraction <=< + A.mul k <=< + flip A.sub (SoV.replicateOf 0.5) <=< + SoV.incPhase (SoV.replicateOf 0.5) + +{- | +Preprocess the phase such that the first half of a wave +is expanded to one period and shifted by 90 degree. +E.g. + +> sine <=< halfEnvelope + +generates a sequence of sine bows that starts and ends with the maximum. +Such a signal can be used to envelope an oscillation +generated using 'replicate'. +-} +halfEnvelope :: + (Field.C a, IsConst a, + SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => + Value v -> CodeGenFunction r (Value v) +halfEnvelope = + A.mul (SoV.replicateOf 0.5) <=< + SoV.incPhase (SoV.replicateOf 0.5) + +partial :: + (LLVM.IsPrimitive i, LLVM.IsPrimitive a, + LLVM.IsInteger i, IsFloating a, + SoV.Replicate a v, SoV.Fraction v) => + (Value v -> CodeGenFunction r (Value v)) -> + Value i -> + (Value v -> CodeGenFunction r (Value v)) +partial w n t = + w =<< + SoV.signedFraction =<< + A.mul t =<< + SoV.replicate =<< + LLVM.sitofp n diff --git a/src/Test/Main.hs b/src/Test/Main.hs new file mode 100644 --- /dev/null +++ b/src/Test/Main.hs @@ -0,0 +1,22 @@ +module Main where + +import qualified Test.Synthesizer.LLVM.Filter as Filter +import qualified Test.Synthesizer.LLVM.Packed as Packed + +import qualified LLVM.Core as LLVM + +import Data.Tuple.HT (mapFst, ) + + +prefix :: String -> [(String, IO ())] -> [(String, IO ())] +prefix msg = + map (mapFst (\str -> msg ++ "." ++ str)) + +main :: IO () +main = do + LLVM.initializeNativeTarget + mapM_ (\(name,test) -> putStr (name ++ ": ") >> test) $ + concat $ + prefix "Filter" Filter.tests : + prefix "Packed" Packed.tests : + [] diff --git a/src/Test/Synthesizer/LLVM/Filter.hs b/src/Test/Synthesizer/LLVM/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Test/Synthesizer/LLVM/Filter.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +module Test.Synthesizer.LLVM.Filter (tests) where + +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.FirstOrder as FirstOrder +import qualified Synthesizer.LLVM.Filter.SecondOrder as SecondOrder +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as SecondOrderP +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFilterP + +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as AllpassCore +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrderCore +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilterCore +import qualified Synthesizer.Plain.Filter.Recursive.Moog as MoogCore +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex as ComplexFilterCore + +import qualified Synthesizer.LLVM.Parameter as Param +import qualified LLVM.Extra.Representation as Rep +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) +-- import qualified Synthesizer.Storable.Signal as SigSt +import qualified Synthesizer.Interpolation.Module as Ip +import qualified Synthesizer.Causal.Interpolation as InterpC +import qualified Synthesizer.Causal.Filter.NonRecursive as FiltC +import qualified Synthesizer.Causal.Displacement as DispC +import qualified Synthesizer.Causal.Process as CausalS +import qualified Synthesizer.Basic.Phase as Phase +import qualified Synthesizer.Basic.Wave as WaveCore +import qualified Synthesizer.State.Displacement as DispS +import qualified Synthesizer.State.Oscillator as OsciS +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Data.StorableVector.Lazy as SVL +import Data.StorableVector.Lazy (ChunkSize, ) + +import Test.Synthesizer.LLVM.Utility + (checkSimilarity, checkSimilarityState, rangeFromInt, ) + +import qualified Control.Category as Cat +import Control.Category ((<<<), ) +import Control.Arrow ((&&&), (^<<), (<<^), ) + +import LLVM.Core (Value, Vector, ) +import qualified LLVM.Core as LLVM +import qualified Data.TypeLevel.Num as TypeNum +import Data.TypeLevel.Num (D4, ) + +import qualified Number.Complex as Complex +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import Test.QuickCheck (quickCheck, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +signalLength :: Int +signalLength = 10000 + + +limitFloat :: SVL.Vector Float -> SVL.Vector Float +limitFloat = SVL.take signalLength + +{- +limitStereoFloat :: SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float) +limitStereoFloat = SVL.take signalLength +-} + + +lfoSine :: + (Rep.Memory a ap, LLVM.IsSized ap asize) => + (forall r. Value Float -> LLVM.CodeGenFunction r a) -> + Param.T p Float -> + SigP.T p a +lfoSine f reduct = + SigP.interpolateConstant reduct $ + SigP.mapSimple f $ + CausalP.apply (CausalP.mapExponential 2 0.01) $ + SigP.osciSimple Wave.sine 0 (fmap (* (0.1/44100)) reduct) + +allpassControl :: + (TypeNum.Nat n) => + n -> + Param.T p Float -> + SigP.T p (Allpass.CascadeParameter n (Value Float)) +allpassControl order = + lfoSine (Allpass.flangerParameter order) + +allpassPhaserCausal, allpassPhaserPipeline :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +allpassPhaserCausal reduct = + CausalP.apply + (Allpass.phaserP + $< allpassControl TypeNum.d16 reduct) + +allpassPhaserPipeline reduct xs = + let order = TypeNum.d16 + in (SigP.drop $# TypeNum.toInt order) $ + (Allpass.phaserPipelineP + $< allpassControl order reduct + $* xs) + +allpassPipeline :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +allpassPipeline = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (allpassPhaserCausal reduct tone) + (allpassPhaserPipeline reduct tone) + + + +{- | +Shrink control signal in time +since we can only handle one control parameter per vector chunk. +-} +applyPacked :: + (Rep.Memory c cp, LLVM.IsSized cp cs) => + CausalP.T p + (c, Value (Vector D4 Float)) + (Value (Vector D4 Float)) -> + SigP.T p c -> + SigP.T p (Value (Vector D4 Float)) -> + SigP.T p (Value (Vector D4 Float)) +applyPacked proc cs xs = + proc + $< ((SigP.interpolateConstant $# + (recip $ fromIntegral $ TypeNum.toInt TypeNum.d4 :: Float)) cs) + $* xs + + +allpassPhaserPacked :: + Param.T p Float -> + SigP.T p (Value (Vector D4 Float)) -> + SigP.T p (Value (Vector D4 Float)) +allpassPhaserPacked reduct = + applyPacked Allpass.phaserPackedP + (allpassControl TypeNum.d16 reduct) + +allpassPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +allpassPacked = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneP = SigPS.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (allpassPhaserCausal reduct tone) + (SigPS.unpack $ allpassPhaserPacked reduct toneP) + + +interpolateConstant :: Float -> SigS.T a -> SigS.T a +interpolateConstant reduct xs = + CausalS.apply (InterpC.relative Ip.constant 0 xs) $ + SigS.repeat $ recip reduct + + +{-# INLINE lfoSineCore #-} +lfoSineCore :: + (Float -> a) -> + Float -> + SigS.T a +lfoSineCore f reduct = + interpolateConstant reduct $ + SigS.map f $ + DispS.mapExponential 2 0.01 $ + OsciS.static WaveCore.sine zero (reduct * 0.1/44100) + +{-# INLINE allpassPhaserCore #-} +allpassPhaserCore :: + Float -> + SigS.T Float -> + SigS.T Float +allpassPhaserCore reduct = + let order = 16 + in CausalS.apply $ + FiltC.amplify 0.5 <<< + DispC.mix <<< + ((CausalS.applyFst (AllpassCore.cascadeCausal order) $ + lfoSineCore (AllpassCore.flangerParameter order) reduct) + &&& + Cat.id) + +allpassCore :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +allpassCore = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneS p = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) + in checkSimilarityState 1e-2 limitFloat + (allpassPhaserCausal reduct tone) + (\p -> allpassPhaserCore (Param.get reduct p) (toneS p)) + + + +diracImpulse :: SigP.T p (Value Float) +diracImpulse = + (CausalP.delay1 $# (one::Float)) $* + (SigP.constant $# (zero::Float)) + +firstOrderConstant :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +firstOrderConstant cutOff xs = + FirstOrder.lowpassCausalP + $< SigP.constant (FirstOrderCore.parameter ^<< cutOff) + $* xs + +firstOrderExponential :: IO (ChunkSize -> (Int,Int) -> Bool) +firstOrderExponential = + let cutOff = rangeFromInt (0.001, 0.01) <<^ fst + gain = exp(-2*pi*cutOff) + in checkSimilarity 1e-2 limitFloat + (SigP.amplify (recip (1 - gain)) $ + firstOrderConstant cutOff diracImpulse) + (SigP.exponentialCore gain $# (one :: Float)) + +firstOrderCausal :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +firstOrderCausal reduct xs = + FirstOrder.lowpassCausalP + $< lfoSine FirstOrder.parameter reduct + $* xs + +{-# INLINE firstOrderCore #-} +firstOrderCore :: + Float -> + SigS.T Float -> + SigS.T Float +firstOrderCore reduct = + CausalS.apply $ + CausalS.applyFst FirstOrderCore.lowpassCausal $ + lfoSineCore FirstOrderCore.parameter reduct + +firstOrder :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +firstOrder = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneS p = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) + in checkSimilarityState 1e-2 limitFloat + (firstOrderCausal reduct tone) + (\p -> firstOrderCore (Param.get reduct p) (toneS p)) + +firstOrderCausalPacked :: + Param.T p Float -> + SigP.T p (Value (Vector D4 Float)) -> + SigP.T p (Value (Vector D4 Float)) +firstOrderCausalPacked reduct = + applyPacked + (FirstOrder.lowpassCausalPackedP) + (lfoSine FirstOrder.parameter reduct) + +firstOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +firstOrderPacked = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneP = SigPS.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (firstOrderCausal reduct tone) + (SigPS.unpack $ firstOrderCausalPacked reduct toneP) + + +secondOrderCausal :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +secondOrderCausal reduct xs = + SecondOrder.causalP + $< lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct + $* xs + +secondOrderCausalPacked :: + Param.T p Float -> + SigP.T p (Value (Vector D4 Float)) -> + SigP.T p (Value (Vector D4 Float)) +secondOrderCausalPacked reduct = + applyPacked SecondOrder.causalPackedP + (lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct) + +secondOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +secondOrderPacked = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneP = SigPS.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (secondOrderCausal reduct tone) + (SigPS.unpack $ secondOrderCausalPacked reduct toneP) + +secondOrderCausalPacked2 :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +secondOrderCausalPacked2 reduct xs = + SecondOrderP.causalP + $< lfoSine (SecondOrderP.bandpassParameter (LLVM.valueOf (10::Float))) reduct + $* xs + +secondOrderPacked2 :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +secondOrderPacked2 = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (secondOrderCausal reduct tone) + (secondOrderCausalPacked2 reduct tone) + + +{- +limitUniFilter :: + SVL.Vector (UniFilterCore.Result Float) -> + SVL.Vector (UniFilterCore.Result Float) +limitUniFilter = SVL.take signalLength +-} + +universalCausal :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (UniFilter.Result (Value Float)) +universalCausal reduct xs = + UniFilter.causalP + $< lfoSine (UniFilter.parameter (LLVM.valueOf (10::Float))) reduct + $* xs + +{-# INLINE universalCore #-} +universalCore :: + Float -> + SigS.T Float -> + SigS.T (UniFilterCore.Result Float) +universalCore reduct = + CausalS.apply $ + CausalS.applyFst UniFilterCore.causal $ + lfoSineCore (UniFilterCore.parameter . Pole 10) reduct + +universal :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +universal = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneS p = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) + in checkSimilarityState 1e-2 limitFloat + (fmap UniFilter.lowpass $ + universalCausal reduct tone) + (\p -> + SigS.map UniFilterCore.lowpass $ + universalCore (Param.get reduct p) (toneS p)) +{- + checkSimilarityState 1e-2 limitUniFilter + (universalCausal reduct tone) + (\p -> universalCore (Param.get reduct p) (toneS p)) +-} + + +moogCausal :: + (TypeNum.Nat n) => + n -> + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +moogCausal order reduct xs = + Moog.causalP + $< lfoSine (Moog.parameter order (LLVM.valueOf (10::Float))) reduct + $* xs + +{-# INLINE moogCore #-} +moogCore :: + Int -> + Float -> + SigS.T Float -> + SigS.T Float +moogCore order reduct = + CausalS.apply $ + CausalS.applyFst (MoogCore.lowpassCausal order) $ + lfoSineCore (MoogCore.parameter order . Pole 10) reduct + +moog :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +moog = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + order = TypeNum.d6 + tone = SigP.osciSimple Wave.triangle phase freq + toneS p = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) + in checkSimilarityState 1e-2 limitFloat + (moogCausal order reduct tone) + (\p -> moogCore (TypeNum.toInt order) (Param.get reduct p) (toneS p)) + + +complexCausal :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Stereo.T (Value Float)) +complexCausal reduct = + CausalP.apply $ + (ComplexFilter.causalP + $< lfoSine (ComplexFilter.parameter (LLVM.valueOf (10::Float))) reduct) + <<^ (\x -> Stereo.cons x (LLVM.value LLVM.zero)) + +complexCausalPacked :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Stereo.T (Value Float)) +complexCausalPacked reduct = + CausalP.apply $ + (ComplexFilterP.causalP + $< lfoSine (ComplexFilterP.parameter (LLVM.valueOf (10::Float))) reduct) + <<^ (\x -> Stereo.cons x (LLVM.value LLVM.zero)) + +complexPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +complexPacked = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (fmap Stereo.left $ + complexCausal reduct tone) + (fmap Stereo.left $ + complexCausalPacked reduct tone) + +{-# INLINE complexCore #-} +complexCore :: + Float -> + SigS.T Float -> + SigS.T (Stereo.T Float) +complexCore reduct = + CausalS.apply $ + (\x -> Stereo.cons (Complex.real x) (Complex.imag x)) ^<< + CausalS.applyFst ComplexFilterCore.causal + (lfoSineCore (ComplexFilterCore.parameter . Pole 10) reduct) + +complex :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) +complex = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneS p = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) + in checkSimilarityState 1e-2 limitFloat + (fmap Stereo.left $ + complexCausal reduct tone) + (\p -> + SigS.map ((0.1*) . Stereo.left) $ + complexCore (Param.get reduct p) (toneS p)) +{- + in checkSimilarityState 1e-2 limitStereoFloat + (complexCausal reduct tone) + (\p -> complexCore (Param.get reduct p) (toneS p)) +-} + + +tests :: [(String, IO ())] +tests = + ("secondOrderPacked", quickCheck =<< secondOrderPacked) : + ("secondOrderPacked2", quickCheck =<< secondOrderPacked2) : + ("firstOrderExponential", quickCheck =<< firstOrderExponential) : + ("firstOrder", quickCheck =<< firstOrder) : + ("firstOrderPacked", quickCheck =<< firstOrderPacked) : + ("universal", quickCheck =<< universal) : + ("allpassPacked", quickCheck =<< allpassPacked) : + ("allpassPipeline", quickCheck =<< allpassPipeline) : + ("allpassCore", quickCheck =<< allpassCore) : + ("moog", quickCheck =<< moog) : + ("complexPacked", quickCheck =<< complexPacked) : + ("complex", quickCheck =<< complex) : + [] diff --git a/src/Test/Synthesizer/LLVM/Packed.hs b/src/Test/Synthesizer/LLVM/Packed.hs new file mode 100644 --- /dev/null +++ b/src/Test/Synthesizer/LLVM/Packed.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Test.Synthesizer.LLVM.Packed (tests) where + +import Test.Synthesizer.LLVM.Utility + (checkSimilarity, checkEquality, rangeFromInt, ) + +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.Parameter as Param + +import LLVM.Core (Value, Vector, ) +import qualified LLVM.Core as LLVM +import Data.TypeLevel.Num (D4, ) +import qualified Data.TypeLevel.Num as TypeNum + +import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import Synthesizer.LLVM.Parameterized.Signal (($#), ) +import Synthesizer.LLVM.CausalParameterized.Process (($*), ) + +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Data.StorableVector.Lazy as SVL +import Data.StorableVector.Lazy (ChunkSize, ) + +import Control.Arrow ((^<<), (<<^), (<<<), ) + +import Data.Word (Word32, ) + +import Test.QuickCheck (quickCheck, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +signalLength :: Int +signalLength = 10000 + + +limitFloat :: SVL.Vector Float -> SVL.Vector Float +limitFloat = SVL.take signalLength + +{- +limitPackedFloat :: + SVL.Vector (Vector D4 Float) -> SVL.Vector (Vector D4 Float) +limitPackedFloat = SVL.take (div signalLength 4) +-} + +constant :: IO (ChunkSize -> Int -> Bool) +constant = + let y = rangeFromInt (-1, 1) + in checkSimilarity 1e-3 limitFloat + (SigP.constant y) + (SigPS.unpack (SigPS.constant y :: + SigP.T Int (Value (Vector D4 Float)))) + +ramp :: IO (ChunkSize -> Int -> Bool) +ramp = + let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) + in checkSimilarity 1e-3 limitFloat + (SigP.rampInf dur) + (SigPS.unpack (SigPS.rampInf dur :: + SigP.T Int (Value (Vector D4 Float)))) + +parabolaFadeIn :: IO (ChunkSize -> Int -> Bool) +parabolaFadeIn = + let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) + in checkSimilarity 1e-3 limitFloat + (SigP.parabolaFadeInInf dur) + (SigPS.unpack (SigPS.parabolaFadeInInf dur :: + SigP.T Int (Value (Vector D4 Float)))) + +parabolaFadeOut :: IO (ChunkSize -> Int -> Bool) +parabolaFadeOut = + let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) + in checkSimilarity 1e-3 limitFloat + (SigP.parabolaFadeOutInf dur) + (SigPS.unpack (SigPS.parabolaFadeOutInf dur :: + SigP.T Int (Value (Vector D4 Float)))) + +parabolaFadeInMap :: IO (ChunkSize -> Int -> Bool) +parabolaFadeInMap = + let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) + in checkSimilarity 1e-3 limitFloat + (SigP.parabolaFadeIn dur) + (SigP.parabolaFadeInMap dur) + +parabolaFadeOutMap :: IO (ChunkSize -> Int -> Bool) +parabolaFadeOutMap = + let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) + in checkSimilarity 1e-3 limitFloat + (SigP.parabolaFadeOut dur) + (SigP.parabolaFadeOutMap dur) + +exponential2 :: IO (ChunkSize -> (Int,Int) -> Bool) +exponential2 = + let halfLife = rangeFromInt (1000,10000) <<^ fst + start = rangeFromInt ( -1, 1) <<^ snd + in checkSimilarity 1e-3 limitFloat + (SigP.exponential2 halfLife start) + (SigPS.unpack (SigPS.exponential2 halfLife start :: + SigP.T (Int,Int) (Value (Vector D4 Float)))) + +exponential2Static :: IO (ChunkSize -> (Int,Int) -> Bool) +exponential2Static = + let halfLife = rangeFromInt (1000,10000) <<^ fst + start = rangeFromInt ( -1, 1) <<^ snd + in checkSimilarity 1e-3 limitFloat + (SigP.exponential2 halfLife start) + (Exp.causalP start <<< + CausalP.mapSimple Exp.parameter $* + SigP.constant halfLife) + +exponential2PackedStatic :: IO (ChunkSize -> (Int,Int) -> Bool) +exponential2PackedStatic = + let halfLife = rangeFromInt (1000,10000) <<^ fst + start = rangeFromInt ( -1, 1) <<^ snd + in checkSimilarity 1e-3 (limitFloat . SigStL.unpack) + (SigPS.exponential2 halfLife start :: + SigP.T (Int,Int) (Value (Vector D4 Float))) + (Exp.causalPackedP start <<< + CausalP.mapSimple Exp.parameterPacked $* + SigP.constant halfLife) + +exponential2Controlled :: IO (ChunkSize -> ((Int,Int), (Int,Int)) -> Bool) +exponential2Controlled = + let halfLife = rangeFromInt (1000,10000) <<^ (fst.fst) + start = rangeFromInt ( -1, 1) <<^ (snd.fst) + -- this is the LFO frequency measured at vector-rate + freq = rangeFromInt (0.0001, 0.001) <<^ (fst.snd) + phase = rangeFromInt (0, 0.99) <<^ (snd.snd) + lfo = + CausalP.mapExponential 2 halfLife $* + SigP.osciSimple Wave.approxSine2 phase freq + in checkSimilarity 1e-3 limitFloat + (Exp.causalP start <<< + CausalP.mapSimple Exp.parameter $* + SigP.interpolateConstant + (fromIntegral (TypeNum.toInt TypeNum.d4) :: Param.T p Float) + lfo) + (SigPS.unpack + (Exp.causalPackedP start <<< + CausalP.mapSimple Exp.parameterPacked $* + lfo :: + SigP.T ((Int,Int),(Int,Int)) (Value (Vector D4 Float)))) + +osci :: IO (ChunkSize -> (Int,Int) -> Bool) +osci = + let freq = rangeFromInt (0.001, 0.01) <<^ fst + phase = rangeFromInt (0, 0.99) <<^ snd + in checkSimilarity 1e-2 limitFloat + (SigP.osciSimple Wave.approxSine2 phase freq) + (SigPS.unpack (SigPS.osciSimple Wave.approxSine2 phase freq :: + SigP.T (Int,Int) (Value (Vector D4 Float)))) + + + +limitWord32 :: SVL.Vector Word32 -> SVL.Vector Word32 +limitWord32 = SVL.take signalLength + +limitPackedWord32 :: + SVL.Vector (Vector D4 Word32) -> SVL.Vector (Vector D4 Word32) +limitPackedWord32 = SVL.take (div signalLength 4) + + +noise :: IO (ChunkSize -> () -> Bool) +noise = + checkEquality limitWord32 + (SigP.noiseCore $# 0) + (SigP.noiseCoreAlt $# 0) + +noiseVector :: IO (ChunkSize -> () -> Bool) +noiseVector = + checkEquality limitPackedWord32 + (SigPS.noiseCore $# 0) + (SigPS.noiseCoreAlt $# 0) + +noiseScalarVector :: IO (ChunkSize -> () -> Bool) +noiseScalarVector = + checkEquality limitPackedWord32 + (SigPS.noiseCore $# 0) + (SigPS.packSmall (SigP.noiseCore $# 0)) + + +tests :: [(String, IO ())] +tests = + ("constant", quickCheck =<< constant) : + ("ramp", quickCheck =<< ramp) : + ("parabolaFadeIn", quickCheck =<< parabolaFadeIn) : + ("parabolaFadeOut", quickCheck =<< parabolaFadeOut) : + ("parabolaFadeInMap", quickCheck =<< parabolaFadeInMap) : + ("parabolaFadeOutMap", quickCheck =<< parabolaFadeOutMap) : + ("exponential2", quickCheck =<< exponential2) : + ("exponential2Static", quickCheck =<< exponential2Static) : + ("exponential2PackedStatic", quickCheck =<< exponential2PackedStatic) : + ("exponential2Controlled", quickCheck =<< exponential2Controlled) : + ("osci", quickCheck =<< osci) : + ("noise", quickCheck =<< noise) : + ("noiseVector", quickCheck =<< noiseVector) : + ("noiseScalarVector", quickCheck =<< noiseScalarVector) : + [] diff --git a/src/Test/Synthesizer/LLVM/Utility.hs b/src/Test/Synthesizer/LLVM/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Test/Synthesizer/LLVM/Utility.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Test.Synthesizer.LLVM.Utility where + +import qualified Synthesizer.LLVM.Parameter as Param +import qualified LLVM.Extra.Representation as Rep +import qualified LLVM.Core as LLVM + +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP + +import qualified Synthesizer.State.Signal as SigS + +import Control.Arrow (arr, ) +import Control.Monad (liftM, liftM2, ) + +import qualified Data.StorableVector.Lazy as SVL +import Data.StorableVector.Lazy (ChunkSize, ) +import Foreign.Storable (Storable, ) + +import qualified Algebra.RealRing as RealRing + +import System.Random (Random, randomR, mkStdGen, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +rangeFromInt :: Random a => (a,a) -> Param.T Int a +rangeFromInt rng = + arr $ fst . randomR rng . mkStdGen + + +{-# INLINE checkSimilarityState #-} +checkSimilarityState :: + (RealRing.C a, Storable a, + LLVM.MakeValueTuple a av, + Rep.Memory av ap) => + a -> + (SVL.Vector a -> SVL.Vector a) -> + SigP.T p av -> + (p -> SigS.T a) -> + IO (ChunkSize -> p -> Bool) +checkSimilarityState tol limit gen0 sig1 = + let render sig = + fmap + (\func chunkSize -> + limit . func chunkSize) $ + SigP.runChunky sig + in liftM + (\sig0 chunkSize p -> + SigS.foldR (&&) True $ + -- dangerous, since shortened signals would be tolerated + SigS.zipWith (\x y -> abs(x-y) < tol) + (SigS.fromStorableSignal (sig0 chunkSize p)) + (sig1 p)) + (render gen0) + + +{-# INLINE checkSimilarity #-} +checkSimilarity :: + (RealRing.C b, Storable b, + Storable a, + LLVM.MakeValueTuple a av, Rep.Memory av ap) => + b -> + (SVL.Vector a -> SVL.Vector b) -> + SigP.T p av -> SigP.T p av -> + IO (ChunkSize -> p -> Bool) +checkSimilarity tol limit gen0 gen1 = + let render sig = + fmap + (\func chunkSize -> + limit . func chunkSize) $ + SigP.runChunky sig + in liftM2 + (\sig0 sig1 chunkSize p -> + SigS.foldR (&&) True $ + -- dangerous, since shortened signals would be tolerated + SigS.zipWith (\x y -> abs(x-y) < tol) + (SigS.fromStorableSignal (sig0 chunkSize p)) + (SigS.fromStorableSignal (sig1 chunkSize p))) + (render gen0) + (render gen1) + + +checkEquality :: + (Eq a, Storable a, + LLVM.MakeValueTuple a av, + Rep.Memory av ap) => + (SVL.Vector a -> SVL.Vector a) -> + SigP.T p av -> SigP.T p av -> + IO (ChunkSize -> p -> Bool) +checkEquality limit gen0 gen1 = + let render sig = + fmap + (\func chunkSize -> + limit . func chunkSize) $ + SigP.runChunky sig + in liftM2 + (\sig0 sig1 chunkSize p -> + sig0 chunkSize p == sig1 chunkSize p) + (render gen0) + (render gen1) diff --git a/synthesizer-llvm.cabal b/synthesizer-llvm.cabal new file mode 100644 --- /dev/null +++ b/synthesizer-llvm.cabal @@ -0,0 +1,153 @@ +Name: synthesizer-llvm +Version: 0.2 +License: GPL +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://www.haskell.org/haskellwiki/Synthesizer +Package-URL: http://code.haskell.org/synthesizer/llvm/ +Category: Sound, Music +Synopsis: Efficient signal processing using runtime compilation +Description: + Efficient signal processing + using runtime compilation and vector instructions. + It uses LLVM library, thus it is not bound to a specific CPU. + If you compile with Cabal flag @buildExamples@ + you get the executable @synthi-llvm-server@, + that is a realtime software synthesizer + that receives MIDI events via ALSA + and in response plays some tones via ALSA. +Stability: Experimental +Tested-With: GHC==6.10.4 +Cabal-Version: >=1.2 +Build-Type: Simple + +Flag buildExamples + description: Build example executables + default: False + +Flag buildTests + description: Build test suite + default: False + +Library + Build-Depends: + llvm-extra >= 0.1 && <0.2, + -- llvm must be imported with restrictive version bounds, + -- because we import implicitly and unqualified + llvm-ht >=0.7.0 && <0.7.1, + type-level >=0.2.3 && <0.3, + functional-arrow >=0.0 && <0.1, + HList >=0.2 && <0.3, + synthesizer-core >=0.4 && <0.5, + -- for ALSA.BendModulation + synthesizer-alsa >=0.3 && <0.4, + alsa-seq >=0.5 && <0.6, + alsa-pcm >=0.5 && <0.6, + midi >= 0.1.5 && <0.2, + storable-record >=0.0.2 && <0.1, + storable-tuple >=0.0.2 && <0.1, + sox >=0.2 && <0.3, + sample-frame-np >=0.0.1 && <0.1, + sample-frame >=0.0.1 && <0.1, + storablevector >=0.2.6 && <0.3, + numeric-prelude >=0.2 && <0.3, + non-negative >=0.1 && <0.2, + event-list >=0.1 && <0.2, + -- data-accessor >=0.1 && <0.2, + random >= 1.0 && < 1.1, + containers >=0.1 && <0.4, + transformers >=0.2 && <0.3, + utility-ht >=0.0.1 && <0.1 + + Build-Depends: + -- base-4 needed for Control.Category + base >= 4 && <5 + + GHC-Options: -Wall + Hs-source-dirs: src + Exposed-Modules: + Synthesizer.LLVM.Simple.Signal + Synthesizer.LLVM.Simple.Value + Synthesizer.LLVM.Simple.Vanilla + Synthesizer.LLVM.Parameterized.Signal + Synthesizer.LLVM.Parameterized.SignalPacked + Synthesizer.LLVM.Parameterized.Value + Synthesizer.LLVM.Parameter + Synthesizer.LLVM.Storable.Signal + Synthesizer.LLVM.Causal.Process + Synthesizer.LLVM.CausalParameterized.Process + Synthesizer.LLVM.CausalParameterized.ProcessPacked + Synthesizer.LLVM.CausalParameterized.Controlled + Synthesizer.LLVM.CausalParameterized.ControlledPacked + Synthesizer.LLVM.Filter.Allpass + Synthesizer.LLVM.Filter.Butterworth + Synthesizer.LLVM.Filter.Chebyshev + Synthesizer.LLVM.Filter.ComplexFirstOrder + Synthesizer.LLVM.Filter.ComplexFirstOrderPacked + Synthesizer.LLVM.Filter.FirstOrder + Synthesizer.LLVM.Filter.SecondOrder + Synthesizer.LLVM.Filter.SecondOrderPacked + Synthesizer.LLVM.Filter.SecondOrderCascade + Synthesizer.LLVM.Filter.Moog + Synthesizer.LLVM.Filter.Universal + Synthesizer.LLVM.Generator.Exponential2 + Synthesizer.LLVM.Sample + Synthesizer.LLVM.Frame.Stereo + Synthesizer.LLVM.Wave + Synthesizer.LLVM.Server.Common + Synthesizer.LLVM.Server.Packed.Test + Synthesizer.LLVM.Server.Packed.Run + Synthesizer.LLVM.Server.Packed.Instrument + Synthesizer.LLVM.Server.Scalar.Test + Synthesizer.LLVM.Server.Scalar.Run + Synthesizer.LLVM.Server.Scalar.Instrument + -- may be moved to a separate package + Synthesizer.LLVM.ALSA.MIDI + + Other-Modules: + Synthesizer.LLVM.Random + Synthesizer.LLVM.EventIterator + Synthesizer.LLVM.Storable.ChunkIterator + Synthesizer.LLVM.Storable.LazySizeIterator + Synthesizer.LLVM.Parameterized.SignalPrivate + Synthesizer.LLVM.CausalParameterized.ProcessPrivate + -- belongs to Synthesizer.LLVM.ALSA.MIDI + Synthesizer.LLVM.ALSA.BendModulation + -- may be moved to llvm-extra + Synthesizer.LLVM.Execution + +Executable synthi-llvm-example + If !flag(buildExamples) + Buildable: False + GHC-Options: -Wall + Hs-Source-Dirs: src + Main-Is: Synthesizer/LLVM/Test.hs + +Executable synthi-llvm-server + If !flag(buildExamples) + Buildable: False + GHC-Options: -Wall -threaded + Hs-Source-Dirs: src + Main-Is: Synthesizer/LLVM/Server.hs + Other-Modules: + Synthesizer.LLVM.Server.Packed.Instrument + Synthesizer.LLVM.Server.Packed.Test + Synthesizer.LLVM.Server.Packed.Run + Synthesizer.LLVM.Server.Scalar.Instrument + Synthesizer.LLVM.Server.Scalar.Test + Synthesizer.LLVM.Server.Scalar.Run + Synthesizer.LLVM.Server.Common + +Executable synthi-llvm-test + If flag(buildTests) + Build-Depends: QuickCheck >= 1 && <3 + Else + Buildable: False + GHC-Options: -Wall + Hs-Source-Dirs: src + Main-Is: Test/Main.hs + Other-Modules: + Test.Synthesizer.LLVM.Filter + Test.Synthesizer.LLVM.Packed + Test.Synthesizer.LLVM.Utility