LAC2011.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Synthesizer.LLVM.LAC2011 where

import Synthesizer.LLVM.ExampleUtility

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.Causal.Controlled as Ctrl
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified Synthesizer.LLVM.Generator.Render as Render
import qualified Synthesizer.LLVM.Generator.SignalPacked as GenP
import qualified Synthesizer.LLVM.Generator.Signal as Gen
import qualified Synthesizer.LLVM.Storable.Signal as SigStL
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Frame as Frame
import qualified Synthesizer.LLVM.Wave as Wave

import qualified LLVM.DSL.Expression as Expr
import LLVM.DSL.Expression (Exp)

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.Nice.Vector as NiceVector
import qualified LLVM.Extra.Nice.Value as NiceValue
import qualified LLVM.Extra.Tuple as Tuple

import qualified LLVM.Core as LLVM

import qualified Type.Data.Num.Decimal as TypeNum
import Type.Data.Num.Decimal (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8)

import Synthesizer.LLVM.Causal.Process (($<), ($*), ($*#))

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 Control.Functor.HT (void)
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.ALSA.Storable.Play as Play

import Data.List (genericLength)
import System.Random (randomRs, mkStdGen)

import qualified System.IO as IO

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


playStereo :: Gen.T (Stereo.T (NiceValue.T Float)) -> IO ()
playStereo sig =
   playStereoStream . ($ SVL.chunkSize 100000) =<<
   Render.run (fmap Stereo.niceValue sig)

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

playMono :: Gen.Nice Float -> IO ()
playMono sig  =  playMonoStream . ($ SVL.chunkSize 100000) =<< Render.run sig

playMonoPacked :: Gen.T (NiceValue.T (Serial.T D4 Float)) -> IO ()
playMonoPacked =
   playMonoStream .
   SigStL.unpack .
   ($ SVL.chunkSize 100000) <=<
   Render.run

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


{-
play ::
   (C.MakeValueTuple y, Tuple.ValueOf y ~ a, Memory.C a struct) =>
   Gen.Nice 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 =
   void . SoxPlay.simple SVL.hPut SoxOption.none sampleRate


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

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))


pingParam :: IO (Float -> SVL.Vector Float)
pingParam =
   fmap ($ SVL.chunkSize 1024) $
   Render.run $ \freq ->
   Gen.exponential2 (second 0.3) 1 * Gen.osci Wave.triangle 0 freq

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) $
   Render.run $ \(amp,freq) ->
   Gen.exponential2 (second 0.3) amp * Gen.osci Wave.triangle 0 freq

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 :: Gen.Nice Float -> Gen.Nice Float
retard xs =
   Causal.frequencyModulationLinear xs .
   Causal.map Field.recip $*
   (1 + Gen.rampInf (second 10))

playRetarded :: IO ()
playRetarded = do
   mel <- melody
   ret <- Render.run retard
   playMonoStream $ ret (SVL.chunkSize 10000) mel



pingGen :: Gen.Nice Float
pingGen =
   Gen.exponential2 (second 0.5) 0.7 *
   Gen.osci Wave.triangle 0 (hertz 440)

delay :: IO ()
delay =
   playMono $
      pingGen + 0.7 * (Causal.delay 0 (intSecond 0.5) $* pingGen)

delayArrow :: IO ()
delayArrow =
   playMono
      ((id + 0.7 * Causal.delay 0 (intSecond 0.5)) $* pingGen)

comb :: IO ()
comb =
   playMono $
      (Causal.loopZero
          (id  &&&  0.7 * Causal.delay 0 (intSecond 0.5)
             <<< Causal.mix) $*
       pingGen)


lfoSine :: Exp Float -> Gen.T (Moog.Parameter D8 (NiceValue.T Float))
lfoSine reduct =
   Causal.map (Moog.parameter d8 30 . (hertz 700 *) . (2**))
   $*
   Gen.osci Wave.sine 0 (reduct * hertz 0.1)

filterSweep :: IO ()
filterSweep =
   playMono $
      (Ctrl.processCtrlRate 128 lfoSine $* Gen.noise 0 (recip $ hertz 3.5e6))


pingPacked :: IO ()
pingPacked =
   playMonoPacked $
      GenP.exponential2 (second 1) 1 * GenP.osci Wave.triangle 0 (hertz 440)