├── init-sandbox.sh ├── src ├── Types.hs ├── WebAudio.hs ├── Cochlea.hs └── Arithmetic.hs ├── deploy.sh ├── .gitignore ├── static ├── default.css └── index.html ├── .gitmodules ├── overrides.nix ├── LICENSE ├── cochleagram.cabal ├── README.md └── exec └── Main.hs /init-sandbox.sh: -------------------------------------------------------------------------------- 1 | cabal sandbox init 2 | cabal sandbox add-source deps/reflex-dom 3 | cabal sandbox add-source deps/reflex-dom-contrib 4 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | data CochlearFilter = Filt 4 | { cfFreq :: Double 5 | , cfAmpl :: Double 6 | } deriving (Show) 7 | 8 | 9 | -------------------------------------------------------------------------------- /deploy.sh: -------------------------------------------------------------------------------- 1 | ./static.sh 2 | cp ./static/* ./dist/build/cochleagram/cochleagram.jsexe/ 3 | cd dist/build/cochleagram/cochleagram.jsexe && git add *.js *.stats *.css *.html && git commit -m "build" && git push origin gh-pages 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | Setup.hs 18 | -------------------------------------------------------------------------------- /static/default.css: -------------------------------------------------------------------------------- 1 | .expr-good { 2 | box-shadow: 0px 0px 5px hsla(100,50%,50%,1); 3 | } 4 | 5 | body { 6 | display: flex; 7 | } 8 | 9 | .controls { 10 | padding: 20px; 11 | } 12 | 13 | .coch-display { 14 | background-color: rgba(0,0,0,1); 15 | } 16 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "deps/reflex-dom"] 2 | path = deps/reflex-dom 3 | url = http://github.com/imalsogreg/reflex-dom 4 | [submodule "dist/build/cochleagram/cochleagram.jsexe"] 5 | path = dist/build/cochleagram/cochleagram.jsexe 6 | url = git@github.com:imalsogreg/cochleagram.git 7 | ignore = all 8 | [submodule "deps/reflex-dom-contrib"] 9 | path = deps/reflex-dom-contrib 10 | url = https://github.com/reflex-frp/reflex-dom-contrib 11 | -------------------------------------------------------------------------------- /static/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /overrides.nix: -------------------------------------------------------------------------------- 1 | { reflex-platform, ... }: 2 | let 3 | 4 | nixpkgs = (import {}); 5 | dontCheck = nixpkgs.pkgs.haskell.lib.dontCheck; 6 | cabal2nixResult = reflex-platform.cabal2nixResult; 7 | 8 | in 9 | reflex-platform.ghcjs.override { 10 | overrides = self: super: { 11 | reflex-dom-contrib = dontCheck (self.callPackage (cabal2nixResult deps/reflex-dom-contrib) {}); 12 | # servant = dontCheck (self.callPackage (cabal2nixResult deps/servant/servant) {}); 13 | # http-api-data = dontCheck (self.callPackage (cabal2nixResult deps/http-api-data) {}); 14 | }; 15 | } 16 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Greg Hale 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Greg Hale nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /cochleagram.cabal: -------------------------------------------------------------------------------- 1 | -- Initial cochleagram.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: cochleagram 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Greg Hale 11 | maintainer: imalsogreg@gmail.com 12 | -- copyright: 13 | category: Web 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: WebAudio 20 | Arithmetic 21 | Cochlea 22 | Types 23 | -- other-modules: 24 | -- other-extensions: 25 | build-depends: base >=4.8 && <4.13, 26 | 27 | arb-fft, 28 | containers, 29 | data-default, 30 | text, 31 | jsaddle, 32 | ghcjs-dom, 33 | parsec, 34 | pretty, 35 | reflex, 36 | reflex-dom, 37 | -- reflex-dom-contrib, 38 | time, 39 | transformers 40 | hs-source-dirs: src 41 | default-language: Haskell2010 42 | 43 | if impl(ghcjs) 44 | build-depends: 45 | ghcjs-base 46 | 47 | executable cochleagram 48 | main-is: Main.hs 49 | hs-source-dirs: exec 50 | default-language: Haskell2010 51 | ghcjs-options: -DGHCJS_BROWSER 52 | build-depends: base, 53 | -- arb-fft, 54 | containers, 55 | cochleagram, 56 | data-default, 57 | jsaddle, 58 | ghcjs-dom, 59 | pretty, 60 | reflex, 61 | reflex-dom, 62 | reflex-dom-core, 63 | reflex-dom-contrib, 64 | text, 65 | time, 66 | transformers 67 | if impl(ghcjs) 68 | build-depends: 69 | ghcjs-base -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Cochleagram 2 | ----------- 3 | 4 | Tools for psychoacoustics 5 | 6 | ## Installation 7 | 8 | 1. `git clone git@github.com:CBMM/cochleagram && cd cochleagram` 9 | 1. Install [Haskell](https://www.haskell.org/downloads#minimal) 10 | 1. Install [ghcjs](https://github.com/ghcjs/ghcjs#quick-start) 11 | 1. `git submodule update --init --recursive` 12 | 1. `./init-sandbox.sh` 13 | 1. `cabal configure --ghcjs` 14 | 1. `cabal install --only-dep` 15 | 1. `cabal install` 16 | 17 | ## Running 18 | 19 | `cochleagram` uses your computer's microphone, so the browser protects you by making sure `cochleagram` only runs over a secured connection. This makes it a little bit tough to test your changes `cochleagram` on your local computer - you need an SSL-enabled server. 20 | 21 | [http-server](https://www.npmjs.com/package/http-server) is a quick way to do this. 22 | 23 | You'll need to [make a self-signed certificate](http://stackoverflow.com/questions/10175812/how-to-create-a-self-signed-certificate-with-openssl). 24 | 25 | Then point your server to the cert and key files, from the `cochleagram` compiler output directory: 26 | 27 | ``` 28 | cd dist/build/cochleagram/cochleagram.jsexe/ 29 | http-server -S -K ~/key.pem -C ~/cert.pem 30 | ``` 31 | 32 | At this point you can reach the files via the browser at `https://localhost:8080` 33 | 34 | If this gives you trouble please feel free to get in touch. 35 | 36 | ## Brainstorming - Hack with us! 37 | 38 | ### Teaching & demos 39 | 40 | - Show basic principles 41 | (filters, power spectrum, spectrograms, cochleagrams) 42 | 43 | - Use data from computer mic (real time visualization) 44 | 45 | - Use data from file on the web (zoomable visualization) 46 | 47 | - Tune parameters 48 | 49 | - Demos usable after the talk is over 50 | 51 | ### Researchy demos 52 | 53 | - Template matching in spectrogram 54 | 55 | - Auditory scene / texture / cepstra analysis 56 | 57 | - Sound generation & playback from scene statistics 58 | 59 | - Stereo source localization demos (too ambitious)? 60 | 61 | 62 | ### Goals, Themes 63 | 64 | - Separate the sound exploration from grungy coding details 65 | 66 | - Abstract the most common tasks into nice libraries 67 | 68 | - Push science findings toward demo-level teaching tools 69 | 70 | ### Related work & Inspiration 71 | 72 | - [Web Audio Spectrogram](https://webaudiodemos.appspot.com/input/index.html) RT spectrogram & distortion demo 73 | 74 | - [Web Audio Demos](http://webaudiodemos.appspot.com/) Many demos of the web audio api 75 | 76 | - [Web Audio API](https://developer.mozilla.org/en-US/docs/Web/API/Web_Audio_API) Mozilla Dev Network. Browser-based audio analysis & production. 77 | 78 | - [VisPy](https://www.youtube.com/watch?v=_3YoaeoiIFI) Luke Campagnola (Paul Manis Lab, Allen Inst.) RT spectrograms & general data vis 79 | 80 | - [MathBox](https://acko.net/blog/mathbox2/) Web math visualization 81 | 82 | - [Pandoc](http://pandoc.org) Generate [slides](http://web.mit.edu/greghale/Public/thesis/build/index.html) from [markdown](https://github.com/imalsogreg/RetroProject/blob/master/thesis/thesis.org) 83 | 84 | - [Explorable Explanations](http://explorableexplanations.com/) 85 | 86 | - [Neurons](http://ncase.me/neurons/) Nicky Case 87 | 88 | - [Parable of the Polygons](http://ncase.me/polygons/) Nicky Case 89 | 90 | ### Brainstorming session with McDermott lab 91 | 92 | - Demo walking through mechanism of generating cochleagram and connection to auditory system. Show traveling wave in basalar membrane. (Sam) 93 | 94 | - How hard to specify (how many dimensions) (how many sliders) for parametizing cochleagram. 95 | 96 | - Export figures 97 | 98 | - Javascript NN? 99 | 100 | - Other ways of visualizing sound than spectrograms? 101 | 102 | - Code box to change the signal? 103 | 104 | - Online training in some way or another (reverse correlation?) 105 | 106 | - Provide filters to the thing. 107 | 108 | - Sliding correlation matrix. 109 | 110 | 111 | -------------------------------------------------------------------------------- /src/WebAudio.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | {-# LANGUAGE ForeignFunctionInterface #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | #ifdef __GHCJS__ 6 | {-# LANGUAGE JavaScriptFFI #-} 7 | #endif 8 | 9 | module WebAudio where 10 | 11 | import GHCJS.Foreign 12 | import qualified JavaScript.Array as JA 13 | import qualified JavaScript.TypedArray as TA 14 | import JavaScript.TypedArray.Internal 15 | 16 | import GHCJS.Types 17 | 18 | import GHCJS.DOM.AnalyserNode 19 | import GHCJS.DOM.AudioBuffer hiding (getGain) 20 | import GHCJS.DOM.AudioBufferCallback 21 | import GHCJS.DOM.AudioContext 22 | import GHCJS.DOM.AudioDestinationNode 23 | import GHCJS.DOM.AudioListener 24 | import GHCJS.DOM.AudioNode 25 | import GHCJS.DOM.AudioParam 26 | import GHCJS.DOM.AudioProcessingEvent 27 | -- import GHCJS.DOM.AudioStreamTrack 28 | import GHCJS.DOM.AudioTrack 29 | import GHCJS.DOM.AudioTrackList 30 | import GHCJS.DOM.GainNode 31 | import GHCJS.DOM.OscillatorNode 32 | 33 | #ifdef __GHCJS__ 34 | import GHCJS.DOM.Enums (PFromJSVal (..), PToJSVal (..)) 35 | import GHCJS.Marshal 36 | import GHCJS.Marshal.Pure (pFromJSVal, pToJSVal) 37 | #endif 38 | 39 | import Control.Monad 40 | import Control.Monad.IO.Class 41 | import Data.Default 42 | import GHCJS.DOM 43 | import GHCJS.DOM.Types hiding (Event (..)) 44 | import qualified GHCJS.DOM.Types as D 45 | import GHCJS.Types 46 | import Reflex 47 | import Reflex.Dom hiding (setValue) 48 | import Reflex.Dom.Class 49 | 50 | data OscillatorNodeConfig t = OscillatorNodeConfig { 51 | _oscillatorNodeConfig_initialFrequency :: Double 52 | , _oscillatorNodeConfig_setFrequency :: Event t Double 53 | } 54 | 55 | oscillatorNode :: MonadWidget t m 56 | => AudioContext 57 | -> OscillatorNodeConfig t 58 | -> m OscillatorNode 59 | oscillatorNode ctx cfg = do 60 | osc <- createOscillator ctx 61 | p <- getFrequency osc 62 | performEvent_ (ffor (_oscillatorNodeConfig_setFrequency cfg)$ \f -> 63 | liftIO (setValue p (realToFrac f))) 64 | return osc 65 | 66 | data GainConfig t = GainConfig { 67 | _gainConfig_initialGain :: Double 68 | , _gainConfig_setGain :: Event t Double 69 | } 70 | 71 | gain :: MonadWidget t m 72 | => AudioContext 73 | -> GainConfig t 74 | -> m GainNode 75 | gain ctx cfg = do 76 | g <- createGain ctx 77 | p <- getGain g 78 | liftIO $ setValue p (realToFrac (_gainConfig_initialGain cfg)) 79 | performEvent_ (ffor (_gainConfig_setGain cfg)$ \f -> 80 | liftIO (setValue p (realToFrac f))) 81 | return g 82 | 83 | data AnalyserNodeConfig t = AnalyserNodeConfig { 84 | _analyserNodeConfig_initial_fftSize :: Int 85 | , _analyserNodeConfig_change_fftSize :: Event t Int 86 | , _analyserNodeConfig_initial_minDecibels :: Double 87 | , _analyserNodeConfig_change_minDecibels :: Event t Double 88 | , _analyserNodeConfig_initial_maxDecibels :: Double 89 | , _analyserNodeConfig_change_maxDecibels :: Event t Double 90 | , _analyserNodeConfig_initial_smoothingTimeConstant :: Double 91 | , _analyserNodeConfig_change_smoothingTimeConstant :: Event t Double 92 | } 93 | 94 | instance Reflex t => Default (AnalyserNodeConfig t) where 95 | def = AnalyserNodeConfig { 96 | _analyserNodeConfig_initial_fftSize = 1024 97 | , _analyserNodeConfig_change_fftSize = never 98 | , _analyserNodeConfig_initial_minDecibels = -100 99 | , _analyserNodeConfig_change_minDecibels = never 100 | , _analyserNodeConfig_initial_maxDecibels = -30 101 | , _analyserNodeConfig_change_maxDecibels = never 102 | , _analyserNodeConfig_initial_smoothingTimeConstant = 0.8 103 | , _analyserNodeConfig_change_smoothingTimeConstant = never 104 | } 105 | 106 | data Analyser t m = Analyser { 107 | 108 | _analyser_node :: AnalyserNode 109 | , _analyser_getFloatFrequencyData :: Event t () -> m (Event t D.Float32Array) 110 | , _analyser_getByteFrequencyData :: Event t () -> m (Event t D.Uint8Array) 111 | } 112 | 113 | analyserNode :: MonadWidget t m 114 | => AudioContext 115 | -> AnalyserNodeConfig t 116 | -> m (Analyser t m) 117 | analyserNode ctx 118 | (AnalyserNodeConfig nFFT dnFFT minDB dminDB maxDB dmaxDB tau dtau) = do 119 | a <- liftIO $ createAnalyser ctx 120 | 121 | setFftSize a (fromIntegral nFFT) 122 | performEvent (ffor dnFFT $ \n -> liftIO (setFftSize a (fromIntegral n))) 123 | 124 | setMinDecibels a minDB 125 | performEvent (ffor dminDB $ \m -> liftIO (setMinDecibels a m)) 126 | 127 | setMaxDecibels a maxDB 128 | performEvent (ffor dmaxDB $ \m -> liftIO (setMaxDecibels a m)) 129 | 130 | setSmoothingTimeConstant a tau 131 | performEvent (ffor dtau $ \t -> liftIO (setSmoothingTimeConstant a t)) 132 | 133 | return $ Analyser a (getFreqFloat a) (getFreqByte a) 134 | 135 | getFreqFloat :: MonadWidget t m 136 | => AnalyserNode 137 | -> Event t () -> m (Event t D.Float32Array) 138 | getFreqFloat a e = performEvent $ ffor e $ \_ -> liftIO $ do 139 | nSamp :: Int <- fromIntegral <$> getFrequencyBinCount a 140 | buffer <- js_createFloat32Array' nSamp 141 | getFloatFrequencyData a (Just buffer) 142 | return buffer 143 | 144 | getFreqByte :: MonadWidget t m 145 | => AnalyserNode 146 | -> Event t () -> m (Event t Uint8Array) 147 | getFreqByte a e = performEvent $ ffor e $ \_ -> liftIO $ do 148 | nSamp <- fromIntegral <$> getFrequencyBinCount a 149 | buffer <- js_createUint8Array' nSamp 150 | getByteFrequencyData a (Just buffer) 151 | return buffer 152 | 153 | foreign import javascript unsafe "new Float32Array($1)" 154 | js_createFloat32Array' :: Int -> IO Float32Array 155 | 156 | foreign import javascript unsafe "new Uint8Array($1)" 157 | js_createUint8Array' :: Int -> IO Uint8Array 158 | 159 | foreign import javascript unsafe "new Uint8ClampedArray($1)" 160 | js_createUint8ClampedArray' :: Int -> IO Uint8ClampedArray 161 | 162 | foreign import javascript unsafe "($1).length" 163 | js_lengthUint8ClampedArray' :: Uint8ClampedArray -> IO Int 164 | 165 | foreign import javascript unsafe "new Uint8ClampedArray($1)" 166 | js_clampUint8Array :: Uint8Array -> IO Uint8ClampedArray 167 | -------------------------------------------------------------------------------- /src/Cochlea.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE RecursiveDo #-} 3 | {-# LANGUAGE JavaScriptFFI #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | module Cochlea where 8 | 9 | import Control.Monad.IO.Class (liftIO) 10 | import Data.Map 11 | import Data.Traversable 12 | import Reflex 13 | import Reflex.Dom 14 | import GHCJS.DOM.Types hiding (Event) 15 | import GHCJS.DOM.AudioNode 16 | import GHCJS.DOM.AudioContext 17 | import GHCJS.DOM.AnalyserNode 18 | import GHCJS.DOM.ConvolverNode 19 | import GHCJS.DOM.AudioBuffer hiding (getSampleRate) 20 | import GHCJS.Marshal 21 | import qualified JavaScript.Array as JA 22 | import WebAudio 23 | import Arithmetic 24 | 25 | 26 | data GammaToneFilter = GammaToneFilter 27 | { gtfOrder :: Int 28 | , gtfCenterFreq :: Double 29 | , gtfBandwidth :: Double 30 | , gtfAmplitude :: Double 31 | } deriving (Show) 32 | 33 | 34 | data Filter = FGammaTone GammaToneFilter -- ^ Standard gammatone filter 35 | | FImpulse (Double -> Double) -- ^ Arbitrary impulse response 36 | | FFreq (Double -> Double) -- ^ Arbitrary frequency response 37 | 38 | 39 | instance Show Filter where 40 | show (FGammaTone g) = show g 41 | 42 | 43 | data CochlearFilterConfig t = CochlearFilterConfig { 44 | _cfcFilter :: Dynamic t Filter 45 | , _cfcNSamples :: Dynamic t Int 46 | } 47 | 48 | data CochlearFilter t m = CochlearFilter { 49 | _cfAudioContext :: AudioContext 50 | , _cfConvolverNode :: ConvolverNode 51 | , _cfAnalyserNode :: AnalyserNode 52 | , _cfGetPower :: Event t () -> m (Event t Double) 53 | } 54 | 55 | 56 | impulseResponse :: Double -> Double -> Filter -> [Double] 57 | impulseResponse freq buffLen filt = Prelude.map sample sampTimes 58 | where nSamps = floor $ buffLen * freq 59 | sampTimes = Prelude.map ((/ freq) . realToFrac) [0..nSamps - 1] 60 | sample = case filt of 61 | FImpulse f -> f 62 | FGammaTone f -> gammaTone f 63 | FFreq _ -> error "FFreq filter not implemented" 64 | 65 | 66 | gammaTone :: GammaToneFilter -> Double -> Double 67 | gammaTone (GammaToneFilter n f b a) t = 68 | a * (t ^^ (n-1)) * exp (-2 * pi * b * t) * cos (2*pi*f*t + 0) 69 | -- NOTE I'm ignoring the 'carrier phase' parameter. That's ok? 70 | -- NOTE There's no way to use complex numbers in the web audio convolver 71 | -- This seems weird. Fortunately gammatone impulse response 72 | -- is purely real. Right? 73 | 74 | 75 | setImpulseResponse :: AudioContext -> CochlearFilter t m -> Filter -> Int -> IO () 76 | setImpulseResponse ctx (CochlearFilter _ conv anyl _) filt nSamps = do 77 | freq <- realToFrac <$> GHCJS.DOM.AudioContext.getSampleRate ctx 78 | let -- freq = 44100 -- TODO: Magic number. Can get this from AudioContext maybe? 79 | len = fromIntegral nSamps / freq 80 | let samps = impulseResponse freq len filt 81 | sampVals <- traverse toJSVal samps 82 | buf <- js_doublesToBuffer ctx (JA.fromList sampVals) freq 83 | setBuffer conv (Just buf) 84 | 85 | 86 | foreign import javascript unsafe 87 | "$r = ($1).createBuffer(2,($2).length,($3)); var d = ($r).getChannelData(0); for (var i = 0; i < ($2).length; i++) {d[i] = ($2)[i]; };" 88 | js_doublesToBuffer :: AudioContext -> JA.JSArray -> Double -> IO AudioBuffer 89 | 90 | 91 | foreign import javascript unsafe 92 | "var buf = new Uint8Array(($1).fftSize); ($1).getByteTimeDomainData(buf); $r = 0; for (var i = 0; i < ($1).fftSize; i++){ var s = (buf[i] - 127) * 0.003921; $r = $r + s*s;}; $r = Math.sqrt($r)/buf.length" 93 | js_getPower :: AnalyserNode -> IO Double 94 | 95 | 96 | 97 | cochlearFilter :: MonadWidget t m 98 | => AudioContext 99 | -> AudioNode 100 | -> CochlearFilterConfig t 101 | -> m (CochlearFilter t m) 102 | cochlearFilter ctx inputNode (CochlearFilterConfig filt nSamp) = mdo 103 | convNode <- liftIO $ createConvolver ctx 104 | anylNode <- liftIO $ createAnalyser ctx 105 | connect inputNode convNode (Just 0) (Just 0) 106 | connect convNode anylNode (Just 0) (Just 0) 107 | let getPower = do 108 | p <- js_getPower anylNode 109 | -- print $ "Power: " ++ show p 110 | return p 111 | pb <- getPostBuild 112 | let filtParams = (,) <$> filt <*> nSamp 113 | let cFilter = CochlearFilter ctx convNode anylNode (\reqs -> performEvent $ ffor reqs $ \() -> liftIO getPower) 114 | _ <- performEvent $ ffor (updated nSamp) (\n -> liftIO (setFftSize (_cfAnalyserNode cFilter) (fromIntegral n))) 115 | _ <- performEvent (ffor (leftmost [tag (current filtParams) pb , updated filtParams]) $ \(f,n) -> liftIO $ setImpulseResponse ctx cFilter f n) 116 | return cFilter 117 | 118 | data CochleaConfig t = CochleaConfig 119 | { _cochleaConfig_initial_freqRange :: (Double,Double) 120 | , _cochleaConfig_change_freqRange :: Event t (Double,Double) 121 | , _cochleaConfig_initial_nFreq :: Int 122 | , _cochleaConfig_change_nFreq :: Event t Int 123 | , _cochleaConfig_initial_logSpace :: Bool 124 | , _cochleaConfig_change_logSpace :: Event t Bool 125 | , _cochleaConfig_initial_bwFunction :: UExp 126 | , _cochleaConfig_change_bwFunction :: Event t UExp 127 | } 128 | 129 | data CochloaConfig' = CochleaConfig' 130 | { _cc_freqRange :: (Double, Double) 131 | , _cc_nFreo :: Int 132 | , _cc_logSpace :: Bool 133 | , _ccBwFunction :: UExp 134 | } deriving (Show) 135 | 136 | data Cochlea t m = Cochlea 137 | { _cochlea_getPowerData :: Event t () -> m (Event t (Map Double Double)) 138 | , _cochlea_filters :: Dynamic t (Map Double (CochlearFilter t m)) 139 | } 140 | 141 | 142 | freqSpace :: (Double, Double) -> Int -> Bool -> UExp -> Map Double Filter 143 | freqSpace (freq1,freqN) n True bwFunc = 144 | fromList $ zipWith (\f b -> (f, FGammaTone (GammaToneFilter 2 f b 1))) freqs bws 145 | where lf1 = log freq1 146 | lfN = log freqN 147 | dFr = (lfN - lf1) / (fromIntegral n - 1) 148 | freqs = Prelude.map (exp . (+ lf1) . (* dFr) . fromIntegral) [0..n-1] 149 | inds = Prelude.map (\f -> log f / dFr) freqs 150 | bws = Prelude.map (flip uevalD bwFunc) freqs 151 | 152 | 153 | cochlea :: MonadWidget t m => AudioContext -> AudioNode -> CochleaConfig t -> m (Cochlea t m) 154 | cochlea ctx inputNode (CochleaConfig rng drng n dn l dl f df) = do 155 | 156 | frange <- holdDyn rng drng 157 | nfilts <- holdDyn n dn 158 | logspace <- holdDyn l dl 159 | bwFunc <- holdDyn f df 160 | let filtspecs = freqSpace <$> frange <*> nfilts <*> logspace <*> bwFunc 161 | filts <- listWithKey filtspecs $ \freq filt -> do 162 | cochlearFilter ctx inputNode 163 | CochlearFilterConfig { _cfcFilter = filt 164 | , _cfcNSamples = constDyn 2048 } 165 | 166 | let getPowers reqs = performEvent $ ffor (tag (current filts) reqs) $ \cFilts -> 167 | traverse (\cf -> liftIO (js_getPower $ _cfAnalyserNode cf)) cFilts 168 | 169 | return (Cochlea getPowers filts) 170 | 171 | -- buildCochlea 172 | -- :: MonadWidget t m 173 | -- => AudioContext 174 | -- -> AudioNode 175 | -- -> CochleaConfig' 176 | -- -> Cochlea' 177 | -- buildCochlea = undefined 178 | -------------------------------------------------------------------------------- /src/Arithmetic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE RecursiveDo #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Arithmetic where 6 | 7 | import Control.Applicative hiding ((<|>), (<*>)) 8 | import Data.Bifunctor 9 | import Data.Functor 10 | import Data.Monoid ((<>)) 11 | import qualified Data.Text as Text 12 | import Debug.Trace 13 | import Text.Parsec 14 | import Data.Bool (bool) 15 | import Data.Maybe (isJust, fromMaybe) 16 | import Text.Parsec.Language 17 | import Text.Parsec.Expr 18 | import Text.Parsec.String 19 | import Reflex (Dynamic, holdDyn, fmapMaybe, updated) 20 | import Text.Parsec.Token hiding (parens) 21 | import Reflex.Dom ((=:)) 22 | import Reflex.Dom.Old (MonadWidget) 23 | import Reflex.Dom.Widget (def, el, text, value) 24 | import Reflex.Dom.Widget.Input (textInput, TextInputConfig(..)) 25 | 26 | import Text.PrettyPrint ((<+>)) 27 | import qualified Text.PrettyPrint as Pretty 28 | 29 | 30 | class Pretty p where 31 | ppr :: Int -> p -> Pretty.Doc 32 | 33 | {-# INLINE pp #-} 34 | pp :: p -> Pretty.Doc 35 | pp = ppr 0 36 | 37 | {-# INLINE ppg #-} 38 | ppg :: p -> String 39 | ppg = Pretty.render . pp 40 | 41 | 42 | data Prim2 = PSum | PDiff | PProd | PDiv | PRange | PPow 43 | deriving (Eq, Show) 44 | 45 | instance Pretty Prim2 where 46 | ppr _ PSum = Pretty.char '+' 47 | ppr _ PDiff = Pretty.char '-' 48 | ppr _ PProd = Pretty.char '*' 49 | ppr _ PDiv = Pretty.char '/' 50 | ppr _ PRange = Pretty.text "->" 51 | ppr _ PPow = Pretty.char '^' 52 | 53 | data Prim1 = PNegate | PExpE | PExp10 | PLogE | PLog10 | PToDb 54 | deriving (Eq, Show) 55 | 56 | instance Pretty Prim1 where 57 | ppr _ PNegate = Pretty.char '-' 58 | ppr _ PExpE = Pretty.text "exp" 59 | ppr _ PExp10 = Pretty.text "exp10" 60 | ppr _ PLogE = Pretty.text "log" 61 | ppr _ PLog10 = Pretty.text "log10" 62 | ppr _ PToDb = Pretty.text "dB" 63 | 64 | evalPrim2 :: Prim2 -> UVal -> UVal -> UVal 65 | evalPrim2 PSum (VLit x) (VLit y) = VLit $ (+) x y 66 | evalPrim2 PDiff (VLit x) (VLit y) = VLit $ (-) x y 67 | evalPrim2 PProd (VLit x) (VLit y) = VLit $ (*) x y 68 | evalPrim2 PDiv (VLit x) (VLit y) = VLit $ (/) x y 69 | evalPrim2 PRange (VLit x) (VPair lo hi) = VLit $ (x-lo)/(hi-lo) 70 | evalPrim2 PPow (VLit x) (VLit y) = VLit $ x ** y 71 | 72 | evalPrim1 :: Prim1 -> UVal -> UVal 73 | evalPrim1 PNegate (VLit x) = VLit $ negate x 74 | evalPrim1 PExpE (VLit x) = VLit $ exp x 75 | evalPrim1 PExp10 (VLit x) = VLit $ (10 **) x 76 | evalPrim1 PLogE (VLit x) = VLit $ log x 77 | evalPrim1 PLog10 (VLit x) = VLit $ logBase 10 x 78 | evalPrim1 PToDb (VLit x) = VLit $ (20 *) . logBase 10 $ x 79 | 80 | 81 | data UExp = ULit Double 82 | | UVar 83 | | UPrim2 Prim2 UExp UExp 84 | | UPrim1 Prim1 UExp 85 | | UPair UExp UExp 86 | deriving (Eq, Show) 87 | 88 | instance Pretty UExp where 89 | ppr _ (ULit x) = Pretty.double x 90 | ppr _ UVar = Pretty.char 'x' 91 | ppr _ (UPrim2 p a b) = Pretty.hsep [pp a, pp p, pp b] 92 | ppr _ (UPrim1 PToDb a) = pp a <+> pp PToDb 93 | ppr _ (UPrim1 p a) = pp p <+> pp a 94 | ppr _ (UPair a b) = Pretty.parens ((pp a <> Pretty.comma) <+> pp b) 95 | 96 | ueval :: Double -> UExp -> UVal 97 | ueval _ (ULit a) = VLit a 98 | ueval _ (UPair (ULit a) (ULit b)) = VPair a b 99 | ueval x UVar = VLit x 100 | ueval x (UPrim2 o a b) = evalPrim2 o (ueval x a) (ueval x b) 101 | ueval x (UPrim1 o a) = evalPrim1 o (ueval x a) 102 | 103 | uevalD :: Double -> UExp -> Double 104 | uevalD x e = case ueval x e of 105 | VLit d -> d 106 | _ -> error "Arithmetic type error" 107 | 108 | data UVal = VLit Double 109 | | VPair Double Double 110 | 111 | parseUexp :: String -> Either String UExp 112 | parseUexp s = bimap show id $ parse expr "string" s 113 | 114 | ptest :: Show a => Parser a -> String -> String 115 | ptest p s = show $ bimap show id $ parse p "test" s 116 | 117 | expr = buildExpressionParser opTable term 118 | "expression" 119 | 120 | term = try litPair 121 | <|> try (between (char '(') (char ')') expr 122 | <|> lit 123 | <|> (char 'x' >> pure UVar)) <* spaces 124 | "simple expression" 125 | 126 | tokP = makeTokenParser emptyDef 127 | opTable = [ [prefix "-" (UPrim1 PNegate), 128 | prefix "log10" (UPrim1 PLog10), 129 | prefix "log" (UPrim1 PLogE), 130 | prefix "exp10" (UPrim1 PExp10), 131 | prefix "exp" (UPrim1 PExpE), 132 | postfix "dB" (UPrim1 PToDb)] 133 | , [binary "^" (UPrim2 PPow) AssocLeft] 134 | , [binary "*" (UPrim2 PProd) AssocLeft, 135 | binary "/" (UPrim2 PDiv) AssocLeft] 136 | , [binary "+" (UPrim2 PSum) AssocLeft, 137 | binary "-" (UPrim2 PDiff) AssocLeft, 138 | binary "->" (UPrim2 PRange) AssocLeft] 139 | ] 140 | 141 | binary name fun assoc = Infix (do{ reservedOp tokP name; return fun}) assoc 142 | prefix name fun = Prefix (do{reservedOp tokP name; return fun}) 143 | postfix name fun = Postfix (do{reservedOp tokP name; return fun}) 144 | 145 | litPair :: Parser UExp 146 | litPair = between (char '(') (char ')') $ do 147 | l1 <- lit 148 | spaces 149 | char ',' 150 | spaces 151 | l2 <- lit 152 | return $ UPair l1 l2 153 | 154 | 155 | lit :: Parser UExp 156 | lit = do 157 | n <- optionMaybe (char '-') 158 | v <- either fromIntegral id <$> 159 | naturalOrFloat (makeTokenParser emptyDef) 160 | case n of 161 | Nothing -> return $ ULit v 162 | Just _ -> return (ULit $ negate v) 163 | 164 | 165 | funExprInput :: MonadWidget t m => UExp -> m (Dynamic t UExp) 166 | funExprInput exp0 = mdo 167 | let pExp0 = Pretty.render $ pp exp0 168 | -- let inputConfig = def 169 | let boxAttrs = 170 | (\ats e -> ats <> "class" =: bool "expr expr-bad" "expr expr-good" (isJust e)) 171 | <$> _textInputConfig_attributes def <*> textExpr 172 | eInp <- textInput def { _textInputConfig_initialValue = Text.pack pExp0 173 | , _textInputConfig_attributes = boxAttrs 174 | } 175 | let textExpr = hush . parseUexp . Text.unpack <$> value eInp 176 | outExp <- holdDyn exp0 $ fmapMaybe id (updated textExpr) 177 | el "br" (return ()) 178 | return outExp 179 | 180 | 181 | defaultRedExpr = UPrim2 PPow (UPrim2 PRange (UPrim1 PToDb UVar) 182 | (UPair (ULit (-90)) (ULit (-50)))) 183 | (ULit 4) 184 | defaultGreenExpr = UPrim2 PPow (UPrim2 PRange (UPrim1 PToDb UVar) 185 | (UPair (ULit (-100)) (ULit (-70)))) 186 | (ULit 4) 187 | defaultBlueExpr = UPrim2 PPow (UPrim2 PRange (UPrim1 PToDb UVar) 188 | (UPair (ULit (-90)) (ULit (-50)))) 189 | (ULit 2) 190 | 191 | 192 | colorMappings :: MonadWidget t m => m (Dynamic t (UExp, UExp, UExp)) 193 | colorMappings = do 194 | rFunc <- text "R" >> funExprInput defaultRedExpr 195 | gFunc <- text "G" >> funExprInput defaultGreenExpr 196 | bFunc <- text "B" >> funExprInput defaultBlueExpr 197 | return $ (,,) <$> rFunc <*> gFunc <*> bFunc 198 | 199 | -- text "R" 200 | -- rFunc <- funExprInput 201 | -- def 202 | -- el "br" $ return () 203 | -- text "G" 204 | -- gFunc <- funExprInput () 205 | -- def 206 | -- el "br" $ return () 207 | 208 | -- text "B" 209 | -- bFunc <- funExprInput () 210 | -- def 211 | -- el "br" $ return () 212 | 213 | -- let cFuncs = (,,) <$> rFunc <*> gFunc <*> bFunc 214 | -- -- cFuncs <- $(qDyn [| ( $(unqDyn [|rFunc|]), $(unqDyn [|gFunc|]), $(unqDyn [|bFunc|])) |]) 215 | 216 | hush :: Either l r -> Maybe r 217 | hush (Left _) = Nothing 218 | hush (Right r) = Just r 219 | -------------------------------------------------------------------------------- /exec/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE JavaScriptFFI #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE RecursiveDo #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | 11 | module Main where 12 | 13 | import Control.Applicative (liftA3) 14 | import Control.Monad (join, when) 15 | import Data.Bool (bool) 16 | import qualified Data.JSString as JS 17 | import Data.Maybe (fromMaybe, isJust) 18 | import Data.Monoid 19 | import qualified Data.Text as Text 20 | import qualified Data.Time as Time 21 | import GHCJS.DOM 22 | import GHCJS.DOM.AudioBuffer 23 | import GHCJS.DOM.AudioBufferCallback 24 | import GHCJS.DOM.AudioContext 25 | import GHCJS.DOM.AudioDestinationNode 26 | import GHCJS.DOM.AudioListener 27 | import GHCJS.DOM.AudioNode 28 | import GHCJS.DOM.AudioParam 29 | import GHCJS.DOM.AudioProcessingEvent 30 | import GHCJS.DOM.AudioTrack 31 | import GHCJS.DOM.AudioTrackList 32 | import GHCJS.DOM.CanvasRenderingContext2D 33 | import GHCJS.DOM.Enums 34 | import GHCJS.DOM.HTMLCanvasElement 35 | import GHCJS.DOM.ImageData 36 | import GHCJS.DOM.Navigator 37 | import qualified GHCJS.DOM.Navigator as Navigator 38 | import GHCJS.DOM.NavigatorUserMediaErrorCallback 39 | import GHCJS.DOM.NavigatorUserMediaSuccessCallback 40 | import GHCJS.DOM.OscillatorNode 41 | import GHCJS.DOM.Types hiding (Event) 42 | import GHCJS.DOM.Window 43 | import GHCJS.Foreign 44 | import GHCJS.Marshal 45 | import GHCJS.Types 46 | import qualified GHCJS.Types as T 47 | import qualified JavaScript.Array as JA 48 | import qualified JavaScript.Object as JO 49 | import qualified JavaScript.Web.Canvas as C 50 | import qualified Text.PrettyPrint as Pretty 51 | 52 | import Arithmetic 53 | import Cochlea 54 | import Control.Monad.IO.Class 55 | import qualified Data.Map as Map 56 | import Reflex 57 | import Reflex.Dom hiding (restore, 58 | setValue) 59 | import Reflex.Dom.Contrib.Widgets.ButtonGroup 60 | import Reflex.Dom.Contrib.Widgets.Common 61 | import Reflex.Time 62 | import Text.Read (readMaybe) 63 | import WebAudio 64 | 65 | 66 | main :: IO () 67 | -- main = js_forceHttps >> mainWidget main' 68 | main = mainWidget main' 69 | 70 | main' :: forall t m. (MonadWidget t m) => m () 71 | main' = do 72 | pb <- getPostBuild 73 | 74 | (cochleaConfig, gainConfig, cFuncs, nSkip) <- elClass "div" "controls" $ do 75 | el "br" $ return () 76 | text "Mic Boost" 77 | gainCoef <- justButtonGroup 4 78 | (constDyn [(1,"1x") ,(2,"2x"),(4,"4x"),(8,"8x")]) 79 | def 80 | let gainConfig = GainConfig 8 (updated gainCoef) 81 | el "br" $ return () 82 | 83 | text "Freq 1" 84 | filtsLo <- justButtonGroup 100 85 | (constDyn [(50,"50 Hz"),(100,"100 Hz"),(200,"200 Hz"), (400,"400 Hz")]) 86 | def 87 | --filtsLo <- numInput (NumInputConfig 0.1 1000 300 True 2 100) 88 | el "br" $ return () 89 | 90 | text "Freq n" 91 | filtsHi <- justButtonGroup 6400 92 | (constDyn [(800,"800"), (1600, "1600"), (3200, "3200") 93 | , (6400, "6400"), (12800, "12800")]) 94 | def 95 | --filtsHi <- numInput (NumInputConfig 0.1 10000 300 True 2 5000) 96 | el "br" $ return () 97 | 98 | text "N Filts" 99 | nFilts <- justButtonGroup 32 100 | (constDyn [(8,"8"), (16,"16"), (32,"32") 101 | , (64,"64"), (128,"128")]) 102 | def 103 | --nFilts <- mapDyn floor =<< numInput (NumInputConfig 1 128 15 True 0 64) 104 | el "br" $ return () 105 | 106 | let filtsRange = (,) <$> filtsLo <*> filtsHi 107 | 108 | text "Bandwidth Function" 109 | let defBwFunc = (UPrim2 PDiv UVar (ULit 100)) 110 | bwFunc <- funExprInput defBwFunc 111 | 112 | 113 | text "Sampling rate" 114 | nSkip <- justButtonGroup 4 115 | (constDyn $ [(120, "1") ,(15,"8"),(4,"30") 116 | ,(2,"60"),(1,"120")]) 117 | def 118 | 119 | el "br" $ return () 120 | 121 | cFuncs <- colorMappings 122 | 123 | let cochleaConfig = CochleaConfig (100,5000) (updated filtsRange) 64 (updated nFilts) True never defBwFunc (updated bwFunc) 124 | return (cochleaConfig, gainConfig, cFuncs, nSkip) 125 | 126 | 127 | let 128 | widgetStartButton = button "run" >>= \b -> return (never, b) 129 | widgetRunning = do 130 | c <- liftIO newAudioContext 131 | 132 | g <- gain c gainConfig 133 | 134 | fullCochlea <- cochlea c (toAudioNode g) cochleaConfig 135 | 136 | -- osc <- oscillatorNode c (OscillatorNodeConfig 440 freq) 137 | 138 | dynText $ ("N filters4: " <>) . Text.pack . show . Map.size <$> _cochlea_filters fullCochlea 139 | 140 | win :: GHCJS.DOM.Window.Window <- fromMaybe (error "No window") <$> liftIO currentWindow 141 | nav <- liftIO $ getNavigator win 142 | b <- liftIO $ toJSVal True 143 | myDict <- liftIO $ JO.create >>= \o -> JO.setProp "audio" b o >> return o 144 | 145 | mediaCallback :: NavigatorUserMediaSuccessCallback <- liftIO $ newNavigatorUserMediaSuccessCallback $ \stream -> do 146 | src <- liftIO $ createMediaStreamSource c stream 147 | liftIO $ connect (toAudioNode src) (g) (Just 0) (Just 0) 148 | 149 | failureCallback :: NavigatorUserMediaErrorCallback <- liftIO $ newNavigatorUserMediaErrorCallback $ \err -> do 150 | liftIO $ print'' err 151 | 152 | liftIO $ do 153 | dest <- getDestination c 154 | nm <- js_userAgent 155 | when ("Chrome" `JS.isInfixOf` nm) $ do 156 | putStrLn "Chrome" 157 | 158 | -- Navigator.getUserMedia nav (Just (Dictionary (jsval myDict))) 159 | -- userMedia :: MediaStream <- getUserMedia nav (Just $ Dictionary (jsval myDict)) -- (mediaCallback) -- (failureCallback) 160 | -- connect userMedia (toAudioNode g) (Just 0) (Just 0) 161 | js_connectMic c (toAudioNode g) 162 | return () 163 | 164 | when ("Firefox" `JS.isInfixOf` nm) $ putStrLn "FF" >> js_connectMic' c (toAudioNode g) 165 | putStrLn "Test2" 166 | 167 | el "br" $ return () 168 | 169 | let playing' = constDyn True 170 | 171 | ticks' <- tickLossyFromPostBuildTime (1/120) :: m (Event t TickInfo) 172 | ticks'' <- downsample (current (nSkip)) ticks' 173 | let ticks = gate (current (traceDyn "playing" playing')) ticks'' 174 | 175 | -- performEvent (ffor ticks' $ \_ -> liftIO (putStrLn "Tick'")) 176 | 177 | 178 | el "br" $ return () 179 | 180 | -- dynText $ (("Playing: " <>) . Text.pack . show) <$> playing 181 | 182 | el "br" $ return () 183 | 184 | cochleaPowers :: Event t (Map.Map Double Double) <- _cochlea_getPowerData fullCochlea (() <$ ticks) 185 | 186 | let applyExpr e xs = Prelude.map (flip uevalD e) xs 187 | let cochleaColors = attachWith (\(fR,fG,fB) ps -> 188 | let cs = Map.elems ps 189 | cR = applyExpr fR cs 190 | cG = applyExpr fG cs 191 | cB = applyExpr fB cs 192 | in (cR,cG,cB)) (current cFuncs) cochleaPowers 193 | 194 | return ( cochleaColors :: Event t ([Double],[Double],[Double]) 195 | , never :: Event t () 196 | ) 197 | 198 | rec 199 | cochleaTicksAndWidgetswaps :: Dynamic t (Event t ([Double],[Double],[Double]), Event t ()) <- widgetHold widgetStartButton nextWidget 200 | let nextWidget = leftmost 201 | [ widgetRunning <$ switchDyn (fmap snd cochleaTicksAndWidgetswaps) 202 | -- TODO add more conditions for restarting 203 | ] 204 | -- ticks = switchDyn $ fmap (\(_,t,_) -> t) <$> cochleaTicksAndWidgetswaps 205 | let cochleaColors :: Event t ([Double],[Double],[Double]) = switchDyn $ fmap fst $ cochleaTicksAndWidgetswaps 206 | 207 | elClass "div" "coch-display" $ do 208 | canvEl :: HTMLCanvasElement <- 209 | fmap (HTMLCanvasElement . unElement . _element_raw . fst) $ 210 | elAttr' "canvas" ("id" =: "canvas" 211 | <> "width" =: "200" 212 | <> "height" =: "128" 213 | <> "style" =: "height:256px;") $ return () 214 | ctx'' <- fmap (fromMaybe (error "getContext error")) $ liftIO $ 215 | GHCJS.DOM.HTMLCanvasElement.getContext 216 | canvEl ("2d" :: JSString) ([] :: [Int]) 217 | 218 | -- TODO: Is there a better way to cast 219 | -- RenderingContext to CanvasRenderingContext2D? 220 | ctx' :: CanvasRenderingContext2D <- 221 | fmap (fromMaybe (error "2d context error")) $ liftIO $ fromJSVal =<< toJSVal ctx'' 222 | 223 | 224 | -- cochleaPowers <- fmap _cochlea_getPowerData fullCochlea (() <$ ticks) 225 | -- cochleaPowers :: Dynamic t (Maybe (Event t () -> m (Event t (Map.Map Double Double)))) = fmap ( _cochlea_getPowerData) <$> fullCochlea 226 | 227 | -- let cochlea' = ffor fullCochlea $ \case 228 | -- Nothing -> \e -> return never -- (\e -> fmap (\() -> Map.empty) e) 229 | -- Just f -> _cochlea_getPowerData f 230 | 231 | -- -- cochleaPowerData <- forM fullCochlea $ 232 | 233 | 234 | -- let cochleaColors = 235 | -- undefined 236 | -- -- fmap 237 | -- -- (\case 238 | -- -- (Nothing,_) -> (0,0,0) 239 | -- -- (Just (fR,fG,fB), ps) -> 240 | -- -- let cs = Map.elems ps 241 | -- -- cR = applyExpr fR cs 242 | -- -- cG = applyExpr fG cs 243 | -- -- cB = applyExpr fB cs 244 | -- -- in (cR,cG,cB) 245 | -- -- ) 246 | -- -- $ attachWith 247 | -- -- ((,) <$> cochleaPowers <*> cFuncs) 248 | 249 | performEvent (ffor cochleaColors $ \(rs,gs,bs) -> liftIO $ do 250 | when (length rs > 0) $ do 251 | let toClamped :: [Double] -> IO Uint8ClampedArray 252 | toClamped xs = (js_makeUint8ClampedArray . JA.fromList) =<< traverse (toJSVal . (* 255)) xs 253 | r <- toClamped rs 254 | g <- toClamped gs 255 | b <- toClamped bs 256 | img <- js_zip_colors_magic_height r g b 257 | let l = 128 * 4 :: Int -- length rs * 4 258 | imgData <- newImageData img 1 (Just $ fromIntegral $ l `div` 4) 259 | shiftAppendColumn ctx' 260 | putImageData ctx' imgData 199 0 261 | printJSVal =<< toJSVal rs 262 | ) 263 | 264 | el "br" $ return () 265 | 266 | 267 | -- map double to 0-255 range 268 | dblToInt :: Double -> Double -> Double -> Int 269 | dblToInt lo hi x = let x' = min hi (max lo x) 270 | in floor $ 255 * ((x' - lo) / (hi - lo)) 271 | 272 | -- toDb :: Double -> Double 273 | -- toDb x = 20 * logBase 10 x 274 | 275 | shiftAppendColumn :: CanvasRenderingContext2D -> IO () 276 | shiftAppendColumn ctx = do 277 | d <- getImageData ctx 1 0 200 128 278 | putImageData ctx d 0 0 279 | 280 | squeezeAppendColumn :: CanvasRenderingContext2D -> HTMLCanvasElement -> IO () 281 | squeezeAppendColumn ctx canv = do 282 | save ctx 283 | scale ctx (199/200) 1 284 | drawImage ctx canv 0 0 285 | restore ctx 286 | 287 | foreign import javascript unsafe "$r = new Uint8ClampedArray($1)" 288 | js_makeUint8ClampedArray :: JA.JSArray -> IO Uint8ClampedArray 289 | 290 | foreign import javascript unsafe 291 | "$r = new Uint8ClampedArray(($1).length * 4); function logC(x){ return(((Math.sqrt(x/255))*255)|0)}; var l = ($1).length; for (var i = 0; i < l; i++) { var i0 = (l-i-1)*4; ($r)[i0] = ($1)[i]; ($r)[i0+1] = ($1)[i]; ($r)[i0+2] = logC(($1)[i]); ($r)[i0+3] = 255;}" 292 | js_toGrayscale :: Uint8ClampedArray -> IO Uint8ClampedArray 293 | 294 | foreign import javascript unsafe 295 | "$r = new Uint8ClampedArray(($1).length * 4); var l = ($1).length; for (var i = 0; i < l; i++) { var i0 = (l - i - 1) * 4; ($r)[i0] = ($1)[i]; ($r)[i0+1] = ($2)[i]; ($r)[i0+2] = ($3)[i]; ($r)[i0+3] = 255;}" 296 | js_zip_colors :: Uint8ClampedArray -> Uint8ClampedArray -> Uint8ClampedArray -> IO Uint8ClampedArray 297 | 298 | foreign import javascript unsafe 299 | "var out_l = 128; var in_l = ($1).length; $r = new Uint8ClampedArray(out_l * 4); for (var i = 0; i < out_l; i++) { var in_i = (i * in_l / out_l) | 0; var i0 = (out_l - i - 1) * 4; ($r)[i0] = ($1)[in_i]; ($r)[i0+1] = ($2)[in_i]; ($r)[i0+2] = ($3)[in_i]; ($r)[i0+3] = 255;}" 300 | js_zip_colors_magic_height :: Uint8ClampedArray -> Uint8ClampedArray -> Uint8ClampedArray -> IO Uint8ClampedArray 301 | 302 | foreign import javascript unsafe "console.log($1)" 303 | printJSVal :: JSVal -> IO () 304 | 305 | foreign import javascript unsafe "console.log(($1).data[0])" 306 | print' :: ImageData -> IO () 307 | 308 | foreign import javascript unsafe "console.log($1)" 309 | print'' :: NavigatorUserMediaError -> IO () 310 | 311 | foreign import javascript unsafe "console.log($1)" 312 | print''' :: Dictionary -> IO () 313 | 314 | foreign import javascript unsafe "try {navigator.webkitGetUserMedia({'audio':true},function(s){mss = ($1).createMediaStreamSource(s); mss.connect($2); console.log('SUCCESS');}, function(e){ console.log('ERROR:' + e);})} catch (e) { alert(e) }" 315 | js_connectMic :: AudioContext -> AudioNode -> IO () 316 | 317 | foreign import javascript unsafe "navigator.userAgent" 318 | js_userAgent :: IO JSString 319 | 320 | foreign import javascript unsafe "navigator.mediaDevices.getUserMedia({'audio':true}).then(function(s){ mss = ($1).createMediaStreamSource(s); mss.connect($2); console.log('SUCCESS2');})" 321 | js_connectMic' :: AudioContext -> AudioNode -> IO () 322 | 323 | foreign import javascript unsafe "if (window.location.protocol != 'https:') { window.location.href = 'https:' + window.location.href.substring(window.location.protocol.length) }" 324 | js_forceHttps :: IO () 325 | 326 | downsample :: forall t m a. MonadWidget t m => Behavior t Int -> Event t a -> m (Event t a) 327 | downsample nDropPerKeep e = do 328 | counted :: Event t (Int, a) <- zipListWithEvent (,) [0 :: Int ..] e 329 | let f :: Int -> (Int, a) -> Maybe a 330 | f n (ind, ev) 331 | | ind `mod` n == 0 = Just ev 332 | | otherwise = Nothing 333 | kept = attachWithMaybe f nDropPerKeep counted 334 | return kept 335 | 336 | 337 | 338 | justButtonGroup 339 | :: (MonadWidget t m, Eq a, Show a) 340 | => a 341 | -> Dynamic t [(a,Text.Text)] 342 | -> WidgetConfig t (Maybe a) 343 | -> m (Dynamic t a) 344 | justButtonGroup vDef btns cfg = do 345 | bg <- bootstrapButtonGroup btns cfg {_widgetConfig_initialValue = Just vDef} 346 | holdDyn vDef (fmapMaybe id $ updated (value bg)) 347 | --------------------------------------------------------------------------------