jammittools 0.2.0.1 → 0.3
raw patch · 14 files changed
+912/−866 lines, 14 filesdep +jammittoolsdep ~boxes
Dependencies added: jammittools
Dependency ranges changed: boxes
Files
- Main.hs +241/−0
- jammittools.cabal +47/−40
- src/AIFC2WAV.hs +0/−27
- src/ImageMagick.hs +0/−89
- src/Jammit.hs +0/−253
- src/Main.hs +0/−320
- src/Sound/Jammit/Base.hs +256/−0
- src/Sound/Jammit/Export.hs +115/−0
- src/Sound/Jammit/Internal/AIFC2WAV.hs +27/−0
- src/Sound/Jammit/Internal/ImageMagick.hs +89/−0
- src/Sound/Jammit/Internal/Sox.hs +96/−0
- src/Sound/Jammit/Internal/TempFile.hs +41/−0
- src/Sox.hs +0/−96
- src/TempFile.hs +0/−41
+ Main.hs view
@@ -0,0 +1,241 @@+module Main (main) where++import Control.Applicative ((<$>), (<|>))+import Control.Monad ((>=>), forM_)+import Data.Char (toLower)+import Data.List (sort, nub, partition)+import Data.Maybe (mapMaybe, fromMaybe, listToMaybe)+import Data.Version (showVersion)+import qualified System.Console.GetOpt as Opt+import qualified System.Environment as Env++import System.FilePath ((</>))+import Text.PrettyPrint.Boxes+ (text, vcat, left, render, hsep, top, (/+/))++import Sound.Jammit.Base+import Sound.Jammit.Export+import qualified Paths_jammittools as Paths++main :: IO ()+main = do+ (fs, _, _) <- Opt.getOpt Opt.Permute argOpts <$> Env.getArgs+ let args = foldr ($) defaultArgs fs+ case function args of+ PrintUsage -> do+ prog <- Env.getProgName+ putStrLn $ "jammittools v" ++ showVersion Paths.version+ let header = "Usage: " ++ prog ++ " [options]"+ putStr $ Opt.usageInfo header argOpts+ ShowDatabase -> do+ matches <- searchResults args+ putStr $ showLibrary matches+ ExportAudio fout -> do+ matches <- getAudioParts <$> searchResults args+ let f = mapM (`getOneResult` matches) . mapMaybe charToAudioPart+ case (f $ selectParts args, f $ rejectParts args) of+ (Left err , _ ) -> error err+ (_ , Left err ) -> error err+ (Right yaifcs, Right naifcs) -> runAudio yaifcs naifcs fout+ CheckPresence -> do+ matches <- getAudioParts <$> searchResults args+ let f = mapM (`getOneResult` matches) . mapMaybe charToAudioPart+ case (f $ selectParts args, f $ rejectParts args) of+ (Left err , _ ) -> error err+ (_ , Left err ) -> error err+ (Right _ , Right _ ) -> return ()+ ExportSheet fout -> do+ matches <- getSheetParts <$> searchResults args+ let f = mapM (`getOneResult` matches) . mapMaybe charToSheetPart+ case f $ selectParts args of+ Left err -> error err+ Right parts -> let+ systemHeight = sum $ map snd parts+ in runSheet parts (getPageLines systemHeight args) fout+ ExportAll dout -> do+ matches <- searchResults args+ let sheets = getSheetParts matches+ audios = getAudioParts matches+ backingOrder = [Drums, Guitar, Keyboard, Bass, Vocal]+ isGuitar p = elem (partToInstrument p) [Guitar, Bass]+ (gtrs, nongtrs) = partition isGuitar [minBound .. maxBound]+ chosenBacking = listToMaybe $ flip mapMaybe backingOrder $ \i ->+ case getOneResult (Without i) audios of+ Left _ -> Nothing+ Right fp -> Just (i, fp)+ forM_ gtrs $ \p ->+ case (getOneResult (Notation p) sheets, getOneResult (Tab p) sheets) of+ (Right note, Right tab) -> let+ parts = [note, tab]+ systemHeight = sum $ map snd parts+ fout = dout </> drop 4 (map toLower (show p) ++ ".pdf")+ in runSheet [note, tab] (getPageLines systemHeight args) fout+ _ -> return ()+ forM_ nongtrs $ \p ->+ case getOneResult (Notation p) sheets of+ Left _ -> return ()+ Right note -> let+ fout = dout </> drop 4 (map toLower (show p) ++ ".pdf")+ in runSheet [note] (getPageLines (snd note) args) fout+ forM_ [minBound .. maxBound] $ \p ->+ case getOneResult (Only p) audios of+ Left _ -> return ()+ Right fp -> let+ fout = dout </> drop 4 (map toLower (show p) ++ ".wav")+ in runAudio [fp] [] fout+ case chosenBacking of+ Nothing -> return ()+ Just (inst, fback) -> let+ others = [ fp | (Only p, fp) <- audios, partToInstrument p /= inst ]+ fout = dout </> "backing.wav"+ in runAudio [fback] others fout++getPageLines :: Integer -> Args -> Int+getPageLines systemHeight args = let+ pageHeight = 724 / 8.5 * 11 :: Double+ defaultLines = round $ pageHeight / fromIntegral systemHeight+ in max 1 $ fromMaybe defaultLines $ pageLines args++-- | If there is exactly one pair with the given first element, returns its+-- second element. Otherwise (for 0 or >1 elements) returns an error.+getOneResult :: (Eq a, Show a) => a -> [(a, b)] -> Either String b+getOneResult x xys = case [ b | (a, b) <- xys, a == x ] of+ [y] -> Right y+ ys -> Left $ "Got " ++ show (length ys) ++ " results for " ++ show x++-- | Displays a table of the library, possibly filtered by search terms.+showLibrary :: Library -> String+showLibrary lib = let+ titleArtists = sort $ nub [ (title info, artist info) | (_, info, _) <- lib ]+ partsFor ttl art = map partToChar $ sort $ concat+ [ mapMaybe (trackTitle >=> titleToPart) trks+ | (_, info, trks) <- lib+ , (ttl, art) == (title info, artist info) ]+ makeColumn h col = text h /+/ vcat left (map text col)+ titleColumn = makeColumn "Title" $ map fst titleArtists+ artistColumn = makeColumn "Artist" $ map snd titleArtists+ partsColumn = makeColumn "Parts" $ map (uncurry partsFor) titleArtists+ in render $ hsep 1 top [titleColumn, artistColumn, partsColumn]++-- | Loads the Jammit library, and applies the search terms from the arguments+-- to filter it.+searchResults :: Args -> IO Library+searchResults args = do+ jmt <- case jammitDir args of+ Just j -> return j+ Nothing -> Env.lookupEnv "JAMMIT" >>= \mv -> case mv of+ Just j -> return j+ Nothing ->+ fromMaybe (error "Couldn't find Jammit directory.") <$> findJammitDir+ db <- loadLibrary jmt+ return $ filterLibrary args db++argOpts :: [Opt.OptDescr (Args -> Args)]+argOpts =+ [ Opt.Option ['t'] ["title"]+ (Opt.ReqArg+ (\s a -> a { filterLibrary = fuzzySearchBy title s . filterLibrary a })+ "str")+ "search by song title"+ , Opt.Option ['r'] ["artist"]+ (Opt.ReqArg+ (\s a -> a { filterLibrary = fuzzySearchBy artist s . filterLibrary a })+ "str")+ "search by song artist"+ , Opt.Option ['T'] ["title-exact"]+ (Opt.ReqArg+ (\s a -> a { filterLibrary = exactSearchBy title s . filterLibrary a })+ "str")+ "search by song title (exact)"+ , Opt.Option ['R'] ["artist-exact"]+ (Opt.ReqArg+ (\s a -> a { filterLibrary = exactSearchBy artist s . filterLibrary a })+ "str")+ "search by song artist (exact)"+ , Opt.Option ['y'] ["yes-parts"]+ (Opt.ReqArg (\s a -> a { selectParts = s }) "parts")+ "parts to appear in sheet music or audio"+ , Opt.Option ['n'] ["no-parts"]+ (Opt.ReqArg (\s a -> a { rejectParts = s }) "parts")+ "parts to subtract (add inverted) from audio"+ , Opt.Option ['l'] ["lines"]+ (Opt.ReqArg (\s a -> a { pageLines = Just $ read s }) "int")+ "number of systems per page"+ , Opt.Option ['j'] ["jammit"]+ (Opt.ReqArg (\s a -> a { jammitDir = Just s }) "directory")+ "location of Jammit library"+ , Opt.Option ['?'] ["help"]+ (Opt.NoArg $ \a -> a { function = PrintUsage })+ "function: print usage info"+ , Opt.Option ['d'] ["database"]+ (Opt.NoArg $ \a -> a { function = ShowDatabase })+ "function: display all songs in db"+ , Opt.Option ['s'] ["sheet"]+ (Opt.ReqArg (\s a -> a { function = ExportSheet s }) "file")+ "function: export sheet music"+ , Opt.Option ['a'] ["audio"]+ (Opt.ReqArg (\s a -> a { function = ExportAudio s }) "file")+ "function: export audio"+ , Opt.Option ['x'] ["export"]+ (Opt.ReqArg (\s a -> a { function = ExportAll s }) "dir")+ "function: export all to dir"+ , Opt.Option ['c'] ["check"]+ (Opt.NoArg $ \a -> a { function = CheckPresence })+ "function: check presence of audio parts"+ ]++data Args = Args+ { filterLibrary :: Library -> Library+ , selectParts :: String+ , rejectParts :: String+ , pageLines :: Maybe Int+ , jammitDir :: Maybe FilePath+ , function :: Function+ }++data Function+ = PrintUsage+ | ShowDatabase+ | ExportSheet FilePath+ | ExportAudio FilePath+ | ExportAll FilePath+ | CheckPresence+ deriving (Eq, Ord, Show, Read)++defaultArgs :: Args+defaultArgs = Args+ { filterLibrary = id+ , selectParts = ""+ , rejectParts = ""+ , pageLines = Nothing+ , jammitDir = Nothing+ , function = PrintUsage+ }++partToChar :: Part -> Char+partToChar p = case p of+ PartGuitar1 -> 'g'+ PartGuitar2 -> 'r'+ PartBass -> 'b'+ PartDrums -> 'd'+ PartKeys1 -> 'k'+ PartKeys2 -> 'y'+ PartPiano -> 'p'+ PartSynth -> 's'+ PartVocal -> 'v'+ PartBVocals -> 'x'++charPartMap :: [(Char, Part)]+charPartMap = [ (partToChar p, p) | p <- [minBound .. maxBound] ]++charToSheetPart :: Char -> Maybe SheetPart+charToSheetPart c = let+ notation = Notation <$> lookup c charPartMap+ tab = Tab <$> lookup (toLower c) charPartMap+ in notation <|> tab++charToAudioPart :: Char -> Maybe AudioPart+charToAudioPart c = let+ only = Only <$> lookup c charPartMap+ without = Without . partToInstrument <$> lookup (toLower c) charPartMap+ in only <|> without
jammittools.cabal view
@@ -1,24 +1,17 @@ Name: jammittools-Version: 0.2.0.1+Version: 0.3 Synopsis: Export sheet music and audio from Windows/Mac app Jammit-Description: <http://www.jammit.com/ Jammit> is a service and associated- app for Windows\/Mac\/iOS that sells isolated instrument- audio tracks from popular music, along with full- transcriptions. This is a tool that allows you to export the- sheet music (in PDF format) and audio (in WAV format) to- tracks that you have purchased.- .- Any sheet music or audio you export is solely for your own- use, e.g. for use on Linux and Android devices that do not- have the official app available. Please do not use this tool- to share content with others who have not purchased it!- .- You must install ImageMagick and Sox for sheet music and- audio export respectively, because they are used to do the- actual conversion.- Please see the- <https://github.com/mtolly/jammittools/blob/master/README.md README>- for usage information.+Description:++ <http://www.jammit.com/ Jammit> is a service and associated app for Windows\/Mac\/iOS that sells isolated instrument audio tracks from popular music, along with full transcriptions.+ This is a library and executable that allow you to export the sheet music (in PDF format) and audio (in WAV format) to tracks that you have purchased.+ .+ Any sheet music or audio you export is solely for your own use, e.g. for use on Linux and Android devices that do not have the official app available.+ Please do not use this tool to share content with others who have not purchased it!+ .+ You must install ImageMagick and Sox for sheet music and audio export respectively, because they are used to do the actual conversion.+ Please see the <https://github.com/mtolly/jammittools/blob/master/README.md README> for usage information.+ License: GPL License-File: LICENSE Author: Michael Tolly@@ -30,26 +23,40 @@ Bug-Reports: https://github.com/mtolly/jammittools/issues Extra-Source-Files: README.md -Executable jammittools- Main-Is: Main.hs- Other-Modules: AIFC2WAV- ImageMagick- Jammit- Sox- TempFile- Hs-Source-Dirs: src- Build-Depends: base >= 4.6.0.1 && < 5- , property-list >= 0.1.0.4 && < 0.2- , directory >= 1.2.0.1 && < 1.3- , filepath >= 1.3.0.1 && < 1.4- , containers >= 0.5.0.0 && < 0.6- , process >= 1.1.0.2 && < 1.3- , temporary >= 1.1.2.5 && < 1.3- , boxes >= 0.1.3 && < 1.2- , transformers >= 0.3.0.0 && < 0.5- Ghc-Options: -Wall- C-Sources: cbits/aifc2wav-5.1.c+library+ exposed-modules:+ Sound.Jammit.Base+ Sound.Jammit.Export+ other-modules:+ Sound.Jammit.Internal.AIFC2WAV+ Sound.Jammit.Internal.ImageMagick+ Sound.Jammit.Internal.Sox+ Sound.Jammit.Internal.TempFile+ hs-source-dirs: src+ build-depends:+ base >= 4.6.0.1 && < 5+ , property-list >= 0.1.0.4 && < 0.2+ , directory >= 1.2.0.1 && < 1.3+ , filepath >= 1.3.0.1 && < 1.4+ , containers >= 0.5.0.0 && < 0.6+ , process >= 1.1.0.2 && < 1.3+ , temporary >= 1.1.2.5 && < 1.3+ , transformers >= 0.3.0.0 && < 0.5+ ghc-options: -Wall+ c-sources: cbits/aifc2wav-5.1.c -Source-Repository head- Type: git+executable jammittools+ main-is: Main.hs+ other-modules:+ Paths_jammittools+ build-depends:+ base >= 4.6.0.1 && < 5+ , directory >= 1.2.0.1 && < 1.3+ , filepath >= 1.3.0.1 && < 1.4+ , boxes >= 0.1.3 && < 1.2+ , jammittools == 0.3+ ghc-options: -Wall++source-repository head+ type: git location: https://github.com/mtolly/jammittools
− src/AIFC2WAV.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-module AIFC2WAV-( aifcToWav-) where--import Foreign.C (withCString, CInt(..), CChar(..))-import Foreign.Marshal.Array (withArrayLen)-import Foreign.Ptr (Ptr)--import TempFile--foreign import ccall unsafe "aifc2wav_main" aifc2wav_main- :: CInt -> Ptr (Ptr CChar) -> IO CInt---- | Given a (new-style) IMA4-compressed AIFC file, converts it to a WAV file.-aifcToWav :: FilePath -> TempIO FilePath-aifcToWav aifc = do- wav <- newTempFile "aifcToWav.wav"- code <- liftIO $- withCString "aifc2wav" $ \progC ->- withCString aifc $ \aifcC ->- withCString wav $ \wavC ->- withArrayLen [progC, aifcC, wavC] $ \n v ->- aifc2wav_main (fromIntegral n) v- if code == 0- then return wav- else error $ "aifcToWav: returned " ++ show code
− src/ImageMagick.hs
@@ -1,89 +0,0 @@-module ImageMagick-( connectVertical-, splitVertical-, joinPages-) where--import Control.Applicative ((<$>))-import Control.Monad (void)-import Data.Char (isDigit)-import Data.List (isPrefixOf, sortBy)-import Data.Maybe (listToMaybe)-import Data.Ord (comparing)-import System.Environment (lookupEnv)-import System.Exit (ExitCode(..))-import qualified System.Info as Info--import System.Directory (getDirectoryContents)-import System.FilePath ((</>))-import System.IO.Temp (createTempDirectory)-import System.Process (readProcess, readProcessWithExitCode)--import TempFile---- | Find an ImageMagick binary, because the names are way too generic, and--- "convert" is both an ImageMagick program and a Windows built-in utility.-imageMagick :: String -> IO (Maybe String)-imageMagick cmd = do- (code, _, _) <- readProcessWithExitCode cmd ["-version"] ""- case code of- ExitSuccess -> return $ Just cmd- _ -> case Info.os of- "mingw32" -> firstJustM $- -- env variables for different configs of (ghc arch)/(imagemagick arch)- -- ProgramFiles: 32/32 or 64/64- -- ProgramFiles(x86): 64/32- -- ProgramW6432: 32/64- flip map ["ProgramFiles", "ProgramFiles(x86)", "ProgramW6432"] $ \env ->- lookupEnv env >>= \var -> case var of- Nothing -> return Nothing- Just pf- -> fmap (\im -> pf </> im </> cmd)- . listToMaybe- . filter ("ImageMagick" `isPrefixOf`)- <$> getDirectoryContents pf- _ -> return Nothing--imageMagick' :: String -> IO String-imageMagick' cmd = imageMagick cmd >>= \ms -> case ms of- Nothing -> error $ "imageMagick': couldn't find program " ++ cmd- Just s -> return s---- | Only runs actions until the first that gives 'Just'.-firstJustM :: (Monad m) => [m (Maybe a)] -> m (Maybe a)-firstJustM [] = return Nothing-firstJustM (mx : xs) = mx >>= \x -> case x of- Nothing -> firstJustM xs- Just y -> return $ Just y---- | Stick images together vertically into one long image.-connectVertical :: [FilePath] -> TempIO FilePath-connectVertical [fin] = return fin-connectVertical fins = do- cmd <- liftIO $ imageMagick' "montage"- fout <- newTempFile "connectVertical.png"- void $ liftIO $ readProcess cmd- (["-geometry", "100%", "-tile", "1x"] ++ fins ++ [fout]) ""- return fout---- | Splits an image vertically into chunks of a given height.-splitVertical :: Integer -> FilePath -> TempIO [FilePath]-splitVertical i fin = do- cmd <- liftIO $ imageMagick' "convert"- tempdir <- ask- splitdir <- liftIO $ createTempDirectory tempdir "splitVertical"- void $ liftIO $- readProcess cmd ["-crop", "x" ++ show i, fin, splitdir </> "x.png"] ""- map (splitdir </>) . sortBy (comparing getNumber) . filter isFile- <$> liftIO (getDirectoryContents splitdir)- where getNumber :: String -> Integer- getNumber = read . takeWhile isDigit . dropWhile (not . isDigit)- isFile = (`notElem` [".", ".."])---- | Joins several images into a PDF, where each image is a page.-joinPages :: [FilePath] -> TempIO FilePath-joinPages fins = do- cmd <- liftIO $ imageMagick' "convert"- fout <- newTempFile "joinPages.pdf"- void $ liftIO $ readProcess cmd (fins ++ [fout]) ""- return fout
− src/Jammit.hs
@@ -1,253 +0,0 @@-module Jammit-( Instrument(..)-, Part(..)-, AudioPart(..)-, SheetPart(..)-, titleToPart-, titleToAudioPart-, partToInstrument-, audioPartToInstrument-, Info(..)-, Track(..)-, loadInfo-, loadTracks-, findJammitDir-, songSubdirs-) where--import Control.Applicative ((<$>), (<*>), liftA2)-import Control.Arrow ((***))-import Control.Exception (evaluate)-import Control.Monad (filterM, guard)-import Data.Char (toLower, toUpper)-import Data.Maybe (catMaybes)-import System.Environment (lookupEnv)-import Text.Read (readMaybe)--import qualified Data.Map as Map-import qualified Data.PropertyList as PL-import qualified System.Directory as Dir-import System.FilePath ((</>))-import qualified System.Info as Info---- | The Enum instance corresponds to the number used in the "instrument"--- property, and the names (used by Show/Read) are capitalized versions of those--- used in the "skillLevel" property.-data Instrument = Guitar | Bass | Drums | Keyboard | Vocal- deriving (Eq, Ord, Show, Read, Enum, Bounded)--data Part- = PartGuitar1- | PartGuitar2- | PartBass- | PartDrums- | PartKeys1- | PartKeys2- | PartPiano- | PartSynth- | PartVocal- | PartBVocals- deriving (Eq, Ord, Show, Read, Enum, Bounded)--data AudioPart- = Only Part- | Without Instrument- deriving (Eq, Ord, Show, Read)--data SheetPart- = Notation Part- | Tab Part- deriving (Eq, Ord, Show, Read)--titleToPart :: String -> Maybe Part-titleToPart s = case s of- "Guitar" -> Just PartGuitar1- "Guitar 1" -> Just PartGuitar1- "Guitar 2" -> Just PartGuitar2- "Bass" -> Just PartBass- "Drums" -> Just PartDrums- "Keys" -> Just PartKeys1- "Keys 1" -> Just PartKeys1- "Keys 2" -> Just PartKeys2- "Piano" -> Just PartPiano- "Synth" -> Just PartSynth- "Vocal" -> Just PartVocal- "B Vocals" -> Just PartBVocals- _ -> Nothing--titleToAudioPart :: String -> Instrument -> Maybe AudioPart-titleToAudioPart "Band" i = Just $ Without i-titleToAudioPart s _ = Only <$> titleToPart s--partToInstrument :: Part -> Instrument-partToInstrument p = case p of- PartGuitar1 -> Guitar- PartGuitar2 -> Guitar- PartBass -> Bass- PartDrums -> Drums- PartKeys1 -> Keyboard- PartKeys2 -> Keyboard- PartPiano -> Keyboard- PartSynth -> Keyboard- PartVocal -> Vocal- PartBVocals -> Vocal--audioPartToInstrument :: AudioPart -> Instrument-audioPartToInstrument (Only p) = partToInstrument p-audioPartToInstrument (Without i) = i--data Info = Info- { album :: String- , artist :: String- , bpm :: String- , copyright :: String- , countInBeats :: Integer- , courtesyOf :: String- , demo :: Bool- , explicit :: Bool- , genre :: String- , instrument :: Instrument- , publishedBy :: String- , skillLevel :: Either Integer [(Instrument, Integer)]- , sku :: String- , slow :: Double- , title :: String- , version :: Integer- , writtenBy :: String- } deriving (Eq, Ord, Show, Read)--instance PL.PropertyListItem Info where-- fromPropertyList pl = PL.fromPlDict pl >>= \dict -> Info- <$> (Map.lookup "album" dict >>= PL.fromPlString)- <*> (Map.lookup "artist" dict >>= PL.fromPlString)- <*> (Map.lookup "bpm" dict >>= PL.fromPlString)- <*> (Map.lookup "copyright" dict >>= PL.fromPlString)- <*> (Map.lookup "countInBeats" dict >>= PL.fromPlInt )- <*> (Map.lookup "courtesyOf" dict >>= PL.fromPlString)- <*> (Map.lookup "demo" dict >>= fromPlEnum )- <*> (Map.lookup "explicit" dict >>= fromPlEnum )- <*> (Map.lookup "genre" dict >>= PL.fromPlString)- <*> (Map.lookup "instrument" dict >>= fromPlEnum )- <*> (Map.lookup "publishedBy" dict >>= PL.fromPlString)- <*> (Map.lookup "skillLevel" dict >>= fromPlSkills)- <*> (Map.lookup "sku" dict >>= PL.fromPlString)- <*> (Map.lookup "slow" dict >>= PL.fromPlReal )- <*> (Map.lookup "title" dict >>= PL.fromPlString)- <*> (Map.lookup "version" dict >>= PL.fromPlInt )- <*> (Map.lookup "writtenBy" dict >>= PL.fromPlString)-- toPropertyList info = PL.plDict $ Map.fromList- [ ("album" , PL.plString $ album info)- , ("artist" , PL.plString $ artist info)- , ("bpm" , PL.plString $ bpm info)- , ("copyright" , PL.plString $ copyright info)- , ("countInBeats", PL.plInt $ countInBeats info)- , ("courtesyOf" , PL.plString $ courtesyOf info)- , ("demo" , plEnum $ demo info)- , ("explicit" , plEnum $ explicit info)- , ("genre" , PL.plString $ genre info)- , ("instrument" , plEnum $ instrument info)- , ("publishedBy" , PL.plString $ publishedBy info)- , ("skillLevel" , plSkills $ skillLevel info)- , ("sku" , PL.plString $ sku info)- , ("slow" , PL.plReal $ slow info)- , ("title" , PL.plString $ title info)- , ("version" , PL.plInt $ version info)- , ("writtenBy" , PL.plString $ writtenBy info)- ]--fromPlEnum :: (Enum a) => PL.PropertyList -> Maybe a-fromPlEnum pl = toEnum . fromIntegral <$> PL.fromPlInt pl--plEnum :: (Enum a) => a -> PL.PropertyList-plEnum = PL.plInt . fromIntegral . fromEnum--fromPlSkills- :: PL.PropertyList -> Maybe (Either Integer [(Instrument, Integer)])-fromPlSkills pl = case (PL.fromPlInt pl, PL.fromPlDict pl) of- (Nothing, Nothing) -> Nothing- (Just i , _ ) -> Just $ Left i- (_ , Just d ) -> let- getSkill (x, y) = liftA2 (,) (readMaybe $ capitalize x) (PL.fromPlInt y)- capitalize "" = ""- capitalize (c:cs) = toUpper c : map toLower cs- in fmap Right $ mapM getSkill $ Map.toList d--plSkills :: Either Integer [(Instrument, Integer)] -> PL.PropertyList-plSkills (Left i ) = PL.plInt i-plSkills (Right sl) = PL.plDict $- Map.fromList $ map (map toLower . show *** PL.plInt) sl--loadInfo :: FilePath -> IO (Maybe Info)-loadInfo dir =- PL.fromPropertyList <$> readXmlPropertyListFromFile' (dir </> "info.plist")--data Track = Track- { trackClass :: String- , identifier :: String- , scoreSystemHeight :: Maybe Integer- , scoreSystemInterval :: Maybe Integer- , trackTitle :: Maybe String- } deriving (Eq, Ord, Show, Read)--instance PL.PropertyListItem Track where-- toPropertyList t = PL.plDict $ Map.fromList $ catMaybes- [ Just ("class" , PL.plString $ trackClass t)- , Just ("identifier" , PL.plString $ identifier t)- , (\i -> ("scoreSystemHeight" , PL.plInt i)) <$> scoreSystemHeight t- , (\i -> ("scoreSystemInterval", PL.plInt i)) <$> scoreSystemInterval t- , (\s -> ("title" , PL.plString s)) <$> trackTitle t- ]-- fromPropertyList pl = PL.fromPlDict pl >>= \d -> Track- <$> (Map.lookup "class" d >>= PL.fromPlString)- <*> (Map.lookup "identifier" d >>= PL.fromPlString)- <*> Just (Map.lookup "scoreSystemHeight" d >>= PL.fromPlInt )- <*> Just (Map.lookup "scoreSystemInterval" d >>= PL.fromPlInt )- <*> Just (Map.lookup "title" d >>= PL.fromPlString)--loadTracks :: FilePath -> IO (Maybe [Track])-loadTracks dir = PL.listFromPropertyList <$>- readXmlPropertyListFromFile' (dir </> "tracks.plist")---- | Reads strictly so as not to exhaust our allowed open files.-readXmlPropertyListFromFile' :: FilePath -> IO PL.PropertyList-readXmlPropertyListFromFile' f = do- str <- readFile f- _ <- evaluate $ length str- either fail return $ PL.readXmlPropertyList str---- | Tries to find the top-level Jammit library directory on Windows or--- Mac OS X.-findJammitDir :: IO (Maybe FilePath)-findJammitDir = case Info.os of- "mingw32" -> do- var <- lookupEnv "LocalAppData"- case var of- Just local -> jammitIn local- Nothing -> return Nothing- "darwin" -> do- home <- Dir.getHomeDirectory- jammitIn $ home </> "Library" </> "Application Support"- _ -> return Nothing- where jammitIn dir = do- let jmt = dir </> "Jammit"- b <- Dir.doesDirectoryExist jmt- return $ guard b >> Just jmt---- | Gets the contents of a directory without the @.@ and @..@ special paths,--- and adds the directory to the front of all the names to make absolute paths.-lsAbsolute :: FilePath -> IO [FilePath]-lsAbsolute d =- map (d </>) . filter (`notElem` [".", ".."]) <$> Dir.getDirectoryContents d---- | Searches a directory and all subdirectories for folders containing a Jammit--- info file.-songSubdirs :: FilePath -> IO [FilePath]-songSubdirs dir = do- isSong <- Dir.doesFileExist $ dir </> "info.plist"- let here = [dir | isSong]- subdirs <- lsAbsolute dir >>= filterM Dir.doesDirectoryExist- (here ++) . concat <$> mapM songSubdirs subdirs
− src/Main.hs
@@ -1,320 +0,0 @@-module Main (main) where--import Control.Applicative ((<$>), liftA2, (<|>))-import Control.Monad (forM, (>=>), forM_)-import Data.Char (toLower)-import Data.List (isInfixOf, transpose, sort, nub, partition, isPrefixOf)-import Data.Maybe (mapMaybe, catMaybes, fromMaybe, listToMaybe)-import Data.Version (showVersion)-import qualified System.Console.GetOpt as Opt-import qualified System.Environment as Env--import System.Directory (getDirectoryContents)-import System.FilePath ((</>), splitFileName, takeFileName)-import Text.PrettyPrint.Boxes- (text, vcat, left, render, hsep, top, (/+/))--import AIFC2WAV-import ImageMagick-import Jammit-import qualified Paths_jammittools as Paths-import Sox-import TempFile--data Args = Args- { filterLibrary :: Library -> Library- , selectParts :: String- , rejectParts :: String- , pageLines :: Maybe Int- , jammitDir :: Maybe FilePath- , function :: Function- }--data Function- = PrintUsage- | ShowDatabase- | ExportSheet FilePath- | ExportAudio FilePath- | ExportAll FilePath- | CheckPresence- deriving (Eq, Ord, Show, Read)--defaultArgs :: Args-defaultArgs = Args- { filterLibrary = id- , selectParts = ""- , rejectParts = ""- , pageLines = Nothing- , jammitDir = Nothing- , function = PrintUsage- }--partToChar :: Part -> Char-partToChar p = case p of- PartGuitar1 -> 'g'- PartGuitar2 -> 'r'- PartBass -> 'b'- PartDrums -> 'd'- PartKeys1 -> 'k'- PartKeys2 -> 'y'- PartPiano -> 'p'- PartSynth -> 's'- PartVocal -> 'v'- PartBVocals -> 'x'--charPartMap :: [(Char, Part)]-charPartMap = [ (partToChar p, p) | p <- [minBound .. maxBound] ]--charToSheetPart :: Char -> Maybe SheetPart-charToSheetPart c = let- notation = Notation <$> lookup c charPartMap- tab = Tab <$> lookup (toLower c) charPartMap- in notation <|> tab--charToAudioPart :: Char -> Maybe AudioPart-charToAudioPart c = let- only = Only <$> lookup c charPartMap- without = Without . partToInstrument <$> lookup (toLower c) charPartMap- in only <|> without--type Library = [(FilePath, Info, [Track])]--fuzzySearchBy :: (Info -> String) -> String -> Library -> Library-fuzzySearchBy f str = let str' = map toLower str in- filter $ \(_, info, _) -> str' `isInfixOf` map toLower (f info)--exactSearchBy :: (Info -> String) -> String -> Library -> Library-exactSearchBy f str = filter $ \(_, info, _) -> f info == str--argOpts :: [Opt.OptDescr (Args -> Args)]-argOpts =- [ Opt.Option ['t'] ["title"]- (Opt.ReqArg- (\s a -> a { filterLibrary = fuzzySearchBy title s . filterLibrary a })- "str")- "search by song title"- , Opt.Option ['r'] ["artist"]- (Opt.ReqArg- (\s a -> a { filterLibrary = fuzzySearchBy artist s . filterLibrary a })- "str")- "search by song artist"- , Opt.Option ['T'] ["title-exact"]- (Opt.ReqArg- (\s a -> a { filterLibrary = exactSearchBy title s . filterLibrary a })- "str")- "search by song title (exact)"- , Opt.Option ['R'] ["artist-exact"]- (Opt.ReqArg- (\s a -> a { filterLibrary = exactSearchBy artist s . filterLibrary a })- "str")- "search by song artist (exact)"- , Opt.Option ['y'] ["yes-parts"]- (Opt.ReqArg (\s a -> a { selectParts = s }) "parts")- "parts to appear in sheet music or audio"- , Opt.Option ['n'] ["no-parts"]- (Opt.ReqArg (\s a -> a { rejectParts = s }) "parts")- "parts to subtract (add inverted) from audio"- , Opt.Option ['l'] ["lines"]- (Opt.ReqArg (\s a -> a { pageLines = Just $ read s }) "int")- "number of systems per page"- , Opt.Option ['j'] ["jammit"]- (Opt.ReqArg (\s a -> a { jammitDir = Just s }) "directory")- "location of Jammit library"- , Opt.Option ['?'] ["help"]- (Opt.NoArg $ \a -> a { function = PrintUsage })- "function: print usage info"- , Opt.Option ['d'] ["database"]- (Opt.NoArg $ \a -> a { function = ShowDatabase })- "function: display all songs in db"- , Opt.Option ['s'] ["sheet"]- (Opt.ReqArg (\s a -> a { function = ExportSheet s }) "file")- "function: export sheet music"- , Opt.Option ['a'] ["audio"]- (Opt.ReqArg (\s a -> a { function = ExportAudio s }) "file")- "function: export audio"- , Opt.Option ['x'] ["export"]- (Opt.ReqArg (\s a -> a { function = ExportAll s }) "dir")- "function: export all to dir"- , Opt.Option ['c'] ["check"]- (Opt.NoArg $ \a -> a { function = CheckPresence })- "function: check presence of audio parts"- ]--loadLibrary :: FilePath -> IO Library-loadLibrary jmt = do- dirs <- songSubdirs jmt- fmap catMaybes $ forM dirs $ \d -> do- maybeInfo <- loadInfo d- maybeTrks <- loadTracks d- return $ liftA2 (\i t -> (d, i, t)) maybeInfo maybeTrks---- | Displays a table of the library, possibly filtered by search terms.-showLibrary :: Library -> String-showLibrary lib = let- titleArtists = sort $ nub [ (title info, artist info) | (_, info, _) <- lib ]- partsFor ttl art = map partToChar $ sort $ concat- [ mapMaybe (trackTitle >=> titleToPart) trks- | (_, info, trks) <- lib- , (ttl, art) == (title info, artist info) ]- makeColumn h col = text h /+/ vcat left (map text col)- titleColumn = makeColumn "Title" $ map fst titleArtists- artistColumn = makeColumn "Artist" $ map snd titleArtists- partsColumn = makeColumn "Parts" $ map (uncurry partsFor) titleArtists- in render $ hsep 1 top [titleColumn, artistColumn, partsColumn]---- | Loads the Jammit library, and applies the search terms from the arguments--- to filter it.-searchResults :: Args -> IO Library-searchResults args = do- jmt <- case jammitDir args of- Just j -> return j- Nothing -> Env.lookupEnv "JAMMIT" >>= \mv -> case mv of- Just j -> return j- Nothing ->- fromMaybe (error "Couldn't find Jammit directory.") <$> findJammitDir- db <- loadLibrary jmt- return $ filterLibrary args db---- | A mapping from audio part to absolute filename of an audio file.-getAudioParts :: Library -> [(AudioPart, FilePath)]-getAudioParts lib = do- (dir, info, trks) <- lib- trk <- trks- case trackTitle trk >>= \t -> titleToAudioPart t (instrument info) of- Nothing -> []- Just ap -> [(ap, dir </> (identifier trk ++ "_jcfx"))]---- | A mapping from sheet part to--- @(prefix of image files, line height in pixels)@.-getSheetParts :: Library -> [(SheetPart, (FilePath, Integer))]-getSheetParts lib = do- (dir, _info, trks) <- lib- trk <- trks- case (trackTitle trk >>= \t -> titleToPart t, scoreSystemInterval trk) of- (Just p, Just ht) -> let- sheet = (Notation p, (dir </> (identifier trk ++ "_jcfn"), ht))- tab = (Tab p, (dir </> (identifier trk ++ "_jcft"), ht))- in if elem (partToInstrument p) [Guitar, Bass]- then [sheet, tab]- else [sheet]- _ -> []---- | If there is exactly one pair with the given first element, returns its--- second element. Otherwise (for 0 or >1 elements) returns an error.-getOneResult :: (Eq a, Show a) => a -> [(a, b)] -> Either String b-getOneResult x xys = case [ b | (a, b) <- xys, a == x ] of- [y] -> Right y- ys -> Left $ "Got " ++ show (length ys) ++ " results for " ++ show x--main :: IO ()-main = do- (fs, _, _) <- Opt.getOpt Opt.Permute argOpts <$> Env.getArgs- let args = foldr ($) defaultArgs fs- case function args of- PrintUsage -> do- prog <- Env.getProgName- putStrLn $ "jammittools v" ++ showVersion Paths.version- let header = "Usage: " ++ prog ++ " [options]"- putStr $ Opt.usageInfo header argOpts- ShowDatabase -> do- matches <- searchResults args- putStr $ showLibrary matches- ExportAudio fout -> do- matches <- getAudioParts <$> searchResults args- let f = mapM (`getOneResult` matches) . mapMaybe charToAudioPart- case (f $ selectParts args, f $ rejectParts args) of- (Left err , _ ) -> error err- (_ , Left err ) -> error err- (Right yaifcs, Right naifcs) -> runAudio yaifcs naifcs fout- CheckPresence -> do- matches <- getAudioParts <$> searchResults args- let f = mapM (`getOneResult` matches) . mapMaybe charToAudioPart- case (f $ selectParts args, f $ rejectParts args) of- (Left err , _ ) -> error err- (_ , Left err ) -> error err- (Right _ , Right _ ) -> return ()- ExportSheet fout -> do- matches <- getSheetParts <$> searchResults args- let f = mapM (`getOneResult` matches) . mapMaybe charToSheetPart- case f $ selectParts args of- Left err -> error err- Right parts -> let- systemHeight = sum $ map snd parts- in runSheet parts (getPageLines systemHeight args) fout- ExportAll dout -> do- matches <- searchResults args- let sheets = getSheetParts matches- audios = getAudioParts matches- backingOrder = [Drums, Guitar, Keyboard, Bass, Vocal]- isGuitar p = elem (partToInstrument p) [Guitar, Bass]- (gtrs, nongtrs) = partition isGuitar [minBound .. maxBound]- chosenBacking = listToMaybe $ flip mapMaybe backingOrder $ \i ->- case getOneResult (Without i) audios of- Left _ -> Nothing- Right fp -> Just (i, fp)- forM_ gtrs $ \p ->- case (getOneResult (Notation p) sheets, getOneResult (Tab p) sheets) of- (Right note, Right tab) -> let- parts = [note, tab]- systemHeight = sum $ map snd parts- fout = dout </> drop 4 (map toLower (show p) ++ ".pdf")- in runSheet [note, tab] (getPageLines systemHeight args) fout- _ -> return ()- forM_ nongtrs $ \p ->- case getOneResult (Notation p) sheets of- Left _ -> return ()- Right note -> let- fout = dout </> drop 4 (map toLower (show p) ++ ".pdf")- in runSheet [note] (getPageLines (snd note) args) fout- forM_ [minBound .. maxBound] $ \p ->- case getOneResult (Only p) audios of- Left _ -> return ()- Right fp -> let- fout = dout </> drop 4 (map toLower (show p) ++ ".wav")- in runAudio [fp] [] fout- case chosenBacking of- Nothing -> return ()- Just (inst, fback) -> let- others = [ fp | (Only p, fp) <- audios, partToInstrument p /= inst ]- fout = dout </> "backing.wav"- in runAudio [fback] others fout--getPageLines :: Integer -> Args -> Int-getPageLines systemHeight args = let- pageHeight = 724 / 8.5 * 11 :: Double- defaultLines = round $ pageHeight / fromIntegral systemHeight- in max 1 $ fromMaybe defaultLines $ pageLines args---- | Takes a list of positive AIFCs, a list of negative AIFCs, and a WAV file--- to produce.-runAudio :: [FilePath] -> [FilePath] -> FilePath -> IO ()-runAudio pos neg fout = runTempIO fout $ do- -- I've only found one audio file where the instruments are not aligned:- -- the drums and drums backing track for Take the Time are 38 samples ahead- -- of the other instruments. So as a hack, we pad the front of them by 38- -- samples to line things up.- let tttDrums = "793EAAE0-6761-44D7-9A9A-1FB451A2A438_jcfx"- tttDrumsBack = "37EE5AA5-4049-4CED-844A-D34F6B165F67_jcfx"- aifcToWav' a = if takeFileName a `elem` [tttDrums, tttDrumsBack]- then Pad (Samples 38) . File <$> aifcToWav a- else File <$> aifcToWav a- posWavs <- map (\w -> ( 1, w)) <$> mapM aifcToWav' pos- negWavs <- map (\w -> (-1, w)) <$> mapM aifcToWav' neg- renderAudio $ optimize $ Mix (posWavs ++ negWavs)--runSheet :: [(FilePath, Integer)] -> Int -> FilePath -> IO ()-runSheet trks lns fout = runTempIO fout $ do- trkLns <- forM trks $ \(fp, ht) -> do- let (dir, file) = splitFileName fp- ls <- liftIO $ getDirectoryContents dir- cnct <- connectVertical $- map (dir </>) $ sort $ filter (file `isPrefixOf`) ls- splitVertical ht cnct- pages <- forM (map concat $ chunksOf lns $ transpose trkLns) $ \pg ->- connectVertical pg- joinPages pages--chunksOf :: Int -> [a] -> [[a]]-chunksOf _ [] = []-chunksOf n xs = case splitAt n xs of- (ys, zs) -> ys : chunksOf n zs
+ src/Sound/Jammit/Base.hs view
@@ -0,0 +1,256 @@+{- |+Basic types and functions for dealing with Jammit song packages.+-}+module Sound.Jammit.Base+( Instrument(..)+, Part(..)+, AudioPart(..)+, SheetPart(..)+, titleToPart+, titleToAudioPart+, partToInstrument+, audioPartToInstrument+, Info(..)+, Track(..)+, loadInfo+, loadTracks+, findJammitDir+, songSubdirs+) where++import Control.Applicative ((<$>), (<*>), liftA2)+import Control.Arrow ((***))+import Control.Exception (evaluate)+import Control.Monad (filterM, guard)+import Data.Char (toLower, toUpper)+import Data.Maybe (catMaybes)+import System.Environment (lookupEnv)+import Text.Read (readMaybe)++import qualified Data.Map as Map+import qualified Data.PropertyList as PL+import qualified System.Directory as Dir+import System.FilePath ((</>))+import qualified System.Info as Info++-- | The Enum instance corresponds to the number used in the "instrument"+-- property, and the names (used by Show/Read) are capitalized versions of those+-- used in the "skillLevel" property.+data Instrument = Guitar | Bass | Drums | Keyboard | Vocal+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++data Part+ = PartGuitar1 -- ^ Used for both Guitar and Guitar 1+ | PartGuitar2+ | PartBass+ | PartDrums+ | PartKeys1 -- ^ Used for both Keys and Keys 1+ | PartKeys2+ | PartPiano -- ^ Rarely used. Seen in \"The Answer Lies Within\" and \"Wait for Sleep\"+ | PartSynth -- ^ Rarely used. Seen in \"Wait for Sleep\"+ | PartVocal+ | PartBVocals+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++data AudioPart+ = Only Part -- ^ An audio file for a single notated part.+ | Without Instrument -- ^ The backing track for an instrument package.+ deriving (Eq, Ord, Show, Read)++data SheetPart+ = Notation Part -- ^ For any instrument, the notation sheet music.+ | Tab Part -- ^ For guitar and bass, the tablature sheet music.+ deriving (Eq, Ord, Show, Read)++titleToPart :: String -> Maybe Part+titleToPart s = case s of+ "Guitar" -> Just PartGuitar1+ "Guitar 1" -> Just PartGuitar1+ "Guitar 2" -> Just PartGuitar2+ "Bass" -> Just PartBass+ "Drums" -> Just PartDrums+ "Keys" -> Just PartKeys1+ "Keys 1" -> Just PartKeys1+ "Keys 2" -> Just PartKeys2+ "Piano" -> Just PartPiano+ "Synth" -> Just PartSynth+ "Vocal" -> Just PartVocal+ "B Vocals" -> Just PartBVocals+ _ -> Nothing++titleToAudioPart :: String -> Instrument -> Maybe AudioPart+titleToAudioPart "Band" i = Just $ Without i+titleToAudioPart s _ = Only <$> titleToPart s++partToInstrument :: Part -> Instrument+partToInstrument p = case p of+ PartGuitar1 -> Guitar+ PartGuitar2 -> Guitar+ PartBass -> Bass+ PartDrums -> Drums+ PartKeys1 -> Keyboard+ PartKeys2 -> Keyboard+ PartPiano -> Keyboard+ PartSynth -> Keyboard+ PartVocal -> Vocal+ PartBVocals -> Vocal++audioPartToInstrument :: AudioPart -> Instrument+audioPartToInstrument (Only p) = partToInstrument p+audioPartToInstrument (Without i) = i++data Info = Info+ { album :: String+ , artist :: String+ , bpm :: String+ , copyright :: String+ , countInBeats :: Integer+ , courtesyOf :: String+ , demo :: Bool+ , explicit :: Bool+ , genre :: String+ , instrument :: Instrument+ , publishedBy :: String+ , skillLevel :: Either Integer [(Instrument, Integer)]+ , sku :: String+ , slow :: Double+ , title :: String+ , version :: Integer+ , writtenBy :: String+ } deriving (Eq, Ord, Show, Read)++instance PL.PropertyListItem Info where++ fromPropertyList pl = PL.fromPlDict pl >>= \dict -> Info+ <$> (Map.lookup "album" dict >>= PL.fromPlString)+ <*> (Map.lookup "artist" dict >>= PL.fromPlString)+ <*> (Map.lookup "bpm" dict >>= PL.fromPlString)+ <*> (Map.lookup "copyright" dict >>= PL.fromPlString)+ <*> (Map.lookup "countInBeats" dict >>= PL.fromPlInt )+ <*> (Map.lookup "courtesyOf" dict >>= PL.fromPlString)+ <*> (Map.lookup "demo" dict >>= fromPlEnum )+ <*> (Map.lookup "explicit" dict >>= fromPlEnum )+ <*> (Map.lookup "genre" dict >>= PL.fromPlString)+ <*> (Map.lookup "instrument" dict >>= fromPlEnum )+ <*> (Map.lookup "publishedBy" dict >>= PL.fromPlString)+ <*> (Map.lookup "skillLevel" dict >>= fromPlSkills)+ <*> (Map.lookup "sku" dict >>= PL.fromPlString)+ <*> (Map.lookup "slow" dict >>= PL.fromPlReal )+ <*> (Map.lookup "title" dict >>= PL.fromPlString)+ <*> (Map.lookup "version" dict >>= PL.fromPlInt )+ <*> (Map.lookup "writtenBy" dict >>= PL.fromPlString)++ toPropertyList info = PL.plDict $ Map.fromList+ [ ("album" , PL.plString $ album info)+ , ("artist" , PL.plString $ artist info)+ , ("bpm" , PL.plString $ bpm info)+ , ("copyright" , PL.plString $ copyright info)+ , ("countInBeats", PL.plInt $ countInBeats info)+ , ("courtesyOf" , PL.plString $ courtesyOf info)+ , ("demo" , plEnum $ demo info)+ , ("explicit" , plEnum $ explicit info)+ , ("genre" , PL.plString $ genre info)+ , ("instrument" , plEnum $ instrument info)+ , ("publishedBy" , PL.plString $ publishedBy info)+ , ("skillLevel" , plSkills $ skillLevel info)+ , ("sku" , PL.plString $ sku info)+ , ("slow" , PL.plReal $ slow info)+ , ("title" , PL.plString $ title info)+ , ("version" , PL.plInt $ version info)+ , ("writtenBy" , PL.plString $ writtenBy info)+ ]++fromPlEnum :: (Enum a) => PL.PropertyList -> Maybe a+fromPlEnum pl = toEnum . fromIntegral <$> PL.fromPlInt pl++plEnum :: (Enum a) => a -> PL.PropertyList+plEnum = PL.plInt . fromIntegral . fromEnum++fromPlSkills+ :: PL.PropertyList -> Maybe (Either Integer [(Instrument, Integer)])+fromPlSkills pl = case (PL.fromPlInt pl, PL.fromPlDict pl) of+ (Nothing, Nothing) -> Nothing+ (Just i , _ ) -> Just $ Left i+ (_ , Just d ) -> let+ getSkill (x, y) = liftA2 (,) (readMaybe $ capitalize x) (PL.fromPlInt y)+ capitalize "" = ""+ capitalize (c:cs) = toUpper c : map toLower cs+ in fmap Right $ mapM getSkill $ Map.toList d++plSkills :: Either Integer [(Instrument, Integer)] -> PL.PropertyList+plSkills (Left i ) = PL.plInt i+plSkills (Right sl) = PL.plDict $+ Map.fromList $ map (map toLower . show *** PL.plInt) sl++loadInfo :: FilePath -> IO (Maybe Info)+loadInfo dir =+ PL.fromPropertyList <$> readXmlPropertyListFromFile' (dir </> "info.plist")++data Track = Track+ { trackClass :: String+ , identifier :: String+ , scoreSystemHeight :: Maybe Integer+ , scoreSystemInterval :: Maybe Integer+ , trackTitle :: Maybe String+ } deriving (Eq, Ord, Show, Read)++instance PL.PropertyListItem Track where++ toPropertyList t = PL.plDict $ Map.fromList $ catMaybes+ [ Just ("class" , PL.plString $ trackClass t)+ , Just ("identifier" , PL.plString $ identifier t)+ , (\i -> ("scoreSystemHeight" , PL.plInt i)) <$> scoreSystemHeight t+ , (\i -> ("scoreSystemInterval", PL.plInt i)) <$> scoreSystemInterval t+ , (\s -> ("title" , PL.plString s)) <$> trackTitle t+ ]++ fromPropertyList pl = PL.fromPlDict pl >>= \d -> Track+ <$> (Map.lookup "class" d >>= PL.fromPlString)+ <*> (Map.lookup "identifier" d >>= PL.fromPlString)+ <*> Just (Map.lookup "scoreSystemHeight" d >>= PL.fromPlInt )+ <*> Just (Map.lookup "scoreSystemInterval" d >>= PL.fromPlInt )+ <*> Just (Map.lookup "title" d >>= PL.fromPlString)++loadTracks :: FilePath -> IO (Maybe [Track])+loadTracks dir = PL.listFromPropertyList <$>+ readXmlPropertyListFromFile' (dir </> "tracks.plist")++-- | Reads strictly so as not to exhaust our allowed open files.+readXmlPropertyListFromFile' :: FilePath -> IO PL.PropertyList+readXmlPropertyListFromFile' f = do+ str <- readFile f+ _ <- evaluate $ length str+ either fail return $ PL.readXmlPropertyList str++-- | Tries to find the top-level Jammit library directory on Windows or+-- Mac OS X.+findJammitDir :: IO (Maybe FilePath)+findJammitDir = case Info.os of+ "mingw32" -> do+ var <- lookupEnv "LocalAppData"+ case var of+ Just local -> jammitIn local+ Nothing -> return Nothing+ "darwin" -> do+ home <- Dir.getHomeDirectory+ jammitIn $ home </> "Library" </> "Application Support"+ _ -> return Nothing+ where jammitIn dir = do+ let jmt = dir </> "Jammit"+ b <- Dir.doesDirectoryExist jmt+ return $ guard b >> Just jmt++-- | Gets the contents of a directory without the @.@ and @..@ special paths,+-- and adds the directory to the front of all the names to make absolute paths.+lsAbsolute :: FilePath -> IO [FilePath]+lsAbsolute d =+ map (d </>) . filter (`notElem` [".", ".."]) <$> Dir.getDirectoryContents d++-- | Searches a directory and all subdirectories for folders containing a Jammit+-- info file.+songSubdirs :: FilePath -> IO [FilePath]+songSubdirs dir = do+ isSong <- Dir.doesFileExist $ dir </> "info.plist"+ let here = [dir | isSong]+ subdirs <- lsAbsolute dir >>= filterM Dir.doesDirectoryExist+ (here ++) . concat <$> mapM songSubdirs subdirs
+ src/Sound/Jammit/Export.hs view
@@ -0,0 +1,115 @@+{- |+Functions for exporting Jammit audio (as WAV) and sheet music (as PDF).+-}+module Sound.Jammit.Export+( Library+, fuzzySearchBy+, exactSearchBy+, loadLibrary+, getAudioParts+, getSheetParts+, runAudio+, runSheet+) where++import Control.Applicative ((<$>), liftA2)+import Control.Monad (forM)+import Data.Char (toLower)+import Data.List (isInfixOf, transpose, sort, isPrefixOf)+import Data.Maybe (catMaybes)++import System.Directory (getDirectoryContents)+import System.FilePath ((</>), splitFileName, takeFileName)++import Sound.Jammit.Internal.AIFC2WAV+import Sound.Jammit.Internal.ImageMagick+import Sound.Jammit.Base+import Sound.Jammit.Internal.Sox+import Sound.Jammit.Internal.TempFile++type Library = [(FilePath, Info, [Track])]++-- | Filter the library based on some string selector. The selector is+-- applied case-insensitively, and the song's field only has to contain the+-- search term rather than match it exactly.+fuzzySearchBy :: (Info -> String) -> String -> Library -> Library+fuzzySearchBy f str = let str' = map toLower str in+ filter $ \(_, info, _) -> str' `isInfixOf` map toLower (f info)++-- | Filter the library based on some string selector. The selector must match+-- exactly.+exactSearchBy :: (Info -> String) -> String -> Library -> Library+exactSearchBy f str = filter $ \(_, info, _) -> f info == str++-- | Given the top-level Jammit library directory, finds all song packages.+loadLibrary :: FilePath -> IO Library+loadLibrary jmt = do+ dirs <- songSubdirs jmt+ fmap catMaybes $ forM dirs $ \d -> do+ maybeInfo <- loadInfo d+ maybeTrks <- loadTracks d+ return $ liftA2 (\i t -> (d, i, t)) maybeInfo maybeTrks++-- | A mapping from audio part to absolute filename of an audio file.+getAudioParts :: Library -> [(AudioPart, FilePath)]+getAudioParts lib = do+ (dir, info, trks) <- lib+ trk <- trks+ case trackTitle trk >>= \t -> titleToAudioPart t (instrument info) of+ Nothing -> []+ Just ap -> [(ap, dir </> (identifier trk ++ "_jcfx"))]++-- | A mapping from sheet part to+-- @(prefix of image files, line height in pixels)@.+getSheetParts :: Library -> [(SheetPart, (FilePath, Integer))]+getSheetParts lib = do+ (dir, _info, trks) <- lib+ trk <- trks+ case (trackTitle trk >>= \t -> titleToPart t, scoreSystemInterval trk) of+ (Just p, Just ht) -> let+ sheet = (Notation p, (dir </> (identifier trk ++ "_jcfn"), ht))+ tab = (Tab p, (dir </> (identifier trk ++ "_jcft"), ht))+ in if elem (partToInstrument p) [Guitar, Bass]+ then [sheet, tab]+ else [sheet]+ _ -> []++runAudio+ :: [FilePath] -- ^ AIFCs to mix in normally+ -> [FilePath] -- ^ AIFCs to mix in inverted+ -> FilePath -- ^ the resulting WAV file+ -> IO ()+runAudio pos neg fout = runTempIO fout $ do+ -- I've only found one audio file where the instruments are not aligned:+ -- the drums and drums backing track for Take the Time are 38 samples ahead+ -- of the other instruments. So as a hack, we pad the front of them by 38+ -- samples to line things up.+ let tttDrums = "793EAAE0-6761-44D7-9A9A-1FB451A2A438_jcfx"+ tttDrumsBack = "37EE5AA5-4049-4CED-844A-D34F6B165F67_jcfx"+ aifcToWav' a = if takeFileName a `elem` [tttDrums, tttDrumsBack]+ then Pad (Samples 38) . File <$> aifcToWav a+ else File <$> aifcToWav a+ posWavs <- map (\w -> ( 1, w)) <$> mapM aifcToWav' pos+ negWavs <- map (\w -> (-1, w)) <$> mapM aifcToWav' neg+ renderAudio $ optimize $ Mix (posWavs ++ negWavs)++runSheet+ :: [(FilePath, Integer)] -- ^ pairs of @(png file prefix, line height in px)@+ -> Int -- ^ how many sheet music systems per page+ -> FilePath -- ^ the resulting PDF+ -> IO ()+runSheet trks lns fout = runTempIO fout $ do+ trkLns <- forM trks $ \(fp, ht) -> do+ let (dir, file) = splitFileName fp+ ls <- liftIO $ getDirectoryContents dir+ cnct <- connectVertical $+ map (dir </>) $ sort $ filter (file `isPrefixOf`) ls+ splitVertical ht cnct+ pages <- forM (map concat $ chunksOf lns $ transpose trkLns) $ \pg ->+ connectVertical pg+ joinPages pages++chunksOf :: Int -> [a] -> [[a]]+chunksOf _ [] = []+chunksOf n xs = case splitAt n xs of+ (ys, zs) -> ys : chunksOf n zs
+ src/Sound/Jammit/Internal/AIFC2WAV.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Sound.Jammit.Internal.AIFC2WAV+( aifcToWav+) where++import Foreign.C (withCString, CInt(..), CChar(..))+import Foreign.Marshal.Array (withArrayLen)+import Foreign.Ptr (Ptr)++import Sound.Jammit.Internal.TempFile++foreign import ccall unsafe "aifc2wav_main" aifc2wav_main+ :: CInt -> Ptr (Ptr CChar) -> IO CInt++-- | Given a (new-style) IMA4-compressed AIFC file, converts it to a WAV file.+aifcToWav :: FilePath -> TempIO FilePath+aifcToWav aifc = do+ wav <- newTempFile "aifcToWav.wav"+ code <- liftIO $+ withCString "aifc2wav" $ \progC ->+ withCString aifc $ \aifcC ->+ withCString wav $ \wavC ->+ withArrayLen [progC, aifcC, wavC] $ \n v ->+ aifc2wav_main (fromIntegral n) v+ if code == 0+ then return wav+ else error $ "aifcToWav: returned " ++ show code
+ src/Sound/Jammit/Internal/ImageMagick.hs view
@@ -0,0 +1,89 @@+module Sound.Jammit.Internal.ImageMagick+( connectVertical+, splitVertical+, joinPages+) where++import Control.Applicative ((<$>))+import Control.Monad (void)+import Data.Char (isDigit)+import Data.List (isPrefixOf, sortBy)+import Data.Maybe (listToMaybe)+import Data.Ord (comparing)+import System.Environment (lookupEnv)+import System.Exit (ExitCode(..))+import qualified System.Info as Info++import System.Directory (getDirectoryContents)+import System.FilePath ((</>))+import System.IO.Temp (createTempDirectory)+import System.Process (readProcess, readProcessWithExitCode)++import Sound.Jammit.Internal.TempFile++-- | Find an ImageMagick binary, because the names are way too generic, and+-- "convert" is both an ImageMagick program and a Windows built-in utility.+imageMagick :: String -> IO (Maybe String)+imageMagick cmd = do+ (code, _, _) <- readProcessWithExitCode cmd ["-version"] ""+ case code of+ ExitSuccess -> return $ Just cmd+ _ -> case Info.os of+ "mingw32" -> firstJustM $+ -- env variables for different configs of (ghc arch)/(imagemagick arch)+ -- ProgramFiles: 32/32 or 64/64+ -- ProgramFiles(x86): 64/32+ -- ProgramW6432: 32/64+ flip map ["ProgramFiles", "ProgramFiles(x86)", "ProgramW6432"] $ \env ->+ lookupEnv env >>= \var -> case var of+ Nothing -> return Nothing+ Just pf+ -> fmap (\im -> pf </> im </> cmd)+ . listToMaybe+ . filter ("ImageMagick" `isPrefixOf`)+ <$> getDirectoryContents pf+ _ -> return Nothing++imageMagick' :: String -> IO String+imageMagick' cmd = imageMagick cmd >>= \ms -> case ms of+ Nothing -> error $ "imageMagick': couldn't find program " ++ cmd+ Just s -> return s++-- | Only runs actions until the first that gives 'Just'.+firstJustM :: (Monad m) => [m (Maybe a)] -> m (Maybe a)+firstJustM [] = return Nothing+firstJustM (mx : xs) = mx >>= \x -> case x of+ Nothing -> firstJustM xs+ Just y -> return $ Just y++-- | Stick images together vertically into one long image.+connectVertical :: [FilePath] -> TempIO FilePath+connectVertical [fin] = return fin+connectVertical fins = do+ cmd <- liftIO $ imageMagick' "montage"+ fout <- newTempFile "connectVertical.png"+ void $ liftIO $ readProcess cmd+ (["-geometry", "100%", "-tile", "1x"] ++ fins ++ [fout]) ""+ return fout++-- | Splits an image vertically into chunks of a given height.+splitVertical :: Integer -> FilePath -> TempIO [FilePath]+splitVertical i fin = do+ cmd <- liftIO $ imageMagick' "convert"+ tempdir <- ask+ splitdir <- liftIO $ createTempDirectory tempdir "splitVertical"+ void $ liftIO $+ readProcess cmd ["-crop", "x" ++ show i, fin, splitdir </> "x.png"] ""+ map (splitdir </>) . sortBy (comparing getNumber) . filter isFile+ <$> liftIO (getDirectoryContents splitdir)+ where getNumber :: String -> Integer+ getNumber = read . takeWhile isDigit . dropWhile (not . isDigit)+ isFile = (`notElem` [".", ".."])++-- | Joins several images into a PDF, where each image is a page.+joinPages :: [FilePath] -> TempIO FilePath+joinPages fins = do+ cmd <- liftIO $ imageMagick' "convert"+ fout <- newTempFile "joinPages.pdf"+ void $ liftIO $ readProcess cmd (fins ++ [fout]) ""+ return fout
+ src/Sound/Jammit/Internal/Sox.hs view
@@ -0,0 +1,96 @@+module Sound.Jammit.Internal.Sox+( Audio(..)+, Time(..)+, renderAudio+, optimize+) where++import Control.Arrow (first)+import Control.Monad (void, forM, guard)++import System.Process (readProcess)++import Sound.Jammit.Internal.TempFile++data Audio+ = Empty -- ^ An empty stereo file+ | File FilePath -- ^ An existing (stereo) file+ | Pad Time Audio -- ^ Pad audio start with silence+ | Mix [(Double, Audio)] -- ^ Add audio sample-wise, also multiplying volumes+ | Concat [Audio] -- ^ Sequentially connect audio+ deriving (Eq, Ord, Show, Read)++data Time+ = Seconds Double+ | Samples Integer+ deriving (Eq, Ord, Show, Read)++showTime :: Time -> String+showTime (Seconds d) = show d+showTime (Samples i) = show i ++ "s"++renderAudio :: Audio -> TempIO FilePath+renderAudio aud = case aud of+ Empty -> do+ fout <- newTempFile "render.wav"+ void $ liftIO $+ readProcess "sox" (["-n", fout] ++ words "trim 0 0 channels 2") ""+ return fout+ File f -> return f+ Pad t x -> do+ fin <- renderAudio x+ fout <- newTempFile "render.wav"+ void $ liftIO $ readProcess "sox" [fin, fout, "pad", showTime t] ""+ return fout+ Mix xs -> case xs of+ [] -> renderAudio Empty+ [(d, x)] -> do+ fin <- renderAudio x+ fout <- newTempFile "render.wav"+ void $ liftIO $+ readProcess "sox" ["-v", show d, fin, fout] ""+ return fout+ _ -> do+ dfins <- forM xs $ \(d, x) -> do+ fin <- renderAudio x+ return (d, fin)+ let argsin = concatMap+ (\(d, fin) -> ["-v", show d, fin]) dfins+ fout <- newTempFile "render.wav"+ void $ liftIO $+ readProcess "sox" (["--combine", "mix"] ++ argsin ++ [fout]) ""+ return fout+ Concat xs -> case xs of+ [] -> renderAudio Empty+ _ -> do+ fins <- mapM renderAudio xs+ fout <- newTempFile "render.wav"+ void $ liftIO $ readProcess "sox" (fins ++ [fout]) ""+ return fout++optimize :: Audio -> Audio+optimize aud = case aud of+ Pad (Samples 0) x -> x+ Pad (Seconds 0) x -> x+ Mix xs -> let+ xs' = do+ (d, x) <- xs+ guard $ d /= 0+ case optimize x of+ Mix ys -> map (first (* d)) ys+ x' -> [(d, x')]+ in case xs' of+ [] -> Empty+ [(1, x)] -> x+ _ -> Mix xs'+ Concat xs -> let+ xs' = do+ x <- xs+ case optimize x of+ Concat ys -> ys+ x' -> [x']+ in case xs' of+ [] -> Empty+ [x] -> x+ _ -> Concat xs'+ _ -> aud
+ src/Sound/Jammit/Internal/TempFile.hs view
@@ -0,0 +1,41 @@+-- | A wrapper around IO that allows you to treat temporary files like+-- garbage-collected values.+module Sound.Jammit.Internal.TempFile+( TempIO+, runTempIO+, newTempFile+, ask+, liftIO+) where++import Data.List (stripPrefix)+import System.IO (hClose)+import System.IO.Error (catchIOError)++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask, ReaderT(..))+import System.Directory (copyFile, renameFile)+import System.FilePath (splitPath)+import System.IO.Temp (openTempFile, withSystemTempDirectory)++-- | A wrapper around IO with a designated directory for temporary files.+type TempIO = ReaderT FilePath IO++-- | Creates a new temporary directory to run a computation in. When finished,+-- the final file will be moved/copied to the given path, and the temporary+-- directory will be deleted.+runTempIO :: FilePath -> TempIO FilePath -> IO ()+runTempIO fout act = withSystemTempDirectory "tempfile" $ \tmp -> do+ res <- runReaderT act tmp+ case stripPrefix (splitPath tmp) (splitPath res) of+ Just f | ".." `notElem` f -> -- try rename if we know the file is in tmp+ catchIOError (renameFile res fout) $ \_ -> copyFile res fout+ _ -> copyFile res fout++-- | Creates a new file in the temporary directory, given a template.+newTempFile :: String -> TempIO FilePath+newTempFile pat = do+ tmp <- ask+ (f, h) <- liftIO $ openTempFile tmp pat+ liftIO $ hClose h+ return f
− src/Sox.hs
@@ -1,96 +0,0 @@-module Sox-( Audio(..)-, Time(..)-, renderAudio-, optimize-) where--import Control.Arrow (first)-import Control.Monad (void, forM, guard)--import System.Process (readProcess)--import TempFile--data Audio- = Empty -- ^ An empty stereo file- | File FilePath -- ^ An existing (stereo) file- | Pad Time Audio -- ^ Pad audio start with silence- | Mix [(Double, Audio)] -- ^ Add audio sample-wise, also multiplying volumes- | Concat [Audio] -- ^ Sequentially connect audio- deriving (Eq, Ord, Show, Read)--data Time- = Seconds Double- | Samples Integer- deriving (Eq, Ord, Show, Read)--showTime :: Time -> String-showTime (Seconds d) = show d-showTime (Samples i) = show i ++ "s"--renderAudio :: Audio -> TempIO FilePath-renderAudio aud = case aud of- Empty -> do- fout <- newTempFile "render.wav"- void $ liftIO $- readProcess "sox" (["-n", fout] ++ words "trim 0 0 channels 2") ""- return fout- File f -> return f- Pad t x -> do- fin <- renderAudio x- fout <- newTempFile "render.wav"- void $ liftIO $ readProcess "sox" [fin, fout, "pad", showTime t] ""- return fout- Mix xs -> case xs of- [] -> renderAudio Empty- [(d, x)] -> do- fin <- renderAudio x- fout <- newTempFile "render.wav"- void $ liftIO $- readProcess "sox" ["-v", show d, fin, fout] ""- return fout- _ -> do- dfins <- forM xs $ \(d, x) -> do- fin <- renderAudio x- return (d, fin)- let argsin = concatMap- (\(d, fin) -> ["-v", show d, fin]) dfins- fout <- newTempFile "render.wav"- void $ liftIO $- readProcess "sox" (["--combine", "mix"] ++ argsin ++ [fout]) ""- return fout- Concat xs -> case xs of- [] -> renderAudio Empty- _ -> do- fins <- mapM renderAudio xs- fout <- newTempFile "render.wav"- void $ liftIO $ readProcess "sox" (fins ++ [fout]) ""- return fout--optimize :: Audio -> Audio-optimize aud = case aud of- Pad (Samples 0) x -> x- Pad (Seconds 0) x -> x- Mix xs -> let- xs' = do- (d, x) <- xs- guard $ d /= 0- case optimize x of- Mix ys -> map (first (* d)) ys- x' -> [(d, x')]- in case xs' of- [] -> Empty- [(1, x)] -> x- _ -> Mix xs'- Concat xs -> let- xs' = do- x <- xs- case optimize x of- Concat ys -> ys- x' -> [x']- in case xs' of- [] -> Empty- [x] -> x- _ -> Concat xs'- _ -> aud
− src/TempFile.hs
@@ -1,41 +0,0 @@--- | A wrapper around IO that allows you to treat temporary files like--- garbage-collected values.-module TempFile-( TempIO-, runTempIO-, newTempFile-, ask-, liftIO-) where--import Data.List (stripPrefix)-import System.IO (hClose)-import System.IO.Error (catchIOError)--import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Reader (ask, ReaderT(..))-import System.Directory (copyFile, renameFile)-import System.FilePath (splitPath)-import System.IO.Temp (openTempFile, withSystemTempDirectory)---- | A wrapper around IO with a designated directory for temporary files.-type TempIO = ReaderT FilePath IO---- | Creates a new temporary directory to run a computation in. When finished,--- the final file will be moved/copied to the given path, and the temporary--- directory will be deleted.-runTempIO :: FilePath -> TempIO FilePath -> IO ()-runTempIO fout act = withSystemTempDirectory "tempfile" $ \tmp -> do- res <- runReaderT act tmp- case stripPrefix (splitPath tmp) (splitPath res) of- Just f | ".." `notElem` f -> -- try rename if we know the file is in tmp- catchIOError (renameFile res fout) $ \_ -> copyFile res fout- _ -> copyFile res fout---- | Creates a new file in the temporary directory, given a template.-newTempFile :: String -> TempIO FilePath-newTempFile pat = do- tmp <- ask- (f, h) <- liftIO $ openTempFile tmp pat- liftIO $ hClose h- return f