LAC2011.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Synthesizer.LLVM.LAC2011 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 Gen
import qualified Synthesizer.LLVM.Storable.Signal as SigStL
import qualified Synthesizer.LLVM.Frame as Frame
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.Memory as Memory
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Class as C
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, d0, d1, d2, d3, d4, d5, d6, d7, d8, )
import qualified Data.TypeLevel.Num as TypeNum

import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS
import qualified Synthesizer.LLVM.Parameterized.Signal as GenP
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 Control.Monad ((<=<), )
import Control.Applicative (liftA2, pure, )
import Data.Traversable (traverse, )

import Foreign.Storable (Storable, )
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 Synthesizer.LLVM.Frame.Stereo as Stereo

import qualified Sound.Sox.Option.Format as SoxOption
import qualified Sound.Sox.Frame as SoxFrame
import qualified Sound.Sox.Play as SoxPlay

import qualified Sound.ALSA.PCM as ALSA
import qualified Synthesizer.Storable.ALSA.Play as Play

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 qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive

import NumericPrelude.Numeric
import NumericPrelude.Base hiding (fst, snd, id, (.), )
import qualified NumericPrelude.Base 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 :: Gen.T (Stereo.T (Value Float)) -> IO ()
playStereo =
   playStereoStream .
   Gen.renderChunky (SVL.chunkSize 100000)

playStereoStream :: SVL.Vector (Stereo.T Float) -> IO ()
playStereoStream = playStreamSox

playMono :: Gen.T (Value Float) -> IO ()
playMono =
   playMonoStream .
   Gen.renderChunky (SVL.chunkSize 100000)

playMonoParam :: GenP.T () (Value Float) -> IO ()
playMonoParam =
   playMonoStream .
   ($ ()) .
   ($ SVL.chunkSize 100000) <=<
   GenP.runChunky

playMonoPacked :: GenP.T () (Value (Vector D4 Float)) -> IO ()
playMonoPacked =
   playMonoStream .
   SigStL.unpack .
   ($ ()) .
   ($ SVL.chunkSize 100000) <=<
   GenP.runChunky

playMonoStream :: SVL.Vector Float -> IO ()
playMonoStream = playStreamSox


{-
play ::
   (C.MakeValueTuple y a, Memory.C a struct) =>
   Gen.T a -> IO ()
play =
   playStreamSox .
   Gen.renderChunky (SVL.chunkSize 100000)
-}

playStreamALSA ::
   (Additive.C y, ALSA.SampleFmt y) =>
   SVL.Vector y -> IO ()
playStreamALSA =
   Play.auto (Play.makeSink Play.defaultDevice (0.05::Double) sampleRate)

-- reacts faster to CTRL-C
playStreamSox ::
   (Storable y, SoxFrame.C y) =>
   SVL.Vector y -> IO ()
playStreamSox =
   fmap (const ()) .
   SoxPlay.simple SVL.hPut SoxOption.none 44100


sampleRate :: Ring.C a => a
sampleRate = 44100

intSecond :: Ring.C a => Float -> a
intSecond t = fromInteger $ round $ t * sampleRate

second :: Field.C a => a -> a
second t = t * sampleRate

hertz :: Field.C a => a -> a
hertz f = f / sampleRate

{-
second :: Float -> Param.T p Float
second t = return (t * sampleRate)

hertz :: Float -> Param.T p Float
hertz f = return (f / sampleRate)
-}

sine :: IO ()
sine =
   playMono (0.99 * Gen.osci Wave.sine 0 (hertz 440))

ping :: IO ()
ping =
   playMono (Gen.exponential2 (second 1) 1 * Gen.osci Wave.triangle 0 (hertz 440))

tremolo :: IO ()
tremolo =
   playMono (Gen.osci Wave.sine 0 (hertz 0.3) * Gen.osci Wave.triangle 0 (hertz 440))


stereo :: IO ()
stereo =
   playStereo (liftA2 Stereo.cons (Gen.osci Wave.triangle 0 (hertz 439)) (Gen.osci Wave.triangle 0 (hertz 441)))

stereoFancy :: IO ()
stereoFancy =
   playStereo (traverse (Gen.osci Wave.triangle 0 . hertz) (Stereo.cons 439 441))


fst :: Arrow arrow => arrow (a,b) a
fst = arr P.fst

snd :: Arrow arrow => arrow (a,b) b
snd = arr P.snd


pingParam :: IO (Float -> SVL.Vector Float)
pingParam =
   fmap ($ SVL.chunkSize 1024) $
   GenP.runChunky $
   GenP.exponential2 (second 0.3) 1 * GenP.osciSimple Wave.triangle 0 id

playPingParam :: IO ()
playPingParam = do
   png <- pingParam
   playMonoStream (SVL.take (intSecond 1) $ png (hertz 880))

melody :: IO (SVL.Vector Float)
melody = do
   png <- pingParam
   return $ SVL.concat $ map (SVL.take (intSecond 0.2) . png . hertz) $ cycle [440, 550, 660, 880]

playMelody :: IO ()
playMelody = do
   mel <- melody
   playMonoStream mel

pingParam2 :: IO ((Float, Float) -> SVL.Vector Float)
pingParam2 =
   fmap ($ SVL.chunkSize 1024) $
   GenP.runChunky $
   GenP.exponential2 (second 0.3) fst * GenP.osciSimple Wave.triangle 0 snd

playMelody2 :: IO ()
playMelody2 = do
   png <- pingParam2
   playMonoStream $ SVL.concat $ map (SVL.take (intSecond 0.2) . png) $ zip (map sin $ [0,0.1..]) (cycle $ map hertz [440, 550, 660, 880])


retard :: GenP.T p (Value Float) -> GenP.T p (Value Float)
retard xs =
   CausalP.frequencyModulationLinear xs .
   CausalP.mapSimple (A.fdiv (LLVM.valueOf 1)) $*
   GenP.rampCore (1 / second 10) 1

playRetarded :: IO ()
playRetarded = do
   mel <- melody
   playMonoParam $ retard $ GenP.fromStorableVectorLazy $ pure $ mel



pingGen :: GenP.T p (Value Float)
pingGen =
   GenP.exponential2 (second 0.5) 0.7 *
   GenP.osciSimple Wave.triangle 0 (hertz 440)

zerop :: Param.T p Float
zerop = pure zero

delayp :: Param.T p Int -> CausalP.T p (Value Float) (Value Float)
delayp = CausalP.delay zerop

delay :: IO ()
delay =
   playMonoParam $
      pingGen + 0.7 * (delayp (intSecond 0.5) $* pingGen)

delayArrow :: IO ()
delayArrow =
   playMonoParam
      ((id + 0.7 * delayp (intSecond 0.5)) $* pingGen)

comb :: IO ()
comb =
   playMonoParam $
      (CausalP.loop zerop
          (id  &&&  0.7 * delayp (intSecond 0.5)
             <<< CausalP.mix) $*
       pingGen)


lfoSine ::
   Param.T p Float ->
   GenP.T p (Moog.Parameter D8 (Value Float))
lfoSine reduct =
   CausalP.mapSimple (Moog.parameter d8 (valueOf (30::Float))) .
   CausalP.mapExponential 2 (hertz 700) $*
   GenP.osciSimple Wave.sine 0 (reduct * hertz 0.1)

filterSweep :: IO ()
filterSweep =
   playMonoParam $
      (0.2 * CtrlP.processCtrlRate 128 lfoSine
       $* GenP.noise 0 0.3)


pingPacked :: IO ()
pingPacked =
   playMonoPacked (GenPS.exponential2 (second 1) 1 * GenPS.osciSimple Wave.triangle 0 (hertz 440))



{-
Module can be loaded into GHCi only when synthesizer-llvm was installed with
$ cabal install --enable-shared

In contrast to that, you have to install with
$ cabal install -fbuildTests -fbuildExamples --enable-shared --disable-library-profiling --ghc-option=-dynamic
for build the executables.
But then GHCi complains:

$ ghci
GHCi, version 6.12.3: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
Loading package ffi-1.0 ... linking ... done.
[1 of 1] Compiling Main             ( src/Synthesizer/LLVM/Test.hs, interpreted )

src/Synthesizer/LLVM/Test.hs:4:0:
    Bad interface file: /home/thielema/.cabal/lib/synthesizer-llvm-0.3/ghc-6.12.3/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hi
        mismatched interface file ways (wanted "", got "dyn")
Failed, modules loaded: none.
-}