Initial commit
[wavedrum/wavedrum-lib.git] / Wavedrum.hs
1 {-
2 wavedrum-lib, a library to parse, edit and write Korg Wavedrum programs.
3 Copyright (C) 2013 Ricardo Wurmus
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17 -}
18
19 {-# LANGUAGE OverloadedStrings #-}
20
21 module Wavedrum where
22
23 import Control.Monad (replicateM,mapM_)
24 import Data.Binary.Get
25 import Data.Binary.Put
26 import qualified Data.ByteString.Lazy as B
27
28 import Wavedrum.Types
29 import Wavedrum.Algorithm
30
31 byTarget :: Program -> Target -> [Param]
32 byTarget prg t = filter (\param -> target param == t) prg
33
34 parseProgram :: Get Program
35 parseProgram = do
36 values1 <- replicateM 7 (fmap fromIntegral getWord16be)
37 headVals <- replicateM 8 (fmap fromIntegral getWord16be)
38 values2 <- replicateM 5 (fmap fromIntegral getWord16be)
39 rimVals <- replicateM 8 (fmap fromIntegral getWord16be)
40 values3 <- replicateM 26 (fmap fromIntegral getWord16be)
41 let headSettings = getSettingsForAlg (last values1)
42 let rimSettings = getSettingsForAlg (last values2)
43 return $ concat
44 [ zipWith ($) params1 values1
45 , zipWith ($) (zipWith3 ($) headParams (map fst headSettings) (map snd headSettings)) headVals
46 , zipWith ($) params2 values2
47 , zipWith ($) (zipWith3 ($) rimParams (map fst rimSettings) (map snd rimSettings)) rimVals
48 , zipWith ($) params3 values3
49 ]
50 where
51 getSettingsForAlg n =
52 if n > 0 && n < length algorithms
53 then algoParams $ algorithms !! (n - 1)
54 else replicate 8 ("<unused>", (0,0))
55 params1 =
56 [ Param HeadAlg "Pressure curve" ( 0, 5)
57 , Param General "Pre EQ" ( 0, 4) -- H-H, H-S, S S, H-n, S-n
58 , Param HeadAlg "Tune" ( 0,100)
59 , Param HeadAlg "Level" ( 0,100)
60 , Param HeadAlg "Decay" ( 0,100)
61 , Param HeadAlg "Pan" (-50, 50) -- L50..R50
62 , Param HeadAlg "Algorithm select" ( 1, 36) -- 01..36
63 ]
64 params2 =
65 [ Param RimAlg "Tune" ( 0,100)
66 , Param RimAlg "Decay" ( 0,100)
67 , Param RimAlg "Level" ( 0,100)
68 , Param RimAlg "Pan" (-50, 50) -- L50..R50
69 , Param RimAlg "Algorithm select" ( 1, 25)
70 ]
71 params3 =
72 [ Param HeadPCM "Tune" (-24, 24) -- semitones
73 , Param HeadPCM "Decay" (-99, 99)
74 , Param HeadPCM "Level" ( 0,100)
75 , Param HeadPCM "Pan" (-50, 50) -- L50..R50
76 , Param HeadPCM "PCM instrument select" ( 0,100)
77 , Param HeadPCM "Velocity curve" ( 0, 9)
78 , Param HeadPCM "Pressure curve" ( 0, 5)
79 , Param HeadPCM "Pressure tune" (-12, 12)
80 , Param HeadPCM "Pressure decay" (-50, 50)
81 , Param RimPCM "Tune" (-24, 24) -- semitones
82 , Param RimPCM "Decay" (-99, 99)
83 , Param RimPCM "Level" ( 0,100)
84 , Param RimPCM "Pan" (-50, 50) -- L50..R50
85 , Param RimPCM "PCM instrument select" ( 0,100)
86 , Param RimPCM "Velocity curve" ( 0, 9)
87 , Param RimPCM "Pressure curve" ( 0, 5)
88 , Param RimPCM "Pressure tune" (-12, 12)
89 , Param RimPCM "Pressure decay" (-50, 50)
90 , Param General "Reverb type" ( 0, 10)
91 , Param General "Reverb effect level" ( 0,100)
92 , Param General "Reverb decay time" ( 0, 90)
93 , Param General "Reverb frequency damping" ( 0,100)
94 , Param General "Delay feedback" ( 0, 99)
95 , Param General "Delay effect level" ( 0,100)
96 , Param General "Delay time" ( 0,200)
97 , Param General "Delay frequency damping" ( 0,100)
98 ]
99 headParams = replicate 8 $ Param HeadAlg
100 rimParams = replicate 8 $ Param RimAlg
101
102 readProgram :: B.ByteString -> Program
103 readProgram = runGet parseProgram
104
105 -- each Program is 108 bytes long (54 16-bit words)
106 readAllPrograms :: B.ByteString -> [Program]
107 readAllPrograms bs =
108 if B.null bs then []
109 else let (rawPrg, rest) = B.splitAt 108 bs in
110 readProgram rawPrg : readAllPrograms rest
111
112 putRawParams :: Program -> Put
113 putRawParams = mapM_ putRawParam
114 where putRawParam = putWord16be . fromIntegral . value
115
116 serialize :: Program -> B.ByteString
117 serialize p = runPut $ putRawParams p
118
119 serializeAll :: [Program] -> B.ByteString
120 serializeAll = B.concat . map serialize
121
122 loadProgramFromFile :: String -> IO Program
123 loadProgramFromFile f = fmap readProgram (B.readFile f)
124
125 loadProgramsFromFile :: String -> IO [Program]
126 loadProgramsFromFile f = fmap readAllPrograms (B.readFile f)
127
128 writeProgramToFile :: String -> Program -> IO ()
129 writeProgramToFile f p = B.writeFile f (serialize p)
130
131 ppProgram :: Program -> IO ()
132 ppProgram = mapM_ (putStrLn . show)