midi-music-box 0.0.0.5 → 0.0.1
raw patch · 3 files changed
+188/−58 lines, 3 filesdep −non-emptydep ~midi
Dependencies removed: non-empty
Dependency ranges changed: midi
Files
- midi-music-box.cabal +11/−7
- src/Main.hs +138/−51
- src/Note.hs +39/−0
midi-music-box.cabal view
@@ -1,5 +1,5 @@ Name: midi-music-box-Version: 0.0.0.5+Version: 0.0.1 Synopsis: Convert MIDI file to music box punch tape Description: Convert MIDI file to music box punch tape for this kind of music box:@@ -47,7 +47,10 @@ If the song has key Y minor, then X=Y+3. . You find executables for MS Windows in two ZIP archives there:- <http://code.haskell.org/~thielema/midi-music-box/>+ .+ * <http://code.henning-thielemann.de/midi-music-box/midi-music-box.zip>+ .+ * <http://code.henning-thielemann.de/midi-music-box/midi-music-box-dll.zip> Homepage: http://hub.darcs.net/thielema/midi-music-box License: BSD3 License-File: LICENSE@@ -58,7 +61,7 @@ Cabal-Version: >=1.10 Source-Repository this- Tag: 0.0.0.5+ Tag: 0.0.1 Type: darcs Location: http://hub.darcs.net/thielema/midi-music-box @@ -67,17 +70,18 @@ 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.5, diagrams-lib >=1.3 && <1.5,- midi >=0.2.1 && <0.3,+ midi >=0.2.2 && <0.3, event-list >=0.1.1 && <0.2, optparse-applicative >=0.11 && <0.15, containers >=0.4 && <0.7,- non-empty >=0.1.3 && <0.4, utility-ht >=0.0.10 && <0.1, base >=4.5 && <5+ Hs-Source-Dirs: src+ Main-Is: Main.hs+ Other-Modules:+ Note
src/Main.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} module Main where +import qualified Note+ 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 @@ -13,17 +14,25 @@ import qualified Diagrams.Backend.Postscript.CmdLine as PS import qualified Diagrams.Backend.CmdLine as Cmd-import Diagrams.Prelude+import Diagrams.Prelude (Diagram)+import Diagrams.Prelude (translateX, translateY, translate, r2, alignTL)+import Diagrams.Prelude (hsep, vsep)+import Diagrams.Prelude (circle, rect, hrule, vrule)+import Diagrams.Prelude (lwO, text, fontSizeL)+import Diagrams.Prelude (fc, lc, yellow, blue, darkgreen, white, grey, black)+import Diagrams.Prelude ((#), (<$>), (<>)) import qualified Options.Applicative as OP import qualified System.IO as IO-import Text.Printf (hPrintf, )+import Text.Printf (hPrintf, printf) import Control.Monad (when, ) import qualified Data.Map as Map; import Data.Map (Map, )-import qualified Data.NonEmpty as NonEmpty+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import qualified Data.Monoid.HT as MnHT import qualified Data.Monoid as Mn import Data.Foldable (foldMap, fold, ) import Data.Tuple.HT (mapSnd, )@@ -31,9 +40,6 @@ type Diag = Diagram PS.B -numLong :: Int-numLong = 15- globalScale :: Double globalScale = 1/7 @@ -41,10 +47,6 @@ 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@@ -54,74 +56,110 @@ thickLW = lwO (8*globalScale) -labels :: Diag-labels =- hcat' (with & sep .~ horsep) $- map (\str -> text str # fontSizeL horsep) $- map (:[]) "CDEFGABCDEFGABC"+data MusicScale =+ MusicScale {+ scaleLabels :: [Char],+ greenLines :: [Bool],+ scaleNoteMap :: Map Int (Bool, Int),+ horizontalMargin, horizontalExtraMargin :: Double+ } -long :: Int -> Diag-long numIntervals =- hcat' (with & sep .~ horsep) $+musicScale15, musicScale30 :: MusicScale+musicScale15 =+ musicScaleFromNotes Note.pitches15 (65*globalScale, 100*globalScale)+musicScale30 =+ musicScaleFromNotes Note.pitches30 (3*horsep, 5*horsep)++musicScaleFromNotes :: [(Bool, (Char, Int))] -> (Double,Double) -> MusicScale+musicScaleFromNotes notes (hormargin, horextramargin) =+ let (greenLines_, (scaleLabels_,ps)) = mapSnd unzip $ unzip notes+ in MusicScale {+ horizontalMargin = hormargin,+ horizontalExtraMargin = horextramargin,+ scaleLabels = scaleLabels_,+ greenLines = greenLines_,+ scaleNoteMap =+ Map.fromList $ concat $+ zipWith3+ (\pos p k ->+ take k $ zip [p..] $ (True,pos) : repeat (False,pos))+ [0..] ps (ListHT.mapAdjacent subtract ps ++ [1])+ }+++labels :: [Char] -> Diag+labels = hsep horsep . map (\char -> text [char] # fontSizeL horsep)++long :: [Bool] -> Int -> Diag+long greenLs numIntervals =+ hsep 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]+ map+ (\isGreen -> if isGreen then (thickLW, darkgreen) else (normalLW, black))+ greenLs -across :: Int -> Diag-across numIntervals =- vcat' (with & sep .~ versep) $+across :: Int -> Int -> Diag+across numLong numIntervals =+ vsep 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) <>+grid :: MusicScale -> Cutter -> Int -> Diag+grid musicScale (Cutter cutter) numIntervals =+ let numLong = length $ scaleLabels musicScale+ hormargin = horizontalMargin musicScale+ horextramargin = horizontalExtraMargin musicScale+ in+ MnHT.when (not cutter)+ (alignTL (long (greenLines musicScale) numIntervals)) <>+ MnHT.when (not cutter) (alignTL (across numLong 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 <>+ MnHT.when (not cutter)+ (translateY (0.5*versep) $ labels $ scaleLabels musicScale) <> (translateX (-horextramargin) $ translateY (verlen 2) $ alignTL $ lc white $ rect (horlen (numLong-1) + 2*horextramargin) (verlen (numIntervals+4))) -dots :: [(DotType, (Int, Double))] -> Diag-dots poss =+dots :: Diameter -> Cutter -> [(DotType, (Int, Double))] -> Diag+dots (Diameter diameterRel) (Cutter cutter) poss = flip foldMap poss $ \(typ, (x,y)) -> translate (r2 (horlen x, - versep * y)) $- let warning txt =+ let radius = horsep*diameterRel/2+ 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+ in if cutter+ then+ case typ of+ Valid -> normalLW $ circle radius+ _ -> Mn.mempty+ else+ case typ of+ Valid -> normalLW $ fc blue $ circle radius+ Semitone -> warning "#"+ TooLow -> warning "!"+ TooHigh -> warning "!" data DotType = Valid | Semitone | TooLow | TooHigh deriving (Eq, Ord) layoutDots ::+ Map Int (Bool, Int) -> TimeStep -> VoiceMsg.Pitch -> MidiFile.T -> [(DotType, (Int, Double))]-layoutDots (TimeStep timeStep) zeroKey (MidiFile.Cons typ division tracks) =+layoutDots+ noteMap (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+ (\ev -> do (_c, (_v, p, True)) <- Query.noteExplicitOff ev let pz = VoiceMsg.subtractPitch zeroKey p return $@@ -138,6 +176,29 @@ map (MidiFile.secondsFromTicks division) tracks +musicScaleMap :: Map String MusicScale+musicScaleMap =+ Map.fromList $+ ("major15", musicScale15) :+ ("mixed30", musicScale30) :+ []++instance Cmd.Parseable MusicScale where+ parser =+ OP.option+ (OP.eitherReader $ \str ->+ maybe+ (Left $+ printf "unknown name '%s', must be one of %s" str+ (List.intercalate ", " $ Map.keys musicScaleMap))+ Right $+ Map.lookup str musicScaleMap)+ (OP.long "music-scale" Mn.<>+ OP.metavar "NAME" Mn.<>+ OP.value musicScale15 Mn.<>+ OP.help "Type of music box")++ newtype ZeroKey = ZeroKey Int instance Cmd.Parseable ZeroKey where@@ -160,16 +221,40 @@ OP.help "time step between lines") +newtype Cutter = Cutter Bool++instance Cmd.Parseable Cutter where+ parser =+ Cutter <$>+ OP.flag False True+ (OP.long "cutter" Mn.<>+ OP.help "stripped graphics ready for laser cutter")+++newtype Diameter = Diameter Double++instance Cmd.Parseable Diameter where+ parser =+ OP.option (Diameter <$> OP.auto)+ (OP.long "hole-diameter" Mn.<>+ OP.metavar "RATIO" Mn.<>+ OP.value (Diameter 0.5) Mn.<>+ OP.help "size of a hole relative to line distance")++ 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+diag ::+ MusicScale -> TimeStep -> ZeroKey -> Diameter -> Cutter -> Input -> IO Diag+diag musicScale timeStep (ZeroKey zeroKey) diameter cutter (Input path) = do midi <- Load.fromFile path- let cloud = layoutDots timeStep (VoiceMsg.toPitch zeroKey) midi+ let cloud =+ layoutDots (scaleNoteMap musicScale)+ timeStep (VoiceMsg.toPitch zeroKey) midi sorted = Map.fromListWith (++) $ map (mapSnd (:[])) cloud warning typ msg = let n = length $ fold $ Map.lookup typ sorted@@ -177,7 +262,9 @@ 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)+ return $+ dots diameter cutter cloud <>+ (grid musicScale cutter $ ceiling $ maximum $ map (snd . snd) cloud) main :: IO () main = PS.mainWith diag
+ src/Note.hs view
@@ -0,0 +1,39 @@+module Note where++pitch :: Char -> Int -> Int -> (Char, Int)+pitch char nt oct = (char, nt+oct*12)++c,d,e,f,g,a,b :: Int -> (Char, Int)+c = pitch 'C' 0+d = pitch 'D' 2+e = pitch 'E' 4+f = pitch 'F' 5+g = pitch 'G' 7+a = pitch 'A' 9+b = pitch 'B' 11++(#) :: (a -> (Char, Int)) -> a -> (Char, Int)+noteFunc # oct = ('#', succ $ snd $ noteFunc oct)+++infixr 5 .:, |:++(.:), (|:) :: a -> [(Bool, a)] -> [(Bool, a)]+x .: xs = (False,x) : xs+x |: xs = (True, x) : xs+++pitches15, pitches30 :: [(Bool, (Char, Int))]+pitches15 =+ c 0 .: d 0 .: e 0 |: f 0 .: g 0 |: a 0 .: b 0 |:+ c 1 .: d 1 |: e 1 .: f 1 |: g 1 .: a 1 .: b 1 .:+ c 2 .: []++pitches30 =+ c 0 .: d 0 .: g 0 .: a 0 .: b 0 .:+ c 1 .: d 1 .: e 1 |:+ f 1 .: f#1 .: g 1 |: g#1 .: a 1 .: a#1 .: b 1 |:+ c 2 .: c#2 .: d 2 |: d#2 .: e 2 .:+ f 2 |: f#2 .: g 2 .: g#2 .: a 2 .: a#2 .: b 2 .:+ c 3 .: d 3 .: e 3 .:+ []