{-# 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.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 (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, printf)
import Control.Monad (when, )
import qualified Data.Map as Map; import Data.Map (Map, )
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, )
type Diag = Diagram PS.B
globalScale :: Double
globalScale = 1/7
horsep, versep :: Double
horsep = 40*globalScale
versep = 80*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)
data MusicScale =
MusicScale {
scaleLabels :: [Char],
greenLines :: [Bool],
scaleNoteMap :: Map Int (Bool, Int),
horizontalMargin, horizontalExtraMargin :: Double
}
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) $
map
(\isGreen -> if isGreen then (thickLW, darkgreen) else (normalLW, black))
greenLs
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 :: 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)) <>
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 :: 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 radius = horsep*diameterRel/2
warning txt =
(fontSizeL horsep $ text txt) <>
(lwO 0 $ fc yellow $ circle (horsep*0.4))
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
noteMap (TimeStep timeStep) zeroKey (MidiFile.Cons typ division tracks) =
map (\(t, (dottyp,p)) -> (dottyp, (p,t))) $
AbsEventList.toPairList $
AbsEventList.mapTime ((/timeStep) . realToFrac) $
AbsEventList.mapMaybe
(\ev -> do
(_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
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
parser =
OP.option (ZeroKey <$> OP.auto)
(OP.long "zerokey" Mn.<>
OP.metavar "INT" Mn.<>
OP.value (ZeroKey 60) Mn.<>
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" Mn.<>
OP.metavar "SECONDS" Mn.<>
OP.value (TimeStep 0.1) Mn.<>
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 ::
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 (scaleNoteMap musicScale)
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 diameter cutter cloud <>
(grid musicScale cutter $ ceiling $ maximum $ map (snd . snd) cloud)
main :: IO ()
main = PS.mainWith diag