├── .gitignore ├── .hlint.yaml ├── ChinaCrash.xml ├── ChinaCrash1.xml ├── DGPatchMaker.cabal ├── DGPatchMaker.glade ├── DGPatchMaker.glade.backup ├── InstrumentPage.glade ├── LICENSE ├── README.md ├── Setup.hs ├── mapex_names.txt ├── modern_folk.txt ├── modern_folk_multi.txt ├── src ├── Data │ ├── Checkers.hs │ ├── Defaults.hs │ ├── DrumDrops │ │ ├── MapexKitParser.hs │ │ ├── ModernFolkParser.hs │ │ ├── Types.hs │ │ ├── Utils.hs │ │ └── VintageFolkParser.hs │ ├── Drumgizmo.hs │ ├── Export.hs │ ├── Import.hs │ ├── MultiVelocity.hs │ ├── Types.hs │ └── Version.hs ├── Gtk │ ├── ClickyKitDialog.hs │ ├── Colors.hs │ ├── DGPatchMakerBuilder.hs │ ├── DirectedChokeDialog.hs │ ├── Drumkit.hs │ ├── ErrorDialog.hs │ ├── FileHandlingDialog.hs │ ├── HitPowerDialog.hs │ ├── InstrumentFrame.hs │ ├── InstrumentPageBuilder.hs │ ├── MainWindow.hs │ ├── MidiMap.hs │ ├── NrHitsDialog.hs │ └── Utils.hs ├── GtkInterface.hs ├── Main.hs └── tests │ ├── CreateGladeSource.hs │ └── ParseTest.hs ├── stack.yaml ├── vintage_folk_multi.txt └── vintage_folk_names.txt /.gitignore: -------------------------------------------------------------------------------- 1 | .ghc.environment.x86_64-linux-8.4.4 2 | .ghc.environment.x86_64-linux-8.6.3 3 | dg.log 4 | DGPatchMaker.glade~ 5 | InstrumentPage.glade~ 6 | LICENSE.orig 7 | README.html 8 | dist/ 9 | dist-newstyle/ 10 | .stack-work 11 | 12 | src/Data/Types.hs.orig 13 | src/Gtk/.goutputstream-UA6RMY 14 | cabal.project.local~ 15 | cabal.project.local 16 | stack.yaml.lock 17 | 18 | stack.yaml.lock 19 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Warnings currently triggered by your code 10 | - ignore: {name: "Unused LANGUAGE pragma"} 11 | - ignore: {name: "Redundant do"} 12 | 13 | 14 | # Specify additional command line arguments 15 | # 16 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 17 | 18 | 19 | # Control which extensions/flags/modules/functions can be used 20 | # 21 | # - extensions: 22 | # - default: false # all extension are banned by default 23 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 24 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 25 | # 26 | # - flags: 27 | # - {name: -w, within: []} # -w is allowed nowhere 28 | # 29 | # - modules: 30 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 31 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 32 | # 33 | # - functions: 34 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 35 | 36 | 37 | # Add custom hints for this project 38 | # 39 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 40 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 41 | 42 | 43 | # Turn on hints that are off by default 44 | # 45 | # Ban "module X(module X) where", to require a real export list 46 | # - warn: {name: Use explicit module export list} 47 | # 48 | # Replace a $ b $ c with a . b $ c 49 | # - group: {name: dollar, enabled: true} 50 | # 51 | # Generalise map to fmap, ++ to <> 52 | # - group: {name: generalise, enabled: true} 53 | 54 | 55 | # Ignore some builtin hints 56 | # - ignore: {name: Use let} 57 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 58 | 59 | 60 | # Define some custom infix operators 61 | # - fixity: infixr 3 ~^#^~ 62 | 63 | 64 | # To generate a suitable file for HLint do: 65 | # $ hlint --default > .hlint.yaml 66 | -------------------------------------------------------------------------------- /ChinaCrash.xml: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 8 | 12 | 16 | 20 | 21 | 22 | 26 | 30 | 34 | 38 | 39 | 40 | 44 | 48 | 52 | 56 | 57 | 58 | 62 | 66 | 70 | 74 | 75 | 76 | 80 | 84 | 88 | 92 | 93 | 94 | 98 | 102 | 106 | 110 | 111 | 112 | 116 | 120 | 124 | 128 | 129 | 130 | 134 | 138 | 142 | 146 | 147 | 148 | 152 | 156 | 160 | 164 | 165 | 166 | 170 | 174 | 178 | 182 | 183 | 184 | 188 | 192 | 196 | 200 | 201 | 202 | 206 | 210 | 214 | 218 | 219 | 220 | 224 | 228 | 232 | 236 | 237 | 238 | 242 | 246 | 250 | 254 | 255 | 256 | 260 | 264 | 268 | 272 | 273 | 274 | 278 | 282 | 286 | 290 | 291 | 292 | 296 | 300 | 304 | 308 | 309 | 310 | 314 | 318 | 322 | 326 | 327 | 328 | 332 | 336 | 340 | 344 | 345 | 346 | 350 | 354 | 358 | 362 | 363 | 364 | 368 | 372 | 376 | 380 | 381 | 382 | 386 | 390 | 394 | 398 | 399 | 400 | 404 | 408 | 412 | 416 | 417 | 418 | 422 | 426 | 430 | 434 | 435 | 436 | 440 | 444 | 448 | 452 | 453 | 454 | 458 | 462 | 466 | 470 | 471 | 472 | 476 | 480 | 484 | 488 | 489 | 490 | 494 | 498 | 502 | 506 | 507 | 508 | 512 | 516 | 520 | 524 | 525 | 526 | 530 | 534 | 538 | 542 | 543 | 544 | 545 | -------------------------------------------------------------------------------- /ChinaCrash1.xml: -------------------------------------------------------------------------------- 1 |  2 | 3 | -------------------------------------------------------------------------------- /DGPatchMaker.cabal: -------------------------------------------------------------------------------- 1 | -- Initial DGPatchMaker.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | -- The name of the package. 5 | name: DGPatchMaker 6 | 7 | -- The package version. See the Haskell package versioning policy (PVP) 8 | -- for standards guiding when and how versions should be incremented. 9 | -- http://www.haskell.org/haskellwiki/Package_versioning_policy 10 | -- PVP summary: +-+------- breaking API changes 11 | -- | | +----- non-breaking API additions 12 | -- | | | +--- code changes with no API change 13 | version: 0.1.0.0 14 | 15 | -- A short (one-line) description of the package. 16 | synopsis: A patch editor for the drumgizmo plugin 17 | 18 | -- A longer description of the package. 19 | -- description: 20 | 21 | -- The license under which the package is released. 22 | license: BSD3 23 | 24 | -- The file containing the license text. 25 | license-file: LICENSE 26 | 27 | -- The package author(s). 28 | author: Michael Oswald 29 | 30 | -- An email address to which users can send suggestions, bug reports, and 31 | -- patches. 32 | maintainer: michael.oswald@onikudaki.net 33 | 34 | -- A copyright notice. 35 | -- copyright: 36 | 37 | category: Tool 38 | 39 | build-type: Simple 40 | 41 | -- Extra files to be distributed with the package, such as examples or a 42 | -- README. 43 | -- extra-source-files: 44 | 45 | -- Constraint on the version of Cabal needed to build this package. 46 | cabal-version: >=1.10 47 | 48 | 49 | executable DGPatchMaker 50 | -- .hs or .lhs file containing the Main module. 51 | main-is: Main.hs 52 | 53 | -- Modules included in this executable, other than Main. 54 | other-modules: 55 | Data.Checkers 56 | ,Data.DrumDrops.MapexKitParser 57 | ,Data.DrumDrops.ModernFolkParser 58 | ,Data.DrumDrops.Types 59 | ,Data.DrumDrops.Utils 60 | ,Data.DrumDrops.VintageFolkParser 61 | ,Data.Drumgizmo 62 | ,Data.Export 63 | ,Data.Import 64 | ,Data.Types 65 | ,Data.Defaults 66 | ,Data.Version 67 | ,Gtk.Colors 68 | ,Gtk.DGPatchMakerBuilder 69 | ,Gtk.Drumkit 70 | ,Gtk.ErrorDialog 71 | ,Gtk.FileHandlingDialog 72 | ,Gtk.HitPowerDialog 73 | ,Gtk.InstrumentFrame 74 | ,Gtk.InstrumentPageBuilder 75 | ,Gtk.MainWindow 76 | ,Gtk.MidiMap 77 | ,Gtk.NrHitsDialog 78 | ,Gtk.Utils 79 | ,Gtk.DirectedChokeDialog 80 | ,Gtk.ClickyKitDialog 81 | ,GtkInterface 82 | -- LANGUAGE extensions used by modules in this package. 83 | -- other-extensions: 84 | 85 | -- Other library packages from which modules are imported. 86 | build-depends: base, 87 | text, 88 | --text-format, 89 | text-builder, 90 | vector, 91 | directory, 92 | filepath, 93 | parsec, 94 | parsec-numbers, 95 | xmlgen, 96 | bytestring, 97 | hsndfile, 98 | hsndfile-vector, 99 | transformers, 100 | containers, 101 | filemanip, 102 | classy-prelude, 103 | resourcet, 104 | conduit, 105 | xml-conduit, 106 | xml-types, 107 | conduit-combinators, 108 | network-uri, 109 | gtk3, 110 | file-embed, 111 | gitrev, 112 | array 113 | 114 | ghc-options: -O2 -Wall -rtsopts -freverse-errors 115 | 116 | -- Directories containing source files. 117 | hs-source-dirs: src 118 | 119 | -- Base language which the package is written in. 120 | default-language: Haskell2010 121 | 122 | 123 | executable ParseTest 124 | -- .hs or .lhs file containing the Main module. 125 | main-is: tests/ParseTest.hs 126 | 127 | -- Modules included in this executable, other than Main. 128 | other-modules: 129 | Data.DrumDrops.MapexKitParser 130 | ,Data.DrumDrops.ModernFolkParser 131 | ,Data.DrumDrops.Types 132 | ,Data.DrumDrops.Utils 133 | ,Data.DrumDrops.VintageFolkParser 134 | ,Data.Drumgizmo 135 | ,Data.Export 136 | ,Data.Types 137 | -- LANGUAGE extensions used by modules in this package. 138 | -- other-extensions: 139 | 140 | -- Other library packages from which modules are imported. 141 | build-depends: base, 142 | text, 143 | text-format, 144 | vector, 145 | directory, 146 | filepath, 147 | parsec, 148 | xmlgen, 149 | bytestring, 150 | hsndfile, 151 | hsndfile-vector, 152 | transformers, 153 | resourcet, 154 | conduit, 155 | xml-conduit, 156 | xml-types, 157 | conduit-combinators, 158 | containers 159 | 160 | ghc-options: -O2 -Wall -rtsopts 161 | 162 | -- Directories containing source files. 163 | hs-source-dirs: src 164 | 165 | -- Base language which the package is written in. 166 | default-language: Haskell2010 167 | 168 | 169 | 170 | -- executable CreateGladeSource 171 | -- -- .hs or .lhs file containing the Main module. 172 | -- main-is: tests/CreateGladeSource.hs 173 | 174 | -- -- Modules included in this executable, other than Main. 175 | -- -- other-modules: 176 | 177 | -- -- LANGUAGE extensions used by modules in this package. 178 | -- -- other-extensions: 179 | 180 | -- -- Other library packages from which modules are imported. 181 | -- build-depends: base, 182 | -- text, 183 | -- directory, 184 | -- filepath 185 | 186 | -- ghc-options: -O2 -Wall 187 | 188 | -- -- Directories containing source files. 189 | -- hs-source-dirs: src 190 | 191 | -- -- Base language which the package is written in. 192 | -- default-language: Haskell2010 193 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DGPatchMaker 2 | 3 | A tool to create patches for the LV2 Drumgizmo plugin from existing sample libraries. 4 | 5 | ## What is the difference to DGEdit? 6 | 7 | DGEdit as provided from the developers of DrumGizmo is an editor to create drumkits for DrumGizmo from self-sampled tracks. This means, the drumkit is recorded on multiple tracks, each hit one after the other has rang out. To create a drumkit patch out of these tracks is quite a hassle, therefore the DGEdit helps here with splitting the available tracks on the right locations and assigning them to instruments and so on. 8 | 9 | In contrast, DGPatchMaker is designed for creating DrumGizmo patches from existing drum sample libraries in WAV format. So, ready made libraries available open source as well as from commercial companies. 10 | 11 | This is not as trivial as it sounds, as every sample library is structured differently and needs to be fit into DrumGizmos model. 12 | 13 | ## Functionality 14 | 15 | What is supported: 16 | 17 | * Instruments, hits, sample selection, calculation of hit power (same as DGEdit), also loading and saving individual instruments 18 | * Creation of the drumkit patch from the created instruments 19 | * mute groups (old ones, not directed chokes) 20 | * channel selections and routing 21 | * GM and default MIDI map creation in XML and also in readable text format for reference 22 | * Metadata in the drumkit in parallel to the old version 23 | * Directed Chokes via it's own dialog 24 | * Clicky Kit feature with simply clicking on the image map to assign colors to the instruments 25 | 26 | ## Download 27 | 28 | Version 1.0 (compiled on Ubuntu 18.04 x86_64): [DGPatchMaker 1.0](https://www.onikudaki.net/blog/wp-content/uploads/2020/04/DGPatchMaker-2.zip) 29 | 30 | Current head has all features, but cannot be used on standard DrumGizmo kits as the directory structure has to be fixed first (see issue #10). 31 | 32 | ## Git Clone 33 | 34 | When cloning the repository, make sure to checkout the stable versions afterwards. Currently version 1.0 is the latest, so do a 35 | 36 | ``` 37 | git clone https://github.com/oswald2/DGPatchMaker 38 | git checkout 1.0 39 | ``` 40 | 41 | 42 | ## Building 43 | 44 | Best option currently is to use the Haskell tool [stack](https://docs.haskellstack.org/). Download and install stack as detailed on the stack homepage. 45 | 46 | Get the source code of DGPatchMaker by either cloning the repository or getting the zip of the master branch and unpack it into a directory. 47 | 48 | ### Dependencies 49 | 50 | To build DGPatchMaker, the `sndfile` library is needed. For compiling also the development packages with the header files are needed. E.g. on Ubuntu 18.04, the 51 | following packages must be installed for compilation: 52 | 53 | ``` 54 | sudo apt install libsndfile1 libsndfile1-dev sndfile-tools 55 | ``` 56 | 57 | ### Building DGPatchMaker 58 | 59 | Building DGPatchMaker itself is then simply changing into the DGPatchMaker source directory and issue: 60 | 61 | ``` 62 | stack build 63 | ``` 64 | 65 | The first build can take some time as stack downloads packages and compiles them. Subsequent builds will be much faster. The executable can either be called from the build directory via 66 | 67 | ``` 68 | stack exec DGPatchMaker 69 | ``` 70 | 71 | or the executable can be installed via 72 | 73 | ``` 74 | stack install 75 | ``` 76 | 77 | which will put DGPatchMaker into `~/.local/bin`. If the executable should be in some other place, just copy it where it should be. 78 | 79 | 80 | ## DrumGizmo's Model 81 | 82 | DrumGizmo works by mapping the recordings of the drum shells via microphones from MIDI notes to these microphone channels (the output channels of DrumGizmo) 83 | 84 | ### Instruments 85 | 86 | An instrument in DrumGizmo is every distinct playable sound, often mapping to real instruments, but not always. E.g. a kick drum is mapped to one instrument, 87 | while on snares there is often articulation done like normal snare, rimshot, side-stick, snare-roll etc. Each of these are of course in reality played on the same instrument, but are mapped to different DrumGizmo-instruments to provide this articulation. 88 | 89 | The instruments contain samples of the hits with different velocities, and often also the same hit with the same velocities so that DrumGizmo can choose the sample to use. Since each real recorded hit sounds a bit different, even if they are the same velocity, this brings more realism to the sounds. 90 | 91 | ### Drumkit 92 | 93 | The drumkit itself then maps all these defined instruments to the output channels. These channels correspond to the microphones with which the drumkit was recorded. On the DrumGizmo kits downloadable from it's homepage, every hit utilises every microphone, just like on a real recording (e.g. a snare hit is also heard on the kick microphone, just quieter). 94 | 95 | On delivered sample libraries this is often not the case, the shells are on their own, but are also present in the overhead- and room-microphones, so these are the only ones with bleed available. This makes the sound "cleaner", more defined, but also a bit less realistic. 96 | 97 | ### Midimap 98 | 99 | The midi-map then specifies, which MIDI note plays which instrument (in the DrumGizmo sense). 100 | 101 | # Using DGPatchMaker 102 | 103 | **Warning:** *DGPatchMaker's GTK interface still has it's quirks! If you encounter them and know how to fix them, please consider a pull request!* 104 | 105 | DGPatchMaker provides two basic workflows: 106 | 107 | 1. Automatic: this can only be done for drum sample libraries delivered from DrumDrops. This was the initial reason of why DGPatchMaker was developed primarily. DrumDrops libraries have certain conventions in their naming, making it easier to make sense of the structure of the libraries (e.g. in the name of the wav sample is defined which instrument, which articulation, which velocity, and which round-robin round while instruments can be found in distinct folders). As other sample libraries have different conventions, the automatic mode is useless for these libraries and will not work. 108 | 2. Manual: one can manually create and edit drumkit patches for DrumGizmo. This has been done for the open source Salamander Kit as well as the SM MegaReaper kit, which have very different structure conventions than the DrumDrops libraries. This process is a bit more involved, but is most probably the standard process for all other libraries. 109 | 110 | As the automatic workflow is mostly not available, the description is for the manual workflow. 111 | 112 | ## Automatic Workflow 113 | 114 | **NOTE:** *this only works for DrumDrops libraries! And only, if the library itself adheres to the strucuture which is not always the case!* 115 | 116 | Currently, three kits from DrumDrops have been converted for DrumGizmo: the Mapex Rock Kit, the Vintage Folk Kit and the Modern Folk Kit. All of them were different in their structure, so different parsers have been developed/modified for them. For new DrumDrops libraries, try all three parsers in the import process. If this doesn't work (errors reported), one may have to do manual interventions. Note that this had to be done for all three kits in some point as there were always some instruments which were not adhereing to their own standard, so it is very likely, that manual intervention is necesssary. 117 | 118 | The steps in creating the kits are: 119 | 120 | 1. Set the base directory 121 | 2. Set the samples directory 122 | 3. Import DrumDrops kit 123 | 4. Manually refine if necessary 124 | 5. Export the drumkit 125 | 126 | ### Set the base directory 127 | 128 | The DrumDrop kits are coming in different packs. Most of them have a base directory where everything other is stored within, including patches for different sample engines, MIDI loops and the samples themselves. Click "Set Base Directory" and in the file chooser navigate to this directory and select it. 129 | 130 | ### Set the samples directory 131 | 132 | Depending on the pack of the libraries, the directory containing the samples may be different. Click the "Set Samples Directory" and select the directory containing the samples. For DrumDrops libraries, this directory has often the name "Samples" in it and contains other directories (for each instrument one) which contain the real WAV files. The selection should be for this directory, containing the instrument sub-directories. The automatic import will go over all directories, create an instrument for them and assign hits for them. 133 | 134 | ### Import DrumDrops Kit 135 | 136 | Click the "Import DrumDrops Drumkit" button on top of DGPatchMaker. This will start the import. It is possible, that errors appear, especially when the library does not full adhere to it's naming standards. In that case revert to the Manual Workflow described below. 137 | 138 | ### Manually refine 139 | 140 | Since DrumGizmo underwent a change in it's file format, also the user interface was slightly changed to be able to handle that. The automatic import can't handle the main outputs flag, which are used for the bleed control inside DrumGizmo. These need to be set manually. To understand this setting, one needs to understand how the bleed control works: it reduces the amplitude of the sample played on other channels which are not selected main. So the instrument needs to have set the "Main" tag checked in the channel map for it's own channels, while the other are bleed-controlled. 141 | 142 | E.g. for the Crocell Kit from the DrumGizmo site, the KDrumL instrument is mapped to all channels, but its channels tagged as "Main" are the "KDrumInside" and "KDrumOutside" channels, as these are the native channels the kick goes out to. The output to all other channels will be controlled by the bleed control. 143 | For cymbals and the hihat, the Crocell Kit defines that their "Main" channels are the "AmbLeft" and "AmbRight" (the room microphones) and all overhead channels ("OHLeft", "OHRight", "OHCenter"). 144 | 145 | It is also important to add a Drumkit Name and a Description in the relevant fields, before saving the drumkit. 146 | 147 | ### Exporting the drumkit 148 | 149 | Simply select File -> Export Drumkit. The drumkit file will be exported with the specified name to the folder selected in "Base Directory" 150 | 151 | ## Manual Workflow 152 | 153 | The manual workflow consists of the following steps: 154 | 155 | 1. Create the instruments 156 | 2. Create the drumkit: 157 | 1. Assign groups 158 | 2. Assign instruments to channels 159 | 3. Assign master flags for the channels for the bleed control 160 | 3. Create the MIDI-Map 161 | 4. Export the drumkit 162 | 5. Export the MIDI-Map 163 | 164 | In order to show the usage, I created a video which demonstrates the basic usage of DGPatchMaker: [How to use DGPatchMaker to create a patch](https://youtu.be/u1fcU8DzxFs) 165 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Data/Checkers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Data.Checkers 3 | ( 4 | checkInt 5 | ,checkIntList 6 | ,checkFloat 7 | ,checkRational 8 | ,checkOctet 9 | ,checkFractional 10 | ,checkSampleRate 11 | ) 12 | where 13 | 14 | import Control.Monad (void) 15 | 16 | import Text.Parsec 17 | import Text.Parsec.Token 18 | import Text.Parsec.Language 19 | import Text.ParserCombinators.Parsec.Number (int) 20 | import Prelude as P 21 | import Data.Ratio 22 | import Data.Text as T 23 | 24 | import Numeric 25 | 26 | import Data.ByteString.Lazy as B (ByteString, pack) 27 | 28 | 29 | 30 | 31 | checkInt :: Text -> Integer -> Integer -> Maybe Text -> Either Text Integer 32 | checkInt str low high ref = 33 | case parse number "" (T.unpack str) of 34 | Left err -> Left (T.pack (show err)) 35 | Right x' -> proc x' 36 | where 37 | which = maybe "" (\x -> ": " `T.append` x) ref 38 | proc x 39 | | x < low = Left $ which `T.append` " value must be >= " `T.append` (T.pack (show low)) 40 | | x > high = Left $ which `T.append` " value must be <= " `T.append` (T.pack (show high)) 41 | | otherwise = Right x 42 | 43 | checkSampleRate :: Text -> Either Text Int 44 | checkSampleRate str = 45 | case parse sampleRate "" (T.unpack str) of 46 | Left err -> Left ("Illegal sample rate: " <> T.pack (show err)) 47 | Right x -> Right x 48 | 49 | 50 | checkIntList :: Text -> Integer -> Integer -> Maybe Text -> Either Text [Integer] 51 | checkIntList str low high ref = 52 | case parse (listOf number) "" (T.unpack str) of 53 | Left err -> Left (T.pack (show err)) 54 | Right x' -> proc x' 55 | where 56 | which = maybe "" (\x -> ": " `T.append` x) ref 57 | proc x = 58 | let vx = P.filter (< low) x 59 | vy = P.filter (> high) x 60 | in 61 | if not (P.null vx) then Left $ which `T.append` " values too low: " `T.append` (T.pack (show vx)) else 62 | if not (P.null vy) then Left $ which `T.append` " values too high: " `T.append` (T.pack (show vy)) else Right x 63 | 64 | 65 | 66 | 67 | checkFloat :: (Fractional a, Read a) => Text -> Either Text a 68 | checkFloat str = 69 | case reads (unpack str) of 70 | ((x, _) :_) -> Right x 71 | _ -> Left $ "Illegal floating point value: " `append` str 72 | 73 | 74 | checkRational :: Text -> Either Text Rational 75 | checkRational str = 76 | either (Left . T.pack . show) Right $ parse ratio "" (T.unpack str) 77 | 78 | checkFractional :: Text -> Either Text (Either Double Rational) 79 | checkFractional str = 80 | either (Left . T.pack . show) Right $ parse fractional "" (T.unpack str) 81 | 82 | 83 | 84 | checkOctet :: Text -> Either Text ByteString 85 | checkOctet str = 86 | either (Left . T.pack . show) (Right . id) $ parse p "" str 87 | where 88 | p = do 89 | ls <- many hexDigit 90 | return $! B.pack $ P.map (fromIntegral.fromHex) $ group2 ls 91 | 92 | group2 :: [Char] -> [[Char]] 93 | group2 [] = [] 94 | group2 (x:[]) = [[x,'0']] 95 | group2 (x:y:xs) = [x,y] : group2 xs 96 | 97 | 98 | fromHex :: String -> Integer 99 | fromHex = fst . P.head . readHex 100 | 101 | 102 | number :: Parsec String u Integer 103 | number = do 104 | let lexer = makeTokenParser haskellStyle 105 | integer lexer 106 | 107 | sampleRate :: Parsec String u Int 108 | sampleRate = do 109 | pre <- int 110 | 111 | post <- option 0 decim 112 | let 113 | sr = if post /= 0 then pre * 1000 + post else pre 114 | return sr 115 | where 116 | decim = do 117 | void $ char '.' 118 | int 119 | 120 | 121 | 122 | fl :: Parsec String u Double 123 | fl = do 124 | let lexer = makeTokenParser haskellStyle 125 | r <- optionMaybe $ char '-' 126 | f <- float lexer 127 | case r of 128 | Just _ -> return $ negate f 129 | Nothing -> return f 130 | 131 | ratio :: Parsec String u Rational 132 | ratio = do 133 | let lexer = makeTokenParser haskellStyle 134 | r <- optionMaybe $ char '-' 135 | n <- integer lexer 136 | spaces >> char '%' >> spaces 137 | d <- integer lexer 138 | let val = n % d 139 | case r of 140 | Just _ -> return $ negate val 141 | Nothing -> return val 142 | 143 | fractional :: Parsec String u (Either Double Rational) 144 | fractional = do 145 | (try fl >>= \f -> return (Left f)) 146 | <|> 147 | (ratio >>= \r -> return (Right r)) 148 | 149 | listOf :: Parsec String u a -> Parsec String u [a] 150 | listOf p = sepBy p listSep 151 | 152 | listSep :: Parsec String u () 153 | listSep = do 154 | spaces 155 | void $ char ',' 156 | spaces 157 | 158 | -------------------------------------------------------------------------------- /src/Data/Defaults.hs: -------------------------------------------------------------------------------- 1 | module Data.Defaults 2 | where 3 | 4 | 5 | defaultSampleRate :: Int 6 | defaultSampleRate = 44100 7 | -------------------------------------------------------------------------------- /src/Data/DrumDrops/MapexKitParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | module Data.DrumDrops.MapexKitParser 3 | ( 4 | getSampleFromFileName 5 | ,determineChannel 6 | ) 7 | where 8 | 9 | 10 | import Control.Monad (void) 11 | 12 | import Data.Text as T 13 | import Data.Types 14 | 15 | import Text.Parsec as P 16 | 17 | import System.FilePath 18 | 19 | import Data.DrumDrops.Types 20 | 21 | import Debug.Trace 22 | import Text.Printf 23 | 24 | 25 | getSampleFromFileName :: FilePath -> Int -> Either ParseError Sample 26 | getSampleFromFileName name nChannels = 27 | parse (sampleParser fname (fromIntegral nChannels)) fname' sname 28 | where 29 | fname' = takeFileName name 30 | fname = pack fname' 31 | sname = pack $ dropExtension fname' 32 | 33 | 34 | 35 | sampleParser :: Text -> Word -> Parsec Text u Sample 36 | sampleParser fname nChannels = do 37 | maker' <- many1 alphaNum 38 | void $ char '_' 39 | inst <- instrument 40 | void $ char '_' 41 | st <- case inst of 42 | HiHat -> hiHat 43 | _ -> instState 44 | void $ char '_' 45 | kitNumber 46 | void $ char '_' 47 | v <- velocity 48 | 49 | rr <- roundRobin 50 | 51 | let 52 | maker = pack maker' 53 | res = 54 | Sample fname maker inst st v rr nChannels 55 | 56 | return res 57 | 58 | 59 | instrument :: Parsec Text u Instrument 60 | instrument = do 61 | (try (string "SNR") >> return Snare) 62 | <|> (try (string "SN") >> return Snare) 63 | <|> (try (string "KICK") >> return Kick) 64 | <|> (try (string "HAT") >> return HiHat) 65 | <|> try toms 66 | <|> (try (string "CRSH") >> return Cymbal) 67 | <|> (try (string "RIDE") >> return Ride) 68 | 69 | 70 | toms :: Parsec Text u Instrument 71 | toms = do 72 | t <- try $ do 73 | void $ char 'R' 74 | n <- digit 75 | return (RackTom (read [n])) 76 | <|> do 77 | void $ string "FL" 78 | return (Floor 1) 79 | void $ string "TM" 80 | return (Tom t) 81 | 82 | 83 | micType :: Parsec Text u MicType 84 | micType = do 85 | genTry "CL" Close 86 | <|> genTry "OH" Overhead 87 | <|> genTry "RM" Room 88 | <|> genTry "FL" FullMix 89 | <|> genTry "K1" Kit1 90 | <|> genTry "K2" Kit2 91 | <|> genTry "KK" KickClose 92 | <|> genTry "SN" SnareClose 93 | 94 | 95 | 96 | genTry :: String -> a -> Parsec Text u a 97 | genTry what whatC = try (string what) >> return whatC 98 | 99 | 100 | hiHatState :: Parsec Text u HiHatState 101 | hiHatState = do 102 | genTry "C1" HiHatFullClosed 103 | <|> genTry "C2" HiHatClosed 104 | <|> genTry "C3" HiHatOpenQuarter 105 | <|> genTry "O1" HiHatOpenHalf 106 | <|> genTry "O2" HiHatOpen3Quart 107 | <|> genTry "O3" HiHatOpen 108 | <|> genTry "FS" HiHatPedalShut 109 | <|> genTry "FO" HiHatPedalOpen 110 | 111 | 112 | hiHat :: Parsec Text u InstState 113 | hiHat = do 114 | st <- hiHatState 115 | mt <- try $ do 116 | void $ string "EG" 117 | micType 118 | <|> do 119 | micType 120 | return (HiHatS st mt) 121 | 122 | 123 | 124 | instState :: Parsec Text u InstState 125 | instState = do 126 | void $ P.count 2 upper 127 | void $ optional (char '_') 128 | --void $ manyTill anyChar (try (lookAhead micType)) 129 | mt <- micType 130 | sb <- try (string "SB") <|> return "" 131 | case sb of 132 | "SB" -> return (InstS Sub) 133 | _ -> return (InstS mt) 134 | 135 | 136 | kitNumber :: Parsec Text u () 137 | kitNumber = do 138 | void $ string "HT_" 139 | void $ many1 digit 140 | return () 141 | 142 | 143 | velocity :: Parsec Text u Int 144 | velocity = do 145 | void $ optional (char 'V') 146 | n <- many1 digit 147 | return (read n) 148 | 149 | 150 | roundRobin :: Parsec Text u (Maybe Int) 151 | roundRobin = do 152 | try $ do 153 | void $ string "_RR" 154 | n <- many1 digit 155 | return (Just (read n)) 156 | <|> 157 | return Nothing 158 | 159 | 160 | determineChannel :: Sample -> Channel -> Microphones 161 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Close)}) Mono = 162 | KickC 163 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Close)}) LeftA = 164 | KickL 165 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Close)}) RightA = 166 | KickR 167 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Sub)}) Mono = 168 | KickS 169 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Overhead)}) LeftA = 170 | OHL 171 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Overhead)}) RightA = 172 | OHR 173 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Room)}) LeftA = 174 | RoomL 175 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Room)}) RightA = 176 | RoomR 177 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Close)}) Mono = 178 | SnareTop 179 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Close)}) LeftA = 180 | SnareL 181 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Close)}) RightA = 182 | SnareR 183 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Overhead)}) LeftA = 184 | OHL 185 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Overhead)}) RightA = 186 | OHR 187 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Room)}) LeftA = 188 | RoomL 189 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Room)}) RightA = 190 | RoomR 191 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Close)}) Mono = 192 | HiHatC 193 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Close)}) LeftA = 194 | HiHatL 195 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Close)}) RightA = 196 | HiHatR 197 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Room)}) LeftA = 198 | RoomL 199 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Room)}) RightA = 200 | RoomR 201 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Overhead)}) LeftA = 202 | OHL 203 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Overhead)}) RightA = 204 | OHR 205 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS Close)}) Mono = 206 | TomC x 207 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS Close)}) LeftA = 208 | TomL x 209 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS Close)}) RightA = 210 | TomR x 211 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Room)}) LeftA = 212 | RoomL 213 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Room)}) RightA = 214 | RoomR 215 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Overhead)}) LeftA = 216 | OHL 217 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Overhead)}) RightA = 218 | OHR 219 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS Close)}) Mono = 220 | FloorTomC x 221 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS Close)}) LeftA = 222 | FloorTomL x 223 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS Close)}) RightA = 224 | FloorTomR x 225 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Room)}) LeftA = 226 | RoomL 227 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Room)}) RightA = 228 | RoomR 229 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Overhead)}) LeftA = 230 | OHL 231 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Overhead)}) RightA = 232 | OHR 233 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Overhead)}) LeftA = 234 | OHL 235 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Overhead)}) RightA = 236 | OHR 237 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Room)}) LeftA = 238 | RoomL 239 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Room)}) RightA = 240 | RoomR 241 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Overhead)}) LeftA = 242 | OHL 243 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Overhead)}) RightA = 244 | OHR 245 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Room)}) LeftA = 246 | RoomL 247 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Room)}) RightA = 248 | RoomR 249 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Close)}) Mono = 250 | RideC 251 | -- Multi Velocity Kits 252 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS FullMix)}) LeftA = 253 | KickL 254 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS FullMix)}) RightA = 255 | KickR 256 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS FullMix)}) LeftA = 257 | SnareL 258 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS FullMix)}) RightA = 259 | SnareR 260 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ FullMix)}) LeftA = 261 | HiHatL 262 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ FullMix)}) RightA = 263 | HiHatR 264 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS FullMix)}) LeftA = 265 | TomL x 266 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS FullMix)}) RightA = 267 | TomR x 268 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS FullMix)}) LeftA = 269 | FloorTomL x 270 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS FullMix)}) RightA = 271 | FloorTomR x 272 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS FullMix)}) LeftA = 273 | RideL 274 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS FullMix)}) RightA = 275 | RideR 276 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS FullMix)}) LeftA = 277 | OHL 278 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS FullMix)}) RightA = 279 | OHR 280 | 281 | 282 | determineChannel sample channel = trace (printf "%s %s" (show sample) (show channel)) Undefined 283 | 284 | -------------------------------------------------------------------------------- /src/Data/DrumDrops/ModernFolkParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | module Data.DrumDrops.ModernFolkParser 3 | ( 4 | getSampleFromFileName 5 | ,determineChannel 6 | ) 7 | where 8 | 9 | 10 | import Control.Monad (void) 11 | 12 | import Data.Text as T 13 | import Data.Types 14 | 15 | import Text.Parsec as P 16 | 17 | import System.FilePath 18 | 19 | import Data.DrumDrops.Types 20 | 21 | 22 | import Debug.Trace 23 | import Text.Printf 24 | 25 | 26 | getSampleFromFileName :: FilePath -> Int -> Either ParseError Sample 27 | getSampleFromFileName name nChannels = 28 | parse (sampleParser fname (fromIntegral nChannels)) fname' sname 29 | where 30 | fname' = takeFileName name 31 | fname = pack fname' 32 | sname = pack $ dropExtension fname' 33 | 34 | 35 | separator :: Parsec Text u () 36 | separator = void (char '-' <|> char '_') 37 | 38 | 39 | 40 | sampleParser :: Text -> Word -> Parsec Text u Sample 41 | sampleParser fname nChannels = do 42 | kitnr <- many1 alphaNum 43 | case kitnr of 44 | "SHKR" -> shakerParser fname nChannels 45 | "TAM1" -> tambourineParser fname nChannels 46 | "TAM" -> tambourineParser fname nChannels 47 | _ -> do 48 | maker' <- case kitnr == "DD014" || kitnr == "DD104" of 49 | True -> do 50 | separator 51 | many1 alphaNum 52 | False -> do 53 | return kitnr 54 | separator 55 | (inst, hhstate) <- instrument 56 | separator 57 | st <- case inst of 58 | HiHat -> hiHat hhstate 59 | _ -> instState 60 | separator 61 | v <- velocity 62 | 63 | rr <- roundRobin 64 | 65 | let 66 | maker = pack maker' 67 | res = 68 | Sample fname maker inst st v rr nChannels 69 | 70 | return res 71 | 72 | 73 | 74 | 75 | shakerParser :: Text -> Word -> Parsec Text u Sample 76 | shakerParser fname nChannels = do 77 | let inst = Shaker 78 | void $ manyTill anyChar (try kitNumber) 79 | separator 80 | v <- velocity 81 | 82 | rr <- roundRobin 83 | let res = Sample fname "" inst (InstS FullMix) v rr nChannels 84 | return res 85 | 86 | tambourineParser :: Text -> Word -> Parsec Text u Sample 87 | tambourineParser fname nChannels = do 88 | let inst = Tambourine 89 | void $ manyTill anyChar (try kitNumber) 90 | separator 91 | v <- velocity 92 | 93 | rr <- roundRobin 94 | let res = Sample fname "" inst (InstS FullMix) v rr nChannels 95 | return res 96 | 97 | 98 | instrument :: Parsec Text u (Instrument, HiHatState) 99 | instrument = do 100 | (try (string "Snare") >> return (Snare, HiHatUndefined)) 101 | <|> (try (string "SNR") >> return (Snare, HiHatUndefined)) 102 | <|> (try (string "Kick") >> return (Kick, HiHatUndefined)) 103 | <|> (try (string "KICK") >> return (Kick, HiHatUndefined)) 104 | <|> (try (string "ClosedHatsEdge") >> return (HiHat, HiHatClosed)) 105 | <|> (try (string "ClosedHats") >> return (HiHat, HiHatClosed)) 106 | <|> (try (string "OpenHatsEdge") >> return (HiHat, HiHatOpen)) 107 | <|> (try (string "OpenHats") >> return (HiHat, HiHatOpen)) 108 | <|> (try (string "FullClosedHats") >> return (HiHat, HiHatFullClosed)) 109 | <|> (try (string "FullClosedEdge") >> return (HiHat, HiHatFullClosed)) 110 | <|> (try (string "PedalHats") >> return (HiHat, HiHatPedalOpen)) 111 | <|> try toms 112 | <|> (try (string "PlainCrash") >> return (Cymbal, HiHatUndefined)) 113 | <|> (try (string "ThinCrash") >> return (Cymbal, HiHatUndefined)) 114 | <|> (try (string "CRSH") >> return (Cymbal, HiHatUndefined)) 115 | <|> (try (string "Ride") >> return (Ride, HiHatUndefined)) 116 | <|> (try (string "RIDE") >> return (Ride, HiHatUndefined)) 117 | 118 | 119 | toms :: Parsec Text u (Instrument, HiHatState) 120 | toms = do 121 | t <- do 122 | void $ string "Tom" 123 | n <- digit 124 | return (RackTom (read [n])) 125 | return ((Tom t), HiHatUndefined) 126 | 127 | 128 | micType :: Parsec Text u MicType 129 | micType = do 130 | genTry "CL" Close 131 | <|> genTry "OH" Overhead 132 | <|> genTry "RM1" Room1 133 | <|> genTry "RM2" Room2 134 | <|> genTry "FL" FullMix 135 | <|> genTry "BL" FullMix 136 | <|> genTry "BT" Bottom 137 | <|> genTry "TP" Top 138 | <|> genTry "K1" Kit1 139 | <|> genTry "K2" Kit2 140 | <|> genTry "KK" KickClose 141 | <|> genTry "SN" SnareClose 142 | 143 | 144 | 145 | genTry :: String -> a -> Parsec Text u a 146 | genTry what whatC = try (string what) >> return whatC 147 | 148 | 149 | 150 | 151 | 152 | hiHat :: HiHatState -> Parsec Text u InstState 153 | hiHat st'' = do 154 | m <- modifier 155 | separator 156 | mt <- micType 157 | let st' = case st'' of 158 | HiHatPedalOpen -> if m == "Closed" then HiHatPedalShut else HiHatPedalOpen 159 | _ -> HiHatPedalOpen 160 | st = case m of 161 | "SticksHalf" -> HiHatOpenHalf 162 | _ -> st' 163 | return (HiHatS st mt) 164 | 165 | 166 | instState :: Parsec Text u InstState 167 | instState = do 168 | void $ modifier 169 | separator 170 | mt <- micType 171 | return (InstS mt) 172 | 173 | 174 | modifier :: Parsec Text u Text 175 | modifier = do 176 | m <- do 177 | try (string "Brushes") 178 | <|> try (string "Hotrods") 179 | <|> try (string "SticksCentre") 180 | <|> try (string "StickCentre") 181 | <|> try (string "SticksEdge") 182 | <|> try (string "SticksRimshot") 183 | <|> try (string "SticksSidestick") 184 | <|> try (string "StcksHalfEdge") 185 | <|> try (string "SticksHalfEdge") 186 | <|> try (string "SticksHalf") 187 | <|> try (string "SticksQuarterEdge") 188 | <|> try (string "SticksQuarter") 189 | <|> try (string "SticksThreeQuartersEdge") 190 | <|> try (string "SticksThreeQuarters") 191 | <|> try (string "Sticks") 192 | <|> try (string "Open") 193 | <|> try (string "Closed") 194 | <|> try (string "HardBeater") 195 | <|> try (string "SoftBeater") 196 | <|> try (string "Centre") 197 | <|> try (string "Edge") 198 | <|> try (string "Bell") 199 | return (pack m) 200 | 201 | velocity :: Parsec Text u Int 202 | velocity = do 203 | void $ optional (char 'V') 204 | n <- many1 digit 205 | return (read n) 206 | 207 | 208 | roundRobin :: Parsec Text u (Maybe Int) 209 | roundRobin = do 210 | try $ do 211 | separator 212 | void $ string "RR" 213 | n <- many1 digit 214 | return (Just (read n)) 215 | <|> 216 | return Nothing 217 | 218 | 219 | kitNumber :: Parsec Text u () 220 | kitNumber = do 221 | void $ string "HT" 222 | separator 223 | void $ many1 digit 224 | return () 225 | 226 | 227 | 228 | 229 | determineChannel :: Sample -> Channel -> Microphones 230 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Close)}) Mono = 231 | KickC 232 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Close)}) LeftA = 233 | KickL 234 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Close)}) RightA = 235 | KickR 236 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Sub)}) Mono = 237 | KickS 238 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Overhead)}) LeftA = 239 | OHL 240 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Overhead)}) RightA = 241 | OHR 242 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Room)}) LeftA = 243 | RoomL 244 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Room)}) RightA = 245 | RoomR 246 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Close)}) Mono = 247 | SnareTop 248 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Close)}) LeftA = 249 | SnareL 250 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Close)}) RightA = 251 | SnareR 252 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Overhead)}) LeftA = 253 | OHL 254 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Overhead)}) RightA = 255 | OHR 256 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Room)}) LeftA = 257 | RoomL 258 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Room)}) RightA = 259 | RoomR 260 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Close)}) Mono = 261 | HiHatC 262 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Close)}) LeftA = 263 | HiHatL 264 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Close)}) RightA = 265 | HiHatR 266 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Room)}) LeftA = 267 | RoomL 268 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Room)}) RightA = 269 | RoomR 270 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Overhead)}) LeftA = 271 | OHL 272 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Overhead)}) RightA = 273 | OHR 274 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS Close)}) Mono = 275 | TomC x 276 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS Close)}) LeftA = 277 | TomL x 278 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS Close)}) RightA = 279 | TomR x 280 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Room)}) LeftA = 281 | RoomL 282 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Room)}) RightA = 283 | RoomR 284 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Overhead)}) LeftA = 285 | OHL 286 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Overhead)}) RightA = 287 | OHR 288 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS Close)}) Mono = 289 | FloorTomC x 290 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS Close)}) LeftA = 291 | FloorTomL x 292 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS Close)}) RightA = 293 | FloorTomR x 294 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Room)}) LeftA = 295 | RoomL 296 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Room)}) RightA = 297 | RoomR 298 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Overhead)}) LeftA = 299 | OHL 300 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Overhead)}) RightA = 301 | OHR 302 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Overhead)}) LeftA = 303 | OHL 304 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Overhead)}) RightA = 305 | OHR 306 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Room)}) LeftA = 307 | RoomL 308 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Room)}) RightA = 309 | RoomR 310 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Overhead)}) LeftA = 311 | OHL 312 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Overhead)}) RightA = 313 | OHR 314 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Room)}) LeftA = 315 | RoomL 316 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Room)}) RightA = 317 | RoomR 318 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Close)}) Mono = 319 | RideC 320 | -- Multi Velocity Kits 321 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS FullMix)}) LeftA = 322 | FullMixL 323 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS FullMix)}) RightA = 324 | FullMixR 325 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS FullMix)}) LeftA = 326 | FullMixL 327 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS FullMix)}) RightA = 328 | FullMixR 329 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ FullMix)}) LeftA = 330 | FullMixL 331 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ FullMix)}) RightA = 332 | FullMixR 333 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS FullMix)}) LeftA = 334 | TomL x 335 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS FullMix)}) RightA = 336 | TomR x 337 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS FullMix)}) LeftA = 338 | FloorTomL x 339 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS FullMix)}) RightA = 340 | FloorTomR x 341 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS FullMix)}) LeftA = 342 | RideL 343 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS FullMix)}) RightA = 344 | RideR 345 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS FullMix)}) LeftA = 346 | OHL 347 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS FullMix)}) RightA = 348 | OHR 349 | 350 | determineChannel (Sample {saInstrument = Tambourine, saInstrumentProperties = (InstS FullMix)}) LeftA = 351 | FullMixL 352 | determineChannel (Sample {saInstrument = Tambourine, saInstrumentProperties = (InstS FullMix)}) RightA = 353 | FullMixR 354 | determineChannel (Sample {saInstrument = Shaker, saInstrumentProperties = (InstS FullMix)}) LeftA = 355 | FullMixL 356 | determineChannel (Sample {saInstrument = Shaker, saInstrumentProperties = (InstS FullMix)}) RightA = 357 | FullMixR 358 | 359 | --- for the modern folk kit 360 | 361 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Room1)}) Mono = 362 | Room1Mono 363 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Room2)}) Mono = 364 | Room2Mono 365 | 366 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Top)}) Mono = 367 | SnareTop 368 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Bottom)}) Mono = 369 | SnareBottom 370 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Room1)}) Mono = 371 | Room1Mono 372 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Room2)}) Mono = 373 | Room2Mono 374 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Room1)}) Mono = 375 | Room1Mono 376 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Room2)}) Mono = 377 | Room2Mono 378 | 379 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Room1)}) Mono = 380 | Room1Mono 381 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Room2)}) Mono = 382 | Room2Mono 383 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Room1)}) Mono = 384 | Room1Mono 385 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Room2)}) Mono = 386 | Room2Mono 387 | 388 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Room1)}) Mono = 389 | Room1Mono 390 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Room2)}) Mono = 391 | Room2Mono 392 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Room1)}) Mono = 393 | Room1Mono 394 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Room2)}) Mono = 395 | Room2Mono 396 | 397 | 398 | determineChannel sample channel = trace (printf "%s %s" (show sample) (show channel)) Undefined 399 | -------------------------------------------------------------------------------- /src/Data/DrumDrops/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | module Data.DrumDrops.Types 3 | ( 4 | Sample(..), 5 | SampleGroup(..), 6 | VelocityGroup(..), 7 | Channel(..), 8 | getMic, 9 | ) 10 | where 11 | 12 | 13 | --import Control.Monad (void) 14 | 15 | import Data.Text as T 16 | import Data.Types 17 | import Data.Maybe (isJust) 18 | 19 | 20 | 21 | 22 | -- data type for the samples 23 | data Sample = 24 | Sample { 25 | saFileName :: !Text, 26 | saMaker :: !Text, 27 | saInstrument :: !Instrument, 28 | saInstrumentProperties :: !InstState, 29 | saVelocity :: !Int, 30 | saRound :: Maybe Int, 31 | saChannels :: !Word 32 | } 33 | deriving (Show, Eq) 34 | 35 | instance Ord Sample where 36 | compare Sample {saVelocity = v1, saRound = rr1} Sample {saVelocity = v2, saRound = rr2} 37 | | v1 < v2 = LT 38 | | v1 == v2 = if isJust rr1 && isJust rr2 39 | then compare rr1 rr2 40 | else EQ 41 | | otherwise = GT 42 | 43 | 44 | data SampleGroup = SampleGroup { 45 | sgPath :: !FilePath, 46 | sgInstName :: !Text, 47 | sgInstrument :: !Instrument, 48 | sgSampleRate :: !Int, 49 | sgGroups :: [VelocityGroup] 50 | } deriving (Show) 51 | 52 | data VelocityGroup = VelocityGroup { 53 | vgVelocity :: Double, 54 | vgRR :: Maybe Int, 55 | vgInstrument :: !Instrument, 56 | vgSamples :: [Sample] 57 | } deriving Show 58 | 59 | 60 | data Channel = 61 | Mono 62 | | LeftA 63 | | RightA 64 | | MonoSplit 65 | deriving (Show) 66 | 67 | 68 | 69 | 70 | 71 | -------------------------------------------------------------------------------- /src/Data/DrumDrops/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards #-} 2 | module Data.DrumDrops.Utils where 3 | 4 | 5 | import Prelude as P 6 | 7 | import System.Directory 8 | import System.FilePath 9 | import Data.List as L 10 | ( sort 11 | , groupBy 12 | ) 13 | import Data.Text ( Text 14 | , pack 15 | , unpack 16 | , append 17 | ) 18 | 19 | import Data.Either 20 | import Data.Char ( isSpace ) 21 | import Data.DrumDrops.Types 22 | import qualified Data.DrumDrops.MapexKitParser as MP 23 | import qualified Data.DrumDrops.VintageFolkParser 24 | as VFP 25 | import qualified Data.DrumDrops.ModernFolkParser 26 | as MFP 27 | 28 | import Data.Types 29 | import Data.Drumgizmo 30 | 31 | import Sound.File.Sndfile ( getFileInfo 32 | , Info(..) 33 | ) 34 | 35 | import Text.Parsec ( ParseError ) 36 | 37 | 38 | 39 | data ParserType = 40 | MapexParser 41 | | VintageFolkParser 42 | | ModernFolkParser 43 | deriving (Enum, Eq, Ord, Show, Read) 44 | 45 | 46 | 47 | 48 | importInstrument 49 | :: ParserType 50 | -> FilePath 51 | -> FilePath 52 | -> FilePath 53 | -> IO (Either Text (InstrumentFile, Int)) 54 | importInstrument parserType basepath samplesPath path = do 55 | 56 | putStrLn $ "Importing Instrument from: " ++ path 57 | 58 | w <- getSamples parserType samplesPath path 59 | case w of 60 | Left err -> return (Left err) 61 | Right wavFiles -> return 62 | (Right 63 | ( convertSampleGroup parserType basepath wavFiles 64 | , sgSampleRate wavFiles 65 | ) 66 | ) 67 | 68 | 69 | 70 | getFiles :: FilePath -> IO (Either Text [FilePath]) 71 | getFiles path = do 72 | is <- doesDirectoryExist path 73 | if is 74 | then do 75 | cont' <- getDirectoryContents path 76 | let cont = P.filter (\x -> not (elem x [".", ".."])) cont' 77 | return (Right cont) 78 | else do 79 | return (Left (pack path `append` " is not a directory")) 80 | 81 | 82 | getVelocityGroups :: [Sample] -> [VelocityGroup] 83 | getVelocityGroups ss = 84 | let gs = (L.groupBy velocityGroup . sort) ss 85 | crV x = 86 | let first = head x 87 | in VelocityGroup (fromIntegral (saVelocity first)) 88 | (saRound first) 89 | (saInstrument first) 90 | x 91 | in map crV gs 92 | 93 | getSamples :: ParserType -> FilePath -> FilePath -> IO (Either Text SampleGroup) 94 | getSamples parserType samplesDir path = do 95 | fs <- getFiles path 96 | case fs of 97 | Left err -> return (Left err) 98 | Right cont -> do 99 | -- get audio information out of the wav files 100 | let 101 | proc c = do 102 | info <- getFileInfo (path c) 103 | return 104 | ( getSampleFromFileName parserType c (channels info) 105 | , (samplerate info) 106 | ) 107 | 108 | res <- mapM proc $ filter 109 | (\x -> takeExtension x == ".wav" || takeExtension x == ".WAV") 110 | cont 111 | 112 | let srate = if null res then 44100 else (snd . head) res 113 | smpls = map fst res 114 | spls = rights smpls 115 | errors = lefts smpls 116 | 117 | if P.null errors 118 | then do 119 | let gr = SampleGroup path 120 | (pathToInstrument samplesDir path) 121 | inst 122 | srate 123 | vgs 124 | inst = vgInstrument (head vgs) 125 | vgs = getVelocityGroups spls 126 | return (Right gr) 127 | else do 128 | let err = "Failed parsing: " `append` pack (show errors) 129 | return (Left err) 130 | 131 | 132 | pathToInstrument :: FilePath -> FilePath -> Text 133 | pathToInstrument sampleDir path' = 134 | let path = makeRelative sampleDir path' 135 | fs = splitDirectories path 136 | ps = P.concat fs 137 | inst = P.filter (not . isSpace) ps 138 | in pack inst 139 | 140 | 141 | 142 | getSampleFromFileName 143 | :: ParserType -> FilePath -> Int -> Either ParseError Sample 144 | getSampleFromFileName MapexParser = MP.getSampleFromFileName 145 | getSampleFromFileName VintageFolkParser = VFP.getSampleFromFileName 146 | getSampleFromFileName ModernFolkParser = MFP.getSampleFromFileName 147 | 148 | 149 | 150 | determineChannel :: ParserType -> Sample -> Channel -> Text 151 | determineChannel parserType sample channel = 152 | pack . showMic $ case parserType of 153 | MapexParser -> MP.determineChannel sample channel 154 | VintageFolkParser -> VFP.determineChannel sample channel 155 | ModernFolkParser -> MFP.determineChannel sample channel 156 | 157 | 158 | convertSampleGroup :: ParserType -> FilePath -> SampleGroup -> InstrumentFile 159 | convertSampleGroup parserType basepath sg = InstrumentFile 160 | dgDefaultVersion 161 | nm 162 | fpath 163 | fname 164 | (Just (sgInstrument sg)) 165 | groups 166 | where 167 | nm = sgInstName sg 168 | vname :: Int -> Text 169 | vname i = nm `append` pack (show i) 170 | groups = P.zipWith 171 | (\vg i -> 172 | convertVelocityGroup parserType (vname i) (sgPath sg) basepath sg vg 173 | ) 174 | (sgGroups sg) 175 | [1 ..] 176 | fpath = "" 177 | fname = nm `append` ".xml" 178 | 179 | 180 | convertVelocityGroup 181 | :: ParserType -> Text -> FilePath -> FilePath -> SampleGroup -> VelocityGroup -> HitSample 182 | convertVelocityGroup parserType name path basepath sampleGroup vg = HitSample 183 | name 184 | (vgVelocity vg) 185 | files 186 | where 187 | files = 188 | sort 189 | (P.concatMap (convertSample parserType basepath path sampleGroup) (vgSamples vg) 190 | ) 191 | 192 | 193 | 194 | convertSample 195 | :: ParserType 196 | -> FilePath 197 | -> FilePath 198 | -> SampleGroup 199 | -> Sample 200 | -> [AudioFile] 201 | convertSample parserType basepath path sampleGroup x = case saChannels x of 202 | 1 -> case saInstrumentProperties x of 203 | InstS FullMix -> 204 | [ AudioFile (determineChannel parserType x LeftA) 205 | (determinePath basepath path (saFileName x)) 206 | 1 207 | Nothing 208 | (Just (sgSampleRate sampleGroup)) 209 | , AudioFile (determineChannel parserType x RightA) 210 | (determinePath basepath path (saFileName x)) 211 | 1 212 | Nothing 213 | (Just (sgSampleRate sampleGroup)) 214 | ] 215 | _ -> 216 | [ AudioFile (determineChannel parserType x Mono) 217 | (determinePath basepath path (saFileName x)) 218 | 1 219 | Nothing 220 | (Just (sgSampleRate sampleGroup)) 221 | ] 222 | 2 -> 223 | [ AudioFile (determineChannel parserType x LeftA) 224 | (determinePath basepath path (saFileName x)) 225 | 1 226 | Nothing 227 | (Just (sgSampleRate sampleGroup)) 228 | , AudioFile (determineChannel parserType x RightA) 229 | (determinePath basepath path (saFileName x)) 230 | 2 231 | Nothing 232 | (Just (sgSampleRate sampleGroup)) 233 | ] 234 | _ -> [] 235 | 236 | 237 | 238 | -- determinePath :: FilePath -> FilePath -> Text -> FilePath 239 | -- determinePath basepath path filename = 240 | -- "../../" makeRelative basepath path unpack filename 241 | 242 | determinePath :: FilePath -> FilePath -> Text -> FilePath 243 | determinePath basepath path filename = 244 | let intermediate = makeRelative basepath path 245 | in if intermediate == path 246 | then doRelativeThing basepath path unpack filename 247 | else intermediate unpack filename 248 | 249 | 250 | doRelativeThing :: FilePath -> FilePath -> FilePath 251 | doRelativeThing basepath path = 252 | let dirs1 = splitPath basepath 253 | dirs2 = splitPath path 254 | (x, y) = process dirs1 dirs2 255 | up = map (const "..") y 256 | result = joinPath (up ++ x) 257 | in 258 | result 259 | where 260 | process [] y = ([], y) 261 | process x [] = (x, []) 262 | process xres@(x:xs) yres@(y:ys) = 263 | if x == y then process xs ys 264 | else (xres, yres) 265 | 266 | 267 | 268 | getMaxVelocity :: SampleGroup -> Double 269 | getMaxVelocity SampleGroup {..} = P.maximum (P.map vgVelocity sgGroups) 270 | 271 | 272 | 273 | 274 | velocityGroup :: Sample -> Sample -> Bool 275 | velocityGroup x1 x2 = 276 | let v = saVelocity x1 == saVelocity x2 277 | rr (Just rr1) (Just rr2) = rr1 == rr2 278 | rr _ _ = True 279 | res = v && rr (saRound x1) (saRound x2) 280 | in res 281 | -------------------------------------------------------------------------------- /src/Data/DrumDrops/VintageFolkParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | module Data.DrumDrops.VintageFolkParser 3 | ( 4 | getSampleFromFileName 5 | ,determineChannel 6 | ) 7 | where 8 | 9 | 10 | import Control.Monad (void) 11 | 12 | import Data.Text as T 13 | import Data.Types 14 | 15 | import Text.Parsec as P 16 | 17 | import System.FilePath 18 | 19 | import Data.DrumDrops.Types 20 | 21 | import Debug.Trace 22 | import Text.Printf 23 | 24 | 25 | getSampleFromFileName :: FilePath -> Int -> Either ParseError Sample 26 | getSampleFromFileName name nChannels = 27 | parse (sampleParser fname (fromIntegral nChannels)) fname' sname 28 | where 29 | fname' = takeFileName name 30 | fname = pack fname' 31 | sname = pack $ dropExtension fname' 32 | 33 | 34 | 35 | sampleParser :: Text -> Word -> Parsec Text u Sample 36 | sampleParser fname nChannels = do 37 | maker' <- many1 alphaNum 38 | case maker' of 39 | "SHKR" -> shakerParser fname nChannels 40 | "TAM1" -> tambourineParser fname nChannels 41 | "TAM" -> tambourineParser fname nChannels 42 | "GR10" -> generalParserWithTom fname nChannels maker' 1 43 | "GR12" -> generalParserWithTom fname nChannels maker' 2 44 | "GR13" -> generalParserWithTom fname nChannels maker' 3 45 | _ -> generalParser fname nChannels maker' 46 | 47 | 48 | 49 | generalParser :: Text -> Word -> String -> Parsec Text u Sample 50 | generalParser fname nChannels maker' = do 51 | void $ char '_' 52 | inst <- instrument 0 53 | void $ char '_' 54 | st <- case inst of 55 | HiHat -> hiHat 56 | _ -> instState 57 | void $ char '_' 58 | kitNumber 59 | void $ char '_' 60 | v <- velocity 61 | 62 | rr <- roundRobin 63 | 64 | let 65 | maker = pack maker' 66 | res = 67 | Sample fname maker inst st v rr nChannels 68 | 69 | return res 70 | 71 | 72 | generalParserWithTom :: Text -> Word -> String -> Int -> Parsec Text u Sample 73 | generalParserWithTom fname nChannels maker' tomNr = do 74 | void $ char '_' 75 | inst <- instrument tomNr 76 | void $ char '_' 77 | st <- case inst of 78 | HiHat -> hiHat 79 | _ -> instState 80 | void $ char '_' 81 | kitNumber 82 | void $ char '_' 83 | v <- velocity 84 | 85 | rr <- roundRobin 86 | 87 | let 88 | maker = pack maker' 89 | res = 90 | Sample fname maker inst st v rr nChannels 91 | 92 | return res 93 | 94 | 95 | 96 | shakerParser :: Text -> Word -> Parsec Text u Sample 97 | shakerParser fname nChannels = do 98 | let inst = Shaker 99 | void $ manyTill anyChar (try kitNumber) 100 | void $ char '_' 101 | v <- velocity 102 | 103 | rr <- roundRobin 104 | let res = Sample fname "" inst (InstS Close) v rr nChannels 105 | return res 106 | 107 | tambourineParser :: Text -> Word -> Parsec Text u Sample 108 | tambourineParser fname nChannels = do 109 | let inst = Tambourine 110 | void $ manyTill anyChar (try kitNumber) 111 | void $ char '_' 112 | v <- velocity 113 | 114 | rr <- roundRobin 115 | let res = Sample fname "" inst (InstS Close) v rr nChannels 116 | return res 117 | 118 | 119 | 120 | instrument :: Int -> Parsec Text u Instrument 121 | instrument tomNr = do 122 | (try (string "SNR") >> return Snare) 123 | <|> (try (string "SN") >> return Snare) 124 | <|> (try (string "KICK") >> return Kick) 125 | <|> (try (string "KK") >> return Kick) 126 | <|> (try (string "HAT") >> return HiHat) 127 | <|> (try (string "HH") >> return HiHat) 128 | <|> try (toms tomNr) 129 | <|> (try (string "CRSH") >> return Cymbal) 130 | <|> (try (string "CRS") >> return Cymbal) 131 | <|> (try (string "RIDE") >> return Ride) 132 | <|> (try (string "RD") >> return Ride) 133 | 134 | 135 | toms :: Int -> Parsec Text u Instrument 136 | toms tomNr = do 137 | t <- try racktom 138 | <|> try racktomN 139 | <|> try floorTom 140 | return (Tom t) 141 | where 142 | racktom = do 143 | void $ try (string "RKTM") 144 | return (RackTom tomNr) 145 | racktomN = do 146 | void $ try (string "RTM") <|> string "RT" 147 | n <- digit 148 | return (RackTom (read [n])) 149 | floorTom = do 150 | void $ try (string "FLTM") <|> string "FTM" 151 | return (Floor 1) 152 | 153 | 154 | micType :: Parsec Text u MicType 155 | micType = do 156 | genTry "CL" Close 157 | <|> genTry "OH" Overhead 158 | <|> genTry "FL" FullMix 159 | <|> genTry "K1" Kit1 160 | <|> genTry "K2" Kit2 161 | <|> genTry "KK" KickClose 162 | <|> genTry "SN" SnareClose 163 | 164 | 165 | 166 | genTry :: String -> a -> Parsec Text u a 167 | genTry what whatC = try (string what) >> return whatC 168 | 169 | 170 | hiHatState :: Parsec Text u HiHatState 171 | hiHatState = do 172 | genTry "BRC" HiHatBrushClosed 173 | <|> genTry "BRO" HiHatBrushOpen 174 | <|> genTry "HRO" HiHatHotRodsOpen 175 | <|> genTry "HRC" HiHatHotRodsClosed 176 | <|> genTry "C1EG" HiHatFullClosed 177 | <|> genTry "C1" HiHatFullClosed 178 | <|> genTry "C2EG" HiHatClosed 179 | <|> genTry "C2" HiHatClosed 180 | <|> genTry "C3EG" HiHatOpenQuarter 181 | <|> genTry "C3" HiHatOpenQuarter 182 | <|> genTry "O1EG" HiHatOpenHalf 183 | <|> genTry "O1" HiHatOpenHalf 184 | <|> genTry "O2EG" HiHatOpen3Quart 185 | <|> genTry "O2" HiHatOpen3Quart 186 | <|> genTry "O3EG" HiHatOpen 187 | <|> genTry "O3" HiHatOpen 188 | <|> genTry "EGC1" HiHatFullClosed 189 | <|> genTry "EGC2" HiHatClosed 190 | <|> genTry "EGC3" HiHatOpenQuarter 191 | <|> genTry "EGO1" HiHatOpenHalf 192 | <|> genTry "EGO2" HiHatOpen3Quart 193 | <|> genTry "EGO3" HiHatOpen 194 | <|> genTry "PC" HiHatPedalShut 195 | <|> genTry "PS" HiHatPedalShut 196 | <|> genTry "PO" HiHatPedalOpen 197 | 198 | 199 | hiHat :: Parsec Text u InstState 200 | hiHat = do 201 | st <- hiHatState 202 | void $ optional (char '_') 203 | mt <- micType 204 | return (HiHatS st mt) 205 | 206 | 207 | 208 | instState :: Parsec Text u InstState 209 | instState = do 210 | void $ manyTill anyChar (try (lookAhead micType)) 211 | mt <- micType 212 | sb <- try (string "SB") <|> return "" 213 | case sb of 214 | "SB" -> return (InstS Sub) 215 | _ -> return (InstS mt) 216 | 217 | 218 | kitNumber :: Parsec Text u () 219 | kitNumber = do 220 | void $ string "HT" 221 | void $ optional (char '_') 222 | void $ many1 digit 223 | return () 224 | 225 | 226 | velocity :: Parsec Text u Int 227 | velocity = do 228 | void $ optional (char 'V') 229 | n <- many1 digit 230 | return (read n) 231 | 232 | 233 | roundRobin :: Parsec Text u (Maybe Int) 234 | roundRobin = do 235 | try $ do 236 | void $ string "_RR" 237 | n <- many1 digit 238 | return (Just (read n)) 239 | <|> 240 | return Nothing 241 | 242 | 243 | 244 | determineChannel :: Sample -> Channel -> Microphones 245 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Close)}) Mono = 246 | KickC 247 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Close)}) LeftA = 248 | KickL 249 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Close)}) RightA = 250 | KickR 251 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Sub)}) Mono = 252 | KickS 253 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Overhead)}) LeftA = 254 | OHL 255 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Overhead)}) RightA = 256 | OHR 257 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Room)}) LeftA = 258 | RoomL 259 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Room)}) RightA = 260 | RoomR 261 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Close)}) Mono = 262 | SnareTop 263 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Close)}) LeftA = 264 | SnareL 265 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Close)}) RightA = 266 | SnareR 267 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Overhead)}) LeftA = 268 | OHL 269 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Overhead)}) RightA = 270 | OHR 271 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Room)}) LeftA = 272 | RoomL 273 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Room)}) RightA = 274 | RoomR 275 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Close)}) Mono = 276 | HiHatC 277 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Close)}) LeftA = 278 | HiHatL 279 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Close)}) RightA = 280 | HiHatR 281 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Room)}) LeftA = 282 | RoomL 283 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Room)}) RightA = 284 | RoomR 285 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Overhead)}) LeftA = 286 | OHL 287 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Overhead)}) RightA = 288 | OHR 289 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS Close)}) Mono = 290 | TomC x 291 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS Close)}) LeftA = 292 | TomL x 293 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS Close)}) RightA = 294 | TomR x 295 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Room)}) LeftA = 296 | RoomL 297 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Room)}) RightA = 298 | RoomR 299 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Overhead)}) LeftA = 300 | OHL 301 | determineChannel (Sample {saInstrument = Tom (RackTom _), saInstrumentProperties = (InstS Overhead)}) RightA = 302 | OHR 303 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS Close)}) Mono = 304 | FloorTomC x 305 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS Close)}) LeftA = 306 | FloorTomL x 307 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS Close)}) RightA = 308 | FloorTomR x 309 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Room)}) LeftA = 310 | RoomL 311 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Room)}) RightA = 312 | RoomR 313 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Overhead)}) LeftA = 314 | OHL 315 | determineChannel (Sample {saInstrument = Tom (Floor _), saInstrumentProperties = (InstS Overhead)}) RightA = 316 | OHR 317 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Overhead)}) LeftA = 318 | OHL 319 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Overhead)}) RightA = 320 | OHR 321 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Room)}) LeftA = 322 | RoomL 323 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Room)}) RightA = 324 | RoomR 325 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Overhead)}) LeftA = 326 | OHL 327 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Overhead)}) RightA = 328 | OHR 329 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Room)}) LeftA = 330 | RoomL 331 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Room)}) RightA = 332 | RoomR 333 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Close)}) Mono = 334 | RideC 335 | -- Multi Velocity Kits 336 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS FullMix)}) LeftA = 337 | KickL 338 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS FullMix)}) RightA = 339 | KickR 340 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS FullMix)}) LeftA = 341 | SnareL 342 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS FullMix)}) RightA = 343 | SnareR 344 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ FullMix)}) LeftA = 345 | HiHatL 346 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ FullMix)}) RightA = 347 | HiHatR 348 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS FullMix)}) LeftA = 349 | TomL x 350 | determineChannel (Sample {saInstrument = Tom (RackTom x), saInstrumentProperties = (InstS FullMix)}) RightA = 351 | TomR x 352 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS FullMix)}) LeftA = 353 | FloorTomL x 354 | determineChannel (Sample {saInstrument = Tom (Floor x), saInstrumentProperties = (InstS FullMix)}) RightA = 355 | FloorTomR x 356 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS FullMix)}) LeftA = 357 | RideL 358 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS FullMix)}) RightA = 359 | RideR 360 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS FullMix)}) LeftA = 361 | OHL 362 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS FullMix)}) RightA = 363 | OHR 364 | 365 | -- For the vintage folk kit 366 | 367 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS KickClose)}) Mono = 368 | KickC 369 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS SnareClose)}) Mono = 370 | SnareTop 371 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Kit1)}) Mono = 372 | RoomL 373 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Kit2)}) Mono = 374 | RoomR 375 | determineChannel (Sample {saInstrument = Kick, saInstrumentProperties = (InstS Overhead)}) Mono = 376 | OHL 377 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS KickClose)}) Mono = 378 | KickC 379 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS SnareClose)}) Mono = 380 | SnareTop 381 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Kit1)}) Mono = 382 | RoomL 383 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Kit2)}) Mono = 384 | RoomR 385 | determineChannel (Sample {saInstrument = Snare, saInstrumentProperties = (InstS Overhead)}) Mono = 386 | OHL 387 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ KickClose)}) Mono = 388 | KickC 389 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ SnareClose)}) Mono = 390 | SnareTop 391 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Kit1)}) Mono = 392 | RoomL 393 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Kit2)}) Mono = 394 | RoomR 395 | determineChannel (Sample {saInstrument = HiHat, saInstrumentProperties = (HiHatS _ Overhead)}) Mono = 396 | OHL 397 | determineChannel (Sample {saInstrument = Tom _, saInstrumentProperties = (InstS KickClose)}) Mono = 398 | KickC 399 | determineChannel (Sample {saInstrument = Tom _, saInstrumentProperties = (InstS SnareClose)}) Mono = 400 | SnareTop 401 | determineChannel (Sample {saInstrument = Tom _, saInstrumentProperties = (InstS Kit1)}) Mono = 402 | RoomL 403 | determineChannel (Sample {saInstrument = Tom _, saInstrumentProperties = (InstS Kit2)}) Mono = 404 | RoomR 405 | determineChannel (Sample {saInstrument = Tom _, saInstrumentProperties = (InstS Overhead)}) Mono = 406 | OHL 407 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS KickClose)}) Mono = 408 | KickC 409 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS SnareClose)}) Mono = 410 | SnareTop 411 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Kit1)}) Mono = 412 | RoomL 413 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Kit2)}) Mono = 414 | RoomR 415 | determineChannel (Sample {saInstrument = Cymbal, saInstrumentProperties = (InstS Overhead)}) Mono = 416 | OHL 417 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS KickClose)}) Mono = 418 | KickC 419 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS SnareClose)}) Mono = 420 | SnareTop 421 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Kit1)}) Mono = 422 | RoomL 423 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Kit2)}) Mono = 424 | RoomR 425 | determineChannel (Sample {saInstrument = Ride, saInstrumentProperties = (InstS Overhead)}) Mono = 426 | OHL 427 | determineChannel (Sample {saInstrument = Tambourine, saInstrumentProperties = (InstS Close)}) Mono = 428 | TambourineC 429 | determineChannel (Sample {saInstrument = Shaker, saInstrumentProperties = (InstS Close)}) Mono = 430 | ShakerC 431 | 432 | 433 | determineChannel sample channel = trace (printf "%s %s" (show sample) (show channel)) Undefined 434 | -------------------------------------------------------------------------------- /src/Data/Drumgizmo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Data.Drumgizmo 3 | 4 | where 5 | 6 | 7 | import Data.Text as T 8 | import Control.Exception 9 | import Control.Monad 10 | 11 | import System.Directory 12 | 13 | 14 | createDrumgizmoDirectories :: FilePath -> IO (Either Text ()) 15 | createDrumgizmoDirectories path = do 16 | catch (do 17 | e <- doesDirectoryExist path 18 | unless e $ createDirectory path 19 | 20 | -- let instPath = getInstrumentDir path 21 | -- e1 <- doesDirectoryExist instPath 22 | -- unless e1 $ createDirectory instPath 23 | 24 | return (Right ()) 25 | ) 26 | (\e -> do 27 | let err = show (e :: SomeException) 28 | return (Left (pack err)) 29 | ) 30 | 31 | 32 | dgDefaultVersion :: Text 33 | dgDefaultVersion = "2.0" 34 | -------------------------------------------------------------------------------- /src/Data/Export.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | module Data.Export 3 | ( convertToTabSep 4 | , writeMidiMapXML 5 | , writeInstrumentXML 6 | , writeDrumKitXML 7 | ) 8 | where 9 | 10 | 11 | import Data.Monoid ( (<>) ) 12 | import Data.Text ( Text 13 | , pack 14 | ) 15 | import qualified Data.Text.Lazy as L 16 | import Data.Text.Lazy.Builder as L 17 | import Data.Text.Lazy.Builder.Int as L 18 | import Data.Types 19 | 20 | import Text.XML.Stream.Render 21 | import Data.XML.Types 22 | import Data.Conduit ( ConduitT ) 23 | import qualified Data.Conduit as C 24 | import qualified Data.Conduit.Combinators as C 25 | 26 | 27 | 28 | 29 | 30 | writeInstrumentXML :: InstrumentFile -> FilePath -> IO () 31 | writeInstrumentXML iF filename = do 32 | C.runConduitRes 33 | $ conduitInstrumentSource iF 34 | C..| renderBytes (def { rsPretty = True }) 35 | C..| C.sinkFile filename 36 | 37 | 38 | conduitInstrumentSource :: Monad m => InstrumentFile -> ConduitT () Event m () 39 | conduitInstrumentSource iF = do 40 | C.yield EventBeginDocument 41 | conduitInstrumentXML iF 42 | 43 | 44 | conduitInstrumentXML :: Monad m => InstrumentFile -> ConduitT () Event m () 45 | conduitInstrumentXML InstrumentFile {..} = tag 46 | "instrument" 47 | (attr "version" ifVersion <> attr "name" ifName) 48 | (tag "samples" mempty (conduitSamples ifSamples)) 49 | 50 | 51 | conduitSamples :: Monad m => [HitSample] -> ConduitT () Event m () 52 | conduitSamples = foldr f mempty 53 | where 54 | f x b = 55 | tag "sample" 56 | (attr "name" (hsName x) <> attr "power" ((pack . show . hsPower) x)) 57 | (conduitAudioFiles (hsSamples x)) 58 | <> b 59 | 60 | 61 | 62 | conduitAudioFiles :: Monad m => [AudioFile] -> ConduitT () Event m () 63 | conduitAudioFiles = foldr f mempty 64 | where 65 | f x b = 66 | tag 67 | "audiofile" 68 | (attr "channel" (afChannel x) <> attr "file" (pack (afPath x)) <> attr 69 | "filechannel" 70 | ((pack . show . afFileChannel) x) 71 | ) 72 | mempty 73 | <> b 74 | 75 | 76 | conduitMidiMap :: Monad m => MidiMap -> ConduitT () Event m () 77 | conduitMidiMap (MidiMap mp) = tag "midimap" mempty noteEntries 78 | where 79 | noteEntries = foldr f mempty mp 80 | f (note, instr) b = 81 | tag "map" (attr "note" (pack (show note)) <> attr "instr" instr) mempty <> b 82 | 83 | conduitFullMidiMap :: Monad m => MidiMap -> ConduitT () Event m () 84 | conduitFullMidiMap mm = do 85 | C.yield EventBeginDocument 86 | conduitMidiMap mm 87 | 88 | 89 | writeMidiMapXML :: MidiMap -> FilePath -> IO () 90 | writeMidiMapXML mp filename = do 91 | C.runConduitRes 92 | $ conduitFullMidiMap mp 93 | C..| renderBytes (def { rsPretty = True }) 94 | C..| C.sinkFile filename 95 | 96 | 97 | dkName :: Drumkit -> Maybe Text 98 | dkName Drumkit { dkInfo = Left descr } = Just (odName descr) 99 | dkName _ = Nothing 100 | 101 | dkDescription :: Drumkit -> Maybe Text 102 | dkDescription Drumkit { dkInfo = Left descr } = Just (odDescription descr) 103 | dkDescription _ = Nothing 104 | 105 | 106 | conduitDrumKitXML :: Monad m => Drumkit -> ConduitT () Event m () 107 | conduitDrumKitXML dr = tag 108 | "drumkit" 109 | ( optionalAttr "name" (dkName dr) 110 | <> optionalAttr "description" (dkDescription dr) 111 | <> optionalAttr "samplerate" (dkSampleRate dr) 112 | ) 113 | (metadata (dkInfo dr) <> channels <> instruments) 114 | where 115 | 116 | channels = tag "channels" mempty (foldr ch mempty (dkChannels dr)) 117 | ch x b = tag "channel" (attr "name" x) mempty <> b 118 | instruments = tag "instruments" mempty (mapM_ ins (dkInstruments dr)) 119 | ins x = 120 | tag "instrument" 121 | (attr "name" (cmName x) <> gr x <> attr "file" (pack (cmFile x))) 122 | $ do 123 | case cmChokes x of 124 | Disabled _ -> return () 125 | Enabled ls -> chokes ls 126 | channelmap x 127 | gr x = case cmGroup x of 128 | Just g -> attr "group" g 129 | Nothing -> mempty 130 | channelmap x = foldr chm mempty (cmMap x) 131 | chm (ChannelMapItem c1 c2 mn) b = if mn 132 | then 133 | tag "channelmap" 134 | (attr "in" c1 <> attr "out" c2 <> attr "main" "true") 135 | mempty 136 | <> b 137 | else tag "channelmap" (attr "in" c1 <> attr "out" c2) mempty <> b 138 | 139 | chokes ls = tag "chokes" mempty $ foldr insChokes mempty ls 140 | insChokes choke acc = 141 | tag 142 | "choke" 143 | ( attr "instrument" (chokeInstrument choke) 144 | <> attr "choketime" (pack (show (chokeTime choke))) 145 | ) 146 | mempty 147 | <> acc 148 | 149 | 150 | 151 | metadata :: Monad m => Either OldDescr MetaData -> ConduitT () Event m () 152 | metadata (Left _) = mempty 153 | metadata (Right m) = tag 154 | "metadata" 155 | mempty 156 | ( version 157 | <> title 158 | <> logo 159 | <> description 160 | <> license 161 | <> notes 162 | <> email 163 | <> website 164 | <> image 165 | ) 166 | where 167 | version = maybe mempty (tag "version" mempty . content) (metaVersion m) 168 | title = maybe mempty (tag "title" mempty . content) (metaTitle m) 169 | logo = maybe mempty (\v -> tag "logo" (attr "src" v) mempty) (metaLogo m) 170 | description = 171 | maybe mempty (tag "description" mempty . content) (metaDescription m) 172 | license = maybe mempty (tag "license" mempty . content) (metaLicense m) 173 | notes = maybe mempty (tag "notes" mempty . content) (metaNotes m) 174 | email = maybe mempty (tag "email" mempty . content) (metaEMail m) 175 | website = maybe mempty (tag "website" mempty . content) (metaWebsite m) 176 | image = maybe mempty conduitImage (metaImage m) 177 | 178 | 179 | 180 | conduitImage :: Monad m => ImageData -> ConduitT () Event m () 181 | conduitImage imageData = do 182 | tag "image" 183 | (attr "src" (imgSource imageData) <> attr "map" (imgMap imageData)) 184 | $ foldr ins mempty (imgClickMap imageData) 185 | where 186 | ins ClickMapItem {cmiInstrument = inst, cmiColour = col} acc = 187 | tag "clickmap" (attr "colour" col <> attr "instrument" inst) mempty <> acc 188 | 189 | 190 | 191 | 192 | conduitFullDrumKit :: Monad m => Drumkit -> ConduitT () Event m () 193 | conduitFullDrumKit dr = do 194 | C.yield EventBeginDocument 195 | conduitDrumKitXML dr 196 | 197 | 198 | writeDrumKitXML :: Drumkit -> FilePath -> IO () 199 | writeDrumKitXML dr filename = do 200 | C.runConduitRes 201 | $ conduitFullDrumKit dr 202 | C..| renderBytes (def { rsPretty = True }) 203 | C..| C.sinkFile filename 204 | 205 | 206 | convertToTabSep :: MidiMap -> L.Text 207 | convertToTabSep mm = 208 | let ls = mmNote mm 209 | f (note, inst) b = 210 | fromText inst 211 | <> fromText "\t" 212 | <> decimal note 213 | <> fromText "\t" 214 | <> fromText (midiToNote note) 215 | <> fromText "\n" 216 | <> b 217 | header = "Instrument\tMIDI\tNote\n" 218 | in toLazyText $ header <> foldr f (fromText "") ls 219 | 220 | -------------------------------------------------------------------------------- /src/Data/Import.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | module Data.Import 3 | ( importMidiMap 4 | , importInstrumentFile 5 | , importDrumkitFile 6 | ) 7 | where 8 | 9 | 10 | import Data.Text ( Text 11 | , pack 12 | , unpack 13 | , append 14 | ) 15 | import Data.Text.Read 16 | import Data.Types 17 | import Text.XML.Stream.Parse 18 | import Data.XML.Types 19 | import qualified Data.Vector as V 20 | import Data.Either 21 | import Data.Maybe 22 | import System.FilePath 23 | 24 | import Control.Monad.Trans.Resource 25 | import Data.Conduit 26 | 27 | import Control.Exception 28 | import Data.Typeable 29 | 30 | 31 | data DKParseException = 32 | AudioFileParseError { dkpeMsg :: Text } 33 | | SampleFileParseError { dkpeMsg :: Text } 34 | | DrumkitParseError { dkpeMsg :: Text } 35 | deriving (Show, Typeable) 36 | 37 | instance Exception DKParseException 38 | 39 | 40 | 41 | parseMidiNote :: MonadThrow m => ConduitM Event o m (Maybe (Int, Text)) 42 | parseMidiNote = tag' "map" ((,) <$> requireAttr "note" <*> requireAttr "instr") 43 | $ \(note, instr) -> return (read (unpack note), instr) 44 | 45 | 46 | parseMidiMap :: MonadThrow m => ConduitM Event o m (Maybe MidiMap) 47 | parseMidiMap = do 48 | mms <- tagNoAttr "midimap" $ many parseMidiNote 49 | case mms of 50 | Nothing -> return Nothing 51 | Just x -> return $ Just (MidiMap x) 52 | 53 | 54 | importMidiMap :: FilePath -> IO (Maybe MidiMap) 55 | importMidiMap path = do 56 | runConduitRes $ parseFile def path .| parseMidiMap 57 | 58 | 59 | 60 | 61 | parseInstrument 62 | :: MonadThrow m => FilePath -> ConduitM Event o m (Maybe InstrumentFile) 63 | parseInstrument fname = do 64 | inst <- 65 | tag' "instrument" ((,) <$> requireAttr "version" <*> requireAttr "name") 66 | $ \(version, name) -> do 67 | smpls <- tagNoAttr "samples" $ many parseSamples 68 | return (version, name, smpls) 69 | case inst of 70 | Just (vers, nam, Just smpl) -> do 71 | let (path, instFileName) = splitFileName fname 72 | return $ Just 73 | (InstrumentFile vers nam (pack path) (pack instFileName) Nothing smpl) 74 | _ -> return Nothing 75 | 76 | 77 | 78 | parseSamples :: MonadThrow m => ConduitM Event o m (Maybe HitSample) 79 | parseSamples = 80 | tag' "sample" ((,) <$> requireAttr "name" <*> requireAttr "power") 81 | $ \(name, power) -> do 82 | af <- many parseAudioFile 83 | let p = double power 84 | if isLeft p 85 | then throwM 86 | (SampleFileParseError 87 | ("Invalid Power specified for Sample: " `append` name) 88 | ) 89 | else do 90 | let Right (x, _) = p 91 | return (HitSample name x af) 92 | 93 | 94 | parseAudioFile :: MonadThrow m => ConduitM Event o m (Maybe AudioFile) 95 | parseAudioFile = do 96 | tag' "audiofile" attrs $ \af -> return af 97 | where 98 | attrs = do 99 | chan <- requireAttr "channel" 100 | file <- requireAttr "file" 101 | filechannel <- requireAttr "filechannel" 102 | let filechannel' = decimal filechannel 103 | 104 | if isLeft filechannel' 105 | then throwM 106 | (AudioFileParseError ("Invalid Filechannel for file: " `append` file)) 107 | else do 108 | let Right (x, _) = filechannel' 109 | return $ AudioFile chan (unpack file) x Nothing Nothing 110 | 111 | 112 | importInstrumentFile :: FilePath -> IO (Either Text InstrumentFile) 113 | importInstrumentFile path = do 114 | catches worker [Handler handler, Handler handler2] 115 | where 116 | worker = do 117 | iF <- runConduitRes $ parseFile def path .| parseInstrument path 118 | return (maybe (Left "Could not parse file") Right iF) 119 | handler e = return (Left (dkpeMsg e)) 120 | handler2 XmlException {..} = do 121 | let msg = pack xmlErrorMessage `append` "\n\nContext: " `append` pack 122 | (show xmlBadInput) 123 | return (Left msg) 124 | handler2 e = return (Left (pack (show e))) 125 | 126 | 127 | conduitDrumKitXML :: MonadThrow m => ConduitM Event o m (Maybe Drumkit) 128 | conduitDrumKitXML = do 129 | tag' "drumkit" 130 | ((,,) <$> attr "name" <*> attr "description" <*> attr "samplerate") 131 | $ \(name, description, samplerate) -> do 132 | meta <- conduitMeta 133 | chans <- channels 134 | insts <- instruments 135 | case (chans, insts) of 136 | (Just c, Just i) -> 137 | return $ generateDrumKit name description meta samplerate c i 138 | _ -> throwM (DrumkitParseError "Cannot parse drumkit") 139 | where 140 | channels = tagNoAttr "channels" (many ch) 141 | ch = tag' "channel" (requireAttr "name") return 142 | instruments = tagNoAttr "instruments" (many instrumentData) 143 | 144 | 145 | 146 | instrumentData 147 | :: (Monad m, MonadThrow m) => ConduitM Event o m (Maybe ChannelMap) 148 | instrumentData = 149 | tag' "instrument" 150 | ((,,) <$> requireAttr "name" <*> attr "group" <*> requireAttr "file") 151 | $ \(name, group, file) -> do 152 | chokes <- chokeData 153 | cm' <- many channelmap 154 | let cm = V.fromList $ map mkChannelMapItemTuple cm' 155 | return $ ChannelMap name 156 | group 157 | (unpack file) 158 | Nothing 159 | cm 160 | (cmCheckUndefined cm) 161 | (mapChokes chokes) 162 | where 163 | channelmap = tag' 164 | "channelmap" 165 | ((,,) <$> requireAttr "in" <*> requireAttr "out" <*> attr "main") 166 | return 167 | mapChokes Nothing = Disabled [] 168 | mapChokes (Just chokes) = Enabled chokes 169 | 170 | 171 | chokeData :: (Monad m, MonadThrow m) => ConduitM Event o m (Maybe [ChokeData]) 172 | chokeData = tagNoAttr "chokes" $ many chokes 173 | where 174 | chokes = 175 | tag' "choke" ((,) <$> requireAttr "instrument" <*> attr "choketime") 176 | $ \(instr, tm) -> case tm of 177 | Nothing -> 178 | return ChokeData { chokeInstrument = instr, chokeTime = Nothing } 179 | Just t -> case signed decimal t of 180 | Left err -> throwM 181 | (DrumkitParseError 182 | ( "Error parsing choke: " 183 | <> t 184 | <> " is not an integer with:" 185 | <> (pack err) 186 | ) 187 | ) 188 | Right (time, _) -> return 189 | $ ChokeData { chokeInstrument = instr, chokeTime = Just time } 190 | 191 | 192 | 193 | generateDrumKit 194 | :: Maybe Text 195 | -> Maybe Text 196 | -> Maybe MetaData 197 | -> Maybe Text 198 | -> [Text] 199 | -> [ChannelMap] 200 | -> Drumkit 201 | generateDrumKit _name _descr (Just meta) samplerate channels instrs = 202 | Drumkit (Right meta) samplerate channels instrs 203 | generateDrumKit name descr Nothing samplerate channels instrs = 204 | let oldDescr = OldDescr (fromMaybe "" name) (fromMaybe "" descr) 205 | in Drumkit (Left oldDescr) samplerate channels instrs 206 | 207 | 208 | conduitMeta :: (Monad m, MonadThrow m) => ConduitM Event o m (Maybe MetaData) 209 | conduitMeta = tagNoAttr "metadata" $ do 210 | v <- version 211 | t <- title 212 | l <- logo 213 | desc <- description 214 | lic <- license 215 | n <- notes 216 | auth <- author 217 | em <- email 218 | ws <- website 219 | im <- imageData 220 | 221 | return MetaData { metaVersion = v 222 | , metaTitle = t 223 | , metaLogo = l 224 | , metaDescription = desc 225 | , metaLicense = lic 226 | , metaNotes = n 227 | , metaAuthor = auth 228 | , metaEMail = em 229 | , metaWebsite = ws 230 | , metaImage = im 231 | } 232 | where 233 | version = tagNoAttr "version" content 234 | title = tagNoAttr "title" content 235 | logo = tag' "logo" (requireAttr "src") pure 236 | description = tagNoAttr "description" content 237 | license = tagNoAttr "license" content 238 | notes = tagNoAttr "notes" content 239 | author = tagNoAttr "author" content 240 | email = tagNoAttr "email" content 241 | website = tagNoAttr "website" content 242 | 243 | 244 | imageData :: (Monad m, MonadThrow m) => ConduitM Event o m (Maybe ImageData) 245 | imageData = 246 | tag' "image" ((,) <$> requireAttr "src" <*> requireAttr "map") 247 | $ \(src, mapImg) -> do 248 | items <- many clickMapItem 249 | return (ImageData src mapImg items) 250 | 251 | clickMapItem 252 | :: (Monad m, MonadThrow m) => ConduitM Event o m (Maybe ClickMapItem) 253 | clickMapItem = 254 | tag' "clickmap" 255 | (ClickMapItem <$> requireAttr "instrument" <*> requireAttr "colour") 256 | $ \item -> return item 257 | 258 | 259 | 260 | importDrumkitFile :: FilePath -> IO (Either Text Drumkit) 261 | importDrumkitFile path = do 262 | catches worker [Handler handler, Handler handler2] 263 | where 264 | worker = do 265 | iF <- runConduitRes $ parseFile def path .| conduitDrumKitXML 266 | return (maybe (Left "Could not parse file") Right iF) 267 | handler e = return (Left (dkpeMsg e)) 268 | handler2 XmlException {..} = do 269 | let msg = pack xmlErrorMessage `append` "\n\nContext: " `append` pack 270 | (show xmlBadInput) 271 | return (Left msg) 272 | handler2 e = return (Left (pack (show e))) 273 | 274 | -------------------------------------------------------------------------------- /src/Data/MultiVelocity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, BangPatterns #-} 2 | module Data.MultiVelocity 3 | where 4 | 5 | 6 | 7 | import System.FilePath 8 | 9 | 10 | import Data.Text as T 11 | 12 | 13 | 14 | getFiles :: FilePath -> IO (Either Text [FilePath]) 15 | getFiles path = 16 | if doesDirectoryExist path 17 | then do 18 | cont' <- getDirectoryContents 19 | let cont = filter (not elem [".", ".."]) cont' 20 | return (Right cont) 21 | else do 22 | return (Left (pack path T.++ " is not a directory")) 23 | 24 | 25 | getVelocity :: FilePath -> Int 26 | getVelocity file = 0 27 | where 28 | filename = takeFileName file 29 | -------------------------------------------------------------------------------- /src/Data/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings 2 | , DeriveFunctor 3 | #-} 4 | module Data.Types where 5 | 6 | import Control.Monad ( void ) 7 | import Data.Text 8 | import Data.Set as S 9 | import Data.List as L 10 | ( (\\) ) 11 | import Data.Vector ( Vector ) 12 | import qualified Data.Vector as V 13 | import System.FilePath 14 | import Text.Parsec as P 15 | import Data.List ( sortOn ) 16 | import qualified Data.IntMap.Strict as M 17 | 18 | 19 | data MetaData = MetaData { 20 | metaVersion :: Maybe Text 21 | , metaTitle :: Maybe Text 22 | , metaLogo :: Maybe Text 23 | , metaDescription :: Maybe Text 24 | , metaLicense :: Maybe Text 25 | , metaNotes :: Maybe Text 26 | , metaAuthor :: Maybe Text 27 | , metaEMail :: Maybe Text 28 | , metaWebsite :: Maybe Text 29 | , metaImage :: Maybe ImageData 30 | } deriving (Show) 31 | 32 | 33 | emptyMetaData :: MetaData 34 | emptyMetaData = MetaData Nothing 35 | Nothing 36 | Nothing 37 | Nothing 38 | Nothing 39 | Nothing 40 | Nothing 41 | Nothing 42 | Nothing 43 | Nothing 44 | 45 | clearMetaData :: MetaData 46 | clearMetaData = MetaData (Just "") 47 | (Just "") 48 | (Just "") 49 | (Just "") 50 | (Just "") 51 | (Just "") 52 | (Just "") 53 | (Just "") 54 | (Just "") 55 | Nothing 56 | 57 | 58 | data ClickMapItem = ClickMapItem { 59 | cmiInstrument :: !Text 60 | , cmiColour :: !Text 61 | } 62 | deriving Show 63 | 64 | data ImageData = ImageData { 65 | imgSource :: !Text 66 | , imgMap :: !Text 67 | , imgClickMap :: [ClickMapItem] 68 | } deriving Show 69 | 70 | newImageData :: [Text] -> ImageData 71 | newImageData availableInstruments = 72 | ImageData "" "" (Prelude.map dat availableInstruments) 73 | where 74 | dat inst = ClickMapItem { cmiInstrument = inst, cmiColour = "" } 75 | 76 | 77 | data ChokeData = ChokeData { 78 | chokeInstrument :: !Text 79 | , chokeTime :: Maybe Int 80 | } deriving Show 81 | 82 | instance Eq ChokeData where 83 | c1 == c2 = chokeInstrument c1 == chokeInstrument c2 84 | 85 | 86 | data OldDescr = OldDescr { 87 | odName :: !Text 88 | , odDescription :: !Text 89 | } deriving(Show) 90 | 91 | data Drumkit = Drumkit { 92 | dkInfo :: Either OldDescr MetaData, 93 | dkSampleRate :: Maybe Text, 94 | dkChannels :: [Text], 95 | dkInstruments :: [ChannelMap] 96 | } deriving (Show) 97 | 98 | 99 | data Enabled a = Enabled a | Disabled a 100 | deriving (Show, Functor) 101 | 102 | isEnabled :: Enabled a -> Bool 103 | isEnabled (Enabled _) = True 104 | isEnabled _ = False 105 | 106 | toggleEnabled :: Enabled a -> Enabled a 107 | toggleEnabled (Enabled x) = Disabled x 108 | toggleEnabled (Disabled x) = Enabled x 109 | 110 | enabledPayload :: Enabled a -> a 111 | enabledPayload (Enabled x) = x 112 | enabledPayload (Disabled x) = x 113 | 114 | 115 | data ChannelMap = ChannelMap { 116 | cmName :: !Text, 117 | cmGroup :: Maybe Text, 118 | cmFile :: !FilePath, 119 | cmType :: Maybe Instrument, 120 | cmMap :: Vector ChannelMapItem, 121 | cmContainsUndefined :: Bool, 122 | cmChokes :: Enabled [ChokeData] 123 | } deriving (Show) 124 | 125 | getChokes :: ChannelMap -> [ChokeData] 126 | getChokes = enabledPayload . cmChokes 127 | 128 | 129 | data ChannelMapItem = ChannelMapItem { 130 | cmiIn :: !Text, 131 | cmiOut :: !Text, 132 | cmiMain :: !Bool 133 | } deriving (Show) 134 | 135 | 136 | newtype MidiMap = MidiMap { 137 | mmNote :: [(Int, Text)] 138 | } deriving (Show) 139 | 140 | data Instrument = 141 | Kick 142 | | Snare 143 | | HiHat 144 | | Tom TomType 145 | | Cymbal 146 | | Ride 147 | | Shaker 148 | | Tambourine 149 | deriving (Show, Read, Eq) 150 | 151 | instance Ord Instrument where 152 | compare x1 x2 = compare (toNumber x1) (toNumber x2) 153 | 154 | 155 | 156 | toNumber :: Instrument -> Int 157 | toNumber Kick = 1 158 | toNumber Snare = 2 159 | toNumber HiHat = 3 160 | toNumber (Tom _) = 4 161 | toNumber Cymbal = 5 162 | toNumber Ride = 6 163 | toNumber Shaker = 7 164 | toNumber Tambourine = 8 165 | 166 | 167 | 168 | data TomType = 169 | RackTom !Int 170 | | Floor !Int 171 | deriving (Show, Read, Eq) 172 | 173 | data MicType = 174 | Close 175 | | Sub 176 | | Overhead 177 | | Room 178 | | Room1 179 | | Room2 180 | | FullMix 181 | | Kit1 182 | | Kit2 183 | | KickClose 184 | | SnareClose 185 | | Top 186 | | Bottom 187 | deriving (Show, Enum, Ord, Eq) 188 | 189 | data HiHatState = 190 | HiHatFullClosed 191 | | HiHatClosed 192 | | HiHatOpenQuarter 193 | | HiHatOpenHalf 194 | | HiHatOpen3Quart 195 | | HiHatOpen 196 | | HiHatPedalShut 197 | | HiHatPedalOpen 198 | | HiHatBrushOpen 199 | | HiHatBrushClosed 200 | | HiHatHotRodsOpen 201 | | HiHatHotRodsClosed 202 | | HiHatUndefined 203 | deriving (Show, Enum, Ord, Eq) 204 | 205 | 206 | data InstState = 207 | HiHatS { 208 | hState :: !HiHatState, 209 | hMicType :: !MicType 210 | } 211 | | InstS { 212 | hMicType :: !MicType 213 | } 214 | deriving (Show, Eq) 215 | 216 | 217 | getMic :: InstState -> MicType 218 | getMic = hMicType 219 | 220 | 221 | 222 | data InstrumentFile = InstrumentFile { 223 | ifVersion :: !Text, 224 | ifName :: !Text, 225 | ifFilePath :: !Text, 226 | ifFileName :: !Text, 227 | ifType :: Maybe Instrument, 228 | ifSamples :: [HitSample] 229 | } deriving Show 230 | 231 | iflDefaultVersion :: Text 232 | iflDefaultVersion = "2.0" 233 | 234 | 235 | data HitSample = HitSample { 236 | hsName :: !Text, 237 | hsPower :: !Double, 238 | hsSamples :: [AudioFile] 239 | } deriving Show 240 | 241 | 242 | data AudioFile = AudioFile { 243 | afChannel:: !Text, 244 | afPath :: !FilePath, 245 | afFileChannel :: !Word, 246 | afPower :: Maybe Double, 247 | afSampleRate :: Maybe Int 248 | } deriving (Show, Read, Eq) 249 | 250 | instance Ord AudioFile where 251 | compare x1 x2 = compare (afChannel x1) (afChannel x2) 252 | 253 | 254 | data Microphones = 255 | KickC 256 | | KickL 257 | | KickR 258 | | KickS 259 | | SnareTop 260 | | SnareBottom 261 | | SnareL 262 | | SnareR 263 | | HiHatC 264 | | HiHatL 265 | | HiHatR 266 | | TomC Int 267 | | TomL Int 268 | | TomR Int 269 | | FloorTomC Int 270 | | FloorTomL Int 271 | | FloorTomR Int 272 | | RideC 273 | | RideL 274 | | RideR 275 | | OHL 276 | | OHR 277 | | RoomL 278 | | RoomR 279 | | Room1Mono 280 | | Room2Mono 281 | | FullMixL 282 | | FullMixR 283 | | ShakerC 284 | | TambourineC 285 | | Undefined 286 | deriving (Show, Read) 287 | 288 | 289 | showMic :: Microphones -> String 290 | showMic KickC = "KickC" 291 | showMic KickL = "KickL" 292 | showMic KickR = "KickR" 293 | showMic KickS = "KickS" 294 | showMic SnareTop = "SnareTop" 295 | showMic SnareBottom = "SnareBottom" 296 | showMic SnareL = "SnareL" 297 | showMic SnareR = "SnareR" 298 | showMic HiHatC = "HiHatC" 299 | showMic HiHatL = "HiHatL" 300 | showMic HiHatR = "HiHatR" 301 | showMic (TomC x) = "TomC" ++ show x 302 | showMic (TomL x) = "TomL" ++ show x 303 | showMic (TomR x) = "TomR" ++ show x 304 | showMic (FloorTomC x) = "FloorTomC" ++ show x 305 | showMic (FloorTomL x) = "FloorTomL" ++ show x 306 | showMic (FloorTomR x) = "FloorTomR" ++ show x 307 | showMic RideC = "RideC" 308 | showMic RideL = "RideL" 309 | showMic RideR = "RideR" 310 | showMic OHL = "OHL" 311 | showMic OHR = "OHR" 312 | showMic RoomL = "RoomL" 313 | showMic RoomR = "RoomR" 314 | showMic Room1Mono = "Room1Mono" 315 | showMic Room2Mono = "Room2Mono" 316 | showMic FullMixL = "FullMixL" 317 | showMic FullMixR = "FullMixR" 318 | showMic ShakerC = "ShakerC" 319 | showMic TambourineC = "TambourineC" 320 | showMic Undefined = "Undefined" 321 | 322 | 323 | 324 | 325 | instance Ord Microphones where 326 | compare x1 x2 = compare (micToInt x1) (micToInt x2) 327 | 328 | micToInt :: Microphones -> Int 329 | micToInt KickC = 0 330 | micToInt KickL = 1 331 | micToInt KickR = 2 332 | micToInt KickS = 3 333 | micToInt SnareTop = 4 334 | micToInt SnareBottom = 5 335 | micToInt SnareL = 6 336 | micToInt SnareR = 7 337 | micToInt HiHatC = 8 338 | micToInt HiHatL = 9 339 | micToInt HiHatR = 10 340 | micToInt (TomC x) = 10 + x 341 | micToInt (TomL x) = 20 + x 342 | micToInt (TomR x) = 30 + x 343 | micToInt (FloorTomC x) = 40 + x 344 | micToInt (FloorTomL x) = 50 + x 345 | micToInt (FloorTomR x) = 60 + x 346 | micToInt RideC = 70 347 | micToInt RideL = 71 348 | micToInt RideR = 72 349 | micToInt OHL = 73 350 | micToInt OHR = 74 351 | micToInt RoomL = 75 352 | micToInt RoomR = 76 353 | micToInt FullMixL = 77 354 | micToInt FullMixR = 78 355 | micToInt ShakerC = 79 356 | micToInt TambourineC = 80 357 | micToInt Room1Mono = 81 358 | micToInt Room2Mono = 82 359 | micToInt Undefined = 100 360 | 361 | 362 | instance Eq Microphones where 363 | x1 == x2 = micToInt x1 == micToInt x2 364 | 365 | 366 | 367 | 368 | micParser :: Parsec Text u Microphones 369 | micParser = 370 | do 371 | try (string "KickC") >> return KickC 372 | <|> (try (string "KickL") >> return KickL) 373 | <|> (try (string "KickR") >> return KickR) 374 | <|> (try (string "KickS") >> return KickS) 375 | <|> (try (string "SnareTop") >> return SnareTop) 376 | <|> (try (string "SnareBottom") >> return SnareBottom) 377 | <|> (try (string "SnareL") >> return SnareL) 378 | <|> (try (string "SnareR") >> return SnareR) 379 | <|> (try (string "HiHatC") >> return HiHatC) 380 | <|> (try (string "HiHatL") >> return HiHatL) 381 | <|> (try (string "HiHatR") >> return HiHatR) 382 | <|> do 383 | void $ try (string "TomC") 384 | n <- many1 digit 385 | return (TomC (read n)) 386 | <|> do 387 | void $ try (string "TomL") 388 | n <- many1 digit 389 | return (TomL (read n)) 390 | <|> do 391 | void $ try (string "TomR") 392 | n <- many1 digit 393 | return (TomR (read n)) 394 | <|> do 395 | void $ try (string "FloorTomC") 396 | n <- many1 digit 397 | return (FloorTomC (read n)) 398 | <|> do 399 | void $ try (string "FloorTomL") 400 | n <- many1 digit 401 | return (FloorTomL (read n)) 402 | <|> do 403 | void $ try (string "FloorTomR") 404 | n <- many1 digit 405 | return (FloorTomR (read n)) 406 | <|> (try (string "RideC") >> return RideC) 407 | <|> (try (string "RideL") >> return RideL) 408 | <|> (try (string "RideR") >> return RideR) 409 | <|> (try (string "OHL") >> return OHL) 410 | <|> (try (string "OHR") >> return OHR) 411 | <|> (try (string "RoomL") >> return RoomL) 412 | <|> (try (string "RoomR") >> return RoomR) 413 | <|> (try (string "Room1Mono") >> return Room1Mono) 414 | <|> (try (string "Room2Mono") >> return Room2Mono) 415 | <|> (try (string "FullMixL") >> return FullMixL) 416 | <|> (try (string "FullMixR") >> return FullMixR) 417 | <|> (try (string "ShakerC") >> return ShakerC) 418 | <|> (try (string "TambourineC") >> return TambourineC) 419 | <|> return Undefined 420 | 421 | 422 | validateMic :: Text -> Either Text Microphones 423 | validateMic txt = case parse micParser "" txt of 424 | Left err -> Left (pack (show err)) 425 | Right mic -> Right mic 426 | 427 | 428 | generateDrumkit 429 | :: Either OldDescr MetaData -> Maybe Text -> [InstrumentFile] -> Drumkit 430 | generateDrumkit descr samplerate ifl = res 431 | where 432 | res = Drumkit descr samplerate channels chanMap 433 | channels' = getAvailableChannels ifl 434 | channels = toAscList channels' 435 | 436 | chanMap = Prelude.map instrumentFileToChannelMap ifl 437 | 438 | 439 | instrumentFileToChannelMap :: InstrumentFile -> ChannelMap 440 | instrumentFileToChannelMap ifl = ChannelMap (ifName ifl) 441 | (grp (ifType ifl)) 442 | filePath 443 | (ifType ifl) 444 | chans 445 | (cmCheckUndefined chans) 446 | (Disabled []) 447 | where 448 | filePath = "Instruments" unpack (ifFileName ifl) 449 | grp (Just t) | t == HiHat = Just "hihat" 450 | grp _ = Nothing 451 | chans' = getAvailableChannelsIF ifl S.empty 452 | chans = 453 | V.fromList $ Prelude.map (\x -> mkChannelMapItem x x Nothing) $ toAscList 454 | chans' 455 | 456 | mkChannelMapItem :: Text -> Text -> Maybe Text -> ChannelMapItem 457 | mkChannelMapItem inp out mn = ChannelMapItem inp out (toBool mn) 458 | where 459 | toBool Nothing = False 460 | toBool (Just txt) = toUpper txt == "TRUE" 461 | 462 | mkChannelMapItemTuple :: (Text, Text, Maybe Text) -> ChannelMapItem 463 | mkChannelMapItemTuple (inp, out, mn) = mkChannelMapItem inp out mn 464 | 465 | 466 | channelMapItemUpdateMain :: ChannelMapItem -> Bool -> ChannelMapItem 467 | channelMapItemUpdateMain cm ena = cm { cmiMain = ena } 468 | 469 | channelMapUpdateMain :: ChannelMap -> Int -> Bool -> ChannelMap 470 | channelMapUpdateMain m idx ena = 471 | let chans = cmMap m 472 | newChans = V.imap f chans 473 | newMap = m { cmMap = newChans } 474 | in newMap 475 | where 476 | f i val | i == idx = channelMapItemUpdateMain val ena 477 | | otherwise = val 478 | 479 | 480 | getAvailableChannelsIF :: InstrumentFile -> Set Text -> Set Text 481 | getAvailableChannelsIF ifl set = Prelude.foldr acc1 set (ifSamples ifl) 482 | where 483 | acc1 hs s = Prelude.foldr acc s (hsSamples hs) 484 | acc af = S.insert (afChannel af) 485 | 486 | 487 | getAvailableChannels :: [InstrumentFile] -> Set Text 488 | getAvailableChannels = Prelude.foldr getAvailableChannelsIF S.empty 489 | 490 | 491 | 492 | getInstrumentNames :: Drumkit -> [Text] 493 | getInstrumentNames dk = Prelude.map cmName $ dkInstruments dk 494 | 495 | 496 | 497 | getMidiMap :: Drumkit -> MidiMap 498 | getMidiMap dk = MidiMap (sortOn fst (Prelude.map f (dkInstruments dk))) 499 | where 500 | f (ChannelMap { cmName = name, cmType = (Just t) }) = 501 | (getMidiNoteFromInstrument t, name) 502 | f cm = (0, cmName cm) 503 | 504 | 505 | 506 | getMidiNoteFromInstrument :: Instrument -> Int 507 | getMidiNoteFromInstrument Kick = 35 508 | getMidiNoteFromInstrument Snare = 38 509 | getMidiNoteFromInstrument HiHat = 42 510 | getMidiNoteFromInstrument (Tom (Floor _)) = 43 511 | getMidiNoteFromInstrument (Tom (RackTom _)) = 45 512 | getMidiNoteFromInstrument Cymbal = 55 513 | getMidiNoteFromInstrument Ride = 51 514 | getMidiNoteFromInstrument Shaker = 48 515 | getMidiNoteFromInstrument Tambourine = 32 516 | 517 | 518 | midiNotes :: M.IntMap Text 519 | midiNotes = M.fromList (Prelude.zip midi finalNotes) 520 | where 521 | midi = [0 .. 127] 522 | octaves = [(-2) .. 8] :: [Int] 523 | notes = ["C", "C#", "D", "D#", "E", "F", "F#", "G", "G#", "A", "A#", "B"] 524 | f oct note = note `append` pack (show oct) 525 | g oct = Prelude.map (f oct) notes 526 | finalNotes = Prelude.concatMap g octaves 527 | 528 | 529 | midiToNote :: Int -> Text 530 | midiToNote x = maybe "--" id $ M.lookup x midiNotes 531 | 532 | 533 | hsRemoveSamples :: HitSample -> [AudioFile] -> HitSample 534 | hsRemoveSamples hs samples = hs { hsSamples = hsSamples hs L.\\ samples } 535 | 536 | 537 | hsAddSamples :: HitSample -> [AudioFile] -> HitSample 538 | hsAddSamples hs samples = hs { hsSamples = hsSamples hs ++ samples } 539 | 540 | hsReplaceSamples :: HitSample -> [AudioFile] -> HitSample 541 | hsReplaceSamples hs samples = hs { hsSamples = samples } 542 | 543 | 544 | cmChangeChannel :: Text -> Text -> ChannelMap -> ChannelMap 545 | cmChangeChannel oldName newName cm = cm { cmMap = chans } 546 | where 547 | chans = V.map chg (cmMap cm) 548 | chg x@(ChannelMapItem inC outC mn) 549 | | outC == oldName = ChannelMapItem inC newName mn 550 | | otherwise = x 551 | 552 | cmCheckUndefined :: Vector ChannelMapItem -> Bool 553 | cmCheckUndefined = or . V.map ((== pack (show Undefined)) . cmiOut) 554 | 555 | cmUpdateIfUndefined :: ChannelMap -> ChannelMap 556 | cmUpdateIfUndefined cm = newCm 557 | where 558 | newCm = cm { cmContainsUndefined = val } 559 | val = cmCheckUndefined (cmMap cm) 560 | 561 | 562 | cmAnyUndefined :: ChannelMap -> Bool 563 | cmAnyUndefined cm = cmCheckUndefined (cmMap cm) 564 | -------------------------------------------------------------------------------- /src/Data/Version.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | OverloadedStrings 3 | , TemplateHaskell 4 | #-} 5 | module Data.Version 6 | (versionString) 7 | where 8 | 9 | import Data.Text as T 10 | import Development.GitRev 11 | 12 | 13 | 14 | versionString :: Text 15 | versionString = T.concat ["Version: 1.0 ", "Branch: ", $(gitBranch), " ", $(gitHash), "\ndirty: ", dirty, "\nCommit Date: ", $(gitCommitDate) ] 16 | 17 | dirty :: Text 18 | dirty | $(gitDirty) = "true" 19 | | otherwise = "false" 20 | -------------------------------------------------------------------------------- /src/Gtk/ClickyKitDialog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | OverloadedStrings 3 | , BangPatterns 4 | , TypeApplications 5 | #-} 6 | module Gtk.ClickyKitDialog 7 | ( ClickyKitDialog 8 | , initClickyKitDialog 9 | , showClickyKitDialog 10 | ) 11 | where 12 | 13 | 14 | import Graphics.UI.Gtk as G 15 | import Control.Monad 16 | import Control.Monad.IO.Class 17 | import Data.Types 18 | import Data.IORef 19 | import Data.Word 20 | import Data.Bits 21 | import Data.Functor.Identity 22 | import Data.Text ( Text ) 23 | import qualified Data.Text as T 24 | import Gtk.Utils 25 | 26 | import Text.Parsec 27 | import System.FilePath 28 | import Data.Array.MArray 29 | import Text.Builder as TB 30 | 31 | 32 | data ClickyKitDialog = ClickyKitDialog { 33 | ckdWindow :: Window 34 | , ckdDialog :: Dialog 35 | , ckdTreeView :: TreeView 36 | , ckdTreeModel :: ListStore ClickMapItem 37 | , ckdDKButton :: Button 38 | , ckdDKEntry :: Entry 39 | , ckdDKImage :: Image 40 | , ckdCMButton :: Button 41 | , ckdCMEntry :: Entry 42 | , ckdCMImage :: Image 43 | , ckdCMEventBox :: EventBox 44 | , ckdRef :: IORef (Maybe ImageData) 45 | } 46 | 47 | 48 | initClickyKitDialog :: Window -> G.Builder -> Entry -> IO ClickyKitDialog 49 | initClickyKitDialog window builder basepathEntry = do 50 | 51 | diag <- builderGetObject builder castToDialog ("clickyKitDialog" :: Text) 52 | 53 | void $ dialogAddButton diag ("Cancel" :: Text) ResponseClose 54 | void $ dialogAddButton diag ("OK" :: Text) ResponseOk 55 | 56 | tv <- builderGetObject builder 57 | castToTreeView 58 | ("treeviewCKInstruments" :: Text) 59 | 60 | dkButton <- builderGetObject builder 61 | castToButton 62 | ("buttonCKBrowseImage" :: Text) 63 | dkEntry <- builderGetObject builder 64 | castToEntry 65 | ("entryCKDrumImageFile" :: Text) 66 | dkImage <- builderGetObject builder castToImage ("imageDrumKit" :: Text) 67 | 68 | cmButton <- builderGetObject builder castToButton ("buttonCKClickMap" :: Text) 69 | cmEntry <- builderGetObject builder 70 | castToEntry 71 | ("entryCKClickMapFile" :: Text) 72 | cmImage <- builderGetObject builder castToImage ("imageClickMap" :: Text) 73 | eventBox <- builderGetObject builder castToEventBox ("eventBox" :: Text) 74 | 75 | 76 | widgetAddEvents cmImage [ButtonPressMask] 77 | miscSetAlignment cmImage 0 0 78 | miscSetAlignment dkImage 0 0 79 | 80 | model <- listStoreNew [] 81 | ref <- newIORef Nothing 82 | 83 | treeViewSetModel tv (Just model) 84 | 85 | col1 <- treeViewColumnNew 86 | col2 <- treeViewColumnNew 87 | 88 | treeViewColumnSetTitle @Text col1 "Instrument" 89 | treeViewColumnSetTitle @Text col2 "Colour" 90 | 91 | renderer1 <- cellRendererTextNew 92 | renderer2 <- cellRendererTextNew 93 | 94 | set renderer2 [cellTextEditable := True, cellTextEditableSet := True] 95 | 96 | cellLayoutPackStart col1 renderer1 True 97 | cellLayoutPackStart col2 renderer2 True 98 | 99 | cellLayoutSetAttributes col1 renderer1 model 100 | $ \cmi -> [cellText := cmiInstrument cmi] 101 | cellLayoutSetAttributes col2 renderer2 model 102 | $ \cmi -> [cellText := cmiColour cmi] 103 | 104 | void $ treeViewAppendColumn tv col1 105 | void $ treeViewAppendColumn tv col2 106 | 107 | -- edit call back for editing the channels 108 | void $ G.on renderer2 edited $ \[i] str -> do 109 | oldVal <- listStoreGetValue model i 110 | if not (T.null str) 111 | then do 112 | case parse colour "" str of 113 | Left err -> 114 | displayErrorBox window 115 | $ "Error: not a valid colour: " 116 | <> str 117 | <> ": " 118 | <> T.pack (show err) 119 | Right t -> do 120 | let newVal = oldVal { cmiColour = t } 121 | listStoreSetValue model i newVal 122 | else do 123 | let newVal = oldVal { cmiColour = "" } 124 | listStoreSetValue model i newVal 125 | 126 | let gui = ClickyKitDialog { ckdWindow = window 127 | , ckdDialog = diag 128 | , ckdTreeView = tv 129 | , ckdTreeModel = model 130 | , ckdDKButton = dkButton 131 | , ckdDKEntry = dkEntry 132 | , ckdDKImage = dkImage 133 | , ckdCMButton = cmButton 134 | , ckdCMEntry = cmEntry 135 | , ckdCMImage = cmImage 136 | , ckdCMEventBox = eventBox 137 | , ckdRef = ref 138 | } 139 | 140 | void $ on eventBox buttonPressEvent $ doubleClickCB gui 141 | 142 | let cb entry image = do 143 | basepath <- entryGetText basepathEntry 144 | file <- loadImage gui basepath 145 | forM_ file $ \f -> do 146 | entrySetText entry (takeFileName f) 147 | imageSetFromFile image f 148 | 149 | void $ on dkButton buttonActivated $ cb dkEntry dkImage 150 | void $ on cmButton buttonActivated $ cb cmEntry cmImage 151 | 152 | return gui 153 | 154 | 155 | doubleClickCB :: ClickyKitDialog -> EventM EButton Bool 156 | doubleClickCB diag = do 157 | button <- eventButton 158 | case button of 159 | LeftButton -> do 160 | cl <- eventClick 161 | case cl of 162 | DoubleClick -> do 163 | px@(x, y) <- eventCoordinates 164 | liftIO $ do 165 | pixbuf <- imageGetPixbuf (ckdCMImage diag) 166 | width <- pixbufGetWidth pixbuf 167 | height <- pixbufGetHeight pixbuf 168 | 169 | if round x < width && round y < height 170 | then do 171 | color <- getColor diag px 172 | putStrLn $ "ClickMap clicked: " <> show px <> " color: " <> T.unpack color 173 | setColorToSelected diag color 174 | return True 175 | else return False 176 | _ -> return False 177 | _ -> return False 178 | 179 | 180 | setColorToSelected :: ClickyKitDialog -> Text -> IO () 181 | setColorToSelected diag color = do 182 | sel <- treeViewGetSelection (ckdTreeView diag) 183 | rows' <- treeSelectionGetSelectedRows sel 184 | case rows' of 185 | ((i: _) : _) -> do 186 | val <- listStoreGetValue (ckdTreeModel diag) i 187 | let !newVal = val { cmiColour = color } 188 | listStoreSetValue (ckdTreeModel diag) i newVal 189 | _ -> return () 190 | 191 | getColor :: ClickyKitDialog -> (Double, Double) -> IO Text 192 | getColor diag (x, y) = do 193 | pixbuf <- imageGetPixbuf (ckdCMImage diag) 194 | rowstride <- pixbufGetRowstride pixbuf 195 | bps <- pixbufGetBitsPerSample pixbuf 196 | nchan <- pixbufGetNChannels pixbuf 197 | 198 | if bps /= 8 199 | then do 200 | displayErrorBox (ckdWindow diag) 201 | $ "Error: number of bits per colour channel is not supported (" 202 | <> run (decimal bps) 203 | return "" 204 | else do 205 | if nchan >= 3 206 | then do 207 | pixels <- pixbufGetPixels pixbuf :: IO (PixbufData Int Word8) 208 | let idx = round y * rowstride + round x * nchan 209 | r <- readArray pixels idx 210 | g <- readArray pixels (idx + 1) 211 | b <- readArray pixels (idx + 2) 212 | let val :: Word32 213 | !val = 214 | fromIntegral r 215 | `shiftL` 16 216 | .|. fromIntegral g 217 | `shiftL` 8 218 | .|. fromIntegral b 219 | return (run (padFromLeft 6 '0' (hexadecimal val))) 220 | else return "" 221 | 222 | 223 | colour :: ParsecT Text u Identity Text 224 | colour = T.pack <$> count 6 hexDigit 225 | 226 | showClickyKitDialog 227 | :: ClickyKitDialog -> ImageData -> FilePath -> IO (Maybe ImageData) 228 | showClickyKitDialog diag image basepath = do 229 | setImageData diag image basepath 230 | res <- dialogRun (ckdDialog diag) 231 | widgetHide (ckdDialog diag) 232 | case res of 233 | ResponseOk -> Just <$> getImageData diag 234 | _ -> return Nothing 235 | 236 | 237 | setImageData :: ClickyKitDialog -> ImageData -> FilePath -> IO () 238 | setImageData diag img basepath = do 239 | writeIORef (ckdRef diag) (Just img) 240 | setListStoreTo (ckdTreeModel diag) (imgClickMap img) 241 | entrySetText (ckdDKEntry diag) (imgSource img) 242 | entrySetText (ckdCMEntry diag) (imgMap img) 243 | 244 | imageSetFromFile (ckdDKImage diag) (basepath T.unpack (imgSource img)) 245 | imageSetFromFile (ckdCMImage diag) (basepath T.unpack (imgMap img)) 246 | 247 | 248 | 249 | 250 | getImageData :: ClickyKitDialog -> IO ImageData 251 | getImageData diag = do 252 | ImageData 253 | <$> entryGetText (ckdDKEntry diag) 254 | <*> entryGetText (ckdCMEntry diag) 255 | <*> listStoreToList (ckdTreeModel diag) 256 | 257 | 258 | loadImage :: ClickyKitDialog -> FilePath -> IO (Maybe FilePath) 259 | loadImage diag basepath = do 260 | dialog <- fileChooserDialogNew 261 | (Just ("Load Image File" :: Text)) --dialog title 262 | (Just (ckdWindow diag)) --the parent window 263 | FileChooserActionSave --the kind of dialog we want 264 | [ ( "gtk-cancel" --The buttons to display 265 | , ResponseCancel 266 | ) 267 | , ("gtk-open", ResponseAccept) 268 | ] 269 | 270 | void $ fileChooserSetCurrentFolder dialog basepath 271 | 272 | widgetShow dialog 273 | resp <- dialogRun dialog 274 | widgetHide dialog 275 | case resp of 276 | ResponseAccept -> do 277 | fileChooserGetFilename dialog 278 | _ -> return Nothing 279 | -------------------------------------------------------------------------------- /src/Gtk/Colors.hs: -------------------------------------------------------------------------------- 1 | module Gtk.Colors 2 | 3 | 4 | where 5 | 6 | import Graphics.UI.Gtk 7 | 8 | 9 | 10 | 11 | black :: Color 12 | black = Color 0 0 0 13 | 14 | white :: Color 15 | white = Color 0xffff 0xffff 0xffff 16 | 17 | green :: Color 18 | green = Color 0 0xffff 0 19 | 20 | yellow :: Color 21 | yellow = Color 0xffff 0xffff 0 22 | 23 | red :: Color 24 | red = Color 0xffff 0 0 25 | 26 | paleYellow :: Color 27 | paleYellow = Color 0xffff 0xffff (102*256) 28 | 29 | -------------------------------------------------------------------------------- /src/Gtk/DGPatchMakerBuilder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell 2 | #-} 3 | module Gtk.DGPatchMakerBuilder 4 | (builderFileAsString) 5 | where 6 | 7 | import Data.FileEmbed 8 | 9 | 10 | builderFileAsString :: String 11 | builderFileAsString = $(embedStringFile "DGPatchMaker.glade") 12 | 13 | 14 | -------------------------------------------------------------------------------- /src/Gtk/DirectedChokeDialog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | OverloadedStrings 3 | , TypeApplications 4 | , BangPatterns 5 | #-} 6 | module Gtk.DirectedChokeDialog 7 | ( DirectedChokeDialog 8 | , initDialog 9 | , showChokeDialog 10 | ) 11 | where 12 | 13 | import Graphics.UI.Gtk as G 14 | import Control.Monad 15 | import Data.Types 16 | import Data.IORef 17 | import Data.Text ( Text ) 18 | import qualified Data.Text as T 19 | 20 | import Text.Parsec 21 | import Text.ParserCombinators.Parsec.Number 22 | 23 | import Gtk.Utils 24 | 25 | 26 | 27 | data DirectedChokeDialog = DirectedChokeDialog { 28 | dcWindow :: Window 29 | , dcDialog :: Dialog 30 | , dcCloseButton :: Button 31 | , dcOkButton :: Button 32 | , dcInstrument :: Entry 33 | , dcAddButton :: Button 34 | , dcRemoveButton :: Button 35 | , dcTvAvailableInstruments :: TreeView 36 | , dcTvAvailableInstrumentsModel :: ListStore Text 37 | , dcTvChokedInstruments :: TreeView 38 | , dcTvChokedInsturmentsModel :: ListStore ChokeData 39 | , dcRef :: IORef (Maybe ChannelMap) 40 | } 41 | 42 | 43 | initDialog :: Window -> Builder -> IO DirectedChokeDialog 44 | initDialog window builder = do 45 | 46 | diag <- builderGetObject builder castToDialog ("chokeDialog" :: Text) 47 | 48 | closeButton <- dialogAddButton diag ("Cancel" :: Text) ResponseClose 49 | okButton <- dialogAddButton diag ("OK" :: Text) ResponseOk 50 | 51 | instr <- builderGetObject builder castToEntry ("entryChokeInstrument" :: Text) 52 | availableInstr <- builderGetObject builder 53 | castToTreeView 54 | ("treeViewAvailableInstruments" :: Text) 55 | chokedInstr <- builderGetObject builder 56 | castToTreeView 57 | ("treeViewInstrumentsToChoke" :: Text) 58 | 59 | addButton <- builderGetObject builder castToButton ("buttonCAdd" :: Text) 60 | removeButton <- builderGetObject builder 61 | castToButton 62 | ("buttonCRemove" :: Text) 63 | 64 | availableInstrLM <- listStoreNew [] 65 | chokedInstrLM <- listStoreNew [] 66 | 67 | initAvailableInstruments availableInstr availableInstrLM 68 | initChokedInstruments window chokedInstr chokedInstrLM 69 | 70 | ref <- newIORef Nothing 71 | 72 | let gui = DirectedChokeDialog 73 | { dcDialog = diag 74 | , dcCloseButton = closeButton 75 | , dcOkButton = okButton 76 | , dcInstrument = instr 77 | , dcAddButton = addButton 78 | , dcRemoveButton = removeButton 79 | , dcTvAvailableInstruments = availableInstr 80 | , dcTvAvailableInstrumentsModel = availableInstrLM 81 | , dcTvChokedInstruments = chokedInstr 82 | , dcTvChokedInsturmentsModel = chokedInstrLM 83 | , dcRef = ref 84 | , dcWindow = window 85 | } 86 | 87 | 88 | void $ on addButton buttonActivated $ addInstrument gui 89 | void $ on removeButton buttonActivated $ removeInstrument gui 90 | 91 | return gui 92 | 93 | 94 | showChokeDialog 95 | :: DirectedChokeDialog -> ChannelMap -> [Text] -> IO (Maybe ChannelMap) 96 | showChokeDialog diag instrument availableInstruments = do 97 | writeIORef (dcRef diag) (Just instrument) 98 | entrySetText (dcInstrument diag) (cmName instrument) 99 | 100 | let chokes = map chokeInstrument (getChokes instrument) 101 | newAvailableInstruments = filter (`notElem` chokes) availableInstruments 102 | 103 | setListStoreTo (dcTvAvailableInstrumentsModel diag) newAvailableInstruments 104 | setListStoreTo (dcTvChokedInsturmentsModel diag) (getChokes instrument) 105 | 106 | res <- dialogRun (dcDialog diag) 107 | widgetHide (dcDialog diag) 108 | case res of 109 | ResponseOk -> getNewChannelMap diag 110 | _ -> return Nothing 111 | 112 | 113 | initAvailableInstruments :: TreeView -> ListStore Text -> IO () 114 | initAvailableInstruments tv lm = do 115 | treeViewSetModel tv (Just lm) 116 | 117 | col <- treeViewColumnNew 118 | treeViewColumnSetTitle @Text col "Instruments" 119 | renderer <- cellRendererTextNew 120 | cellLayoutPackStart col renderer True 121 | 122 | cellLayoutSetAttributes col renderer lm $ \i -> [cellText := i] 123 | 124 | void $ treeViewAppendColumn tv col 125 | 126 | sel <- treeViewGetSelection tv 127 | treeSelectionSetMode sel SelectionMultiple 128 | 129 | 130 | 131 | initChokedInstruments :: Window -> TreeView -> ListStore ChokeData -> IO () 132 | initChokedInstruments window tv lm = do 133 | treeViewSetModel tv (Just lm) 134 | 135 | col1 <- treeViewColumnNew 136 | col2 <- treeViewColumnNew 137 | 138 | treeViewColumnSetTitle @Text col1 "Instrument" 139 | treeViewColumnSetTitle @Text col2 "Choke Time" 140 | 141 | renderer1 <- cellRendererTextNew 142 | renderer2 <- cellRendererTextNew 143 | 144 | set renderer2 [cellTextEditable := True, cellTextEditableSet := True] 145 | 146 | cellLayoutPackStart col1 renderer1 True 147 | cellLayoutPackStart col2 renderer2 True 148 | 149 | cellLayoutSetAttributes col1 renderer1 lm 150 | $ \(ChokeData i _) -> [cellText := i] 151 | cellLayoutSetAttributes col2 renderer2 lm 152 | $ \(ChokeData _ t) -> [cellText := T.pack (show t)] 153 | 154 | void $ treeViewAppendColumn tv col1 155 | void $ treeViewAppendColumn tv col2 156 | 157 | sel <- treeViewGetSelection tv 158 | treeSelectionSetMode sel SelectionMultiple 159 | 160 | -- edit call back for editing the channels 161 | void $ G.on renderer2 edited $ \[i] str -> do 162 | oldVal <- listStoreGetValue lm i 163 | if null str 164 | then do 165 | let newVal = oldVal { chokeTime = Nothing } 166 | listStoreSetValue lm i newVal 167 | else do 168 | case parse int "" str of 169 | Left err -> 170 | displayErrorBox window 171 | $ "Error: time must be an integer number: " 172 | <> T.pack (show err) 173 | Right t -> do 174 | let newVal = oldVal { chokeTime = Just t } 175 | listStoreSetValue lm i newVal 176 | 177 | 178 | 179 | 180 | getNewChannelMap :: DirectedChokeDialog -> IO (Maybe ChannelMap) 181 | getNewChannelMap diag = do 182 | inst' <- readIORef (dcRef diag) 183 | case inst' of 184 | Nothing -> return Nothing 185 | Just inst -> do 186 | lst <- listStoreToList (dcTvChokedInsturmentsModel diag) 187 | let newChokes = if Prelude.null lst then Disabled [] else Enabled lst 188 | !newCm = inst { cmChokes = newChokes } 189 | return (Just newCm) 190 | 191 | 192 | 193 | addInstrument :: DirectedChokeDialog -> IO () 194 | addInstrument diag = do 195 | sel <- treeViewGetSelection (dcTvAvailableInstruments diag) 196 | rows <- Prelude.map Prelude.head <$> treeSelectionGetSelectedRows sel 197 | 198 | instruments <- forM rows 199 | $ listStoreGetValue (dcTvAvailableInstrumentsModel diag) 200 | forM_ instruments $ \inst -> 201 | listStoreAppend (dcTvChokedInsturmentsModel diag) (ChokeData inst Nothing) 202 | 203 | -- now remove the instruments 204 | insts <- listStoreToList (dcTvAvailableInstrumentsModel diag) 205 | let newInsts = filter (`notElem` instruments) insts 206 | setListStoreTo (dcTvAvailableInstrumentsModel diag) newInsts 207 | 208 | 209 | removeInstrument :: DirectedChokeDialog -> IO () 210 | removeInstrument diag = do 211 | sel <- treeViewGetSelection (dcTvChokedInstruments diag) 212 | rows <- Prelude.map Prelude.head <$> treeSelectionGetSelectedRows sel 213 | 214 | chokes <- forM rows 215 | $ listStoreGetValue (dcTvChokedInsturmentsModel diag) 216 | forM_ chokes $ \inst -> 217 | listStoreAppend (dcTvAvailableInstrumentsModel diag) (chokeInstrument inst) 218 | 219 | -- now remove the instruments 220 | oldChokes <- listStoreToList (dcTvChokedInsturmentsModel diag) 221 | let newChokes = filter (`notElem` chokes) oldChokes 222 | setListStoreTo (dcTvChokedInsturmentsModel diag) newChokes 223 | 224 | -------------------------------------------------------------------------------- /src/Gtk/ErrorDialog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, BangPatterns #-} 2 | module Gtk.ErrorDialog 3 | 4 | where 5 | 6 | 7 | 8 | import Data.Text 9 | import Graphics.UI.Gtk 10 | 11 | 12 | data ErrorDialog = ErrorDialog { 13 | guiEdDialog :: MessageDialog, 14 | guiEdTextView :: TextView 15 | } 16 | 17 | 18 | initErrorDialog :: Builder -> IO ErrorDialog 19 | initErrorDialog builder = do 20 | messageDialog <- builderGetObject builder castToMessageDialog ("messagedialogCustom" :: Text) 21 | 22 | textview <- builderGetObject builder castToTextView ("textviewErrorMsgs" :: Text) 23 | 24 | let gui = ErrorDialog { 25 | guiEdDialog = messageDialog, 26 | guiEdTextView = textview 27 | } 28 | 29 | return gui 30 | 31 | 32 | displayMultiErrors :: ErrorDialog -> Text -> [Text] -> IO () 33 | displayMultiErrors diag mainText errors = do 34 | let tv = guiEdTextView diag 35 | dialog = guiEdDialog diag 36 | errorText = intercalate "\n\nNext Error:\n\n" errors 37 | 38 | buffer <- textViewGetBuffer tv 39 | textBufferSetText buffer errorText 40 | 41 | set dialog [messageDialogText := Just mainText] 42 | 43 | _ <- dialogRun dialog 44 | widgetHide dialog 45 | 46 | return () 47 | 48 | -------------------------------------------------------------------------------- /src/Gtk/FileHandlingDialog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, BangPatterns #-} 2 | module Gtk.FileHandlingDialog 3 | ( 4 | initFileHandlingDialog 5 | ,askUserForOverwriteIfNecessary 6 | ,FileHandlingDialog 7 | ,FhResultValue(..) 8 | ,resetFileHandlingDialog 9 | ,withFileHandlingDialog 10 | ) 11 | where 12 | 13 | 14 | import Control.Monad (void) 15 | import Control.Exception (bracket, catch, SomeException(..)) 16 | import Data.Text 17 | import Graphics.UI.Gtk 18 | import Data.IORef 19 | import System.Directory 20 | 21 | data FileHandlingDialog = FileHandlingDialog { 22 | guiFhDialog :: MessageDialog, 23 | guiFhValue :: IORef FHandling 24 | } 25 | 26 | data FHandling = 27 | Skip 28 | | SkipAll 29 | | Overwrite 30 | | OverwriteAll 31 | deriving (Eq, Ord, Enum, Show) 32 | 33 | data FhResultValue = SkipFile | OverwriteFile 34 | deriving (Eq, Ord, Enum, Show) 35 | 36 | 37 | initFileHandlingDialog :: Builder -> IO FileHandlingDialog 38 | initFileHandlingDialog builder = do 39 | messageDialog <- builderGetObject builder castToMessageDialog ("messagedialogFileHandling" :: Text) 40 | 41 | buttonSkip <- builderGetObject builder castToButton ("buttonSkip" :: Text) 42 | buttonSkipAll <- builderGetObject builder castToButton ("buttonSkipAll" :: Text) 43 | buttonOverwrite <- builderGetObject builder castToButton ("buttonOverwrite" :: Text) 44 | buttonOverwriteAll <- builderGetObject builder castToButton ("buttonOverwriteAll" :: Text) 45 | 46 | ir <- newIORef Overwrite 47 | 48 | let gui = FileHandlingDialog { 49 | guiFhDialog = messageDialog, 50 | guiFhValue = ir 51 | } 52 | 53 | void $ on buttonSkip buttonActivated $ setValue gui Skip 54 | void $ on buttonSkipAll buttonActivated $ setValue gui SkipAll 55 | void $ on buttonOverwrite buttonActivated $ setValue gui Overwrite 56 | void $ on buttonOverwriteAll buttonActivated $ setValue gui OverwriteAll 57 | 58 | return gui 59 | 60 | setValue :: FileHandlingDialog -> FHandling -> IO () 61 | setValue gui handling = do 62 | writeIORef (guiFhValue gui) handling 63 | dialogResponse (guiFhDialog gui) (ResponseUser (fromEnum handling)) 64 | 65 | askUserForOverwriteIfNecessary :: FileHandlingDialog -> FilePath -> (IO ()) -> IO (Either Text ()) 66 | askUserForOverwriteIfNecessary diag file writeAction = do 67 | let dialog = guiFhDialog diag 68 | txt = "File '" `append` pack file `append` "' does already exist." 69 | 70 | ex <- doesFileExist file 71 | case ex of 72 | True -> do 73 | val <- readIORef (guiFhValue diag) 74 | 75 | let showDialog = do 76 | set dialog [messageDialogText := Just txt] 77 | (ResponseUser resp) <- dialogRun dialog 78 | widgetHide dialog 79 | case toEnum resp of 80 | Skip -> return SkipFile 81 | SkipAll -> return SkipFile 82 | Overwrite -> return OverwriteFile 83 | OverwriteAll -> return OverwriteFile 84 | 85 | v <- case val of 86 | Skip -> showDialog 87 | Overwrite -> showDialog 88 | SkipAll -> return SkipFile 89 | OverwriteAll -> return OverwriteFile 90 | 91 | case v of 92 | SkipFile -> return (Right ()) 93 | OverwriteFile -> writeAction' 94 | False -> writeAction' 95 | where 96 | writeAction' = do 97 | catch (writeAction >> return (Right ())) 98 | (\e -> do 99 | let err = show (e :: SomeException) 100 | return (Left (pack err)) 101 | ) 102 | 103 | 104 | withFileHandlingDialog :: FileHandlingDialog -> (IO a) -> IO a 105 | withFileHandlingDialog gui action = do 106 | bracket (resetFileHandlingDialog gui) 107 | (\_ -> resetFileHandlingDialog gui) 108 | (\_ -> action) 109 | 110 | 111 | resetFileHandlingDialog :: FileHandlingDialog -> IO () 112 | resetFileHandlingDialog gui = writeIORef (guiFhValue gui) Overwrite 113 | 114 | -------------------------------------------------------------------------------- /src/Gtk/HitPowerDialog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, BangPatterns #-} 2 | module Gtk.HitPowerDialog 3 | ( 4 | HitPowerDialog 5 | ,initHitPowerDialog 6 | ,dialogGetHitParams 7 | ,dialogEqualEnable 8 | ,HitPowerDialogResult(..) 9 | ) 10 | where 11 | 12 | 13 | import Control.Monad (void) 14 | import Data.Text 15 | import Graphics.UI.Gtk 16 | 17 | 18 | data HitPowerDialog = HitPowerDialog { 19 | hpdStart :: SpinButton, 20 | hpdStop :: SpinButton, 21 | hpdStep :: SpinButton, 22 | hpdDialog :: Dialog 23 | } 24 | 25 | 26 | data HitPowerDialogResult = HitPowerDialogResult { 27 | hprStart :: Int, 28 | hprStop :: Int, 29 | hprStep :: Int 30 | } 31 | 32 | initHitPowerDialog :: Builder -> IO HitPowerDialog 33 | initHitPowerDialog builder = do 34 | diag <- builderGetObject builder castToDialog ("dialogHitPowerLin" :: Text) 35 | start <- builderGetObject builder castToSpinButton ("spinbuttonStart" :: Text) 36 | stop <- builderGetObject builder castToSpinButton ("spinbuttonStop" :: Text) 37 | step <- builderGetObject builder castToSpinButton ("spinbuttonStep" :: Text) 38 | 39 | void $ dialogAddButton diag ("OK" :: Text) ResponseOk 40 | void $ dialogAddButton diag ("Cancel" :: Text) ResponseCancel 41 | 42 | 43 | let gui = HitPowerDialog { 44 | hpdDialog = diag, 45 | hpdStart = start, 46 | hpdStop = stop, 47 | hpdStep = step 48 | } 49 | 50 | return gui 51 | 52 | 53 | dialogEqualEnable :: HitPowerDialog -> Bool -> IO () 54 | dialogEqualEnable gui val = do 55 | widgetSetSensitive (hpdStop gui) val 56 | widgetSetSensitive (hpdStep gui) val 57 | 58 | 59 | 60 | dialogGetHitParams :: HitPowerDialog -> IO (Maybe HitPowerDialogResult) 61 | dialogGetHitParams diag = do 62 | let 63 | dialog = hpdDialog diag 64 | 65 | resp <- dialogRun dialog 66 | widgetHide dialog 67 | case resp of 68 | ResponseOk -> do 69 | sta <- spinButtonGetValueAsInt (hpdStart diag) 70 | sto <- spinButtonGetValueAsInt (hpdStop diag) 71 | ste <- spinButtonGetValueAsInt (hpdStep diag) 72 | return $ Just (HitPowerDialogResult sta sto ste) 73 | _ -> return Nothing 74 | -------------------------------------------------------------------------------- /src/Gtk/InstrumentPageBuilder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell 2 | #-} 3 | module Gtk.InstrumentPageBuilder 4 | (builderFileAsString) 5 | where 6 | 7 | import Data.FileEmbed 8 | 9 | 10 | builderFileAsString :: String 11 | builderFileAsString = $(embedStringFile "InstrumentPage.glade") 12 | 13 | -------------------------------------------------------------------------------- /src/Gtk/MainWindow.hs: -------------------------------------------------------------------------------- 1 | module Gtk.MainWindow 2 | where 3 | 4 | 5 | import Graphics.UI.Gtk 6 | --import Data.Text 7 | import Data.IORef 8 | import Data.Vector 9 | import Gtk.Drumkit 10 | import Gtk.InstrumentFrame 11 | 12 | 13 | data MainWindow = MainWindow { 14 | guiWindow :: Window, 15 | guiNotebook :: Notebook, 16 | guiNotebookInstruments :: Notebook, 17 | guiInstrumentPages :: IORef (Vector InstrumentPage), 18 | guiProgress :: ProgressBar, 19 | guiDrumkitPage :: DrumkitPage 20 | } 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /src/Gtk/MidiMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, BangPatterns, NoImplicitPrelude #-} 2 | module Gtk.MidiMap 3 | ( 4 | MidiMapPage 5 | ,initMidiMap 6 | ,setMidiMap 7 | ,getMidiMapFromGUI 8 | ,writeMidiMapFile 9 | ,resetMidiMap 10 | ) 11 | where 12 | 13 | import ClassyPrelude 14 | 15 | import Data.Types 16 | import Data.Checkers 17 | --import Data.Drumgizmo 18 | import Data.Import 19 | import Data.Export 20 | 21 | import qualified Data.Text as T 22 | import qualified Data.Text.Lazy.IO as L 23 | --import qualified Data.ByteString.Lazy as B 24 | import qualified Data.Vector as V 25 | 26 | import Graphics.UI.Gtk as G 27 | 28 | import Gtk.Colors 29 | import Gtk.Utils 30 | import Gtk.FileHandlingDialog 31 | 32 | import System.FilePath 33 | 34 | --import Debug.Trace 35 | 36 | 37 | data MidiMapPage = MidiMapPage { 38 | mmMainWindow :: Window, 39 | mmMidiMapView :: TreeView, 40 | mmMidiMapModel :: ListStore MidiMapItem, 41 | mmNoteRenderer :: CellRendererText, 42 | mmLoadMap :: Button, 43 | mmExportMap :: Button, 44 | mmBasePath :: Entry, 45 | mmFhDialog :: FileHandlingDialog 46 | } 47 | 48 | 49 | data MidiMapItem = MidiMapItem { 50 | mmiNote :: Int, 51 | mmiInstrument :: Text, 52 | mmiIsOverlap :: Bool 53 | } deriving (Show, Eq) 54 | 55 | --instance Eq MidiMapItem where 56 | -- x1 == x2 = (mmiNote x1) == (mmiNote x2) 57 | 58 | instance Ord MidiMapItem where 59 | compare x1 x2 = compare (mmiNote x1) (mmiNote x2) 60 | 61 | 62 | initMidiMap :: Window -> TreeView -> Entry -> Button -> Button -> FileHandlingDialog -> IO MidiMapPage 63 | initMidiMap window tv basepath loadButton exportButton fhDialog = do 64 | 65 | ls <- listStoreNew [] 66 | 67 | rend <- initTreeViewMM tv ls 68 | 69 | let gui = MidiMapPage { 70 | mmMainWindow = window, 71 | mmMidiMapModel = ls, 72 | mmMidiMapView = tv, 73 | mmNoteRenderer = rend, 74 | mmLoadMap = loadButton, 75 | mmExportMap = exportButton, 76 | mmBasePath = basepath, 77 | mmFhDialog = fhDialog 78 | } 79 | 80 | setupCallbacks gui 81 | 82 | void $ G.on loadButton buttonActivated $ cbImportMidiMap gui 83 | void $ G.on exportButton buttonActivated $ cbExportMidiMap gui 84 | 85 | return gui 86 | 87 | 88 | initTreeViewMM :: TreeView -> ListStore MidiMapItem -> IO CellRendererText 89 | initTreeViewMM tv ls = do 90 | sortModel <- treeModelSortNewWithModel ls 91 | 92 | treeViewSetModel tv (Just sortModel) 93 | 94 | treeViewSetHeadersVisible tv True 95 | 96 | -- add a couple columns 97 | col1 <- treeViewColumnNew 98 | col2 <- treeViewColumnNew 99 | col3 <- treeViewColumnNew 100 | 101 | let sort0 = 0 102 | sort1 = 1 103 | sort2 = 2 104 | 105 | treeViewColumnSetSortColumnId col1 sort0 106 | treeViewColumnSetSortColumnId col2 sort1 107 | treeViewColumnSetSortColumnId col3 sort2 108 | 109 | treeViewColumnSetTitle col1 ("MIDI" :: Text) 110 | treeViewColumnSetTitle col2 ("Note" :: Text) 111 | treeViewColumnSetTitle col3 ("Instrument" :: Text) 112 | 113 | renderer1 <- cellRendererTextNew 114 | renderer2 <- cellRendererTextNew 115 | renderer3 <- cellRendererTextNew 116 | 117 | set renderer1 [cellTextEditable := True, 118 | cellTextEditableSet := True 119 | ] 120 | 121 | cellLayoutPackStart col1 renderer1 True 122 | cellLayoutPackStart col2 renderer2 True 123 | cellLayoutPackStart col3 renderer3 True 124 | 125 | 126 | cellLayoutSetAttributes col1 renderer1 ls $ \x -> [ cellText := T.pack (show (mmiNote x)), 127 | cellTextBackgroundColor := yellow, 128 | cellTextBackgroundSet := mmiIsOverlap x] 129 | cellLayoutSetAttributes col2 renderer2 ls $ \x -> [ cellText := midiToNote (mmiNote x), 130 | cellTextBackgroundColor := yellow, 131 | cellTextBackgroundSet := mmiIsOverlap x] 132 | cellLayoutSetAttributes col3 renderer3 ls $ \x -> [ cellText := mmiInstrument x] 133 | 134 | 135 | _ <- treeViewAppendColumn tv col1 136 | _ <- treeViewAppendColumn tv col2 137 | _ <- treeViewAppendColumn tv col3 138 | 139 | treeViewSetEnableSearch tv True 140 | treeViewSetSearchEqualFunc tv $ Just $ \str iter -> do 141 | res <- treeModelGetPath ls iter 142 | if (not (null res)) 143 | then do 144 | let (i : _) = res 145 | !row <- listStoreGetValue ls i 146 | return $ toLower str `isInfixOf` toLower (mmiInstrument row) 147 | else return False 148 | 149 | treeSortableSetSortFunc sortModel sort0 $ \iter1 iter2 -> do 150 | m1 <- treeModelGetRow ls iter1 151 | m2 <- treeModelGetRow ls iter2 152 | return (compare (mmiNote m1) (mmiNote m2)) 153 | treeSortableSetSortFunc sortModel sort1 $ \iter1 iter2 -> do 154 | m1 <- treeModelGetRow ls iter1 155 | m2 <- treeModelGetRow ls iter2 156 | return (compare (mmiNote m1) (mmiNote m2)) 157 | treeSortableSetSortFunc sortModel sort2 $ \iter1 iter2 -> do 158 | m1 <- treeModelGetRow ls iter1 159 | m2 <- treeModelGetRow ls iter2 160 | return (compare (mmiInstrument m1) (mmiInstrument m2)) 161 | 162 | 163 | return renderer1 164 | 165 | 166 | setMidiMap :: MidiMapPage -> MidiMap -> IO () 167 | setMidiMap gui mm = do 168 | let ls = mmMidiMapModel gui 169 | setListStoreTo ls ((checkOverlap.convertFromMM) mm) 170 | 171 | getMidiMapFromGUI :: MidiMapPage -> IO MidiMap 172 | getMidiMapFromGUI gui = do 173 | ls <- listStoreToList (mmMidiMapModel gui) 174 | return $! (convertToMM ls) 175 | 176 | 177 | convertFromMM :: MidiMap -> [MidiMapItem] 178 | convertFromMM mm = map conv (mmNote mm) 179 | where 180 | conv (note, inst) = MidiMapItem note inst False 181 | 182 | convertToMM :: [MidiMapItem] -> MidiMap 183 | convertToMM ls = MidiMap (map conv ls) 184 | where 185 | conv mm = (mmiNote mm, mmiInstrument mm) 186 | 187 | 188 | checkOverlap :: [MidiMapItem] -> [MidiMapItem] 189 | checkOverlap mm = 190 | let is :: [(Int, MidiMapItem)] 191 | is = zip [0..] mm 192 | is' = sortOn snd is 193 | 194 | pred' (_, mm1) (_, mm2) = mmiNote mm1 == mmiNote mm2 195 | gr = groupBy pred' is' 196 | overlaps = concat $ map f gr 197 | f [] = [] 198 | f [(idx, mmi)] = [(idx, mmi {mmiIsOverlap = False})] 199 | f l@(_ : _) = map overlap l 200 | overlap (idx, mmi) = (idx, mmi {mmiIsOverlap = True}) 201 | 202 | result = map snd $ sortOn fst overlaps 203 | in 204 | result 205 | 206 | 207 | --printList :: Show a => [a] -> String 208 | --printList ls = intercalate "\n" $ map (pack.show) ls 209 | 210 | 211 | setupCallbacks :: MidiMapPage -> IO () 212 | setupCallbacks gui = do 213 | let model = mmMidiMapModel gui 214 | 215 | void $ G.on (mmNoteRenderer gui) edited $ \[i] str -> do 216 | val <- listStoreGetValue model i 217 | let res = checkInt str 0 127 (Just "Illegal Value for MIDI Note") 218 | case res of 219 | Left err -> displayErrorBox (mmMainWindow gui) err 220 | Right x -> do 221 | let val' = val {mmiNote = fromIntegral x} 222 | listStoreSetValue model i val' 223 | 224 | -- check for overlaps 225 | ls <- listStoreToList model 226 | let vec = V.fromList $ checkOverlap ls 227 | n <- listStoreGetSize model 228 | forM_ [0..(n-1)] $ \j -> do 229 | m <- listStoreGetValue model j 230 | let vm = vec V.! j 231 | if (m /= vm) then listStoreSetValue model j vm else return () 232 | 233 | 234 | 235 | cbImportMidiMap :: MidiMapPage -> IO () 236 | cbImportMidiMap gui = do 237 | let parentWindow = mmMainWindow gui 238 | dialog <- fileChooserDialogNew 239 | (Just $ ("Select MIDI Map for Loading" :: Text)) --dialog title 240 | (Just parentWindow) --the parent window 241 | FileChooserActionOpen --the kind of dialog we want 242 | [("gtk-cancel" --The buttons to display 243 | ,ResponseCancel) 244 | ,("gtk-open" 245 | , ResponseAccept)] 246 | path <- entryGetText (mmBasePath gui) 247 | void $ fileChooserSetFilename dialog path 248 | 249 | widgetShow dialog 250 | resp <- dialogRun dialog 251 | case resp of 252 | ResponseAccept -> do 253 | Just file <- fileChooserGetFilename dialog 254 | res <- importMidiMap file 255 | case res of 256 | Nothing -> displayErrorBox parentWindow ("Could not load MIDI Map: " `T.append` (pack file)) 257 | Just x -> setMidiMap gui x 258 | return () 259 | ResponseCancel -> return () 260 | ResponseDeleteEvent -> return () 261 | _ -> return () 262 | widgetHide dialog 263 | 264 | 265 | cbExportMidiMap :: MidiMapPage -> IO () 266 | cbExportMidiMap gui = do 267 | let parentWindow = mmMainWindow gui 268 | dialog <- fileChooserDialogNew 269 | (Just $ ("Save MIDI Map" :: Text)) --dialog title 270 | (Just parentWindow) --the parent window 271 | FileChooserActionSave --the kind of dialog we want 272 | [("gtk-cancel" --The buttons to display 273 | ,ResponseCancel) 274 | ,("gtk-save" 275 | , ResponseAccept)] 276 | path <- entryGetText (mmBasePath gui) 277 | void $ fileChooserSetFilename dialog path 278 | 279 | widgetShow dialog 280 | resp <- dialogRun dialog 281 | case resp of 282 | ResponseAccept -> do 283 | Just file <- fileChooserGetFilename dialog 284 | -- export the file 285 | midimap <- getMidiMapFromGUI gui 286 | writeMidiMapFile gui (pack file) midimap 287 | return () 288 | ResponseCancel -> return () 289 | ResponseDeleteEvent -> return () 290 | _ -> return () 291 | widgetHide dialog 292 | 293 | 294 | 295 | 296 | 297 | writeMidiMapFile :: MidiMapPage -> Text -> MidiMap -> IO () 298 | writeMidiMapFile gui filename midimap = do 299 | catch (writeMidiMapFile' gui filename midimap) 300 | (\e -> displayErrorBox (mmMainWindow gui) ("Error during MIDI map export: " <> pack (show (e :: SomeException)))) 301 | 302 | writeMidiMapFile' :: MidiMapPage -> Text -> MidiMap -> IO () 303 | writeMidiMapFile' gui filename midimap = do 304 | basepath <- entryGetText (mmBasePath gui) 305 | let 306 | content2 = convertToTabSep midimap 307 | path = basepath unpack filename 308 | path2 = replaceExtension path ".txt" 309 | 310 | res <- askUserForOverwriteIfNecessary (mmFhDialog gui) path $ writeMidiMapXML midimap path 311 | case res of 312 | Left err -> displayErrorBox (mmMainWindow gui) err 313 | Right _ -> L.writeFile path2 content2 314 | 315 | 316 | 317 | 318 | resetMidiMap :: MidiMapPage -> IO () 319 | resetMidiMap gui = do 320 | listStoreClear (mmMidiMapModel gui) 321 | return () 322 | 323 | -------------------------------------------------------------------------------- /src/Gtk/NrHitsDialog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, BangPatterns #-} 2 | module Gtk.NrHitsDialog 3 | ( 4 | NrHitsDialog 5 | ,initNrHitsDialog 6 | ,dialogGetNrHits 7 | ) 8 | where 9 | 10 | 11 | import Control.Monad (void) 12 | import Data.Text 13 | import Graphics.UI.Gtk 14 | 15 | 16 | data NrHitsDialog = NrHitsDialog { 17 | nrhNumberHits :: SpinButton, 18 | nrhDialog :: Dialog 19 | } 20 | 21 | 22 | initNrHitsDialog :: Builder -> IO NrHitsDialog 23 | initNrHitsDialog builder = do 24 | nrHitsDiag <- builderGetObject builder castToDialog ("dialogNrHits" :: Text) 25 | spin <- builderGetObject builder castToSpinButton ("spinbuttonNrHits" :: Text) 26 | 27 | void $ dialogAddButton nrHitsDiag ("OK" :: Text) ResponseOk 28 | void $ dialogAddButton nrHitsDiag ("Cancel" :: Text) ResponseCancel 29 | 30 | 31 | let gui = NrHitsDialog { 32 | nrhDialog = nrHitsDiag, 33 | nrhNumberHits = spin 34 | } 35 | 36 | return gui 37 | 38 | 39 | 40 | dialogGetNrHits :: NrHitsDialog -> IO (Maybe Int) 41 | dialogGetNrHits diag = do 42 | let 43 | dialog = nrhDialog diag 44 | 45 | resp <- dialogRun dialog 46 | widgetHide dialog 47 | case resp of 48 | ResponseOk -> Just <$> spinButtonGetValueAsInt (nrhNumberHits diag) 49 | _ -> return Nothing 50 | -------------------------------------------------------------------------------- /src/Gtk/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, BangPatterns, NoImplicitPrelude #-} 2 | module Gtk.Utils where 3 | 4 | import ClassyPrelude 5 | 6 | import Data.Char 7 | import qualified Data.Vector as V 8 | 9 | import Graphics.UI.Gtk 10 | import Data.Text as T 11 | hiding ( map ) 12 | 13 | 14 | displayErrorBox :: Window -> Text -> IO () 15 | displayErrorBox parentWindow txt = do 16 | dialog <- messageDialogNew (Just parentWindow) 17 | [DialogDestroyWithParent] 18 | MessageError 19 | ButtonsClose 20 | (cropText txt) 21 | _ <- dialogRun dialog 22 | widgetHide dialog 23 | return () 24 | 25 | displayInfoBox :: Window -> Text -> IO () 26 | displayInfoBox parentWindow txt = do 27 | dialog <- messageDialogNew (Just parentWindow) 28 | [DialogDestroyWithParent] 29 | MessageInfo 30 | ButtonsClose 31 | (cropText txt) 32 | _ <- dialogRun dialog 33 | widgetHide dialog 34 | return () 35 | 36 | 37 | cropText :: Text -> Text 38 | cropText txt = 39 | let len = 1024 40 | in if T.length txt > len then T.take len txt `append` "..." else txt 41 | 42 | 43 | clearNotebook :: Notebook -> IO () 44 | clearNotebook nb = do 45 | n <- notebookGetNPages nb 46 | forM_ [0 .. n] (notebookRemovePage nb) 47 | 48 | 49 | setListStoreTo :: ListStore a -> [a] -> IO () 50 | setListStoreTo ls xs = do 51 | listStoreClear ls 52 | mapM_ (void . listStoreAppend ls) xs 53 | 54 | setListStoreToVec :: ListStore a -> Vector a -> IO () 55 | setListStoreToVec ls xs = do 56 | listStoreClear ls 57 | V.mapM_ (void . listStoreAppend ls) xs 58 | 59 | 60 | 61 | 62 | listStoreMap :: ListStore a -> (a -> a) -> IO () 63 | listStoreMap ls f = do 64 | xs <- listStoreToList ls 65 | let newxs = map f xs 66 | setListStoreTo ls newxs 67 | 68 | listStoreIMap :: ListStore a -> (Int -> a -> a) -> IO () 69 | listStoreIMap ls f = do 70 | len <- listStoreGetSize ls 71 | let go i 72 | | i >= len = return () 73 | | otherwise = do 74 | val <- listStoreGetValue ls i 75 | listStoreSetValue ls i (f i val) 76 | 77 | go 0 78 | 79 | 80 | textViewGetText :: TextView -> IO Text 81 | textViewGetText tv = do 82 | buffer <- textViewGetBuffer tv 83 | (start, end) <- textBufferGetBounds buffer 84 | textBufferGetText buffer start end False 85 | 86 | 87 | activateRow :: TreeView -> Int -> IO () 88 | activateRow tv idx = do 89 | Just col <- treeViewGetColumn tv 0 90 | treeViewRowActivated tv [idx] col 91 | 92 | 93 | isLeftChannel :: Text -> Bool 94 | isLeftChannel x | T.last x == 'L' = True 95 | | isDigit (T.last x) && (T.last (T.dropEnd 1 x)) == 'L' = True 96 | | otherwise = False 97 | 98 | isRightChannel :: Text -> Bool 99 | isRightChannel x | T.last x == 'R' = True 100 | | isDigit (T.last x) && (T.last (T.dropEnd 1 x)) == 'R' = True 101 | | otherwise = False 102 | 103 | -------------------------------------------------------------------------------- /src/GtkInterface.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, BangPatterns #-} 2 | module GtkInterface where 3 | 4 | 5 | import Control.Monad as M 6 | ( void ) 7 | import Control.Monad.IO.Class ( liftIO ) 8 | 9 | import Graphics.UI.Gtk 10 | 11 | import Data.Text as T 12 | import Data.IORef 13 | import Data.Vector as V 14 | 15 | import Gtk.MainWindow 16 | import Gtk.InstrumentFrame 17 | import Gtk.Drumkit 18 | import Gtk.FileHandlingDialog 19 | import Gtk.ErrorDialog 20 | 21 | import Gtk.DGPatchMakerBuilder 22 | 23 | 24 | 25 | 26 | initMainWindow :: IO MainWindow 27 | initMainWindow = do 28 | void initGUI 29 | -- Create the builder, and load the UI file 30 | builder <- builderNew 31 | 32 | --builderAddFromFile builder "DGPatchMaker.glade" 33 | builderAddFromString builder builderFileAsString 34 | 35 | -- Retrieve some objects from the UI 36 | window <- builderGetObject builder castToWindow ("mainWindow" :: Text) 37 | 38 | windowMaximize window 39 | 40 | set window [windowTitle := ("DrumgGizmo Patch Maker" :: Text)] 41 | 42 | notebook <- builderGetObject builder castToNotebook ("notebookMain" :: Text) 43 | itemQuit <- builderGetObject builder castToMenuItem ("menuitemQuit" :: Text) 44 | notebookInstruments <- builderGetObject builder 45 | castToNotebook 46 | ("notebookInstruments" :: Text) 47 | 48 | buttonNewInstrument <- builderGetObject builder 49 | castToButton 50 | ("buttonNewInstrument" :: Text) 51 | buttonRemoveInstrument <- builderGetObject builder 52 | castToButton 53 | ("buttonRemoveInstrument" :: Text) 54 | entryBaseDirectory <- builderGetObject builder 55 | castToEntry 56 | ("entryBaseDirectory" :: Text) 57 | entrySamplesDir <- builderGetObject builder 58 | castToEntry 59 | ("entrySamplesDirectory" :: Text) 60 | entryExportDir <- builderGetObject builder 61 | castToEntry 62 | ("entryExportDirectory" :: Text) 63 | 64 | progress <- builderGetObject builder 65 | castToProgressBar 66 | ("progressbar" :: Text) 67 | 68 | combo <- builderGetObject builder castToComboBox ("comboboxParser" :: Text) 69 | 70 | fhDialog <- initFileHandlingDialog builder 71 | errDiag <- initErrorDialog builder 72 | 73 | instPages <- newIORef (V.empty) 74 | 75 | -- initialise the drumkit page 76 | drumkitPage <- initDrumkitPage window 77 | builder 78 | notebookInstruments 79 | progress 80 | combo 81 | entryBaseDirectory 82 | entrySamplesDir 83 | entryExportDir 84 | instPages 85 | fhDialog 86 | 87 | let gui = MainWindow 88 | { guiWindow = window 89 | , guiNotebook = notebook 90 | , guiNotebookInstruments = notebookInstruments 91 | , guiInstrumentPages = instPages 92 | , guiProgress = progress 93 | , guiDrumkitPage = drumkitPage 94 | } 95 | 96 | --insertInstrumentPage inst 97 | 98 | void $ on buttonNewInstrument buttonActivated $ do 99 | let name = "New Instrument" :: Text 100 | ins <- instrumentPageNew window 101 | notebookInstruments 102 | entryExportDir 103 | entrySamplesDir 104 | combo 105 | instPages 106 | fhDialog 107 | errDiag 108 | (setDkSampleRate drumkitPage) 109 | i <- notebookAppendPage notebookInstruments 110 | (instrumentPageGetMainBox ins) 111 | name 112 | instrumentPageInsert ins 113 | notebookSetCurrentPage notebookInstruments i 114 | instrumentPageSetInstrumentName ins name 115 | 116 | void $ on buttonRemoveInstrument buttonActivated $ do 117 | i <- notebookGetCurrentPage notebookInstruments 118 | modifyIORef' instPages $ V.ifilter (\ix _ -> ix /= i) 119 | notebookRemovePage notebookInstruments i 120 | 121 | 122 | -- set termination 123 | void $ window `on` deleteEvent $ liftIO quit 124 | void $ on itemQuit menuItemActivate (void quit) 125 | 126 | 127 | -- setup about dialog 128 | aboutDialog <- aboutDialogNew 129 | set 130 | aboutDialog 131 | [ aboutDialogProgramName := ("DrumGizmo Patch Maker" :: Text) 132 | , aboutDialogVersion := ("V0.8" :: Text) 133 | , aboutDialogCopyright := ("(C) by Michael Oswald" :: Text) 134 | , aboutDialogComments 135 | := ("A tool for creating patches for the drumgizmo plugin\n\n" :: Text 136 | ) 137 | , aboutDialogAuthors := [("Michael Oswald" :: Text)] 138 | ] 139 | -- Display the window 140 | widgetShowAll window 141 | 142 | return gui 143 | 144 | gtkInterfaceMainLoop :: MainWindow -> IO () 145 | gtkInterfaceMainLoop _ = do 146 | mainGUI 147 | 148 | 149 | quit :: IO Bool 150 | quit = do 151 | mainQuit 152 | return False 153 | 154 | 155 | 156 | 157 | 158 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | where 3 | 4 | 5 | 6 | import GtkInterface 7 | 8 | 9 | 10 | main :: IO () 11 | main = do 12 | gui <- initMainWindow 13 | 14 | gtkInterfaceMainLoop gui 15 | 16 | return () 17 | -------------------------------------------------------------------------------- /src/tests/CreateGladeSource.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | where 3 | 4 | 5 | import System.Environment 6 | import System.Console.GetOpt 7 | import System.FilePath 8 | 9 | import Data.List 10 | import Data.Maybe 11 | 12 | 13 | main :: IO () 14 | main = do 15 | (conf, _) <- (getArgs >>= parseOpts) 16 | case optVersion conf of 17 | True -> putStrLn "Version 1.1" 18 | False -> do 19 | writeDGBuilder conf 20 | writeIPBuilder conf 21 | 22 | 23 | writeDGBuilder :: CmdOptions -> IO () 24 | writeDGBuilder conf = do 25 | content <- readFile (optGladeFile conf) 26 | let outfile = (optOutFilePath conf "DGPatchMakerBuilder.hs") 27 | putStrLn $ "Processing file " ++ (optGladeFile conf) ++ " into " ++ outfile 28 | writeFile outfile (newCont content) 29 | where 30 | newCont content = concat [header, escapedContent content, footer] 31 | header = "module Gtk.DGPatchMakerBuilder\n(builderFileAsString)\nwhere\n\n\nbuilderFileAsString :: String\nbuilderFileAsString = \"" 32 | footer = "\"\n\n" 33 | escapedContent cont = intercalate "\\n" $ map escapeDoubleQuotes $ lines cont 34 | escapeDoubleQuotes str = go str 35 | where go [] = [] 36 | go (x:xs) = case x of 37 | '"' -> '\\' : '"' : go xs 38 | _ -> x : go xs 39 | 40 | writeIPBuilder :: CmdOptions -> IO () 41 | writeIPBuilder conf = do 42 | content <- readFile (optGladeFile1 conf) 43 | let outfile = (optOutFilePath conf "InstrumentPageBuilder.hs") 44 | putStrLn $ "Processing file " ++ (optGladeFile conf) ++ " into " ++ outfile 45 | writeFile outfile (newCont content) 46 | where 47 | newCont content = concat [header, escapedContent content, footer] 48 | header = "module Gtk.InstrumentPageBuilder\n(builderFileAsString)\nwhere\n\n\nbuilderFileAsString :: String\nbuilderFileAsString = \"" 49 | footer = "\"\n\n" 50 | escapedContent cont = intercalate "\\n" $ map escapeDoubleQuotes $ lines cont 51 | escapeDoubleQuotes str = go str 52 | where go [] = [] 53 | go (x:xs) = case x of 54 | '"' -> '\\' : '"' : go xs 55 | _ -> x : go xs 56 | 57 | 58 | data CmdOptions = CmdOptions { 59 | optVersion :: Bool, 60 | optGladeFile :: String, 61 | optGladeFile1 :: String, 62 | optOutFilePath :: String 63 | } 64 | deriving (Show) 65 | 66 | 67 | defaultCmdOptions :: CmdOptions 68 | defaultCmdOptions = 69 | CmdOptions {optVersion = False, optGladeFile = "DGPatchMaker.glade", optGladeFile1 = "InstrumentPage.glade", optOutFilePath = "src/Gtk" } 70 | 71 | options :: [OptDescr (CmdOptions -> CmdOptions)] 72 | options = 73 | [Option ['V','?'] ["version"] 74 | (NoArg (\ opts -> opts { optVersion = True })) 75 | "show version number" 76 | , Option ['g'] ["glade-file"] 77 | (OptArg ((\f opts -> opts { optGladeFile = f }) . fromMaybe "DGPatchMaker.glade") "FILE") 78 | "GTK builder FILE" 79 | , Option ['h'] ["glade-file-ip"] 80 | (OptArg ((\f opts -> opts { optGladeFile1 = f }) . fromMaybe "InstrumentPage.glade") "FILE") 81 | "GTK builder FILE" 82 | , Option ['o'] ["output-path"] 83 | (OptArg ((\f opts -> opts { optOutFilePath = f }) . fromMaybe "src/Gtk") "FILE") 84 | "Haskell output source FILE" 85 | ] 86 | 87 | 88 | -- , Option ['d'] ["domain"] 89 | -- (OptArg ((\d opts -> opts { confDomain = d }) . fromMaybe defaultDomain) "DOMAIN") 90 | -- "the domain prefix (e.g. 3A5)" 91 | 92 | 93 | parseOpts :: [String] -> IO (CmdOptions, [String]) 94 | parseOpts argv = 95 | case getOpt Permute options argv of 96 | (o,n,[] ) -> return (Prelude.foldl (flip id) defaultCmdOptions o, n) 97 | (_,_,errs) -> ioError (userError (Prelude.concat errs ++ usageInfo header options)) 98 | where header = "Usage: CreateGladeSource [OPTION...]" 99 | 100 | -------------------------------------------------------------------------------- /src/tests/ParseTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main 3 | 4 | where 5 | 6 | 7 | import System.Environment 8 | import System.Exit 9 | 10 | import Data.DrumDrops.Utils 11 | 12 | import Data.Text as T 13 | import Data.Text.IO as T 14 | --import qualified Data.ByteString.Lazy as B 15 | --import Data.List (sort) 16 | --import Data.Either 17 | 18 | 19 | 20 | str1 :: String 21 | str1 = "MPEX_KICK_EQCL_HT_005_V1_RR1.wav" 22 | 23 | path :: FilePath 24 | path = "/home/oswald/Sounds/Drumkits/2015_10_04_Mapex_Kit_AS_Pack_V2.3/Kontakt Pack Samples/Kontakt Pack Samples/Mapex Kick Drum/EQ Head" 25 | 26 | basepath :: FilePath 27 | basepath = "/home/oswald/Sounds/Drumkits/2015_10_04_Mapex_Kit_AS_Pack_V2.3/Kontakt Pack Samples" 28 | 29 | samplesPath :: FilePath 30 | samplesPath = "/home/oswald/Sounds/Drumkits/2015_10_04_Mapex_Kit_AS_Pack_V2.3/Kontakt Pack Samples/Kontakt Pack Samples" 31 | 32 | main :: IO () 33 | main = do 34 | [parserType, file] <- getArgs 35 | content <- T.readFile file 36 | mapM_ (f parserType) (T.lines content) 37 | where 38 | f parserType x = do 39 | T.putStrLn x 40 | let res = getSampleFromFileName (read parserType) (unpack x) 1 41 | case res of 42 | Left err -> do 43 | Prelude.putStrLn (show err) 44 | exitFailure 45 | Right sample -> print sample 46 | 47 | 48 | --printSample :: Sample -> IO () 49 | --printSample x = Prelude.putStrLn (show x) 50 | 51 | 52 | --printSampleGroup :: SampleGroup -> IO () 53 | --printSampleGroup x = do 54 | --T.putStrLn ("Path: " `T.append` T.pack (sgPath x)) 55 | --T.putStrLn ("Instrument: " `T.append` sgInstName x) 56 | --mapM_ printGroup (sgGroups x) 57 | 58 | --printGroup :: VelocityGroup -> IO () 59 | --printGroup x = do 60 | --T.putStrLn ("Group: Velocity: " `append` pack (show (vgVelocity x)) `append` " Round Robin: " `append` pack (show (vgRR x))) 61 | --mapM_ printSample (vgSamples x) 62 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # A warning or info to be displayed to the user on config load. 8 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 9 | # A snapshot resolver dictates the compiler version and the set of packages 10 | # to be used for project dependencies. For example: 11 | # 12 | # resolver: lts-3.5 13 | # resolver: nightly-2015-09-21 14 | # resolver: ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-21.25 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | extra-deps: 42 | - cairo-0.13.11.0 43 | - gio-0.13.11.0 44 | - glib-0.13.11.0 45 | - gtk2hs-buildtools-0.13.11.0 46 | - gtk3-0.15.9 47 | - pango-0.13.11.0 48 | 49 | # Override default flag values for local packages and extra-deps 50 | # flags: {} 51 | 52 | # Extra package databases containing global packages 53 | # extra-package-dbs: [] 54 | 55 | # Control whether we use the GHC we find on the path 56 | # system-ghc: true 57 | # 58 | # Require a specific version of stack, using version ranges 59 | # require-stack-version: -any # Default 60 | # require-stack-version: ">=1.9" 61 | # 62 | # Override the architecture used by stack, especially useful on Windows 63 | # arch: i386 64 | # arch: x86_64 65 | # 66 | # Extra directories used by stack for building 67 | # extra-include-dirs: [/path/to/dir] 68 | # extra-lib-dirs: [/path/to/dir] 69 | # 70 | # Allow a newer minor version of GHC than the snapshot specifies 71 | # compiler-check: newer-minor 72 | --------------------------------------------------------------------------------