diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/midi-music-box.cabal b/midi-music-box.cabal new file mode 100644 --- /dev/null +++ b/midi-music-box.cabal @@ -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: + +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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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