midi-music-box (empty) → 0.0
raw patch · 4 files changed
+254/−0 lines, 4 filesdep +basedep +containersdep +diagrams-libsetup-changed
Dependencies added: base, containers, diagrams-lib, diagrams-postscript, event-list, midi, non-empty, optparse-applicative, utility-ht
Files
- LICENSE +30/−0
- Setup.lhs +3/−0
- midi-music-box.cabal +39/−0
- src/Main.hs +182/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Henning Thielemann nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ midi-music-box.cabal view
@@ -0,0 +1,39 @@+Name: midi-music-box+Version: 0.0+Synopsis: Convert MIDI file to music box punch tape+Description:+ Convert MIDI file to music box punch tape for this kind of music box:+ <http://www.amazon.de/Spieluhr-Lochstreifen/dp/B001WNZOVO/>+Homepage: http://hub.darcs.net/thielema/midi-music-box+License: BSD3+License-File: LICENSE+Author: Henning Thielemann+Maintainer: haskell@henning-thielemann.de+Category: Sound+Build-Type: Simple+Cabal-Version: >=1.10++Source-Repository this+ Tag: 0.0+ Type: darcs+ Location: http://hub.darcs.net/thielema/midi-music-box++Source-Repository head+ Type: darcs+ Location: http://hub.darcs.net/thielema/midi-music-box++Executable midi-music-box+ Main-Is: Main.hs+ Hs-Source-Dirs: src+ Default-Language: Haskell2010+ GHC-Options: -Wall+ Build-Depends:+ diagrams-postscript >=1.3 && <1.4,+ diagrams-lib >=1.3 && <1.4,+ midi >=0.2.1 && <0.3,+ event-list >=0.1.1 && <0.2,+ optparse-applicative >=0.11 && <0.12,+ containers >=0.4 && <0.6,+ non-empty >=0.1.3 && <0.3,+ utility-ht >=0.0.10 && <0.1,+ base >=4.5 && <4.9
+ src/Main.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE FlexibleContexts #-}+module Main where++import qualified Sound.MIDI.Message.Class.Query as Query++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.File.Event as FileEvent+import qualified Sound.MIDI.File.Load as Load+import qualified Sound.MIDI.File as MidiFile++import qualified Data.EventList.Absolute.TimeBody as AbsEventList+import qualified Data.EventList.Relative.TimeBody as EventList++import qualified Diagrams.Backend.Postscript.CmdLine as PS+import qualified Diagrams.Backend.CmdLine as Cmd+import Diagrams.Prelude++import qualified Options.Applicative as OP++import qualified System.IO as IO+import Text.Printf (hPrintf, )++import Control.Monad (when, )++import qualified Data.Map as Map; import Data.Map (Map, )+import qualified Data.NonEmpty as NonEmpty+import Data.Foldable (foldMap, fold, )+import Data.Tuple.HT (mapSnd, )+++type Diag = Diagram PS.B++numLong :: Int+numLong = 15++globalScale :: Double+globalScale = 1/7++horsep, versep :: Double+horsep = 40*globalScale+versep = 80*globalScale++hormargin, horextramargin :: Double+hormargin = 65*globalScale+horextramargin = 100*globalScale++horlen, verlen :: Int -> Double+horlen n = fromIntegral n * horsep+verlen n = fromIntegral n * versep++normalLW, thickLW :: Diag -> Diag+normalLW = lwO (5*globalScale)+thickLW = lwO (8*globalScale)+++labels :: Diag+labels =+ hcat' (with & sep .~ horsep) $+ map (\str -> text str # fontSizeL horsep) $+ map (:[]) "CDEFGABCDEFGABC"++long :: Int -> Diag+long numIntervals =+ hcat' (with & sep .~ horsep) $+ map (\(wid, col) ->+ vrule (verlen numIntervals) # wid # lc col) $+ let l = (normalLW, black); h = (thickLW, darkgreen)+ in [l, l, h, l, h, l, h, l, h, l, h, l, l, l, l]++across :: Int -> Diag+across numIntervals =+ vcat' (with & sep .~ versep) $+ take (succ numIntervals) $ cycle $+ let len = horlen (numLong-1)+ in map (# normalLW) [hrule len, hrule len # lc grey]++grid :: Int -> Diag+grid numIntervals =+ alignTL (long numIntervals) <>+ alignTL (across numIntervals) <>+ translateX (-hormargin)+ (alignTL (vrule (verlen numIntervals) # normalLW # lc grey)) <>+ translateX (horlen (numLong-1) + hormargin)+ (alignTL (vrule (verlen numIntervals) # normalLW # lc grey)) <>+ translateY (0.5*versep) labels <>+ (translateX (-horextramargin) $ translateY (verlen 2) $ alignTL $ lc white $+ rect (horlen (numLong-1) + 2*horextramargin) (verlen (numIntervals+4)))+++dots :: [(DotType, (Int, Double))] -> Diag+dots poss =+ flip foldMap poss $+ \(typ, (x,y)) ->+ translate (r2 (horlen x, - versep * y)) $+ let warning txt =+ (fontSizeL horsep $ text txt) <>+ (lwO 0 $ fc yellow $ circle (horsep*0.4))+ in case typ of+ Valid -> normalLW $ fc blue $ circle (horsep*0.25)+ Semitone -> warning "#"+ TooLow -> warning "!"+ TooHigh -> warning "!"++noteMap :: Map Int (Bool, Int)+noteMap =+ let o = True; x = False+ semitones = cycle [o,x,o,x,o,o,x,o,x,o,x,o]+ in Map.fromList $ take 25 $ zip [0..] $ zip semitones $+ NonEmpty.tail $ NonEmpty.scanl (+) (-1) $ map fromEnum semitones+++data DotType = Valid | Semitone | TooLow | TooHigh+ deriving (Eq, Ord)++layoutDots ::+ TimeStep -> VoiceMsg.Pitch -> MidiFile.T -> [(DotType, (Int, Double))]+layoutDots (TimeStep timeStep) zeroKey (MidiFile.Cons typ division tracks) =+ map (\(t, (dottyp,p)) -> (dottyp, (p,t))) $+ AbsEventList.toPairList $+ AbsEventList.mapTime ((/timeStep) . realToFrac) $+ AbsEventList.mapMaybe+ (\fev -> do+ FileEvent.MIDIEvent ev <- Just fev+ (_c, (_v, p, True)) <- Query.noteExplicitOff ev+ let pz = VoiceMsg.subtractPitch zeroKey p+ return $+ case Map.lookup pz noteMap of+ Just (s, n) -> (if s then Valid else Semitone, n)+ Nothing ->+ let ( pmin, (_, nmin)) = Map.findMin noteMap+ (_pmax, (_, nmax)) = Map.findMax noteMap+ in if pz < pmin+ then (TooLow, nmin)+ else (TooHigh, nmax)) $+ EventList.toAbsoluteEventList 0 $+ MidiFile.mergeTracks typ $+ map (MidiFile.secondsFromTicks division) tracks+++newtype ZeroKey = ZeroKey Int++instance Cmd.Parseable ZeroKey where+ parser =+ OP.option (ZeroKey <$> OP.auto)+ (OP.long "zerokey" OP.<>+ OP.metavar "INT" OP.<>+ OP.value (ZeroKey 60) OP.<>+ OP.help "MIDI key for the lowest note line")+++newtype TimeStep = TimeStep Double++instance Cmd.Parseable TimeStep where+ parser =+ OP.option (TimeStep <$> OP.auto)+ (OP.long "timestep" OP.<>+ OP.metavar "SECONDS" OP.<>+ OP.value (TimeStep 0.1) OP.<>+ OP.help "time step between lines")+++newtype Input = Input FilePath++instance Cmd.Parseable Input where+ parser = OP.argument (Input <$> OP.str) (OP.metavar "INPUT")+++diag :: TimeStep -> ZeroKey -> Input -> IO Diag+diag timeStep (ZeroKey zeroKey) (Input path) = do+ midi <- Load.fromFile path+ let cloud = layoutDots timeStep (VoiceMsg.toPitch zeroKey) midi+ sorted = Map.fromListWith (++) $ map (mapSnd (:[])) cloud+ warning typ msg =+ let n = length $ fold $ Map.lookup typ sorted+ in when (n > 0) $ hPrintf IO.stderr "Warning: %i %s\n" n msg+ warning Semitone "semitones"+ warning TooLow "notes are too low"+ warning TooHigh "notes are too high"+ return $ dots cloud <> (grid $ ceiling $ maximum $ map (snd . snd) cloud)++main :: IO ()+main = PS.mainWith diag