Initial commitHEADmaster

1 files changed, 132 insertions, 0 deletions

diff --git a/Wavedrum.hs b/Wavedrum.hs
new file mode 100644
index 0000000..0001098
--- /dev/null
+++ b/Wavedrum.hs
@@ -0,0 +1,132 @@
+{-
+wavedrum-lib, a library to parse, edit and write Korg Wavedrum programs.
+Copyright (C) 2013  Ricardo Wurmus
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program.  If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Wavedrum where
+
+import           Control.Monad (replicateM,mapM_)
+import           Data.Binary.Get
+import           Data.Binary.Put
+import qualified Data.ByteString.Lazy as B
+
+import           Wavedrum.Types
+import           Wavedrum.Algorithm
+
+byTarget :: Program -> Target -> [Param]
+byTarget prg t = filter (\param -> target param == t) prg
+
+parseProgram :: Get Program
+parseProgram = do
+  values1  <- replicateM  7 (fmap fromIntegral getWord16be)
+  headVals <- replicateM  8 (fmap fromIntegral getWord16be)
+  values2  <- replicateM  5 (fmap fromIntegral getWord16be)
+  rimVals  <- replicateM  8 (fmap fromIntegral getWord16be)
+  values3  <- replicateM 26 (fmap fromIntegral getWord16be)
+  let headSettings = getSettingsForAlg (last values1)
+  let rimSettings  = getSettingsForAlg (last values2)
+  return $ concat
+    [ zipWith ($) params1 values1
+    , zipWith ($) (zipWith3 ($) headParams (map fst headSettings) (map snd headSettings)) headVals
+    , zipWith ($) params2 values2
+    , zipWith ($) (zipWith3 ($) rimParams (map fst rimSettings) (map snd rimSettings)) rimVals
+    , zipWith ($) params3 values3
+    ]
+  where
+    getSettingsForAlg n =
+      if n > 0 && n < length algorithms
+      then algoParams $ algorithms !! (n - 1)
+      else replicate 8 ("<unused>", (0,0))
+    params1 =
+      [ Param HeadAlg "Pressure curve"           (  0,  5)
+      , Param General "Pre EQ"                   (  0,  4) -- H-H, H-S, S S, H-n, S-n
+      , Param HeadAlg "Tune"                     (  0,100)
+      , Param HeadAlg "Level"                    (  0,100)
+      , Param HeadAlg "Decay"                    (  0,100)
+      , Param HeadAlg "Pan"                      (-50, 50) -- L50..R50
+      , Param HeadAlg "Algorithm select"         (  1, 36) -- 01..36
+      ]
+    params2 =
+      [ Param RimAlg  "Tune"                     (  0,100)
+      , Param RimAlg  "Decay"                    (  0,100)
+      , Param RimAlg  "Level"                    (  0,100)
+      , Param RimAlg  "Pan"                      (-50, 50) -- L50..R50
+      , Param RimAlg  "Algorithm select"         (  1, 25)
+      ]
+    params3 =
+      [ Param HeadPCM "Tune"                     (-24, 24) -- semitones
+      , Param HeadPCM "Decay"                    (-99, 99)
+      , Param HeadPCM "Level"                    (  0,100)
+      , Param HeadPCM "Pan"                      (-50, 50) -- L50..R50
+      , Param HeadPCM "PCM instrument select"    (  0,100)
+      , Param HeadPCM "Velocity curve"           (  0,  9)
+      , Param HeadPCM "Pressure curve"           (  0,  5)
+      , Param HeadPCM "Pressure tune"            (-12, 12)
+      , Param HeadPCM "Pressure decay"           (-50, 50)
+      , Param RimPCM  "Tune"                     (-24, 24) -- semitones
+      , Param RimPCM  "Decay"                    (-99, 99)
+      , Param RimPCM  "Level"                    (  0,100)
+      , Param RimPCM  "Pan"                      (-50, 50) -- L50..R50
+      , Param RimPCM  "PCM instrument select"    (  0,100)
+      , Param RimPCM  "Velocity curve"           (  0,  9)
+      , Param RimPCM  "Pressure curve"           (  0,  5)
+      , Param RimPCM  "Pressure tune"            (-12, 12)
+      , Param RimPCM  "Pressure decay"           (-50, 50)
+      , Param General "Reverb type"              (  0, 10)
+      , Param General "Reverb effect level"      (  0,100)
+      , Param General "Reverb decay time"        (  0, 90)
+      , Param General "Reverb frequency damping" (  0,100)
+      , Param General "Delay feedback"           (  0, 99)
+      , Param General "Delay effect level"       (  0,100)
+      , Param General "Delay time"               (  0,200)
+      , Param General "Delay frequency damping"  (  0,100)
+      ]
+    headParams = replicate 8 $ Param HeadAlg
+    rimParams  = replicate 8 $ Param RimAlg
+
+readProgram :: B.ByteString -> Program
+readProgram = runGet parseProgram
+
+-- each Program is 108 bytes long (54 16-bit words)
+readAllPrograms :: B.ByteString -> [Program]
+readAllPrograms bs =
+  if B.null bs then []
+  else let (rawPrg, rest) = B.splitAt 108 bs in
+    readProgram rawPrg : readAllPrograms rest
+
+putRawParams :: Program -> Put
+putRawParams = mapM_ putRawParam
+  where putRawParam = putWord16be . fromIntegral . value
+
+serialize :: Program -> B.ByteString
+serialize p = runPut $ putRawParams p
+
+serializeAll :: [Program] -> B.ByteString
+serializeAll = B.concat . map serialize
+
+loadProgramFromFile :: String -> IO Program
+loadProgramFromFile f = fmap readProgram (B.readFile f)
+
+loadProgramsFromFile :: String -> IO [Program]
+loadProgramsFromFile f = fmap readAllPrograms (B.readFile f)
+
+writeProgramToFile :: String -> Program -> IO ()
+writeProgramToFile f p = B.writeFile f (serialize p)
+
+ppProgram :: Program -> IO ()
+ppProgram = mapM_ (putStrLn . show)
\ No newline at end of file