jammittools 0.3.2 → 0.4
raw patch · 13 files changed
+582/−1158 lines, 13 filesdep +HPDFdep +JuicyPixelsdep +bytestringdep ~jammittoolsPVP ok
version bump matches the API change (PVP)
Dependencies added: HPDF, JuicyPixels, bytestring, conduit, vector
Dependency ranges changed: jammittools
API changes (from Hackage documentation)
Files
- Main.hs +64/−12
- README.md +2/−8
- cbits/aifc2wav-5.1.c +0/−793
- jammittools.cabal +13/−13
- src/Sound/Jammit/Export.hs +21/−28
- src/Sound/Jammit/Internal/AIFC2WAV.hs +0/−38
- src/Sound/Jammit/Internal/Audio.hs +220/−0
- src/Sound/Jammit/Internal/AudioExpr.hs +109/−0
- src/Sound/Jammit/Internal/Image.hs +112/−0
- src/Sound/Jammit/Internal/ImageMagick.hs +0/−89
- src/Sound/Jammit/Internal/Sox.hs +0/−136
- src/Sound/Jammit/Internal/TempFile.hs +0/−41
- src/Sound/Jammit/Internal/TempIO.hs +41/−0
Main.hs view
@@ -22,8 +22,22 @@ printUsage = do prog <- Env.getProgName putStrLn $ "jammittools v" ++ showVersion Paths.version- let header = "Usage: " ++ prog ++ " [options]"+ putStrLn ""+ let header = "Usage: " ++ prog ++ " -t <title> -r <artist> [options]" putStr $ Opt.usageInfo header argOpts+ putStrLn ""+ putStrLn "Instrument parts:"+ putStr showCharPartMap+ putStrLn "For sheet music, GRB are tab instead of notation."+ putStrLn "For audio, GBDKV are the backing tracks for each instrument."+ putStrLn ""+ putStrLn "Example usage:"+ 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 " # Make an audio track with no drums and no vocals"+ putStrLn $ " " ++ prog ++ " -t title -r artist -y D -n vx -a nodrumsvox.wav" main :: IO () main = do@@ -40,21 +54,21 @@ matches <- searchResults args putStr $ showLibrary matches ExportAudio fout -> do- matches <- getAudioParts <$> searchResults args+ matches <- getAudioParts <$> searchResultsChecked 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+ matches <- getAudioParts <$> searchResultsChecked 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+ matches <- getSheetParts <$> searchResultsChecked args let f = mapM (`getOneResult` matches) . mapMaybe charToSheetPart case f $ selectParts args of Left err -> error err@@ -62,7 +76,7 @@ systemHeight = sum $ map snd parts in runSheet parts (getPageLines systemHeight args) fout ExportAll dout -> do- matches <- searchResults args+ matches <- searchResultsChecked args let sheets = getSheetParts matches audios = getAudioParts matches backingOrder = [Drums, Guitar, Keyboard, Bass, Vocal]@@ -78,26 +92,34 @@ 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+ in do+ putStrLn $ "Exporting notation & tab for " ++ show p+ 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+ in do+ putStrLn $ "Exporting notation for " ++ show p+ 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+ in do+ putStrLn $ "Exporting audio for " ++ show p+ 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+ in do+ putStrLn "Exporting backing audio (could take a while)"+ runAudio [fback] others fout getPageLines :: Integer -> Args -> Int getPageLines systemHeight args = let@@ -110,7 +132,14 @@ 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+ [] -> Left $ "Couldn't find the part " ++ show x+ ys -> Left $ unwords+ [ "Found"+ , show $ length ys+ , "different parts for"+ , show x ++ ";"+ , "this is probably a bug?"+ ] -- | Displays a table of the library, possibly filtered by search terms. showLibrary :: Library -> String@@ -140,18 +169,33 @@ db <- loadLibrary jmt return $ filterLibrary args db +-- | Checks that the search actually narrowed down the library to a single song.+searchResultsChecked :: Args -> IO Library+searchResultsChecked args = do+ lib <- searchResults args+ case [ info | (_, info, _) <- lib ] of+ [] -> do+ putStrLn "No songs matched your search."+ exitFailure+ x : xs -> if all (\y -> title y == title x && artist y == artist x) xs+ then return lib+ else do+ putStrLn "Multiple songs matched your search:"+ putStr $ showLibrary lib+ exitFailure+ 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"+ "search by song title (fuzzy)" , Opt.Option ['r'] ["artist"] (Opt.ReqArg (\s a -> a { filterLibrary = fuzzySearchBy artist s . filterLibrary a }) "str")- "search by song artist"+ "search by song artist (fuzzy)" , Opt.Option ['T'] ["title-exact"] (Opt.ReqArg (\s a -> a { filterLibrary = exactSearchBy title s . filterLibrary a })@@ -239,6 +283,14 @@ charPartMap :: [(Char, Part)] charPartMap = [ (partToChar p, p) | p <- [minBound .. maxBound] ]++showCharPartMap :: String+showCharPartMap = let+ len = ceiling (fromIntegral (length charPartMap) / 2 :: Double)+ (map1, map2) = splitAt len charPartMap+ col1 = vcat left [ text $ [c] ++ ": " ++ drop 4 (show p) | (c, p) <- map1 ]+ col2 = vcat left [ text $ [c] ++ ": " ++ drop 4 (show p) | (c, p) <- map2 ]+ in render $ hsep 2 top [text "", col1, col2] charToSheetPart :: Char -> Maybe SheetPart charToSheetPart c = let
README.md view
@@ -1,18 +1,12 @@ # `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 -- it is for your use only! [Jammit]: https://www.jammit.com/--## Requirements--This is basically a fancy shell script but written in Haskell.-[ImageMagick](http://www.imagemagick.org) and [Sox](http://sox.sourceforge.net/)-are used to do the actual conversion work, so install those and put them in your path.-If you're on Windows, `jammittools` will look in your Program Files for both of them-so you shouldn't need to do anything after running their installers. ## Usage
− cbits/aifc2wav-5.1.c
@@ -1,793 +0,0 @@-/* public domain- * ima4, sowt and sdx2 handled- * sdx2 not hardly tested, may fail, contact me if problems- * endian-independant code- * sed@free.fr for comments/suggestions/anything- * http://sed.free.fr/aifc2wav.html- * Wed, 22 Jan 2003- * Last update: Fri, 30 Mar 2007- *- * algo, tables ripped from http://www.pcisys.net/~melanson/codecs/adpcm.txt- * the above link looks dead (2007-03-30), try the following link- * http://wiki.multimedia.cx/index.php?title=Category:ADPCM_Audio_Codecs- *- * file format in : ftp://ftp.sgi.com/sgi/aiff-c.9.26.91.ps.Z- *- * http://www.mactech.com/articles/mactech/Vol.06/06.01/SANENormalized/- * helped for handling extended numbers- *- * http://ewhac.best.vwh.net/3DO-old/music/- * for sdx2 code (see aif2raw.c there)- */--/* handled chunks types */-#define FORM 1-#define COMM 2-#define FVER 3-#define SSND 4--#include <stdio.h>-#include <stdlib.h>-#include <string.h>--static int index_table[16] = {- -1, -1, -1, -1, 2, 4, 6, 8,- -1, -1, -1, -1, 2, 4, 6, 8,-};--static int step_table[89] = {- 7, 8, 9, 10, 11, 12, 13, 14, 16, 17,- 19, 21, 23, 25, 28, 31, 34, 37, 41, 45,- 50, 55, 60, 66, 73, 80, 88, 97, 107, 118,- 130, 143, 157, 173, 190, 209, 230, 253, 279, 307,- 337, 371, 408, 449, 494, 544, 598, 658, 724, 796,- 876, 963, 1060, 1166, 1282, 1411, 1552, 1707, 1878, 2066,- 2272, 2499, 2749, 3024, 3327, 3660, 4026, 4428, 4871, 5358,- 5894, 6484, 7132, 7845, 8630, 9493, 10442, 11487, 12635, 13899,- 15289, 16818, 18500, 20350, 22385, 24623, 27086, 29794, 32767-};--/* parse a chunk - waits a 34 bytes buffer, returns a little endian buffer */-void decode_chunk(unsigned char *input, unsigned char *output, short *static_predictor)-{- char d;- int i;- short predictor;- short step_index;- int hnb, lnb;- int diff;- int sign, delta;- short step;-- d = *input++;- predictor=d << 8;- d = *input++;- step_index = d & 127;- predictor |= d&128;-- // onyxite: use this channel's last packet's last sample as predictor- predictor = *static_predictor;-- /* is this necessary ? */- if (step_index < 0) step_index = 0;- if (step_index > 88) step_index = 88;-- step = step_table[step_index];-- for (i=0; i<32; i++, input++) {- d = *input;- hnb = (d>>4) & 15;- lnb = d & 15;-- /* decode lnb */- step_index += index_table[lnb];- /* necessary ? */- if (step_index<0) step_index = 0;- if (step_index>88) step_index = 88;-- sign = lnb & 8;- delta = lnb & 7;- diff = step >> 3;- if (delta & 4) diff += step;- if (delta & 2) diff += step >> 1;- if (delta & 1) diff += step >> 2;- /* take care of clamping (Adam Sampson <ats@offog.org>) */- if (sign) {- int p = ((int) predictor) - diff;- if (p < -32768)- predictor = -32768;- else- predictor = p;- } else {- int p = ((int) predictor) + diff;- if (p > 32767)- predictor = 32767;- else- predictor = p;- }-- *output = predictor&255;- output++;- *output = (predictor>>8)&255;- output++;-- step = step_table[step_index];-- /* decode hnb */- step_index += index_table[hnb];- if (step_index<0) step_index = 0;- if (step_index>88) step_index = 88;-- sign = hnb & 8;- delta = hnb & 7;- diff = step >> 3;- if (delta & 4) diff += step;- if (delta & 2) diff += step >> 1;- if (delta & 1) diff += step >> 2;- /* take care of clamping (Adam Sampson <ats@offog.org>) */- if (sign) {- int p = ((int) predictor) - diff;- if (p < -32768)- predictor = -32768;- else- predictor = p;- } else {- int p = ((int) predictor) + diff;- if (p > 32767)- predictor = 32767;- else- predictor = p;- }-- *output = predictor&255;- output++;- *output = (predictor>>8)&255;- output++;-- // onyxite: save this sample so (if it's the last sample in this packet)- // it becomes the predictor for the next packet in this channel- *static_predictor = predictor;-- step = step_table[step_index];- }-}--/* reads the FILE, return the type of the chunk, size too */-/* return -1 on error, -2 if unhandled chunk, -3 if EOF */-int get_type(FILE *f, long *size)-{- int ret;-- unsigned char buf[8];-- ret=fread(buf, 1, 8, f);-- if (ret == 0 && feof(f))- return -3;-- if (ferror(f) || ret != 8)- return -1;-- *size = (unsigned)(buf[4]<<24) + (buf[5]<<16) + (buf[6]<<8) + buf[7];-- if (!strncmp((char*)buf, "FORM", 4)) {- /* let's check if it's AIFC or not */- if (fread(buf, 1, 4, f) != 4)- return -1;-- if (strncmp((char*)buf, "AIFC", 4)) {- buf[4] = 0;- fprintf(stderr, "unsupported type %s\nonly AIFC handled\n", buf);- return -1;- }-- *size -= 4;- return FORM;- }-- if (!strncmp((char*)buf, "COMM", 4))- return COMM;-- if (!strncmp((char*)buf, "FVER", 4))- return FVER;-- if (!strncmp((char*)buf, "SSND", 4))- return SSND;-- if (!strncmp((char*)buf, "FLLR", 4))- return -2;-- buf[4] = 0;- fprintf(stderr, "warning: unhandled chunk %s (size=%ld)\n", buf, *size);-- return -2;-}--/* transform an int into a little endian buffer */-unsigned char *itole(unsigned long l, unsigned char *t)-{- *t = l & 255;- *(t+1) = (l >> 8) & 255;- *(t+2) = (l >> 16) & 255;- *(t+3) = (l >> 24) & 255;- return t;-}--/* transform a short into a little endian buffer */-unsigned char *stole(unsigned short l, unsigned char *t)-{- *t = l & 255;- *(t+1) = (l >> 8) & 255;- return t;-}--/* different flags to know what chunk here, what chunk has been proceeded */-#define FORM_DONE 1-#define COMM_DONE 2-#define FVER_DONE 4-#define SSND_DONE 8--/* we don't want stack space for those */-static unsigned char buf[24];-static unsigned char in[34];-static unsigned char out[256]; /* only 128 if mono, 256 if stereo */-static unsigned char out2[128]; /* for stereo, another buffer (we must- * interleave the two buffers in the WAV file)- */--/* != file types supported */-#define IMA4 1-#define SOWT 2-#define SDX2 3--#ifdef WIDE_CBITS- #define my_char wchar_t- #define my_perror _wperror- #define my_remove _wremove-#else- #define my_char char- #define my_perror perror- #define my_remove remove-#endif--int aifc2wav_main(my_char *input_file, my_char *output_file)-{- long size;- int flags = 0;- FILE *fin, *fout;- int nb_chans; /* number of channels, must be 1 or 2 */- int nb_frames; /* number of sound chunks */- int nb_bits; /* nb bits / sample, must be 16 */- long double freq; /* sample rate */- long ssnd_pos; /* pos of beginning of the stream in the input file */- long total_size=1; /* some files are bigger than what says FORM size- * so we must only parse the nb of bytes given by- * FORM size (init to 1 for the while to run)- */- int sound_type=0; /* the type of the data in the sound file */- long riff_size; /* the riff size - depends of the type of data sound */- short *last; /* for SDX2 files */-- short predictor_left = 0;- short predictor_right = 0;--#ifdef WIDE_CBITS- fin = _wfopen(input_file, L"rb");-#else- fin = fopen(input_file, "rb");-#endif- if (!fin) {- my_perror(input_file);- return 1;- }--#ifdef WIDE_CBITS- fout = _wfopen(output_file, L"wb");-#else- fout = fopen(output_file, "wb");-#endif- if (!fout) {- my_perror(output_file);- fclose(fin);- return 1;- }-- /* we don't care about the order (only FORM must be first) */- /* we require only one SSND, one COMM, at most one FVER, that's all */- /* total_size must be != 0 before to come here */- while(total_size)- switch (get_type(fin, &size)) {- case FORM :- if (flags) goto bad_file;-- flags = FORM_DONE;- total_size = size;-- break;-- case COMM :- if (!(flags & FORM_DONE)) goto bad_file;-- if (flags & COMM_DONE) goto bad_file;-- total_size -= 8;- if (total_size < 0) goto in_error_size;-- flags |= COMM_DONE;-- if (fread(buf, 1, 22, fin) != 22)- goto bad_file;- total_size -= 22;- if (total_size < 0) goto in_error_size;-- nb_chans = (buf[0]<<8) + buf[1];- nb_frames = (unsigned)(buf[2]<<24) + (buf[3]<<16) + (buf[4]<<8) + buf[5];- nb_bits = (buf[6]<<8) + buf[7];-- /* converting this silly extended format into freq- * IAFC people are weird, why extended ?- * this code is far from efficient- * based on :- * http://www.mactech.com/articles/mactech/Vol.06/06.01/SANENormalized/- * this may fail on your machine, it works on ia32 and sparc- */- {- int sign = (buf[8] >> 7) & 1;- int exp = ((buf[8] & 127) << 8) + buf[9] - 16383;- int j = (buf[10]>>7)&1;- unsigned long frac = ((buf[10]&127) << 24) +- (buf[11] << 16) +- (buf[12] << 8) +- (buf[13]);- unsigned long frac2 = (unsigned)(buf[14] << 24) +- (buf[15] << 16) +- (buf[16] << 8) +- (buf[17]);- int i;-- freq = frac2;- for (i=0; i<32; i++) freq /= 2;- freq += frac;- for (i=0; i<31; i++) freq /= 2;- if (j) freq += 1.;- while (exp) {- freq *= 2;- exp--;- }-- if (sign) freq = -freq;- }-- if (nb_chans != 1 && nb_chans != 2) {- fprintf(stderr, "nb of channels = %d\nonly 1 or 2 channels handled\n",- nb_chans);- goto bad_file;- }-- // onyxite: assume 16 bit samples- if (nb_bits == 0) {- nb_bits = 16;- }- - if (nb_bits != 16) {- fprintf(stderr, "bits per sample = %d\nonly 16 bits handled\n",- nb_bits);- goto bad_file;- }-- /* 1e7 is enough ? */- if (freq <= 0 || freq >=1e7) {- fprintf(stderr, "freq = %Lf\nonly 0 < freq < 1e7 handled\n", freq);- goto bad_file;- }-- /* let's test if it's a ima4, sowt or SDX2 or something else */- memcpy(buf, &buf[18], 4);- buf[4] = 0;- if (strcmp((char*)buf, "ima4") &&- strcmp((char*)buf, "sowt") &&- strcmp((char*)buf, "SDX2")) {- fprintf(stderr,- "compression scheme = %s\nonly ima4, sowt and SDX2 handled\n", buf);- goto bad_file;- }- sound_type = IMA4;- if (!strcmp((char*)buf, "sowt"))- sound_type = SOWT;- else if (!strcmp((char*)buf, "SDX2"))- sound_type = SDX2;-- /* should we optimize here ? no */- /* the doc says there may be a non-counted byte */- if (size & 1) size++;- size -= 22;- total_size -= size;- if (total_size < 0) goto in_error_size;-- while(size > 0) {- int c = fgetc(fin);- if (c == EOF) {- fprintf(stderr, "error with COMM chunk, bad size\n");- goto bad_file;- }- size--;- }-- break;-- case FVER : {- unsigned long version;-- if (!(flags & FORM_DONE)) goto bad_file;-- if (flags & FVER_DONE) goto bad_file;-- flags |= FVER_DONE;-- total_size -= 8;- if (total_size < 0) goto in_error_size;-- if (fread(buf, 1, 4, fin) != 4)- goto bad_file;- total_size -= 4;- if (total_size < 0) goto in_error_size;-- version = (unsigned)(buf[0]<<24) + (buf[1]<<16) + (buf[2]<<8) + buf[3];-- if (version != 2726318400U) {- fprintf(stderr, "version = %lu\nonly 2726318400 handled\n", version);- goto bad_file;- }-- /* size should be 4, what to do ? if we don't read, there might- * be a problem, but someone might not set it to 4 and still- * telling us there is nothing more... well, let's read it- */- /* the doc says there may be a non-counted byte */- if (size & 1) size++;- size -= 4;- total_size -= size;- if (total_size < 0) goto in_error_size;-- while(size > 0) {- int c = fgetc(fin);- if (c == EOF) {- fprintf(stderr, "error with FVER chunk, bad size\n");- goto bad_file;- }- size--;- }-- break;- }-- case SSND : {- unsigned long offset, blocksize;- unsigned long nbbytes=0;-- if (!(flags & FORM_DONE)) goto bad_file;-- if (flags & SSND_DONE) {- fprintf(stderr, "more than one SSND\n");- goto bad_file;- }-- total_size -= 8;- if (total_size < 0) goto in_error_size;-- flags |= SSND_DONE;-- if (fread(buf, 1, 8, fin) != 8)- goto bad_file;- total_size -= 8;- if (total_size < 0) goto in_error_size;-- offset = (unsigned)(buf[0]<<24) + (buf[1]<<16) + (buf[2]<<8) + buf[3];- blocksize = (unsigned)(buf[4]<<24) + (buf[5]<<16) + (buf[6]<<8) + buf[7];--#if 0- if (offset || blocksize) {- fprintf(stderr, "offset = %lu, blocksize = %lu\nthey both must be 0\n",- offset, blocksize);- goto bad_file;- }-#endif-- ssnd_pos = ftell(fin) + offset;- if (ssnd_pos == -1) {- perror("ftell");- goto bad_file;- }-- /* the doc says there may be a non-counted byte */- if (size & 1) size++;-- /* we should optimize here, no ? */- size -= 8;- total_size -= size;- if (total_size < 0) goto in_error_size;-- while(size > 0) {- int c = fgetc(fin);-#if 0- if (c == EOF) {- fprintf(stderr, "error with SSND chunk, bad size\n");- goto bad_file;- }-#endif- if (c == EOF) {- if (!(flags & COMM_DONE)) goto bad_file;-- /* a little hack to update nb_frames for sowt only */- fprintf(stderr, "warning - bad size in SSND, the output file will"- " probably be wrong\n");-- nbbytes -= offset;- if (sound_type == SDX2) {- fprintf(stderr, "error - for SDX2 files, I don't know what to"- " do\nContact sed@free.fr to see what"- " we can do.\n");- goto both_error;- } else if (sound_type == SOWT)- nbbytes /= 2;- else- nbbytes /= 34;- if (nb_chans == 2) nbbytes /= 2;- nb_frames = nbbytes;-- /* we go to all_parsed, because it's EOF */- goto all_parsed;- }-- nbbytes++;- size--;- }-- break;- }-- /* -1 is error */- case -1:- goto bad_file;-- /* -2 is unhandled chunk type, so pass it */- case -2: {- if (!(flags & FORM_DONE)) goto bad_file;-- total_size -= 8;- if (total_size < 0) goto in_error_size;-- /* the doc says there may be a non-counted byte */- if (size & 1) size++;- total_size -= size;- if (total_size < 0) goto in_error_size;-- while (size) {- int c = fgetc(fin);- if (c == EOF)- goto bad_file;- size --;- }- break;- }-- /* -3 is EOF */- case -3 :- /* this may be an error, let's just produce a warning */- fprintf(stderr, "warning: your file is shorter than expected\n");- goto all_parsed;-- default : - fprintf(stderr, "you should not read this...\n");- goto bad_file;- }--all_parsed:- /* we must have parsed COMM and SSND */- if ((flags & (COMM_DONE | SSND_DONE)) != (COMM_DONE | SSND_DONE)) {-- if (!(flags & COMM_DONE))- fprintf(stderr, "no COMM chunk found\n");-- if (!(flags & SSND_DONE))- fprintf(stderr, "no SSND chunk found\n");-- goto bad_file;- }-- /* is freq an integer ? */- if (freq != (long double)((int)freq))- fprintf(stderr, "warning, freq = %Lf will be truncated to %d\n",- freq, (int)freq);-- /* all is alright */-- /* write header of wav */- /* start with RIFF */- if (fwrite("RIFF", 1, 4, fout) != 4) goto out_error;-- if (sound_type == IMA4)- riff_size = nb_frames * 128;- else- riff_size = nb_frames * 2;- if (nb_chans == 2)- riff_size *= 2;-- /* then size of the stuff */- if (fwrite(itole(riff_size+36, buf), 1, 4, fout) != 4) goto out_error;-- /* then WAVEfmt */- if (fwrite("WAVEfmt ", 1, 8, fout) != 8) goto out_error;-- /* length of fmt chunk (16) */- if (fwrite(itole(16, buf), 4, 1, fout) != 1) goto out_error;-- /* 1 => PCM */- if (fwrite(stole(1, buf), 2, 1, fout) != 1) goto out_error;-- /* nb of channels */- if (fwrite(stole(nb_chans, buf), 2, 1, fout) != 1) goto out_error;-- /* freq */- if (fwrite(itole((int)freq, buf), 4, 1, fout) != 1) goto out_error;-- /* don't know what */- if (fwrite(itole((int)freq * nb_chans * (nb_bits/8), buf), 4, 1, fout) != 1)- goto out_error;-- /* don't know what */- if (fwrite(stole(nb_chans * (nb_bits/8), buf), 2, 1, fout) != 1)- goto out_error;-- /* nb bits */- if (fwrite(stole(nb_bits, buf), 2, 1, fout) != 1) goto out_error;-- /* data chunk */- if (fwrite("data", 4, 1, fout) != 1) goto out_error;-- /* data size */- if (fwrite(itole(riff_size, buf), 1, 4, fout) != 4) goto out_error;-- /* let's kick all the frames out */- if (fseek(fin, ssnd_pos, SEEK_SET) == -1) goto out_error;-- if (sound_type != SOWT) goto not_sowt;-- /* sowt */- while (nb_frames) {- nb_frames--;-- if (fread(in, 1, 2, fin) != 2) {- my_perror(input_file);- goto bad_file;- }- if (fwrite(in, 1, 2, fout) != 2)- goto out_error;-- if (nb_chans == 1)- continue;-- if (fread(in, 1, 2, fin) != 2) {- my_perror(input_file);- goto bad_file;- }- if (fwrite(in, 1, 2, fout) != 2)- goto out_error;- }-- goto file_done;--not_sowt:- /* SDX2? */- if (sound_type != SDX2) goto not_sdx2;-- last = malloc(nb_chans * sizeof(short));- if (!last) {- perror("memory");- goto both_error;- }- memset(last, 0, sizeof(short) * nb_chans);-- while (nb_frames > 0) {- signed char src;- unsigned short dst;- int i;-- nb_frames--;-- for (i=0; i<nb_chans; i++) {- if (fread(&src, 1, 1, fin) != 1) {- my_perror(input_file);- free(last);- goto bad_file;- }-- if (src & 1)- dst = last[i] + ((src * abs(src)) << 1);- else- dst = (src * abs(src)) << 1;-- last[i] = dst;-- /* out is 256 bytes, so we're fine */- out[0] = dst&255;- out[1] = (dst>>8)&255;-- if (fwrite(out, 1, 2, fout) != 2) {- free(last);- goto out_error;- }- }- }-- free(last);-- goto file_done;--not_sdx2:- /* ima4 */- while (nb_frames) {- if (fread(in, 1, 34, fin) != 34) {- my_perror(input_file);- goto bad_file;- }-- decode_chunk(in, out, &predictor_left);-- /* if stereo mode the next chunk is right channel */- if (nb_chans == 2) {- int i;-- if (fread(in, 1, 34, fin) != 34) {- my_perror(input_file);- goto bad_file;- }-- decode_chunk(in, out2, &predictor_right);-- /* we must now interleave the two channels */-- /* first part, move the first channel to its correct position */- /* we should optimize this code */- for (i=63; i>0; i--) {- out[i*4] = out[i*2];- out[i*4+1] = out[i*2+1];- }-- /* second, add right channel to output buffer */- /* we should optimize this code */- for (i=0; i<64; i++) {- out[i*4+2] = out2[i*2];- out[i*4+3] = out2[i*2+1];- }- }-- if (fwrite(out, 1, nb_chans == 2 ? 256 : 128, fout) !=- (nb_chans == 2 ? 256 : 128))- goto out_error;-- nb_frames--;- }--file_done:- fclose(fin);- fclose(fout);- return 0;--in_error_size:- fprintf(stderr, "the size information of your file is bad\n");--bad_file:- fprintf(stderr, "%s: bad sound file, can't load\n", input_file);- fprintf(stderr, "contact sed@free.fr to add support for your file\n");--both_error:- fclose(fin);- fclose(fout);- my_remove(output_file);- return 1;--out_error:- my_perror(output_file);- goto both_error;-}
jammittools.cabal view
@@ -1,5 +1,5 @@ Name: jammittools-Version: 0.3.2+Version: 0.4 Synopsis: Export sheet music and audio from Windows/Mac app Jammit Description: @@ -9,7 +9,6 @@ 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@@ -28,10 +27,10 @@ Sound.Jammit.Base Sound.Jammit.Export other-modules:- Sound.Jammit.Internal.AIFC2WAV- Sound.Jammit.Internal.ImageMagick- Sound.Jammit.Internal.Sox- Sound.Jammit.Internal.TempFile+ Sound.Jammit.Internal.Audio+ Sound.Jammit.Internal.AudioExpr+ Sound.Jammit.Internal.Image+ Sound.Jammit.Internal.TempIO hs-source-dirs: src build-depends: base >= 4.6.0.1 && < 5@@ -42,11 +41,12 @@ , 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- if os(windows)- cpp-options: -DWIDE_CBITS- cc-options: -DWIDE_CBITS+ , JuicyPixels >= 3.2.2 && < 3.3+ , HPDF >= 1.4.6 && < 1.5+ , bytestring >= 0.10.4.0 && < 0.11+ , conduit >= 1.2.3.1 && < 1.3+ , vector >= 0.10.12.2 && < 0.11+ ghc-options: -Wall -O2 executable jammittools main-is: Main.hs@@ -57,8 +57,8 @@ , directory >= 1.2.0.1 && < 1.3 , filepath >= 1.3.0.1 && < 1.4 , boxes >= 0.1.3 && < 0.2- , jammittools == 0.3.2- ghc-options: -Wall+ , jammittools == 0.4+ ghc-options: -Wall -O2 source-repository head type: git
src/Sound/Jammit/Export.hs view
@@ -12,20 +12,19 @@ , runSheet ) where -import Control.Applicative ((<$>), liftA2)+import Control.Applicative (liftA2) import Control.Monad (forM) import Data.Char (toLower)-import Data.List (isInfixOf, transpose, sort, isPrefixOf)+import Data.List (isInfixOf, 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.Internal.Image import Sound.Jammit.Base-import Sound.Jammit.Internal.Sox-import Sound.Jammit.Internal.TempFile+import Sound.Jammit.Internal.AudioExpr+import Sound.Jammit.Internal.TempIO type Library = [(FilePath, Info, [Track])] @@ -79,19 +78,19 @@ -> [FilePath] -- ^ AIFCs to mix in inverted -> FilePath -- ^ the resulting WAV file -> IO ()-runAudio pos neg fout = runTempIO fout $ do+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.- 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)+ 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 runSheet :: [(FilePath, Integer)] -- ^ pairs of @(png file prefix, line height in px)@@@ -99,17 +98,11 @@ -> FilePath -- ^ the resulting PDF -> IO () runSheet trks lns fout = runTempIO fout $ do- trkLns <- forM trks $ \(fp, ht) -> do+ trkLns <- liftIO $ 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+ ls <- getDirectoryContents dir+ return (map (dir </>) $ sort $ filter (file `isPrefixOf`) ls, ht)+ jpegs <- partsToPages trkLns lns+ pdf <- newTempFile "pages.pdf"+ liftIO $ jpegsToPDF jpegs pdf+ return pdf
− src/Sound/Jammit/Internal/AIFC2WAV.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Sound.Jammit.Internal.AIFC2WAV-( aifcToWav-) where--#ifdef WIDE_CBITS--import Foreign.C (withCWString, CInt(..), CWchar(..))-#define My_CChar CWchar-#define my_withCString withCWString--#else--import Foreign.C (withCString, CInt(..), CChar(..))-#define My_CChar CChar-#define my_withCString withCString--#endif--import Foreign.Ptr (Ptr)--import Sound.Jammit.Internal.TempFile--foreign import ccall unsafe "aifc2wav_main" aifc2wav_main- :: Ptr My_CChar -> Ptr My_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 $- my_withCString aifc $ \aifcC ->- my_withCString wav $ \wavC ->- aifc2wav_main aifcC wavC- if code == 0- then return wav- else error $ "aifcToWav: returned " ++ show code
+ src/Sound/Jammit/Internal/Audio.hs view
@@ -0,0 +1,220 @@+{- |+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+) where++import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import qualified Data.Vector as V+import Data.Int (Int16, Int32)+import Data.Word (Word16, Word32)+import Control.Monad.IO.Class (MonadIO, 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)++parseChunk :: IO.Handle -> IO (B.ByteString, (HandlePosn, HandlePosn))+parseChunk h = do+ ctype <- B.hGet h 4+ clen <- fmap toInteger (readBE h :: IO Word32)+ startPosn <- IO.hGetPosn h+ IO.hSeek h IO.RelativeSeek clen+ endPosn <- IO.hGetPosn h+ return (ctype, (startPosn, endPosn))++parseChunksUntil+ :: Maybe HandlePosn -> IO.Handle -> IO [(B.ByteString, (HandlePosn, HandlePosn))]+parseChunksUntil maybeEnd h = do+ eof <- IO.hIsEOF h+ HandlePosn _ here <- IO.hGetPosn h+ let pastEnd = case maybeEnd of+ Nothing -> False+ Just (HandlePosn _ end) -> end <= here+ if eof || pastEnd+ then return []+ else liftM2 (:) (parseChunk h) (parseChunksUntil maybeEnd h)++readIMA :: (MonadIO m) => FilePath -> C.Source m (V.Vector (Int16, Int16))+readIMA fp = do+ h <- liftIO $ IO.openBinaryFile fp IO.ReadMode+ let ctype `chunkBefore` maybeEnd = \f -> do+ here <- liftIO $ IO.hGetPosn h+ chunks <- liftIO $ parseChunksUntil maybeEnd h+ case lookup ctype chunks of+ Nothing -> error $ "readIMA: no chunk of type " ++ show ctype+ Just (start, end) -> do+ liftIO $ IO.hSetPosn start+ 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++decodeChunk :: (Int16, B.ByteString) -> (Int16, V.Vector Int16)+decodeChunk (initPredictor, chunk) = runST $ do+ predictor <- newSTRef initPredictor+ stepIndex <- newSTRef (fromIntegral (B.index chunk 1) .&. 127 :: Int16)+ let step = fmap (\si -> stepTable V.! fromIntegral si) $ readSTRef stepIndex+ v <- fmap (V.fromList . concat) $ forM (B.unpack $ B.drop 2 chunk) $ \d -> do+ let hnb = fromIntegral $ d `shiftR` 4 :: Int32+ lnb = fromIntegral $ d .&. 15 :: Int32+ forM [lnb, hnb] $ \nb -> do+ thisStep <- step+ let sign = nb .&. 8+ diff = sum+ [ thisStep `shiftR` 3+ , if nb .&. 4 /= 0 then thisStep else 0+ , if nb .&. 2 /= 0 then thisStep `shiftR` 1 else 0+ , if nb .&. 1 /= 0 then thisStep `shiftR` 2 else 0+ ]+ modifySTRef predictor $ \old -> let+ op = if sign /= 0 then (-) else (+)+ new = fromIntegral old `op` fromIntegral diff :: Int32+ in fromIntegral $ clamp (-32768, 32767) new+ modifySTRef stepIndex $ \old ->+ clamp (0, 88) $ old + (indexTable V.! fromIntegral nb)+ readSTRef predictor+ finalPredictor <- readSTRef predictor+ return (finalPredictor, v)++clamp :: (Ord a) => (a, a) -> a -> a+clamp (vmin, vmax) v+ | v < vmin = vmin+ | v > vmax = vmax+ | otherwise = v++indexTable :: V.Vector Int16+indexTable = V.fromList+ [ -1, -1, -1, -1, 2, 4, 6, 8+ , -1, -1, -1, -1, 2, 4, 6, 8+ ]++stepTable :: V.Vector Int16+stepTable = V.fromList+ [ 7, 8, 9, 10, 11, 12, 13, 14, 16, 17+ , 19, 21, 23, 25, 28, 31, 34, 37, 41, 45+ , 50, 55, 60, 66, 73, 80, 88, 97, 107, 118+ , 130, 143, 157, 173, 190, 209, 230, 253, 279, 307+ , 337, 371, 408, 449, 494, 544, 598, 658, 724, 796+ , 876, 963, 1060, 1166, 1282, 1411, 1552, 1707, 1878, 2066+ , 2272, 2499, 2749, 3024, 3327, 3660, 4026, 4428, 4871, 5358+ , 5894, 6484, 7132, 7845, 8630, 9493, 10442, 11487, 12635, 13899+ , 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++class BE a where+ readBE :: IO.Handle -> IO a++instance BE Word32 where+ readBE h = do+ [a, b, c, d] <- fmap B.unpack $ B.hGet h 4+ return $ sum+ [ fromIntegral a `shiftL` 24+ , fromIntegral b `shiftL` 16+ , fromIntegral c `shiftL` 8+ , fromIntegral d+ ]++instance BE Int32 where+ readBE h = fmap fromIntegral (readBE h :: IO Word32)++instance BE Word16 where+ readBE h = do+ [a, b] <- fmap B.unpack $ B.hGet h 2+ return $ sum+ [ fromIntegral a `shiftL` 8+ , fromIntegral b+ ]++instance BE Int16 where+ readBE h = fmap fromIntegral (readBE h :: IO Word16)++class LE a where+ writeLE :: IO.Handle -> a -> IO ()++instance LE Word32 where+ writeLE h w = B.hPut h $ B.pack [a, b, c, d] where+ a = fromIntegral w+ b = fromIntegral $ w `shiftR` 8+ c = fromIntegral $ w `shiftR` 16+ d = fromIntegral $ w `shiftR` 24++instance LE Word16 where+ writeLE h w = B.hPut h $ B.pack [a, b] where+ a = fromIntegral w+ b = fromIntegral $ w `shiftR` 8++instance LE Int32 where+ writeLE h w = writeLE h (fromIntegral w :: Word32)++instance LE Int16 where+ writeLE h w = writeLE h (fromIntegral w :: Word16)
+ src/Sound/Jammit/Internal/AudioExpr.hs view
@@ -0,0 +1,109 @@+{-# 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
@@ -0,0 +1,112 @@+{-# LANGUAGE LambdaCase #-}+module Sound.Jammit.Internal.Image+( partsToPages+, jpegsToPDF+) where++import qualified Codec.Picture as P+import Codec.Picture.Types (convertImage, dropTransparency)+import Control.Monad (forM_, replicateM)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Class (lift)+import qualified Graphics.PDF as PDF+import qualified Data.ByteString.Lazy as BL+import qualified Data.Conduit as C+import Data.Maybe (catMaybes)+import qualified Data.Vector.Storable as V++import Sound.Jammit.Internal.TempIO++loadPNG :: FilePath -> IO (P.Image P.PixelRGBA8)+loadPNG fp = do+ Right dyn <- P.readImage fp+ case dyn of+ P.ImageRGBA8 i -> return i+ _ -> error "loadPNG: pixels aren't RGBA8"++pngChunks :: (MonadIO m) =>+ Int -> [FilePath] -> C.Source m (P.Image P.PixelRGBA8)+pngChunks h fps = let+ raw :: (MonadIO m) => C.Source m (P.Image P.PixelRGBA8)+ 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+ 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+ 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+ [] -> return ()+ systems -> C.yield (vertConcat $ concat systems) >> chunksToPages n++sinkJPEG :: C.Sink (P.Image P.PixelRGBA8) TempIO [FilePath]+sinkJPEG = go [] where+ go jpegs = C.await >>= \case+ Nothing -> return jpegs+ Just img -> do+ jpeg <- lift $ newTempFile "page.jpg"+ liftIO $ saveJPEG jpeg img+ go $ jpegs ++ [jpeg]++partsToPages+ :: [([FilePath], Integer)] -- ^ [(images, system height)]+ -> Int -- ^ systems per page+ -> TempIO [FilePath]+partsToPages parts n = let+ sources = map (\(imgs, h) -> pngChunks (fromIntegral h) imgs) parts+ in C.sequenceSources sources C.$$ chunksToPages n C.=$= sinkJPEG++saveJPEG :: FilePath -> P.Image P.PixelRGBA8 -> IO ()+saveJPEG fp img = BL.writeFile fp $ P.encodeJpegAtQuality 100 $+ convertImage $ P.pixelMap dropTransparency img++vertConcat :: [P.Image P.PixelRGBA8] -> P.Image P.PixelRGBA8+vertConcat [] = P.Image 0 0 V.empty+-- efficient version: all images have same width, just concat vectors+vertConcat allimgs@(img : imgs)+ | all (\i -> P.imageWidth i == P.imageWidth img) imgs+ = P.Image+ { P.imageWidth = P.imageWidth img+ , P.imageHeight = sum $ map P.imageHeight allimgs+ , P.imageData = V.concat $ map P.imageData allimgs+ }+-- this algorithm is probably not needed+vertConcat imgs = P.generateImage f w h where+ w = foldr max 0 $ map P.imageWidth imgs+ h = sum $ map P.imageHeight imgs+ f = go imgs+ empty = P.PixelRGBA8 0 0 0 0+ go [] _ _ = empty+ go (i : is) x y = if y < P.imageHeight i+ then if x < P.imageWidth i+ then P.pixelAt i x y+ else empty+ else go is x $ y - P.imageHeight i++vertSplit :: Int -> P.Image P.PixelRGBA8 -> [P.Image P.PixelRGBA8]+vertSplit h img = map f $ takeWhile (< P.imageHeight img) [0, h ..] where+ f yoff = P.generateImage+ (g yoff)+ (P.imageWidth img)+ (min h $ P.imageHeight img - yoff)+ g yoff x y = P.pixelAt img x $ y + yoff++imagePage :: PDF.JpegFile -> PDF.PDF ()+imagePage jpeg = do+ let (w, h) = PDF.jpegBounds jpeg+ page <- PDF.addPage $ Just $ PDF.PDFRect 0 0 (round w) (round h)+ ref <- PDF.createPDFJpeg jpeg+ PDF.drawWithPage page $ PDF.drawXObject ref++jpegsToPDF :: [FilePath] -> FilePath -> IO ()+jpegsToPDF jpegs pdf = do+ Right js <- fmap sequence $ mapM PDF.readJpegFile jpegs+ PDF.runPdf pdf PDF.standardDocInfo (PDF.PDFRect 0 0 600 400) $+ forM_ js imagePage
− src/Sound/Jammit/Internal/ImageMagick.hs
@@ -1,89 +0,0 @@-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
@@ -1,136 +0,0 @@-module Sound.Jammit.Internal.Sox-( Audio(..)-, Time(..)-, renderAudio-, optimize-) where--import Control.Arrow (first)-import Control.Applicative ((<$>))-import Control.Monad (forM, guard, void)-import Data.List (isPrefixOf)-import Data.Maybe (listToMaybe)-import System.Environment (lookupEnv)-import qualified System.Info as Info--import System.Directory (getDirectoryContents, findExecutable)-import System.FilePath ((</>))-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"- liftIO $ runSox $ ["-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"- liftIO $ runSox [fin, fout, "pad", showTime t]- return fout- Mix xs -> case xs of- [] -> renderAudio Empty- [(d, x)] -> do- fin <- renderAudio x- fout <- newTempFile "render.wav"- liftIO $ runSox ["-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"- liftIO $ runSox $ ["--combine", "mix"] ++ argsin ++ [fout]- return fout- Concat xs -> case xs of- [] -> renderAudio Empty- _ -> do- fins <- mapM renderAudio xs- fout <- newTempFile "render.wav"- liftIO $ runSox $ 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--runSox :: [String] -> IO ()-runSox args = do- sox <- findSox- case sox of- Just prog -> void $ readProcess prog args ""- Nothing -> error "runSox: couldn't find sox executable"---- | Find the SoX binary on Windows in case it's not in the PATH.-findSox :: IO (Maybe String)-findSox = do- inPath <- findExecutable "sox"- case inPath of- Just prog -> return $ Just prog- Nothing -> case Info.os of- "mingw32" -> firstJustM $- -- env variables for different configs of (ghc arch)/(sox 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 </> "sox.exe")- . listToMaybe- . filter ("sox-" `isPrefixOf`)- <$> getDirectoryContents pf- _ -> return Nothing---- | 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
− src/Sound/Jammit/Internal/TempFile.hs
@@ -1,41 +0,0 @@--- | 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/Sound/Jammit/Internal/TempIO.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.TempIO+( 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