diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2007, George Giorgidze and Henrik Nilsson + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,81 @@ +YampaSynth Release Notes +------------------------------------------- + +Description +----------- +YampaSynth is a software synthesizer implemented in Haskell, using Yampa domain specific language. It contains little framework of sound generating and sound shaping modules and example applications: + * yampasynth-wav is an application which synthesizes a MIDI music and writes result into a WAVE audio file. + * yampasynth-openal is an application which synthesizes MIDI music and sends audio data in real-time to a sound card. We use Haskell binding of OpenAL library as an interface to audio hardware. + * yampasynth-gtk is an application with simple graphical user interface which allows you to play music with various instruments in real-time using keyboard of your computer. We use Haskell binding of GTK library for GUI programming and Haskell binding of OpenAL library as an interface to audio hardware. + +Software synthesizer uses the MIDI standard as a music description and the SoundFont standard as an instrument description. + +Implementation is based on the paper "Switched-on Yampa: Declarative Programming of Modular Synthesizers" by George Giorgidze and Henrik Nilsson (http://www.cs.nott.ac.uk/~ggg/publications/padl2008.pdf). + +This is mainly a proof of concept, but already useful to some extent. + +Prerequisites +------------- +* You will need Glasgow Haskell Compiler (GHC) version 6.8 or higher. +* Cabal version 1.2 or higher. +* To install any of the example applications you will need the following packages: + * base + * array + * containers + * bytestring + * Yampa + * HCodecs + All of them are either included with GHC or are available for download from Hackage (http://hackage.haskell.org/). + + Aforementioned dependencies are enough to build yampasynth-wav application. + To build yampasynth-openal in addition you will need OpenAL package from Hackage. + To build yampasynth-gtk in addition you will need to install Gtk2Hs, available from Gtk2Hs website (http://www.haskell.org/gtk2hs/). + + For further details about dependencies see cabal package description file (YampaSynth.cabal). + +Installation +------------ +Use standard steps for Cabal package installation. + +runhaskell Setup.hs configure +runhaskell Setup.hs build +runhaskell Setup.hs install + +This will install applications for which your system satisfies dependencies. + +Usage +----- +Some typical usage example are: + +yampasynth-wav -r 44100 -s /path/to/SoundFontFile.sf2 -m /path/to/MidiFile.mid -o /path/to/result.wav + +yampasynth-openal -r 11025 -s /path/to/SoundFontFile.sf2 -m /path/to/MidiFile.mid + +yampasynth-gtk -r 22050 -s /path/to/SoundFontFile.sf2 + +If you have dual core CPU add "+RTS -N2 -RTS" to your options (this works only for yampasynth-openal and yampasynth-gtk). +You may also try "+RTS -N2 -C -RTS". + +Option "-r 44100" sets sampling rate (or sampling frequency) of a synthesizer to 44100 samples per second. +With yampasynth-wav I recommend to use 44100 Hz, which will generate audio CD quality .wav files. +With yampasynth-openal I recommend to use 11025 Hz to get a smooth real-time playback without interruption, especially when playing a polyphonic music with several instruments. But sometimes you can afford higher sampling rates, feel free to experiment with this value. +With yampasynth-gtk I recommend to use 22050 Hz, if you get interruptions decrease it. + +SoundFonts +---------- +SoundFonts are instrument description files. They are used in software and hardware synthesis. Free soundfonts are available for download. Try to google "free soundfont". Here are some links which I have found and used: +http://soundfonts.homemusician.net/ +http://www.sf2midi.com/ + +I recommend to search for "FluidR3_GM.SF2" (it is also included in some linux distributions). However the file size is about 150 MB and it takes some time for synthesizer to parse and import it into memory. But quality of the generated audio is very good. +There are smaller ones e.g. "Ultimate.SF2" which is only 8 MB in size. + +OpenAL +------ +For real-time playback I use Haskell binding of OpenAL library. +On some linux systems (including my Ubuntu 7.10, OpenAL version libopenal0a 1:0.0.8) there are some issues with original C library, it is very buggy. For example on my system there were problems with ALSA output, so I had to put "(define devices '(native esd))" into my "~/.openalrc" file. +Also output was not that good on sampling rates other than 11025, 22050 and 44100. +In general I recommend to use these sampling rates if you experience similar problems. + + +George Giorgidze (Last Update: Apr 5, 2008) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/YampaSynth.cabal b/YampaSynth.cabal new file mode 100644 --- /dev/null +++ b/YampaSynth.cabal @@ -0,0 +1,71 @@ +name: YampaSynth +version: 0.0.1 +cabal-Version: >= 1.2 +license: BSD3 +license-file: LICENSE +copyright: (c) 2007-2008 George Giorgidze and Henrik Nilsson +author: George Giorgidze and Henrik Nilsson +maintainer: George Giorgidze (GGG at CS dot NOTT dot AC dot UK) +homepage: http://www.cs.nott.ac.uk/~ggg/ +stability: experimental +category: Sound, Music +synopsis: Software synthesizer +description: + YampaSynth is a software synthesizer implemented in Yampa, domain specific language embedded in Haskell. It contains a little framework of sound generating and sound shaping modules (e.g. oscillator, amplifier, mixer, envelope generator, filter, etc.) and example applications: + . + * "yampasynth-wav" is an application which synthesizes a MIDI music and writes result into a WAVE audio file. + . + * "yampasynth-openal" is an application which synthesizes a MIDI music and sends audio data in real-time to a sound card. We use Haskell binding of OpenAL library as an interface to audio hardware. + . + * "yampasynth-gtk" is an application with the simple graphical user interface which allows you to play a music with various instruments in real-time using the keyboard of your computer. We use Haskell binding of GTK library for GUI programming and Haskell binding of OpenAL library as an interface to audio hardware. + . + Software synthesizer uses the MIDI standard as a music description and the SoundFont standard as an instrument description. + . + Implementation is based on the paper "Switched-on Yampa: Declarative Programming of Modular Synthesizers", by George Giorgidze and Henrik Nilsson (), In Proceedings of 10th International Symposium on Practical Aspects of Declarative Languages, San Francisco, CA, USA, January 7-8, 2008. + . + This is mainly a proof of concept, but already useful to some extent. + +build-type: Simple +tested-with: GHC==6.8.2 + +data-files: gui/YampaSynth.glade, README + +flag wav + description: Builds yampasynth-wav executable which synthesizes a MIDI music and writes result into a WAVE audio file. + +flag openal + description: Builds yampasynth-openal executable which synthesizes MIDI music and sends audio data in real-time to a sound card. We use Haskell binding of OpenAL library as an interface to audio hardware. + +flag gtk + description: Builds yampasynth-gtk executable with simple graphical user interface which allows you to play music with various instruments in real-time using keyboard of your computer. We use Haskell binding of GTK library for GUI programming and Haskell binding of OpenAL library as an interface to audio hardware. + +executable yampasynth-wav + if flag (wav) + build-depends: base, array, bytestring, containers, Yampa, HCodecs + else + buildable: False + hs-source-dirs: src + main-is: Main/Wav.hs + other-modules: SynthBasics, SynthParams, MidiSynth, Player.Wav + ghc-options: -O2 -Wall + +executable yampasynth-openal + if flag (openal) + build-Depends: base, array, containers, OpenAL, Yampa, HCodecs + else + buildable: False + hs-source-dirs: src + main-is: Main/OpenAL.hs + other-modules: SynthBasics, SynthParams, MidiSynth, Player.OpenAL + ghc-options: -threaded -O2 -Wall + +executable yampasynth-gtk + if flag (gtk) + build-Depends: base, array, containers, OpenAL, glade, gtk, Yampa, HCodecs + else + buildable: False + hs-source-dirs: src + main-is: Main/Gtk.hs + other-modules: SynthBasics, SynthParams, MidiSynth, Player.OpenAL, Player.Gtk + ghc-options: -threaded -O2 -Wall + diff --git a/gui/YampaSynth.glade b/gui/YampaSynth.glade new file mode 100644 --- /dev/null +++ b/gui/YampaSynth.glade @@ -0,0 +1,199 @@ + + + + + + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + YampaSynth + GTK_WIN_POS_CENTER + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 4 + 4 + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + YampaSynth + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 1 Acoustic piano +2 Bright piano +3 Grand piano +4 Honky-tonk piano +5 Rhodes piano 1 +6 Chorused piano 2 +7 Harpsichord +8 Clavinet +9 Celesta +10 Glockenspiel +11 Music box +12 Vibraphone +13 Marimba +14 Xylophone +15 Tubular bell +16 Dulcimer +17 Hammmond organ +18 Percussive organ +19 Rock organ +20 Church organ +21 Reed organ +22 Accordion +23 Harmonica +24 Tango accordion +25 Acoustic nylon guitar +26 Acoustic steel guitar +27 Jazz guitar +28 Clean guitar +29 Muted guitar +30 Overdriven guitar +31 Distortion guitar +32 Guitar harmonics +33 Acoustic bass +34 Finger bass +35 Picked bass +36 Fretless bass +37 Slap bass 1 +38 Slap bass 2 +39 Synth bass 1 +40 Synth bass 2 +41 Violin +42 Viola +43 Cello +44 Double bass +45 Tremolo strings +46 Pizzicato strings +47 Orchestral harp +48 Timpani +49 Strings 1 +50 Strings 2 +51 Synth strings 1 +52 Synth strings 2 +53 Voice aahs +54 Voice oohs +55 Synth voice +56 Orchestra hit +57 Trumpet +58 Trombone +59 Tuba +60 Muted trumpet +61 French horn +62 Brass +63 Synth brass 1 +64 Synth brass 2 +65 Soprano sax +66 Alto sax +67 Tenor sax +68 Baritone sax +69 Oboe +70 English horn +71 Bassoon +72 Clarinet +73 Piccolo +74 Flute +75 Recorder +76 Pan flute +77 Bottle blow +78 Shakuhachi +79 Whistle +80 Ocarina +81 Square wave +82 Sawtooth +83 Calliope +84 Chiff lead +85 Charang +86 Solo synth lead +87 Bright saw +88 Bass and lead +89 Fantasia +90 Warm pad +91 Poly synth +92 Space pad +93 Bowed glass +94 Metal +95 Halo pad +96 Sweep pad +97 Ice rain +98 Soundtrack +99 Crystal +100 Atmosphere +101 Brightness +102 Goblin +103 Echo drops +104 Star theme +105 Sitar +106 Banjo +107 Shamisen +108 Koto +109 Kalimba +110 Bagpipe +111 Fiddle +112 Shanai +113 Tinkle bell +114 Agogô +115 Steel drums +116 Woodblock +117 Taiko drum +118 Melodic tom +119 Synth drum +120 Reverse cymbal +121 Guitar fret +122 Breath +123 Seashore +124 Bird tweet +125 Telephone Ring +126 Helicopter +127 Applause +128 Gunshot + + + 1 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 4 + 4 + True + + + True + True + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + gtk-media-play + True + 0 + + + + + True + True + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + gtk-media-stop + True + 0 + + + 1 + + + + + 2 + + + + + + diff --git a/src/Main/Gtk.hs b/src/Main/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Main/Gtk.hs @@ -0,0 +1,52 @@ +module Main where + +import MidiSynth +import qualified Codec.SoundFont as SF +import Player.Gtk +import SynthParams + +import Data.Char +import Numeric +import Control.Monad +import System.IO +import System.Environment +import System.Console.GetOpt + +data Flag = + SampleRate String + | SoundFontFile FilePath + | MidiFile FilePath + | Output FilePath + deriving Show + +options :: [OptDescr Flag] +options = + [ Option ['r'] ["samplerate"] (ReqArg SampleRate "SAMPLERATE") + "synthesizer sampling rate" + , Option ['s'] ["soundfont"] (ReqArg SoundFontFile "FILE") + "SoundFont FILE" + ] + +main :: IO () +main = do + argv <- getArgs + (sampleRate', soundFontFile) <- + case getOpt Permute options argv of + ([SampleRate srs, SoundFontFile sf], _,_) -> do + sr <- case (readDec srs) of + [] -> fail "SAMPLERATE must be a decimal integer number" + (i,_) : _ -> return i + return (sr, sf) + _ -> fail $ usageInfo "all options are mandatory\n" options + + putStrLn "Importing SoundFont file ... This may take a while ..." + eSoundFont <- SF.importFile soundFontFile + soundFont <- case eSoundFont of + Left err -> fail err + Right sf -> return sf + putStrLn "Done." + + putStrLn "If you are getting interruptions decrase sampling rate." + let paramsGen = soundFontToSynthParams soundFont + Player.Gtk.play sampleRate' (1024) (midiSynth paramsGen) + putStrLn "Done." diff --git a/src/Main/OpenAL.hs b/src/Main/OpenAL.hs new file mode 100644 --- /dev/null +++ b/src/Main/OpenAL.hs @@ -0,0 +1,66 @@ +module Main where + +import MidiSynth +import qualified Codec.SoundFont as SF +import qualified Codec.Midi as Midi +import Player.OpenAL +import SynthParams + +import FRP.Yampa + +import Data.Char +import Numeric +import Control.Monad +import System.IO +import System.Environment +import System.Console.GetOpt + +data Flag = + SampleRate String + | SoundFontFile FilePath + | MidiFile FilePath + | Output FilePath + deriving Show + +options :: [OptDescr Flag] +options = + [ Option ['r'] ["samplerate"] (ReqArg SampleRate "SAMPLERATE") + "synthesizer sampling rate" + , Option ['s'] ["soundfont"] (ReqArg SoundFontFile "FILE") + "SoundFont FILE" + , Option ['m'] ["midi"] (ReqArg MidiFile "FILE") + "midi FILE to synthesize" + ] + +main :: IO () +main = do + argv <- getArgs + (sampleRate', soundFontFile, midiFile) <- + case getOpt Permute options argv of + ([SampleRate srs, SoundFontFile sf, MidiFile mf], _,_) -> do + sr <- case (readDec srs) of + [] -> fail "SAMPLERATE must be a decimal integer number" + (i,_) : _ -> return i + return (sr, sf, mf) + _ -> fail $ usageInfo "all options are mandatory\n" options + + putStrLn "Importing MIDI File ..." + eMidi <- Midi.importFile midiFile + midi <- case eMidi of + Left err -> fail err + Right midi -> return midi + putStrLn "Done." + + putStrLn "Importing SoundFontFile ... This may take a while ..." + eSoundFont <- SF.importFile soundFontFile + soundFont <- case eSoundFont of + Left err -> fail err + Right sf -> return sf + putStrLn "Done." + + putStrLn "Now you should hear something ..." + putStrLn "If you are getting interruptions decrase sampling rate." + let paramsGen = soundFontToSynthParams soundFont + signalFunction = midiToEventSource midi >>> midiSynth paramsGen + Player.OpenAL.play sampleRate' (256 * 1024) signalFunction + putStrLn "Done." diff --git a/src/Main/Wav.hs b/src/Main/Wav.hs new file mode 100644 --- /dev/null +++ b/src/Main/Wav.hs @@ -0,0 +1,67 @@ +module Main where + +import MidiSynth +import qualified Codec.SoundFont as SF +import qualified Codec.Midi as Midi +import Player.Wav +import SynthParams + +import FRP.Yampa + +import Data.Char +import Numeric +import Control.Monad +import System.IO +import System.Environment +import System.Console.GetOpt + +data Flag = + SampleRate String + | SoundFontFile FilePath + | MidiFile FilePath + | Output FilePath + deriving Show + +options :: [OptDescr Flag] +options = + [ Option ['r'] ["samplerate"] (ReqArg SampleRate "SAMPLERATE") + "synthesizer sampling rate" + , Option ['s'] ["soundfont"] (ReqArg SoundFontFile "FILE") + "SoundFont FILE" + , Option ['m'] ["midi"] (ReqArg MidiFile "FILE") + "midi FILE to synthesize" + , Option ['o'] ["output"] (ReqArg Output "FILE") + "output FILE (.wav file), if FILE argument ommited audio will be sent to sound card in real-time" + ] + +main :: IO () +main = do + argv <- getArgs + (sampleRate', soundFontFile, midiFile, wavFile) <- + case getOpt Permute options argv of + ([SampleRate srs, SoundFontFile sf, MidiFile mf, Output wf], _,_) -> do + sr <- case (readDec srs) of + [] -> fail "SAMPLERATE must be a decimal integer number" + (i,_) : _ -> return i + return (sr, sf, mf, wf) + _ -> fail $ usageInfo "all options are mandatory\n" options + + putStrLn "Importing MIDI File ..." + eMidi <- Midi.importFile midiFile + midi <- case eMidi of + Left err -> fail err + Right midi -> return midi + putStrLn "Done." + + putStrLn "Importing SoundFontFile ... This may take a while ..." + eSoundFont <- SF.importFile soundFontFile + soundFont <- case eSoundFont of + Left err -> fail err + Right sf -> return sf + putStrLn "Done." + + putStrLn $ "Writing WAV audio data to '" ++ wavFile ++ "' ..." + let paramsGen = soundFontToSynthParams soundFont + sf = midiToEventSource midi >>> midiSynth paramsGen + Player.Wav.play wavFile sampleRate' sf + putStrLn "Done." diff --git a/src/MidiSynth.hs b/src/MidiSynth.hs new file mode 100644 --- /dev/null +++ b/src/MidiSynth.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE Arrows #-} + +module MidiSynth ( + midiSynth + , midiToEventSource + ) where + +import qualified SynthParams as SP +import SynthBasics + +import Data.Audio +import Codec.Midi hiding (Time) + +import FRP.Yampa + +import qualified Data.Map as Map + +type MidiSynth = SF (Event [Message]) (Sample, Event ()) +type Col a = Map.Map (Channel,Key) a + +eventToList :: Event [a] -> [a] +eventToList me = if isEvent me then fromEvent me else [] + +synthParamsToMonoSynth :: SP.SynthParams -> MidiSynth +synthParamsToMonoSynth params = proc me -> do + e <- iEdge False -< any msgPred (eventToList me) + s <- oscSampleBased params -< (0,e) + (cv,end) <- envGen 0 adsr (Just 2) -< e + sample <- amp 0.125 (SP.velocity params) -< (s,cv) +-- cv <- oscSine 1.5 >>> arr( + 1) -< 0 +-- s <- moogVCF 48000 (19000) 0.0 -< (s,0) + returnA -< (sample,end) + where + adsr = [(0.001,1.0),(0.001,0.80),(0.24,0.0)] + msgPred msg = (isNoteOff msg || isNoteOn msg && velocity msg == 0) + && (key msg == SP.key params) + && (channel msg == SP.channel params) + +midiToEventSource :: Midi -> SF a (Event [Message]) +midiToEventSource m = afterEachCat + $! toRealTime (timeDiv m') + $! head + $! tracks m' + where + m' = toSingleTrack m + +data SynthState = SynthState { + channelState :: Map.Map Channel (Bank,Preset) +-- , synthParams :: Map.Map (Bank, Preset, Key, Channel, Velocity) +-- SP.SynthParams + } + +defaultSynthState :: SynthState +defaultSynthState = SynthState { + channelState = Map.singleton 9 (128,0) +-- , synthParams = Map.empty + } + +getChannelState :: Channel -> SynthState -> (Bank,Preset) +getChannelState c s = Map.findWithDefault (0,0) c (channelState s) + +updateSynthState :: Message -> SynthState -> SynthState +updateSynthState (ProgramChange c p) s = s {channelState = + Map.insertWith (\_ (b,_) -> (b,p)) c (0,p) (channelState s)} +updateSynthState (ControlChange c 0 b) s = s {channelState = -- Bank Select + Map.insertWith (\_ (_,p) -> (b,p)) c (b,0) (channelState s)} +updateSynthState _ s = s + +triggerChange :: SynthState -> + SF (Event [Message], Col (Sample, Event ())) + (Event ([(Channel, Key, Velocity)], [(Channel,Key)], SynthState)) +triggerChange initState = proc (me, ses) -> do + let msgList = eventToList me + onMsgs = filter (\msg -> isNoteOn msg && velocity msg > 0) msgList + ons = map (\m -> (channel m, key m, velocity m)) onMsgs + newState = foldr updateSynthState initState msgList + offs = Map.keys $ Map.filter (isEvent . snd) ses + e <- iEdge False -< not (null ons) + || not (null offs) + || (channelState newState /= channelState initState) + returnA -< tag e (ons,offs,newState) + +performChange :: + SP.SynthParamsGen + -> Col MidiSynth + -> ([(Channel, Key, Velocity)], [(Channel,Key)], SynthState) + -> SF (Event [Message]) (Col (Sample, Event ())) +performChange paramsGen sfs (ons,offs,synthState) = + pSwitchB sfs2 (noEvent --> triggerChange synthState) (performChange paramsGen) + where + sfs1 = foldr (Map.delete) sfs offs + sfs2 = foldr (\(c,k,v) col -> insertSynth c k v col) sfs1 ons + cmbSynths :: MidiSynth -> MidiSynth -> MidiSynth + cmbSynths newSF oldSF = noEvent >-- proc midiEvent -> do + s1 <- switch sf (\_ -> constant 0) -< () + (s2,e2) <- newSF -< midiEvent + returnA -< (s1 + s2, e2) + where + sf = proc () -> do + (cv,e) <- envGen 1.0 [(0.001, 0.0)] Nothing -< noEvent + (s,_) <- oldSF -< noEvent + returnA -< (s * cv,e) + + insertSynth :: Channel -> Key -> Velocity -> Col MidiSynth -> Col MidiSynth + insertSynth c k v col = case paramsGen b p c k v of + (Just params) -> Map.insertWith (cmbSynths) (c,k) + (synthParamsToMonoSynth params) col + Nothing -> col + where (b,p) = getChannelState c synthState + +midiSynth :: SP.SynthParamsGen -> MidiSynth +midiSynth paramsGen = proc me -> do + ses <- pSwitchB Map.empty (triggerChange defaultSynthState) + (performChange paramsGen) -< me + end <- iEdge False -< any isTrackEnd (eventToList me) +-- end <- after 15.0 () -< () +-- smpl <- mixer -< Map.elems $ Map.map fst ses + let smpl = Map.fold (\(s,_) s' -> s + s') 0 ses + returnA -< (smpl, end) diff --git a/src/Player/Gtk.hs b/src/Player/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Player/Gtk.hs @@ -0,0 +1,187 @@ +module Player.Gtk (Player.Gtk.play) where + +import Paths_YampaSynth (getDataFileName) + +import Player.OpenAL + +import Codec.Midi +import Data.Audio + +import FRP.Yampa + +import Data.Int +import qualified Data.Map as Map +import Data.IORef +import Control.Concurrent +import Foreign.Storable +import Foreign.Marshal.Alloc + +import Graphics.UI.Gtk hiding (Event) +import Graphics.UI.Gtk.Glade + +import Sound.OpenAL + +play :: Int -> Int -> SF (Event [Message]) (Sample, Event ()) -> IO () +play sampleRate' sampleNumber' synth = do + (device,context,pSource,pBuffer) <- initOpenAL + mVarMessage <- newEmptyMVar + mVarReplyGui <- newEmptyMVar + mVarKeyboardActive <- newEmptyMVar + refKeyboardStatus <- newIORef $ (Map.empty :: Map.Map String ()) + + unsafeInitGUIForThreadedRTS --initGUI + + guiDescFile <- getDataFileName "gui/YampaSynth.glade" + Just xml <- xmlNew guiDescFile + + window <- xmlGetWidget xml castToWindow "window1" + onDestroy window $ do + deInitOpenAL device context pSource pBuffer + mainQuit + let + onKeyPressWindow e = do + b <- isEmptyMVar mVarKeyboardActive + if b + then return () + else do + let k = eventKeyName e + m <- readIORef refKeyboardStatus + if Map.member k m + then return () + else do + writeIORef refKeyboardStatus (Map.insert k () m) + putMVar mVarMessage (NoteOn {channel = 0, key = str2key k, velocity = 85}) + return True + onKeyReleaseWindow e = do + b <- isEmptyMVar mVarKeyboardActive + if b + then return () + else do + let k = eventKeyName e + modifyIORef refKeyboardStatus (\m -> Map.delete k m) + putMVar mVarMessage (NoteOff {channel = 0, key = str2key k, velocity = 85}) + return True + onKeyPress window onKeyPressWindow + onKeyRelease window onKeyReleaseWindow + + combobox <- xmlGetWidget xml castToComboBox "combobox1" + comboBoxSetActive combobox 0 + + onChanged combobox $ do + b <- isEmptyMVar mVarKeyboardActive + if b + then return () + else do + mi <- comboBoxGetActive combobox + case mi of + Nothing -> return () + Just i -> putMVar mVarMessage (ProgramChange { channel = 0, preset = fromIntegral i }) + return () + + playButton <- xmlGetWidget xml castToButton "button1" + stopButton <- xmlGetWidget xml castToButton "button2" + widgetSetSensitivity stopButton False + + onClicked playButton $ do + forkIO $ runSynth sampleRate' sampleNumber' pSource pBuffer + mVarMessage mVarReplyGui synth + widgetSetSensitivity playButton False + widgetSetSensitivity stopButton True + mi <- comboBoxGetActive combobox + case mi of + Nothing -> return () + Just i -> putMVar mVarMessage (ProgramChange { channel = 0, preset = fromIntegral i }) + putMVar mVarKeyboardActive () + + onClicked stopButton $ do + putMVar mVarMessage TrackEnd + takeMVar mVarReplyGui + widgetSetSensitivity stopButton False + widgetSetSensitivity playButton True + takeMVar mVarKeyboardActive + + widgetShowAll window + mainGUI + +runSynth :: Int -> Int -> Source -> Buffer -> MVar Message -> MVar () + -> SF (Event [Message]) (Sample, Event ()) -> IO () +runSynth sampleRate' sampleNumber' pSource pBuffer mVarMessage mVarReplyGui synth = do + + mVarMaybeChunk <- newEmptyMVar + mVarReplyPlayer <- newEmptyMVar + + forkIO $ process sampleRate' pSource pBuffer mVarMaybeChunk mVarReplyPlayer + + ir <- newIORef (0 :: Int) + let sampleSize = sizeOf (undefined :: Int16) + chunkSize' = sampleNumber' * sampleSize + chunkData' <- mallocBytes chunkSize' + + let chunk = Chunk chunkData' chunkSize' + sense _ = do + let dt = 1.0 / fromIntegral sampleRate' + maybeMsg <- tryTakeMVar mVarMessage + case maybeMsg of + Nothing -> return (dt, Just noEvent) + Just msg -> return (dt, Just (Event [msg])) + actuate _ (s,e) = if (isEvent e) + then return True + else do + i <- readIORef ir + pokeElemOff (chunkData chunk) i (fromSample s) + if i == (sampleNumber' - 1) + then do + putMVar mVarMaybeChunk (Just chunk) + takeMVar mVarReplyPlayer + writeIORef ir 0 + return False + else do + writeIORef ir (i + 1) + return False + + reactimate (return noEvent) sense actuate synth + + i <- readIORef ir + putMVar mVarMaybeChunk (Just $ chunk {chunkSize = i * sampleSize}) + takeMVar mVarReplyPlayer + putMVar mVarMaybeChunk Nothing + takeMVar mVarReplyPlayer + + free (chunkData chunk) + putMVar mVarReplyGui () + + +str2key :: String -> Key +str2key s = case s of + "p" -> 64 + "0" -> 63 + "o" -> 62 + "9" -> 61 + "i" -> 60 + "u" -> 59 + "7" -> 58 + "y" -> 57 + "6" -> 56 + "t" -> 55 + "5" -> 54 + "r" -> 53 + "e" -> 52 + "3" -> 51 + "w" -> 50 + "2" -> 49 + "q" -> 48 + + "m" -> 59 - 12 + "j" -> 58 - 12 + "n" -> 57 - 12 + "h" -> 56 - 12 + "b" -> 55 - 12 + "g" -> 54 - 12 + "v" -> 53 - 12 + "c" -> 52 - 12 + "d" -> 51 - 12 + "x" -> 50 - 12 + "s" -> 49 - 12 + "z" -> 48 - 12 + + _ -> 0 diff --git a/src/Player/OpenAL.hs b/src/Player/OpenAL.hs new file mode 100644 --- /dev/null +++ b/src/Player/OpenAL.hs @@ -0,0 +1,141 @@ +module Player.OpenAL ( + Player.OpenAL.play + , initOpenAL + , deInitOpenAL + , process + , Chunk (..) + ) where + +import Data.Audio + +import FRP.Yampa + +import Sound.OpenAL + +import Data.Maybe +import Data.Int +import Data.IORef +import Control.Monad +import Foreign.Storable +import Foreign.Marshal.Alloc +import Foreign.Storable +import Foreign.Ptr +import Control.Concurrent + +play ::Int -> Int -> SF () (Sample, Event ()) -> IO () +play sampleRate' sampleNumber' sf = do + mVarEnd <- newEmptyMVar + forkIO $ (play' sampleRate' sampleNumber' sf) >> putMVar mVarEnd () + takeMVar mVarEnd + return () + +play' ::Int -> Int -> SF () (Sample, Event ()) -> IO () +play' sampleRate' sampleNumber' sf = do + (device,context,pSource,pBuffer) <- initOpenAL + + mVarMaybeChunk <- newEmptyMVar + mVarReply <- newEmptyMVar + + forkIO $ process sampleRate' pSource pBuffer mVarMaybeChunk mVarReply + + ir <- newIORef (0 :: Int) + let sampleSize = sizeOf (undefined :: Int16) + chunkSize' = sampleNumber' * sampleSize + chunkData' <- mallocBytes chunkSize' + + let chunk = Chunk chunkData' chunkSize' + sense _ = return (1.0 / fromIntegral sampleRate', Just ()) + actuate _ (s,e) = if (isEvent e) + then return True + else do + i <- readIORef ir + pokeElemOff (chunkData chunk) i (fromSample s) + if i == (sampleNumber' - 1) + then do + putMVar mVarMaybeChunk (Just chunk) + takeMVar mVarReply + writeIORef ir 0 + return False + else do + writeIORef ir (i + 1) + return False + + reactimate (return ()) sense actuate sf + + i <- readIORef ir + putMVar mVarMaybeChunk (Just $ chunk {chunkSize = i * sampleSize}) + takeMVar mVarReply + putMVar mVarMaybeChunk Nothing + takeMVar mVarReply + + deInitOpenAL device context pSource pBuffer + free (chunkData chunk) + + +initOpenAL :: IO (Device, Context, Source, Buffer) +initOpenAL = do + mDevice <- openDevice Nothing + case mDevice of + Nothing -> fail "opening OpenAL device" + Just device -> do + mContext <- createContext device [ +-- Frequency (fromIntegral 44100) +-- , Refresh (fromIntegral 44101) +-- Frequency (fromIntegral sampleRate) +-- , MonoSources 1 +-- , StereoSources 0 + ] + case mContext of + Nothing -> fail "opening OpenAL context" + Just context -> do + currentContext $= Just context + [pSource] <- genObjectNames 1 + [pBuffer] <- genObjectNames 1 + queueBuffers pSource [pBuffer] + return (device,context,pSource,pBuffer) + +deInitOpenAL :: Device -> Context -> Source -> Buffer -> IO () +deInitOpenAL device context pSource pBuffer = do + unqueueBuffers pSource [pBuffer] + deleteObjectNames [pSource] + deleteObjectNames [pBuffer] + currentContext $= Nothing + destroyContext context + b <- closeDevice device + case b of + True -> return () + False -> fail "closing OpenAL device" + +data Chunk = Chunk { + chunkData :: Ptr Int16 + , chunkSize :: Int + } deriving (Eq, Show) + +process :: Int -> Source -> Buffer -> MVar (Maybe Chunk) -> MVar () -> IO () +process sampleRate' pSource pBuffer mVarMaybeChunk mVarReply = do + mChunk <- takeMVar mVarMaybeChunk + case mChunk of + Nothing -> do + waitForSource pSource + putMVar mVarReply () + Just chunk -> do + (bufferData pBuffer) $= createBufferData sampleRate' chunk + putMVar mVarReply () + Sound.OpenAL.play [pSource] + waitForSource pSource + process sampleRate' pSource pBuffer mVarMaybeChunk mVarReply + +createBufferData :: Int -> Chunk -> BufferData Int16 +createBufferData sampleRate' chunk = + BufferData (MemoryRegion (chunkData chunk) (fromIntegral $ chunkSize chunk)) + Mono16 + (fromIntegral sampleRate') + +waitForSource :: Source -> IO () +waitForSource pSource = do + state <- get (sourceState pSource) + case state of + Playing -> do + threadDelay 10 -- micro seconds + waitForSource pSource + _ -> return () diff --git a/src/Player/Wav.hs b/src/Player/Wav.hs new file mode 100644 --- /dev/null +++ b/src/Player/Wav.hs @@ -0,0 +1,42 @@ +module Player.Wav (play) where + +import Data.Audio +import Codec.Wav +import Data.ByteString.Builder + +import FRP.Yampa + +import Data.Int +import Data.Array.IArray +import Data.ByteString.Lazy +import System.IO + +play :: FilePath -> Int -> SF () (Sample, Event ()) -> IO () +play filePath sampleRate' signalFunction = do + h <- openFile filePath WriteMode + hSetBuffering h (BlockBuffering (Just 1024)) + let a = Audio { + sampleRate = sampleRate' + , channelNumber = 1 + , sampleData = array (0,0) [(0,0)] + } :: Audio Int16 + hPut h (toLazyByteString $ buildWav a) + let sense _ = return (1.0 / fromIntegral (sampleRate a), Just ()) + actuate _ (_,e) | isEvent e = return True + actuate _ (s,_) = do + hPut h (toLazyByteString $ buildSample ((fromSample s) :: Int16)) + return False + reactimate (return ()) sense actuate signalFunction + hClose h + correctWavHeader filePath + +correctWavHeader :: FilePath -> IO () +correctWavHeader filePath = do + h <- openFile filePath ReadWriteMode + hSetBuffering h NoBuffering + s <- hFileSize h + hSeek h AbsoluteSeek 0x04 + hPut h (toLazyByteString $ putWord32le $ fromIntegral $ s - 0x04 - 4) + hSeek h AbsoluteSeek 0x28 + hPut h (toLazyByteString $ putWord32le $ fromIntegral $ s - 0x28 - 4) + hClose h diff --git a/src/SynthBasics.hs b/src/SynthBasics.hs new file mode 100644 --- /dev/null +++ b/src/SynthBasics.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE Arrows #-} + +module SynthBasics ( + oscSine + , oscSine' + , amp + , envGen + , oscSampleBased + , mixer + , moogVCF + , CV + , Frequency + , Resonance + ) where + +import FRP.Yampa +import Data.Audio hiding (sampleRate) +import Codec.Midi hiding (Time) +import SynthParams + +type CV = Double +type Frequency = Double +type Resonance = Double -- 0 - 1 + +oscSine :: Frequency -> SF CV Sample +oscSine f0 = proc cv -> do + let f = f0 * (2 ** cv) + phi <- integral -< 2 * pi * f + returnA -< sin phi + +oscSine' :: Frequency -> SF a Sample +oscSine' f0 = time >>> arr (sin . (2 * pi * f0 *)) + +amp :: CV -> Velocity -> SF (Sample, CV) Sample +amp volumeLevel vel = proc (smpl,cv) -> do + returnA -< (fromIntegral vel / 127) * smpl * cv * volumeLevel + +envGen :: CV -> [(Time,CV)] -> Maybe Int + -> SF (Event ()) (CV, Event ()) +envGen l0 tls Nothing = envGenAux l0 tls &&& after (sum (map fst tls)) () +envGen l0 tls (Just n) = + switch (proc release -> do + l <- envGenAux l0 tls1 -< () + returnA -< ((l, noEvent), release `tag` l)) + (\l -> envGenAux l tls2 &&& after (sum (map fst tls2)) ()) + where + (tls1, tls2) = splitAt n tls + +envGenAux :: CV -> [(Time,CV)] -> SF a CV +envGenAux l0 tls = afterEach trs >>> hold r0 >>> integral >>^ (+ l0) + where + (r0, trs) = toRates l0 tls + +toRates :: CV -> [(Time, CV)] -> (Double, [(Time, Double)]) +toRates _ [] = (0, []) +toRates l0 ((t,l):tls) = (((l - l0) / t), trAux t l tls) + +trAux :: Time -> CV -> [(Time, CV)] -> [(Time, Double)] +trAux t _ [] = [(t, 0)] +trAux t l ((t',l'):tls) = (t, (l' - l) / t') : trAux t' l' tls + +moogVCF :: Int -> Frequency -> Resonance -> SF (Sample, CV) Sample +moogVCF sr f0 r = proc (x, cv) -> do + let f = f0 * (2 ** cv) + g = 1 - exp (-2 * pi * f / fromIntegral sr) + rec ya <- moogAux -< (x - 4 * r * y, g) + yb <- moogAux -< (ya, g) + yc <- moogAux -< (yb, g) + yd <- moogAux -< (yc, g) + + -- 1/2-sample delay for phase compensation + ye <- iPre 0 -< yd + y <- iPre 0 -< (ye + yd) / 2 + returnA -< y + where + vt = 40000 -- 2 * Vt + moogAux = proc (x,g) -> do + rec let y = ym1 + vt * g * (tanh (x / vt) - tanh (ym1 / vt)) + ym1 <- iPre 0 -< y + returnA -< y + +oscSampleBasedAux :: SynthParams -> SF CV (Sample, Int, Int) +oscSampleBasedAux params = proc cv -> do + phi <- integral -< (freq params) / (rootFreq params) * (2 ** cv) + let (n,f) = properFraction (phi * (fromIntegral $ sampleRate params)) + p1 = posAux n + s1 = g p1 + p2 = posAux (n + 1) + s2 = g p2 + returnA -< (s1 + f * (s2 - s1), p2, n) + where + g = sampleGen params + s = start params + m = startLoop params + e = endLoop params + posAux n = if (s + n < m) + then s + n + else m + mod (s + n - m) (e - m) + +oscSampleBased :: SynthParams -> SF (CV, Event ()) Sample +oscSampleBased params | sampleMode params == NoLoop = + switch ( + proc (cv,_) -> do + (smpl,_,n) <- oscSampleBasedAux params -< cv + e <- iEdge False -< start params + n >= end params + returnA -< (smpl,e) + ) (\_ -> constant 0.0) +oscSampleBased params | sampleMode params == ContLoop = + proc (cv,_) -> do + (smpl,_,_) <- oscSampleBasedAux params -< cv + returnA -< smpl +oscSampleBased params {- | sampleMode params == Audio.PressLoop -} = + proc (cv,e) -> do + smpl <- switch auxSF1 auxSF2 -< (cv,e) + returnA -< smpl + where + auxSF1 = proc (cv,e) -> do + (smpl,p,_) <- oscSampleBasedAux params -< cv + returnA -< (smpl, tag e p ) + auxSF2 s = oscSampleBased (params {start = s, sampleMode = NoLoop}) + +mixer :: SF [Sample] Sample +mixer = arr sum diff --git a/src/SynthParams.hs b/src/SynthParams.hs new file mode 100644 --- /dev/null +++ b/src/SynthParams.hs @@ -0,0 +1,219 @@ +module SynthParams ( + SynthParams (..) + , soundFontToSynthParams + , SynthParamsGen + , toFreq + ) where + +import qualified Codec.SoundFont as SF +import qualified Data.Audio as Audio +import qualified Codec.Midi as Midi + +import Data.List +import Data.Array.IArray +import Data.Word + +import Control.Monad +import Control.Applicative + + +toFreq :: Midi.Key -> Int -> Double +toFreq key' correction' = + let k = fromIntegral key' + (fromIntegral correction' / 100) - 69 + in 440 * 2 ** (k / 12) + +data SynthParams = SynthParams { + sampleGen :: Int -> Audio.Sample + , start :: !Int + , end :: !Int + , startLoop :: !Int + , endLoop :: !Int + , sampleMode :: !Audio.SampleMode + , sampleRate :: !Int +-- , envelope :: [(Double,Double)] -- [(Time, CV)] + , rootKey :: !Int + , rootFreq :: !Double + , key :: !Int + , freq :: !Double + , channel :: !Int + , velocity :: !Int + } -- deriving (Show) + + +type SynthParamsGen = + Midi.Bank -> Midi.Preset -> Midi.Channel -> Midi.Key -> Midi.Velocity + -> Maybe SynthParams + + +data SoundFontParams = SoundFontParams { + sfStart :: Word + , sfEnd :: Word + , sfStartLoop :: Word + , sfEndLoop :: Word + , sfSampleMode :: Audio.SampleMode + , sfSampleRate :: Word + , sfRootKey :: Word + , sfRootKeyCorrection :: Int + , sfKey :: Word + , sfVel :: Word + , sfCoarseTune :: Int + , sfFineTune :: Int +-- , sfDelayVolEnv :: Int +-- , sfAttackVolEnv :: Int +-- , sfHoldVolEnv :: Int +-- , sfDecayVolEnv :: Int +-- , sfSustainVolEnv :: Int +-- , sfReleaseVolEnv :: Int + } + + +-- For subset of generators I am dealing here this definition is OK +-- But in general preset and instrument generator should be handeled separatly +applyGen :: SF.Generator -> SoundFontParams -> SoundFontParams +applyGen g p = case g of + SF.StartAddressOffset v -> + p {sfStart = fromIntegral $ (fromIntegral $ sfStart p) + v} + SF.EndAddressOffset v -> + p {sfEnd = fromIntegral $ (fromIntegral $ sfEnd p) + v} + SF.LoopStartAddressOffset v -> + p {sfStartLoop = fromIntegral $ (fromIntegral $ sfStartLoop p) + v} + SF.LoopEndAddressOffset v -> + p {sfEndLoop = fromIntegral $ (fromIntegral $ sfEndLoop p) + v} + SF.StartAddressCoarseOffset v -> + p {sfStart = fromIntegral $ (fromIntegral $ sfStart p) + v * 2 ^ (15::Int)} + SF.EndAddressCoarseOffset v -> + p {sfEnd = fromIntegral $ (fromIntegral $ sfEnd p) + v * 2 ^ (15::Int)} + SF.LoopStartAddressCoarseOffset v -> + p {sfStartLoop = fromIntegral $ (fromIntegral $ sfStartLoop p) + v * 2 ^ (15::Int)} + SF.LoopEndAddressCoarseOffset v -> + p {sfEndLoop = fromIntegral $ (fromIntegral $ sfEndLoop p) + v * 2 ^ (15::Int)} + + SF.RootKey v -> p {sfRootKey = v} + SF.SampleMode v -> p {sfSampleMode = v} + + SF.Key v -> p {sfKey = v} + SF.Vel v -> p {sfVel = v} + + SF.CoarseTune v -> p {sfCoarseTune = sfCoarseTune p + v} + SF.FineTune v -> p {sfFineTune = sfFineTune p + v} + +-- SF.DelayVolEnv v -> p {sfDelayVolEnv = v} +-- SF.AttackVolEnv v -> p {sfAttackVolEnv = v} +-- SF.HoldVolEnv v -> p {sfHoldVolEnv = v} +-- SF.DecayVolEnv v -> p {sfDecayVolEnv = v} +-- SF.SustainVolEnv v -> p {sfSustainVolEnv = v} +-- SF.ReleaseVolEnv v -> p {sfReleaseVolEnv = v} + + _ -> p + +-- Is can be implemented way more efficiently by translating soundFont +-- to intermediate data structure more suitable for real-time scenarios +-- But this is ok for now, it implements subset of SoundFont standard +soundFontToSynthParams :: SF.SoundFont -> SynthParamsGen +soundFontToSynthParams sf b p c k v = do + (phdrNdx,phdr) <- find (\(_,phdr) -> SF.bank phdr == fromIntegral b + && SF.preset phdr == fromIntegral p) + (assocs phdrs) + let pBagNdx1 = SF.presetBagNdx phdr + pBagNdx2 = SF.presetBagNdx (phdrs ! (phdrNdx + 1)) - 1 + pgenss'' = [ [ pgens ! i' | i' <- [pGenNdx1 .. pGenNdx2]] + | i <- [pBagNdx1 .. pBagNdx2] + , let pGenNdx1 = (SF.genNdx $ pbags ! i) + , let pGenNdx2 = ((SF.genNdx $ pbags ! (i + 1)) - 1)] + guard $ (not $ null pgenss'') + let (pGlobalGens,pgenss') = case head pgenss'' of + [] -> ([],pgenss'') + gs -> if (not $ SF.isInstIndex $ last gs) + then (gs, tail pgenss'') + else ([], pgenss'') + (igens',iGlobalGens,pgens') <- foldr (<|>) Nothing (map f pgenss') + + SF.SampleIndex smplNdx <- find SF.isSampleIndex igens' + let shdr = shdrs ! smplNdx + defSFParams = SoundFontParams { + sfStart = SF.start shdr + , sfEnd = SF.end shdr + , sfStartLoop = SF.startLoop shdr + , sfEndLoop = SF.endLoop shdr + , sfRootKey = SF.originalPitch shdr + , sfRootKeyCorrection = SF.pitchCorrection shdr + , sfSampleRate = SF.sampleRate shdr + , sfSampleMode = Audio.NoLoop + , sfKey = fromIntegral k + , sfVel = fromIntegral v + , sfCoarseTune = 0 + , sfFineTune = 0 + +-- , sfDelayVolEnv = -12000 +-- , sfAttackVolEnv = -12000 +-- , sfHoldVolEnv = -12000 +-- , sfDecayVolEnv = -12000 +-- , sfSustainVolEnv = 0 +-- , sfReleaseVolEnv = -12000 + } + sfParams = foldr applyGen defSFParams (pGlobalGens ++ pgens' ++ iGlobalGens ++ igens') + let synthParams = SynthParams { + sampleGen = \i -> Audio.toSample $ (SF.smpl $ SF.sdta sf) ! i + , start = fromIntegral $ sfStart sfParams + , end = fromIntegral $ sfEnd sfParams + , startLoop = fromIntegral $ sfStartLoop sfParams + , endLoop = fromIntegral $ sfEndLoop sfParams + , sampleMode = sfSampleMode sfParams + , sampleRate = fromIntegral $ sfSampleRate sfParams + , rootKey = fromIntegral $ sfRootKey sfParams + , rootFreq = toFreq (fromIntegral $ sfRootKey sfParams) + (sfRootKeyCorrection sfParams) +-- , envelope = [ +-- ( 2 ** ((fromIntegral $ sfDelayVolEnv sfParams) / 1200) , 0) +-- , ( 2 ** ((fromIntegral $ sfAttackVolEnv sfParams) / 1200) , 1) +-- , ( 2 ** ((fromIntegral $ sfHoldVolEnv sfParams) / 1200) , 1) +-- , ( 2 ** ((fromIntegral $ sfDecayVolEnv sfParams) / 1200) , +-- let l = sfSustainVolEnv sfParams +-- in if (l <= 0) then 1 else 1 / ((fromIntegral l) * 10 ** (1 / 200)) +-- ) +-- , ( 2 ** ((fromIntegral $ sfReleaseVolEnv sfParams) / 1200) , 0) +-- ] + , key = k + , freq = toFreq ((fromIntegral $ sfKey sfParams) + sfCoarseTune sfParams) + (sfFineTune sfParams) + , channel = c + , velocity = fromIntegral $ sfVel sfParams + } + return +-- $ trace (show pGlobalGens ++ "\n" ++ show pgens' ++ "\n" +-- ++ show iGlobalGens ++ "\n" ++ show igens' ++ "\n" +-- ++ show (envelope synthParams) +-- ) + + $! synthParams + where + pdta = SF.pdta sf + phdrs = SF.phdrs pdta + pbags = SF.pbags pdta + pgens = SF.pgens pdta + insts = SF.insts pdta + ibags = SF.ibags pdta + igens = SF.igens pdta + shdrs = SF.shdrs pdta + + areSuitableGens gens = case gens of + (SF.KeyRange k1 k2 : _) | fromIntegral k < k1 || k2 < fromIntegral k -> False + (_ : SF.VelRange v1 v2 : _) | fromIntegral v < v1 || v2 < fromIntegral v -> False + (SF.VelRange v1 v2 : _) | fromIntegral v < v1 || v2 < fromIntegral v -> False + _ -> True + + f pgens'= do + SF.InstIndex instNdx <- find (SF.isInstIndex) pgens' + let iBagNdx1 = SF.instBagNdx $ insts ! instNdx + iBagNdx2 = (SF.instBagNdx $ insts ! (instNdx + 1)) - 1 + igenss'' = [ [ igens ! i' | i' <- [iGenNdx1 .. iGenNdx2]] + | i <- [iBagNdx1 .. iBagNdx2] + , let iGenNdx1 = (SF.genNdx $ ibags ! i) + , let iGenNdx2 = ((SF.genNdx $ ibags ! (i + 1)) - 1)] + (iGlobalGens,igenss') = case head igenss'' of + [] -> ([],igenss'') + gs -> if (not $ SF.isSampleIndex $ last gs) + then (gs, tail igenss'') + else ([], igenss'') + igens' <- find areSuitableGens igenss' + return $! (igens', iGlobalGens, pgens')