Experiment.hs

module Synthesizer.LLVM.Experiment where

import Synthesizer.LLVM.ExampleUtility

import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1
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.Source as Source
import qualified Synthesizer.LLVM.Generator.Signal as Sig
import qualified Synthesizer.LLVM.Wave as Wave
import Synthesizer.LLVM.Causal.Process (($<), ($*), ($<#))

import qualified LLVM.DSL.Expression as Expr
import LLVM.DSL.Expression (Exp, (==*), (<=*), (.&.*))

import qualified LLVM.Extra.Nice.Value as NiceValue

import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core

import Control.Arrow ((^<<), (<<^))
import Control.Category ((.))

import qualified Data.StorableVector as SV

import Data.Tuple.HT (mapFst)
import Data.Word (Word8)
import System.Random (randomRs, randoms, mkStdGen)

import NumericPrelude.Numeric (fromIntegral, sum, (+), (-), (/), (*))
import Prelude hiding (fst, snd, id, (.), fromIntegral, sum, (+), (-), (/), (*))



phaserSawSymmetric :: Exp Float -> Sig.T (NiceValue.T Float)
phaserSawSymmetric freq =
   (0.3*) $
   Sig.osci Wave.saw 0.0 (freq*1.003) +
   Sig.osci Wave.saw 0.2 (freq*0.997) +
   Sig.osci Wave.saw 0.1 freq

phaserSawAsymmetric :: Exp Float -> Sig.T (NiceValue.T Float)
phaserSawAsymmetric freq =
   (0.3*) $
   Sig.osci Wave.saw 0.0 (freq*1.001) +
   Sig.osci Wave.saw 0.2 (freq*1.003) +
   Sig.osci Wave.saw 0.1 (freq*0.996)

sigZipWith3 ::
   (Expr.Aggregate ae a) =>
   (Expr.Aggregate be b) =>
   (Expr.Aggregate ce c) =>
   (Expr.Aggregate de d) =>
   (ae -> be -> ce -> de) ->
   Sig.T a -> Sig.T b -> Sig.T c -> Sig.T d
sigZipWith3 f sa sb sc =
   Causal.map (\(a,(b,c)) -> f a b c) $< sa $< sb $* sc

phaserSawMinMax :: Exp Float -> Sig.T (NiceValue.T Float)
phaserSawMinMax freq =
   sigZipWith3
      (\a b c -> (Expr.min a (Expr.min b c) + Expr.max a (Expr.max b c)) / 2)
      (Sig.osci Wave.saw 0.0 (freq*1.001))
      (Sig.osci Wave.saw 0.2 (freq*1.003))
      (Sig.osci Wave.saw 0.1 (freq*0.996))

median3 ::
   (NiceValue.Comparison a, NiceValue.Select a) =>
   Exp a -> Exp a -> Exp a -> Exp a
median3 a b c =
   Expr.with (a<=*b) $ \a_le_b ->
   Expr.with (b<=*c) $ \b_le_c ->
   Expr.with (a<=*c) $ \a_le_c ->
   Expr.select a_le_b
      (Expr.select b_le_c b (Expr.select a_le_c c a))
      (Expr.select a_le_c a (Expr.select b_le_c c b))

phaserSawMedian :: Exp Float -> Sig.T (NiceValue.T Float)
phaserSawMedian freq =
   sigZipWith3 median3
      (Sig.osci Wave.saw 0.0 (freq*1.0001))
      (Sig.osci Wave.saw 0.2 (freq*1.0003))
      (Sig.osci Wave.saw 0.1 (freq*0.9996))

phaserSineMedian :: Exp Float -> Sig.T (NiceValue.T Float)
phaserSineMedian freq =
   sigZipWith3 median3
      (Sig.osci Wave.approxSine4 0.0 (freq*1.0001))
      (Sig.osci Wave.approxSine4 0.2 (freq*1.0003))
      (Sig.osci Wave.approxSine4 0.1 (freq*0.9996))


harmonicsTremolo0 :: Exp Float -> Sig.T (NiceValue.T Float)
harmonicsTremolo0 freq =
   0.5 *
   sum (map (\k ->
               recip (fromInteger k) *
               Sig.osci Wave.sine 0 (fromInteger k * freq))
            [1..10])

harmonicsTremolo1 :: Exp Float -> Sig.T (NiceValue.T Float)
harmonicsTremolo1 freq =
   0.5 *
   sum
      (zipWith3
         (\k lfoPhase lfoFreq ->
            recip (fromInteger k) *
            Sig.osci Wave.sine (Expr.cons lfoPhase)
               (Expr.cons (fromInteger k * lfoFreq)) *
            Sig.osci Wave.sine 0 (fromInteger k * freq))
         [1..10]
{-
         (repeat 0)
         (repeat 1e-5))
-}
         (randomRs (0,1) (mkStdGen 42))
         (let f = 1e-5 in randomRs (0.5*f,3*f) (mkStdGen 23)))

param1 :: NiceValue.T (Filt1.Parameter a) -> Filt1.Parameter (NiceValue.T a)
param1 = NiceValue.decompose (Filt1Core.Parameter NiceValue.atom)

param2 ::
   NiceValue.T (UniFilter.Parameter a) -> UniFilter.Parameter (NiceValue.T a)
param2 = NiceValue.decompose UniFilter.parameterAtoms

harmonicsTremolo2 :: Exp Float -> Sig.T (NiceValue.T Float)
harmonicsTremolo2 freq =
   100 *
   sum
      (zipWith
         (\k seed ->
            recip (fromInteger k) *
            ((Filt1.lowpassCausal <<^ mapFst param1)
               $<# Filt1.parameter (1e-6 * fromInteger k)
               $* Sig.noise (Expr.cons seed) 1) *
            Sig.osci Wave.sine 0 (fromInteger k * freq))
         [1..10]
         (randoms (mkStdGen 23)))

harmonicsTremolo :: Exp Float -> Sig.T (NiceValue.T Float)
harmonicsTremolo freq =
   4 *
   sum
      (zipWith
         (\k seed ->
            recip (fromInteger k) *
            ((UniFilter.lowpass ^<< Ctrl.process <<^ mapFst param2)
               -- lower resonance frequency seems to exceed Float precision
               $<# UniFilter.parameter 10 (0.5e-4 * fromInteger k)
               $* Sig.noise (Expr.cons seed) 1) *
            Sig.osci Wave.sine 0 (fromInteger k * freq))
         [1..10]
         (randoms (mkStdGen 23)))

bandpassHarmonics :: Exp Float -> Sig.T (NiceValue.T Float)
bandpassHarmonics freq =
   0.02 *
   sum
      (zipWith
         (\k seed ->
            recip (fromInteger k) *
            ((UniFilter.lowpass ^<< Ctrl.process)
               $< Sig.constant
                     (UniFilter.parameter 1000
                        (fromInteger k * freq :: Exp Float))
               $* Sig.noise (Expr.cons seed) 1))
         [1..10]
         (randoms (mkStdGen 23)))


asciiWave0 :: Exp Float -> Sig.T (NiceValue.T Float)
asciiWave0 freq =
   let char :: Exp Word8
       char = Expr.cons $ fromIntegral $ fromEnum 'Y' in
   let wave t =
         Expr.select
            (Expr.shr char (Expr.floorToInt (t*8)) .&.* 1 ==* 0) (-1) 1 in
   Sig.osci (Expr.unliftM1 wave) 0 freq

asciiWave1 :: Exp Float -> Sig.T (NiceValue.T Float)
asciiWave1 freq =
   let char :: Exp Word8
       char = Expr.cons $ fromIntegral $ fromEnum 'Y' in
   let wave t =
         Expr.select
            (Expr.shr char (Expr.floorToInt (t*8)) .&.* 1 ==* 0) (-1) 1 in
   (0.7 *) $
   ((Filt1.highpassCausal <<^ mapFst param1)
      $<# Filt1.parameter (1e-4)
      $* Sig.osci (Expr.unliftM1 wave) 0 freq)

asciiWavePulse ::
   Exp (Source.StorableVector Word8) ->
   Exp Float -> Sig.T (NiceValue.T Float)
asciiWavePulse str freq =
   let wave char t =
         Expr.select
            (Expr.shr char (Expr.floorToInt (t*8)) .&.* 1 ==* 0) (-1) 1 in
   (0.5 *) $
   ((Filt1.highpassCausal <<^ mapFst param1)
      $<# Filt1.parameter (1e-3)
      $* (Causal.shapeModOsci (Expr.unliftM2 wave)
            $< Sig.interpolateConstant
                  (10000::Exp Float) (Source.storableVector str)
            $* Sig.constant (Expr.zero, freq)))

asciiWaveSaw ::
   Exp (Source.StorableVector Word8) ->
   Exp Float -> Sig.T (NiceValue.T Float)
asciiWaveSaw str freq =
   let wave char t =
         Expr.with (8*t) $ \t8 ->
         Expr.select
            (Expr.shr char (Expr.floorToInt t8) .&.* 1 ==* 0)
            (2 * Expr.fraction t8 - 1)
            (1 - 2 * Expr.fraction t8) in
   Causal.shapeModOsci (Expr.unliftM2 wave)
      $< Sig.interpolateConstant
            (10000::Exp Float) (Source.storableVector str)
      $* Sig.constant (Expr.zero, freq)


render :: Sig.T (NiceValue.T Float) -> IO ()
render sig =
   SV.writeFile "experiment.f32" . asMono .  ($ 1000000) =<<
   Render.run sig


main :: IO ()
main =
   case fromInteger 4 :: Integer of
      0 -> render (phaserSawMedian 0.01)
      1 -> render (harmonicsTremolo 0.01)
      2 -> render (bandpassHarmonics 0.01)
      3 -> render (asciiWave1 0.01)
      _4 ->
         SV.writeFile "experiment.f32" . asMono
            . ($ Render.buffer
                     (SV.pack (map (fromIntegral.fromEnum) "Hello World!")))
            . ($ 1000000)
         =<<
         Render.run (flip asciiWaveSaw 0.01)