diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # `jammittools` -![Available on Hackage](https://img.shields.io/hackage/v/jammittools.svg) +[![Available on Hackage](https://img.shields.io/hackage/v/jammittools.svg)](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 -- diff --git a/jammittools.cabal b/jammittools.cabal --- a/jammittools.cabal +++ b/jammittools.cabal @@ -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 diff --git a/src/Sound/Jammit/Export.hs b/src/Sound/Jammit/Export.hs --- a/src/Sound/Jammit/Export.hs +++ b/src/Sound/Jammit/Export.hs @@ -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)@ diff --git a/src/Sound/Jammit/Internal/Audio.hs b/src/Sound/Jammit/Internal/Audio.hs --- a/src/Sound/Jammit/Internal/Audio.hs +++ b/src/Sound/Jammit/Internal/Audio.hs @@ -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 diff --git a/src/Sound/Jammit/Internal/AudioExpr.hs b/src/Sound/Jammit/Internal/AudioExpr.hs deleted file mode 100644 --- a/src/Sound/Jammit/Internal/AudioExpr.hs +++ /dev/null @@ -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 diff --git a/src/Sound/Jammit/Internal/Image.hs b/src/Sound/Jammit/Internal/Image.hs --- a/src/Sound/Jammit/Internal/Image.hs +++ b/src/Sound/Jammit/Internal/Image.hs @@ -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"