jammittools 0.4 → 0.4.1
raw patch · 7 files changed
+119/−199 lines, 7 filesdep +conduit-audiodep +resourcetdep ~jammittoolsPVP ok
version bump matches the API change (PVP)
Dependencies added: conduit-audio, resourcet
Dependency ranges changed: jammittools
API changes (from Hackage documentation)
+ Sound.Jammit.Export: audioSource :: MonadResource m => FilePath -> IO (AudioSource m Int16)
Files
- Main.hs +1/−1
- README.md +1/−1
- jammittools.cabal +5/−3
- src/Sound/Jammit/Export.hs +33/−14
- src/Sound/Jammit/Internal/Audio.hs +74/−65
- src/Sound/Jammit/Internal/AudioExpr.hs +0/−109
- src/Sound/Jammit/Internal/Image.hs +5/−6
Main.hs view
@@ -35,7 +35,7 @@ putStrLn " # Export all sheet music and audio to a new folder" putStrLn $ " mkdir export; " ++ prog ++ " -t title -r artist -x export" putStrLn " # Make a sheet music PDF with Guitar 1's notation and tab"- putStrLn $ " " ++ prog ++ " -t title -r artist -y gr -s gtr1.pdf"+ putStrLn $ " " ++ prog ++ " -t title -r artist -y gG -s gtr1.pdf" putStrLn " # Make an audio track with no drums and no vocals" putStrLn $ " " ++ prog ++ " -t title -r artist -y D -n vx -a nodrumsvox.wav"
README.md view
@@ -1,6 +1,6 @@ # `jammittools` -+[](http://hackage.haskell.org/package/jammittools) A command-line tool for exporting sheet music and audio from the Windows/Mac app [Jammit]. It should go without saying, but please do not distribute content from songs you have purchased --
jammittools.cabal view
@@ -1,5 +1,5 @@ Name: jammittools-Version: 0.4+Version: 0.4.1 Synopsis: Export sheet music and audio from Windows/Mac app Jammit Description: @@ -28,7 +28,6 @@ Sound.Jammit.Export other-modules: Sound.Jammit.Internal.Audio- Sound.Jammit.Internal.AudioExpr Sound.Jammit.Internal.Image Sound.Jammit.Internal.TempIO hs-source-dirs: src@@ -46,6 +45,9 @@ , bytestring >= 0.10.4.0 && < 0.11 , conduit >= 1.2.3.1 && < 1.3 , vector >= 0.10.12.2 && < 0.11+ + , conduit-audio >= 0.1 && < 0.2+ , resourcet ghc-options: -Wall -O2 executable jammittools@@ -57,7 +59,7 @@ , directory >= 1.2.0.1 && < 1.3 , filepath >= 1.3.0.1 && < 1.4 , boxes >= 0.1.3 && < 0.2- , jammittools == 0.4+ , jammittools == 0.4.1 ghc-options: -Wall -O2 source-repository head
src/Sound/Jammit/Export.hs view
@@ -8,6 +8,7 @@ , loadLibrary , getAudioParts , getSheetParts+, audioSource , runAudio , runSheet ) where@@ -15,6 +16,7 @@ import Control.Applicative (liftA2) import Control.Monad (forM) import Data.Char (toLower)+import Data.Int (Int16, Int32) import Data.List (isInfixOf, sort, isPrefixOf) import Data.Maybe (catMaybes) @@ -23,9 +25,12 @@ import Sound.Jammit.Internal.Image import Sound.Jammit.Base-import Sound.Jammit.Internal.AudioExpr+import Sound.Jammit.Internal.Audio import Sound.Jammit.Internal.TempIO +import qualified Data.Conduit.Audio as A+import Control.Monad.Trans.Resource (MonadResource, runResourceT)+ type Library = [(FilePath, Info, [Track])] -- | Filter the library based on some string selector. The selector is@@ -73,24 +78,38 @@ else [sheet] _ -> [] +audioSource :: (MonadResource m) => FilePath -> IO (A.AudioSource m Int16)+audioSource fp = if takeFileName fp `elem` [tttDrums, tttDrumsBack]+ then fmap (A.padStart $ A.Frames 38) $ readIMA fp+ else readIMA fp+ -- 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.+ where tttDrums = "793EAAE0-6761-44D7-9A9A-1FB451A2A438_jcfx"+ tttDrumsBack = "37EE5AA5-4049-4CED-844A-D34F6B165F67_jcfx"+ runAudio :: [FilePath] -- ^ AIFCs to mix in normally -> [FilePath] -- ^ AIFCs to mix in inverted -> FilePath -- ^ the resulting WAV file -> IO ()-runAudio pos neg = let- -- 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.- tttDrums = "793EAAE0-6761-44D7-9A9A-1FB451A2A438_jcfx"- tttDrumsBack = "37EE5AA5-4049-4CED-844A-D34F6B165F67_jcfx"- aifcFile a = if takeFileName a `elem` [tttDrums, tttDrumsBack]- then Pad (Samples 38) $ File a- else File a- posAifcs = map (\f -> ( 1, aifcFile f)) pos- negAifcs = map (\f -> (-1, aifcFile f)) neg- in renderAudio $ optimize $ Mix $ posAifcs ++ negAifcs+runAudio pos neg fp = do+ pos' <- mapM audioSource pos+ neg' <- mapM audioSource neg+ let src = case (pos', neg') of+ ([] , [] ) -> A.silent (A.Frames 0) 44100 2+ ([p] , [] ) -> p+ ([] , [n] ) -> A.mapSamples negate16 n+ (p : ps, [] ) -> i32To16 $ mix16To32 p ps+ ([] , n : ns) -> i32To16 $ A.mapSamples negate $ mix16To32 n ns+ (p : ps, n : ns) -> i32To16 $ A.mix (mix16To32 p ps) $ A.mapSamples negate $ mix16To32 n ns+ i16To32 = A.mapSamples (fromIntegral :: Int16 -> Int32)+ i32To16 = A.mapSamples (fromIntegral . clamp (-32768, 32767) :: Int32 -> Int16)+ negate16 :: Int16 -> Int16+ negate16 x = if x == minBound then maxBound else negate x+ mix16To32 x xs = foldr A.mix (i16To32 x) (map i16To32 xs)+ runResourceT $ writeWAV fp src runSheet :: [(FilePath, Integer)] -- ^ pairs of @(png file prefix, line height in px)@
src/Sound/Jammit/Internal/Audio.hs view
@@ -2,30 +2,31 @@ AIFC\/IMA audio decoding functions in this module are ported from http://sed.free.fr/aifc2wav.html -}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} module Sound.Jammit.Internal.Audio ( readIMA , writeWAV+, clamp ) where import qualified Data.Conduit as C import qualified Data.Conduit.List as CL-import qualified Data.Vector as V+import qualified Data.Vector.Storable as V import Data.Int (Int16, Int32) import Data.Word (Word16, Word32)-import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as B import Data.ByteString.Char8 () -- for IsString instance import qualified System.IO as IO import GHC.IO.Handle (HandlePosn(..)) import Data.Bits (shiftL, shiftR, (.&.))-import Data.Foldable (forM_) import Control.Monad (unless, forM, liftM2) import Control.Monad.ST (runST) import Data.STRef (newSTRef, readSTRef, modifySTRef) +import qualified Data.Conduit.Audio as A+import Control.Monad.Trans.Resource (MonadResource)+ parseChunk :: IO.Handle -> IO (B.ByteString, (HandlePosn, HandlePosn)) parseChunk h = do ctype <- B.hGet h 4@@ -47,10 +48,9 @@ then return [] else liftM2 (:) (parseChunk h) (parseChunksUntil maybeEnd h) -readIMA :: (MonadIO m) => FilePath -> C.Source m (V.Vector (Int16, Int16))+readIMA :: (MonadResource m) => FilePath -> IO (A.AudioSource m Int16) readIMA fp = do- h <- liftIO $ IO.openBinaryFile fp IO.ReadMode- let ctype `chunkBefore` maybeEnd = \f -> do+ let insideChunk h ctype maybeEnd f = do here <- liftIO $ IO.hGetPosn h chunks <- liftIO $ parseChunksUntil maybeEnd h case lookup ctype chunks of@@ -60,33 +60,42 @@ x <- f end liftIO $ IO.hSetPosn here return x- "FORM" `chunkBefore` Nothing $ \formEnd -> do- "AIFC" <- liftIO $ B.hGet h 4- frames <- "COMM" `chunkBefore` Just formEnd $ \_ -> do- 2 <- liftIO (readBE h :: IO Word16) -- channels- frames <- liftIO (readBE h :: IO Word32) -- number of chunk pairs- bits <- liftIO (readBE h :: IO Word16) -- bits per sample, 0 means 16?- unless (bits `elem` [0, 16]) $ error "readIMA: bits per sample not 16 or 0"- -- next 10 bytes are sample rate as long float- -- for now we just compare to the known 44100- 0x400eac44 <- liftIO (readBE h :: IO Word32)- 0 <- liftIO (readBE h :: IO Word32)- 0 <- liftIO (readBE h :: IO Word16)- "ima4" <- liftIO $ B.hGet h 4- return frames- "SSND" `chunkBefore` Just formEnd $ \_ -> do- 0 <- liftIO (readBE h :: IO Word32) -- offset- 0 <- liftIO (readBE h :: IO Word32) -- blocksize- let go _ _ 0 = return ()- go predL predR remFrames = do- chunkL <- liftIO $ B.hGet h 34- chunkR <- liftIO $ B.hGet h 34- let (predL', vectL) = decodeChunk (predL, chunkL)- (predR', vectR) = decodeChunk (predR, chunkR)- V.zip vectL vectR `C.yieldOr` liftIO (IO.hClose h)- go predL' predR' $ remFrames - 1- go 0 0 frames- liftIO $ IO.hClose h+ frames <- IO.withBinaryFile fp IO.ReadMode $ \h -> do+ let chunkBefore = insideChunk h+ "FORM" `chunkBefore` Nothing $ \formEnd -> do+ "AIFC" <- liftIO $ B.hGet h 4+ "COMM" `chunkBefore` Just formEnd $ \_ -> do+ 2 <- liftIO (readBE h :: IO Word16) -- channels+ frames <- liftIO (readBE h :: IO Word32) -- number of chunk pairs+ bits <- liftIO (readBE h :: IO Word16) -- bits per sample, 0 means 16?+ unless (bits `elem` [0, 16]) $ error "readIMA: bits per sample not 16 or 0"+ -- next 10 bytes are sample rate as long float+ -- for now we just compare to the known 44100+ 0x400eac44 <- liftIO (readBE h :: IO Word32)+ 0 <- liftIO (readBE h :: IO Word32)+ 0 <- liftIO (readBE h :: IO Word16)+ "ima4" <- liftIO $ B.hGet h 4+ return frames+ let src = C.bracketP+ (IO.openBinaryFile fp IO.ReadMode)+ IO.hClose+ $ \h -> do+ let chunkBefore = insideChunk h+ "FORM" `chunkBefore` Nothing $ \formEnd -> do+ "AIFC" <- liftIO $ B.hGet h 4+ "SSND" `chunkBefore` Just formEnd $ \_ -> do+ 0 <- liftIO (readBE h :: IO Word32) -- offset+ 0 <- liftIO (readBE h :: IO Word32) -- blocksize+ let go _ _ 0 = return ()+ go predL predR remFrames = do+ chunkL <- liftIO $ B.hGet h 34+ chunkR <- liftIO $ B.hGet h 34+ let (predL', vectL) = decodeChunk (predL, chunkL)+ (predR', vectR) = decodeChunk (predR, chunkR)+ C.yield $ A.interleave [vectL, vectR]+ go predL' predR' $ remFrames - 1+ go 0 0 frames+ return $ A.AudioSource src 44100 2 $ fromIntegral frames decodeChunk :: (Int16, B.ByteString) -> (Int16, V.Vector Int16) decodeChunk (initPredictor, chunk) = runST $ do@@ -140,36 +149,36 @@ , 15289, 16818, 18500, 20350, 22385, 24623, 27086, 29794, 32767 ] -writeWAV :: (MonadIO m) => FilePath -> C.Sink (V.Vector (Int16, Int16)) m ()-writeWAV fp = do- h <- liftIO $ IO.openBinaryFile fp IO.WriteMode- let chunk ctype f = do- let getPosn = liftIO $ IO.hGetPosn h- liftIO $ B.hPut h ctype- lenPosn <- getPosn- liftIO $ B.hPut h $ B.pack [0xDE, 0xAD, 0xBE, 0xEF] -- filled in later- HandlePosn _ start <- getPosn- x <- f- endPosn@(HandlePosn _ end) <- getPosn- liftIO $ do- IO.hSetPosn lenPosn- writeLE h (fromIntegral $ end - start :: Word32)- IO.hSetPosn endPosn- return x- chunk "RIFF" $ do- liftIO $ B.hPut h "WAVE"- chunk "fmt " $ liftIO $ do- writeLE h (1 :: Word16) -- 1 is PCM- writeLE h (2 :: Word16) -- channels- writeLE h (44100 :: Word32) -- sample rate- writeLE h (176400 :: Word32) -- avg. bytes per second = rate * block align- writeLE h (4 :: Word16) -- block align = chans * (bps / 8)- writeLE h (16 :: Word16) -- bits per sample- chunk "data" $ CL.mapM_ $ \v -> liftIO $ do- forM_ v $ \(l, r) -> do- writeLE h l- writeLE h r- liftIO $ IO.hClose h+writeWAV :: (MonadResource m) => FilePath -> A.AudioSource m Int16 -> m ()+writeWAV fp (A.AudioSource s r c _) = s C.$$ C.bracketP+ (IO.openBinaryFile fp IO.WriteMode)+ IO.hClose+ (\h -> do+ let chunk ctype f = do+ let getPosn = liftIO $ IO.hGetPosn h+ liftIO $ B.hPut h ctype+ lenPosn <- getPosn+ liftIO $ B.hPut h $ B.pack [0xDE, 0xAD, 0xBE, 0xEF] -- filled in later+ HandlePosn _ start <- getPosn+ x <- f+ endPosn@(HandlePosn _ end) <- getPosn+ liftIO $ do+ IO.hSetPosn lenPosn+ writeLE h (fromIntegral $ end - start :: Word32)+ IO.hSetPosn endPosn+ return x+ chunk "RIFF" $ do+ liftIO $ B.hPut h "WAVE"+ chunk "fmt " $ liftIO $ do+ writeLE h (1 :: Word16) -- 1 is PCM+ writeLE h (fromIntegral c :: Word16) -- channels+ writeLE h (floor r :: Word32) -- sample rate+ writeLE h (floor r * fromIntegral c * 2 :: Word32) -- avg. bytes per second = rate * block align+ writeLE h (fromIntegral c * 2 :: Word16) -- block align = chans * (bps / 8)+ writeLE h (16 :: Word16) -- bits per sample+ chunk "data" $ CL.mapM_ $ \v -> liftIO $ do+ V.forM_ v $ writeLE h+ ) class BE a where readBE :: IO.Handle -> IO a
− src/Sound/Jammit/Internal/AudioExpr.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE LambdaCase #-}-module Sound.Jammit.Internal.AudioExpr-( Audio(..)-, Time(..)-, renderAudio-, optimize-) where--import Control.Arrow (first, (***))-import Control.Monad (guard, forever)-import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL-import Data.Conduit.Internal (zipSources)-import qualified Data.Vector as V-import Data.Int (Int16)-import Data.Maybe (fromMaybe)--import Sound.Jammit.Internal.Audio--data Audio- = Empty -- ^ An empty stereo file- | File FilePath -- ^ A Jammit-provided AIFC 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)--renderAudio :: Audio -> FilePath -> IO ()-renderAudio aud wavout = renderSource aud C.$$ writeWAV wavout--renderSource :: Audio -> C.Source IO (V.Vector (Int16, Int16))-renderSource aud = case aud of- Empty -> return ()- File f -> readIMA f- Pad t x -> do- let samples = case t of- Samples s -> fromIntegral s- Seconds s -> floor $ s * 44100- C.yield $ V.replicate samples (0, 0)- renderSource x- Concat xs -> mapM_ renderSource xs- Mix xs -> let- toDoubles :: (Double, Audio) -> C.Source IO (V.Vector (Double, Double))- toDoubles (p, x) = renderSource x C.=$= CL.map (V.map $ multiplyBy p *** multiplyBy p)- multiplyBy :: Double -> Int16 -> Double- multiplyBy p i16 = (fromIntegral i16 / 32767) * p- doubleToInt16 :: Double -> Int16- doubleToInt16 d =- if d > 1 then maxBound else if d < (-1) then minBound else round $ d * 32767- in foldr mixAudio (return ()) (map toDoubles xs) C.=$= CL.map (V.map $ doubleToInt16 *** doubleToInt16)--mixAudio- :: C.Source IO (V.Vector (Double, Double))- -> C.Source IO (V.Vector (Double, Double))- -> C.Source IO (V.Vector (Double, Double))-mixAudio s1 s2 = let- justify src = (src C.=$= CL.map Just) >> forever (C.yield Nothing)- nothingPanic = error "mixAudio: internal error! reached end of infinite stream"- mix = V.zipWith $ \(l1, r1) (l2, r2) -> (l1 + l2, r1 + r2)- in zipSources (justify s1) (justify s2) C.=$= let- loop = C.await >>= \case- Nothing -> nothingPanic- Just pair -> case pair of- (Nothing, Nothing) -> return ()- (Just v1, Nothing) -> C.yield v1 >> loop- (Nothing, Just v2) -> C.yield v2 >> loop- (Just v1, Just v2) -> case compare (V.length v1) (V.length v2) of- EQ -> C.yield (mix v1 v2) >> loop- LT -> let- (v2a, v2b) = V.splitAt (V.length v1) v2- in C.yield (mix v1 v2a) >> C.await >>= \case- Nothing -> nothingPanic- Just (next1, next2) -> do- C.leftover (next1, Just $ v2b V.++ fromMaybe V.empty next2)- loop- GT -> C.leftover (Just v2, Just v1) >> loop- in loop--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/Image.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} module Sound.Jammit.Internal.Image ( partsToPages , jpegsToPDF@@ -31,24 +30,24 @@ raw = mapM_ (\fp -> liftIO (loadPNG fp) >>= C.yield) fps chunk :: (Monad m) => C.Conduit (P.Image P.PixelRGBA8) m (P.Image P.PixelRGBA8)- chunk = C.await >>= \case+ chunk = C.await >>= \x -> case x of Nothing -> return () Just page -> case span (\c -> P.imageHeight c == h) $ vertSplit h page of (full, [] ) -> mapM_ C.yield full >> chunk- (full, part) -> mapM_ C.yield full >> C.await >>= \case+ (full, part) -> mapM_ C.yield full >> C.await >>= \y -> case y of Nothing -> mapM_ C.yield part Just page' -> C.leftover (vertConcat $ part ++ [page']) >> chunk in raw C.=$= chunk chunksToPages :: (Monad m) => Int -> C.Conduit [P.Image P.PixelRGBA8] m (P.Image P.PixelRGBA8)-chunksToPages n = fmap catMaybes (replicateM n C.await) >>= \case+chunksToPages n = fmap catMaybes (replicateM n C.await) >>= \systems -> case systems of [] -> return ()- systems -> C.yield (vertConcat $ concat systems) >> chunksToPages n+ _ -> C.yield (vertConcat $ concat systems) >> chunksToPages n sinkJPEG :: C.Sink (P.Image P.PixelRGBA8) TempIO [FilePath] sinkJPEG = go [] where- go jpegs = C.await >>= \case+ go jpegs = C.await >>= \x -> case x of Nothing -> return jpegs Just img -> do jpeg <- lift $ newTempFile "page.jpg"