├── .github └── workflows │ ├── doc.yml │ └── test.yml ├── .gitignore ├── Changelog.md ├── LICENSE ├── README.md ├── TODO ├── ape ├── ape-tags-v2.lisp ├── ape.lisp ├── decode.lisp ├── definitions.lisp ├── examples │ ├── ape2wav.lisp │ └── package.lisp ├── frame.lisp └── package.lisp ├── bitreader ├── bitreader.lisp ├── crc.lisp ├── definitions.lisp ├── macros.lisp ├── package.lisp └── sbcl.lisp ├── core ├── core.lisp └── package.lisp ├── docs ├── manifest.lisp └── manual.scr ├── easy-audio.asd ├── flac ├── decode.lisp ├── definitions.lisp ├── examples │ ├── flac2wav.lisp │ ├── ogg2wav.lisp │ └── package.lisp ├── flac-ogg.lisp ├── flac-reader.lisp ├── flac.lisp ├── frame.lisp ├── metadata.lisp └── package.lisp ├── general-decoders ├── g.711.lisp └── package.lisp ├── ogg ├── ogg.lisp └── package.lisp ├── tests ├── package.lisp ├── sample-mono.ape ├── sample-mono.flac ├── sample-mono.oga ├── sample-mono.wav ├── sample-mono.wv ├── sample-stereo-low.flac ├── sample-stereo.ape ├── sample-stereo.flac ├── sample-stereo.oga ├── sample-stereo.wav ├── sample-stereo.wv ├── sample32-mono.wav ├── sample32-mono.wv ├── sample32-stereo.wav ├── sample32-stereo.wv ├── sample32-upsample.wav ├── sample32-upsample.wv ├── tests.lisp └── travis.lisp ├── wav ├── definitions.lisp ├── examples │ ├── decode.lisp │ └── package.lisp ├── package.lisp ├── wav.lisp └── write-header.lisp └── wv ├── decode.lisp ├── definitions.lisp ├── examples ├── package.lisp └── wv2wav.lisp ├── metadata.lisp ├── package.lisp ├── wavpack-reader.lisp ├── wv-block.lisp └── wv-blocks-multichannel.lisp /.github/workflows/doc.yml: -------------------------------------------------------------------------------- 1 | name: Documentation 2 | 3 | on: 4 | push: 5 | tags: [v*] 6 | 7 | jobs: 8 | docs: 9 | runs-on: ubuntu-latest 10 | env: 11 | LISP: sbcl-bin 12 | steps: 13 | - name: Checkout 14 | uses: actions/checkout@v2 15 | - name: Install roswell 16 | run: | 17 | curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 18 | - name: Checkout Codex 19 | uses: actions/checkout@v2 20 | with: 21 | repository: shamazmazum/codex 22 | path: ~/.roswell/local-projects/codex 23 | - name: Checkout docparser 24 | uses: actions/checkout@v2 25 | with: 26 | repository: shamazmazum/docparser 27 | path: ~/.roswell/local-projects/docparser 28 | - name: Build documentation 29 | run: | 30 | ros -s codex -e '(codex:document :easy-audio :skip-undocumented t)' 31 | - name: Deploy to GH pages 32 | uses: peaceiris/actions-gh-pages@v3 33 | with: 34 | github_token: ${{ secrets.GITHUB_TOKEN }} 35 | publish_dir: docs/build/easy-audio/html 36 | -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | test: 7 | runs-on: ubuntu-latest 8 | env: 9 | LISP: sbcl-bin 10 | steps: 11 | - name: Checkout 12 | uses: actions/checkout@v2 13 | - name: Install roswell 14 | run: | 15 | curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 16 | - name: Run tests 17 | run: | 18 | ros -l $GITHUB_WORKSPACE/tests/travis.lisp 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | docs/build 2 | -------------------------------------------------------------------------------- /Changelog.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | ## Version 1.3 4 | 5 | * API change: APEv2 tags are now read with READ-AVEV2-TAG(-FROM-END) as a list 6 | of APEV2-TAG-ITEM structures. 7 | * Improvement: APE decoder now supports mono audio. 8 | * Improvement: APE decoder no longer modifies frames in DECODE-FRAME. 9 | * Bug fix: Reading of verbatim subframes is fixed in the FLAC decoder. 10 | * Bug fix: APE decoder correctly handles pseudo-stereo frames. 11 | 12 | ## Version 1.2 13 | 14 | This version is a step towards removing CLOS and unsafe code. 15 | 16 | * API change: MIXCHANNELS is renamed to INTERLEAVE-CHANNELS and creates now a 17 | new array. 18 | * API change: MAKE-OUTPUT-BUFFERS is gone. It's cheap to create an array 19 | implicitly when needed. 20 | * API change: Readers for vorbis comment metadata in flac are renamed to 21 | VORBIS-COMMENT-USER and VORBIS-COMMENT-VENDOR 22 | * API change: FLAC:FRAME-DECODE is renamed to FLAC:DECODE-FRAME. 23 | * Improvement: flac2wav example can decode 24bps files. 24 | * Improvement: flac audio frames are now not modified while decoding. 25 | * Optimization INTERLEAVE-CHANNELS with number of channels > 2 now works faster. 26 | * Bug fix: Wavpack decoder correctly handles 32 bps audio files 27 | * Bug fix: Wavpack decoder correctly handles pseudo-stereo data blocks. 28 | 29 | ## Version 1.1 30 | 31 | `easy-audio/utils` system was merged to `easy-audio/core`. Global nicknames were 32 | removed from all packages loaded with `(asdf:load-system :easy-audio)`. Use full 33 | names (like `easy-audio.flac` instead of `flac`) or local nicknames. 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-2025, Vasily Postnicov 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 20 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Easy audio 2 | ========== 3 | ![CI](https://github.com/shamazmazum/easy-audio/workflows/CI/badge.svg) 4 | 5 | Overview 6 | ------- 7 | **NB**: 25.04.2022: `easy-audio/utils` system was merged to 8 | `easy-audio/core`. Global nicknames were removed from all packages loaded with 9 | `(asdf:load-system :easy-audio)`. Use full names (like `easy-audio.flac` instead 10 | of `flac`) or local nicknames. The version was bumped to `1.1`. 11 | 12 | Easy audio is my small but slowly growing pack of audio decoders. It can 13 | help you decode audio files and also provides easy access to metadata. 14 | 15 | It has: 16 | * FLAC format support. Can decode anything, supports almost all metadata 17 | blocks. 18 | * Partial support for WavPack format. Can read and decode non-hybrid 19 | lossless WavPack data which is the most used, anyway. Support many 20 | metadata blocks (though they are not as useful as in FLAC). 21 | * Partial wav container support, can read uncompressed, a-law compressed 22 | and mu-law compressed audio data. 23 | * OGG container support, but, unfortunately, without Vorbis decoder. 24 | Can read FLAC compressed data inside OGG container. 25 | * APEv2 tags support (currently only in wavpack files). 26 | * Partial APE support. Only the most recent version (3.99) is supported, also 27 | there is no integrity checks. 28 | 29 | Documentation 30 | ------------ 31 | Documentation for `easy-audio` is automatically generated by `codex` (my version 32 | of [codex](https://github.com/shamazmazum/codex) and 33 | [docparser](https://github.com/shamazmazum/docparser) is needed). Just run 34 | `(codex:document :easy-audio)`. You can also visit a 35 | [project page](http://shamazmazum.github.io/easy-audio/). 36 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | 1. The low-level bitreader definitely is a bottleneck and have big 2 | potential for optimizations. 3 | 4 | 2. There is no good "container" abstraction. For FLAC we do not need one 5 | (just bit reader -> frame reader -> decoder is enough), but for ogg we 6 | need a facility which allows transparent work with logical bitstreams. 7 | Maybe use of CLOS (building containers atop of bitreader class) is 8 | justified here. 9 | -------------------------------------------------------------------------------- /ape/ape-tags-v2.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.ape) 2 | 3 | (define-constant +apev2-preamble+ 4 | (map 'vector #'char-code "APETAGEX") 5 | :test #'equalp) 6 | 7 | (defparameter *apev2-external-format* '(:utf-8 :eol-style :crlf) 8 | "External format used in human-readable APEv2 items. Defaults to UTF-8, CR/LF EOL style.") 9 | 10 | (defconstant +flag-has-header+ (ash 1 31)) 11 | (defconstant +flag-has-footer+ (ash 1 30)) 12 | (defconstant +flag-h/f-type+ (ash 1 29)) 13 | (defconstant +flag-read-only+ (ash 1 0)) 14 | 15 | (sera:-> has-footer-p ((ub 32)) 16 | (values boolean &optional)) 17 | (declaim (inline has-footer-p)) 18 | (defun has-footer-p (flags) 19 | (not (some-bits-set-p flags +flag-has-footer+))) 20 | 21 | (sera:-> has-header-p ((ub 32)) 22 | (values boolean &optional)) 23 | (declaim (inline has-header-p)) 24 | (defun has-header-p (flags) 25 | (some-bits-set-p flags +flag-has-header+)) 26 | 27 | (sera:-> h/f-type ((ub 32)) 28 | (values (member :footer :header) &optional)) 29 | (declaim (inline h/f-type)) 30 | (defun h/f-type (flags) 31 | (if (some-bits-set-p flags +flag-h/f-type+) 32 | :header :footer)) 33 | 34 | (sera:-> check-bits-3...28 ((ub 32)) 35 | (values (ub 32) &optional)) 36 | (declaim (inline check-bits-3...28)) 37 | (defun check-bits-3...28 (flags) 38 | (unless (zerop (logand #x1ffffff8 flags)) 39 | (error 'apev2-tag-error :format-control "Invalid tag/item flags")) 40 | flags) 41 | 42 | (sera:-> apev2-item-content-type ((ub 32)) 43 | (values (member :utf-8 :binary :external) &optional)) 44 | (declaim (inline apev2-item-content-type)) 45 | (defun apev2-item-content-type (flags) 46 | "Return content type of an item: either UTF-8, :BINARY or 47 | :EXTERNAL. :UTF-8 and :EXTERNAL are strings (the latter is in a 48 | special format) and :BINARY is a vector of octets." 49 | (case (ldb (byte 2 1) flags) 50 | (0 :utf-8) 51 | (1 :binary) 52 | (2 :external) 53 | (3 (error 'apev2-tag-error :format-control "Invalid tag item content type")))) 54 | 55 | (declaim (inline check-preamble)) 56 | (defun check-preamble (preamble) 57 | (unless (every #'= preamble +apev2-preamble+) 58 | (error 'apev2-tag-error :format-control "Not an APEv2 tag")) 59 | preamble) 60 | 61 | (declaim (inline check-h/f-reserved)) 62 | (defun check-h/f-reserved (reserved) 63 | (unless (zerop reserved) 64 | (error 'apev2-tag-error :format-control "Header/footer reserved slot is not zero")) 65 | reserved) 66 | 67 | (sera:defconstructor apev2-tag-block 68 | (version (ub 32)) 69 | (size (ub 32)) 70 | (items (ub 32)) 71 | (flags (ub 32))) 72 | 73 | (defreader* (read-tag-block apev2-tag-block () ()) 74 | (preamble (:octet-vector (length +apev2-preamble+)) :function check-preamble :ignore t) 75 | (version (:octets 4) :endianness :little) 76 | (size (:octets 4) :endianness :little) 77 | (items (:octets 4) :endianness :little) 78 | (flags (:octets 4) :endianness :little :function check-bits-3...28) 79 | (reserved1 (:octets 4) :function check-h/f-reserved :ignore t) 80 | (reserved2 (:octets 4) :function check-h/f-reserved :ignore t)) 81 | 82 | (sera:defconstructor apev2-tag-item 83 | "An item (key/value pair) in apev2 tag block" 84 | (key string) 85 | (value t) 86 | (read-only boolean)) 87 | 88 | (sera:-> read-item (reader) 89 | (values apev2-tag-item &optional)) 90 | (defun read-item (reader) 91 | (let ((value-size (read-octets 4 reader :endianness :little)) 92 | (flags (check-bits-3...28 (read-octets 4 reader :endianness :little))) 93 | (position (reader-position reader)) 94 | (new-position (progn 95 | (peek-octet reader 0) 96 | (reader-position reader)))) 97 | (reader-position reader position) 98 | (let ((key 99 | (prog1 (map 'string #'code-char 100 | (read-octet-vector/new (- new-position position) reader)) 101 | ;; Read zero terminator 102 | (read-octet reader))) 103 | (value 104 | ;; FIXME: Value list is not supported now, but support may be 105 | ;; easily added later. 106 | (let ((array (read-octet-vector/new value-size reader))) 107 | (case (apev2-item-content-type flags) 108 | (:utf-8 (flexi-streams:octets-to-string 109 | array :external-format *apev2-external-format*)) 110 | (:binary array) 111 | (t (error 'apev2-tag-error :format-control "Unknown content type")))))) 112 | (apev2-tag-item key value (some-bits-set-p flags +flag-read-only+))))) 113 | 114 | (sera:-> read-apev2-tag (reader) 115 | (values list &optional)) 116 | (defun read-apev2-tag (reader) 117 | "Read APEv2 tag from the reader" 118 | (let* ((header (read-tag-block reader)) 119 | (items (loop repeat (apev2-tag-block-items header) 120 | collect (read-item reader)))) 121 | (when (has-footer-p (apev2-tag-block-flags header)) 122 | (read-tag-block reader)) 123 | items)) 124 | 125 | (defun read-apev2-tag-from-end (reader) 126 | "Helper function to read APEv2 tag from the end of the reader's 127 | stream. Needs APEv2 tag with a footer." 128 | (let ((length (reader-length reader))) 129 | (when (< length 32) 130 | (error 'apev2-tag-error :format-control "Stream is too short to be an APEv2 tag")) 131 | (reader-position reader (- length 32)) 132 | (let* ((footer (read-tag-block reader)) 133 | (flags (apev2-tag-block-flags footer)) 134 | (size (apev2-tag-block-size footer))) 135 | (unless (and (has-header-p flags) 136 | (has-footer-p flags) ; Sanity check 137 | (eq (h/f-type flags) :footer)) 138 | (error 'apev2-tag-error :format-control "Cannot read APEv2 tag from the end of stream")) 139 | (when (< length (+ size 32)) 140 | (error 'apev2-tag-error :format-control "Stream is too short to be an APEv2 tag")) 141 | (reader-position reader (- length 32 size)) 142 | (read-apev2-tag reader)))) 143 | -------------------------------------------------------------------------------- /ape/ape.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.ape) 2 | 3 | (defconstant +ape-id+ #x4d414320 4 | "4-byte value identifying APE file") 5 | 6 | (defconstant +ape-min-version+ 3990 7 | "Minimal supported APE version") 8 | 9 | (defconstant +ape-max-version+ 3990 10 | "Maximal supported APE version") 11 | 12 | (sera:-> open-ape (stream) 13 | (values reader &optional)) 14 | (defun open-ape (stream) 15 | "Open ape audio file and return bitreader for further operations" 16 | (let ((reader (make-reader :stream stream))) 17 | (when (/= (read-octets 4 reader) +ape-id+) 18 | (error 'ape-error :format-control "Not an APE stream")) 19 | reader)) 20 | 21 | (defreader* (read-metadata-header/3980 metadata (version) ()) 22 | (padding1 (:octets 2) 23 | :endianness :little 24 | :ignore t) 25 | (desc-len (:octets 4) 26 | :endianness :little) 27 | (header-len (:octets 4) 28 | :endianness :little) 29 | (seektable-len (:octets 4) 30 | :endianness :little) 31 | (wavheader-len (:octets 4) 32 | :endianness :little) 33 | (audiodata-len (:octets 4) 34 | :endianness :little) 35 | (audiodata-len-high (:octets 4) 36 | :endianness :little) 37 | (wavtail-len (:octets 4) 38 | :endianness :little) 39 | (header-md5 (:octet-vector 16)) 40 | (padding2 (:octet-vector (- desc-len 52)) 41 | :ignore t) 42 | (compression-type (:octets 2) 43 | :endianness :little) 44 | (format-flags (:octets 2) 45 | :endianness :little) 46 | (blocks-per-frame (:octets 4) 47 | :endianness :little) 48 | (final-frame-blocks (:octets 4) 49 | :endianness :little) 50 | (total-frames (:octets 4) 51 | :endianness :little) 52 | (bps (:octets 2) 53 | :endianness :little) 54 | (channels (:octets 2) 55 | :endianness :little) 56 | (samplerate (:octets 4) 57 | :endianness :little) 58 | (total-samples (:expr (+ final-frame-blocks 59 | (* blocks-per-frame (1- total-frames))))) 60 | (bittable (:expr nil)) 61 | (seektable (:expr (make-array total-frames 62 | :element-type '(ub 32))))) 63 | 64 | (sera:-> read-metadata-header (reader (ub 16)) 65 | (values metadata &optional)) 66 | (declaim (inline read-metadata-header)) 67 | (defun read-metadata-header (reader version) 68 | (cond 69 | ((>= version 3980) 70 | (read-metadata-header/3980 reader version)) 71 | (t 72 | (error 'ape-error 73 | :format-control "Unsupported version ~d" 74 | :format-arguments (list version))))) 75 | 76 | (sera:-> read-bittable (reader metadata) 77 | (values metadata &optional)) 78 | (declaim (inline read-bittable)) 79 | (defun read-bittable (reader metadata) 80 | (declare (ignore reader)) 81 | (let ((version (metadata-version metadata))) 82 | (cond 83 | ((>= version 3810) 84 | ;; No bittable in versions >= 3810 85 | metadata) 86 | (t 87 | (error 'ape-error 88 | :format-control "Unsupported version ~d" 89 | :format-arguments (list version)))))) 90 | 91 | (sera:-> read-metadata (reader) 92 | (values metadata &optional)) 93 | (defun read-metadata (reader) 94 | "Read ape metadata using @c(reader) returned by @c(open-ape)" 95 | (let ((version (read-octets 2 reader :endianness :little))) 96 | (when (or (< version +ape-min-version+) 97 | (> version +ape-max-version+)) 98 | (error 'ape-error 99 | :format-control "Unsupported APE version ~d" 100 | :format-arguments (list version))) 101 | (let ((metadata (read-metadata-header reader version))) 102 | ;; A bit of sanity checks 103 | (let ((expected-len (* (metadata-total-frames metadata) 4))) 104 | (when (/= (metadata-seektable-len metadata) expected-len) 105 | (error 'ape-error 106 | :format-control "Unexpected seektable length (expected ~d, got ~d)" 107 | :format-arguments (list expected-len (metadata-seektable-len metadata))))) 108 | ;; COMPRESSION-TYPE must be multiple of 1000 109 | (unless (zerop (rem (metadata-compression-type metadata) 1000)) 110 | (error 'ape-error 111 | :format-control "Compression type is not multiple of 1000: ~d" 112 | :format-arguments (list (metadata-compression-type metadata)))) 113 | ;; Read seektable 114 | (let ((seektable (metadata-seektable metadata))) 115 | (dotimes (i (length seektable)) 116 | (setf (aref seektable i) 117 | (read-octets 4 reader :endianness :little)))) 118 | ;; Read bittable (if any) 119 | (read-bittable reader metadata)))) 120 | 121 | (defmacro with-open-ape ((reader name) &body body) 122 | "Open ape file with the pathname @c(name) and creates @c(reader) 123 | for that file. The file is closed when the control leaves body of this 124 | macro." 125 | (let ((stream (gensym))) 126 | `(with-open-file (,stream ,name :element-type '(unsigned-byte 8)) 127 | (let ((,reader (open-ape ,stream))) 128 | ,@body)))) 129 | 130 | (sera:-> seconds=>frame-number (metadata non-negative-fixnum) 131 | (values non-negative-fixnum non-negative-fixnum &optional)) 132 | (defun seconds=>frame-number (metadata seconds) 133 | "Return the number of a frame whose play time is @c(seconds) from 134 | the beginning of file." 135 | (let ((samplerate (metadata-samplerate metadata)) 136 | (total-samples (metadata-total-samples metadata)) 137 | (frame-size (metadata-blocks-per-frame metadata))) 138 | (let ((sample-number (* seconds samplerate))) 139 | (when (>= sample-number total-samples) 140 | (error 'ape-error 141 | :format-control "Sample ~d is requested, but maximal value is ~d" 142 | :format-arguments (list sample-number total-samples))) 143 | (floor sample-number frame-size)))) 144 | -------------------------------------------------------------------------------- /ape/definitions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.ape) 2 | 3 | ;; Conditions 4 | (define-condition ape-error (error simple-condition) 5 | () 6 | (:report 7 | (lambda (c s) 8 | (apply #'format s 9 | (concatenate 'string "Ape error: " 10 | (simple-condition-format-control c)) 11 | (simple-condition-format-arguments c)))) 12 | (:documentation "General APE error")) 13 | 14 | (define-condition apev2-tag-error (ape-error) () 15 | (:documentation "APEv2 tag error")) 16 | 17 | ;; Some constants 18 | (defconstant +code-bits+ 32) 19 | (defconstant +top-value+ (ash 1 (1- +code-bits+))) 20 | (defconstant +shift-bits+ (- +code-bits+ 9)) 21 | (defconstant +extra-bits+ (1+ (rem (- +code-bits+ 2) 8))) 22 | (defconstant +bottom-value+ (ash +top-value+ -8)) 23 | 24 | ;; Structures 25 | (sera:defconstructor metadata 26 | (version (ub 16)) 27 | (desc-len (ub 32)) 28 | (header-len (ub 32)) 29 | (seektable-len (ub 32)) 30 | (wavheader-len (ub 32)) 31 | (audiodata-len (ub 32)) 32 | (audiodata-len-high (ub 32)) 33 | (wavtail-len (ub 32)) 34 | (header-md5 (sa-ub 8)) 35 | (compression-type (ub 16)) 36 | (format-flags (ub 16)) 37 | (blocks-per-frame (ub 32)) 38 | (final-frame-blocks (ub 32)) 39 | (total-frames (ub 32)) 40 | (bps (ub 16)) 41 | (channels (ub 16)) 42 | (samplerate (ub 32)) 43 | (total-samples (ub 32)) 44 | (bittable t) 45 | (seektable (sa-ub 32))) 46 | 47 | (defstruct rice-state 48 | (k 10 :type (integer 0 24)) 49 | (ksum 16384 :type (ub 32))) 50 | 51 | (defstruct range-coder 52 | (low 0 :type (ub 32)) 53 | (range (ash 1 +extra-bits+) 54 | :type (ub 32)) 55 | (help 0 :type (ub 32)) 56 | (buffer 0 :type (ub 32))) 57 | 58 | (sera:defconstructor frame 59 | (version (ub 16)) 60 | ;; Compression level 61 | (fset (integer 0 4)) 62 | (samples (ub 32)) 63 | (bps (ub 16)) 64 | (flags (ub 32)) 65 | (buffer (ub 8)) 66 | (crc (ub 32)) 67 | (entropy list)) 68 | -------------------------------------------------------------------------------- /ape/examples/ape2wav.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.ape-examples) 2 | 3 | (defun ape2wav (ape-name wav-name) 4 | "Decodes ape file to wav." 5 | (with-open-ape (in-reader ape-name) 6 | (let* ((meta (read-metadata in-reader)) 7 | (total-samples (metadata-total-samples meta)) 8 | (total-frames (metadata-total-frames meta)) 9 | (bps (metadata-bps meta)) 10 | (channels (metadata-channels meta)) 11 | (samplerate (metadata-samplerate meta))) 12 | (with-output-to-wav (out-stream wav-name 13 | :supersede t 14 | :samplerate samplerate 15 | :channels channels 16 | :bps bps 17 | :totalsamples total-samples) 18 | (loop for i below total-frames 19 | for frame = (read-frame in-reader meta i) do 20 | (write-sequence (interleave-channels (decode-frame frame)) out-stream)))))) 21 | -------------------------------------------------------------------------------- /ape/examples/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.ape-examples 2 | (:use #:cl 3 | #:easy-audio.wav 4 | #:easy-audio.ape 5 | #:easy-audio.core) 6 | (:nicknames #:ape-examples) 7 | (:export #:ape2wav)) 8 | -------------------------------------------------------------------------------- /ape/frame.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.ape) 2 | 3 | (defconstant +mono-silence+ 1) 4 | (defconstant +stereo-silence+ 3) 5 | (defconstant +pseudo-stereo+ 4) 6 | 7 | (deftype octet-reader () 8 | '(function () (values (ub 8) &optional))) 9 | 10 | (define-constant +stereo-entropy-versions+ 11 | '(3990 3930 3900 3860 0) 12 | :test #'equalp) 13 | 14 | (define-constant +mono-entropy-versions+ 15 | '(3990 3900 3860 0) 16 | :test #'equalp) 17 | 18 | (define-constant +counts-3980+ 19 | (make-array 22 20 | :element-type '(ub 16) 21 | :initial-contents '(0 19578 36160 48417 56323 60899 63265 64435 22 | 64971 65232 65351 65416 65447 65466 65476 65482 23 | 65485 65488 65490 65491 65492 65493)) 24 | :test #'equalp) 25 | 26 | ;; TODO: calculate this from *counts* 27 | (define-constant +counts-diff-3980+ 28 | (make-array 21 29 | :element-type '(ub 16) 30 | :initial-contents (map 'list #'- 31 | (subseq +counts-3980+ 1) +counts-3980+)) 32 | :test #'equalp) 33 | 34 | (sera:-> make-swapped-reader (reader) 35 | (values octet-reader &optional)) 36 | (defun make-swapped-reader (reader) 37 | "This function generates a closure that read octets in strange 38 | reversed order observed in ffmpeg (as if they are part of 39 | little-endian values)." 40 | (declare (optimize (speed 3))) 41 | (let (octets) 42 | (lambda () 43 | (when (null octets) 44 | (setq octets 45 | (reverse (loop repeat 4 collect (read-octet reader))))) 46 | (prog1 47 | (car octets) 48 | (setq octets (cdr octets)))))) 49 | 50 | (sera:-> read-32 (octet-reader) 51 | (values (ub 32) &optional)) 52 | (defun read-32 (reader) 53 | (declare (optimize (speed 3))) 54 | (logior 55 | (ash (funcall reader) 24) 56 | (ash (funcall reader) 16) 57 | (ash (funcall reader) 8) 58 | (ash (funcall reader) 0))) 59 | 60 | (declaim (inline frame-start)) 61 | (defun frame-start (metadata n) 62 | (let* ((seektable (metadata-seektable metadata)) 63 | (start (aref seektable n)) 64 | (skip (logand (- start (aref seektable 0)) 3))) 65 | (values (- start skip) 66 | skip))) 67 | 68 | (sera:-> range-dec-normalize (octet-reader range-coder) 69 | (values &optional)) 70 | (defun range-dec-normalize (reader range-coder) 71 | (declare (optimize (speed 3))) 72 | (with-accessors ((buffer range-coder-buffer) 73 | (low range-coder-low) 74 | (range range-coder-range)) 75 | range-coder 76 | ;; Overflows can happen here, so values must be bringed back to 77 | ;; (ub 32) type. 78 | (loop while (<= range +bottom-value+) do 79 | (setf buffer (+ (logand (ash buffer 8) 80 | #xffffffff) 81 | (funcall reader)) 82 | low (logior (logand (ash low 8) 83 | #xffffffff) 84 | (logand (ash buffer -1) #xff)) 85 | range (logand (ash range 8) 86 | #xffffffff)))) 87 | (values)) 88 | 89 | (sera:-> range-decode-culshift (octet-reader range-coder (integer 0 32)) 90 | (values (ub 16) &optional)) 91 | (defun range-decode-culshift (reader range-coder shift) 92 | (declare (optimize (speed 3))) 93 | (range-dec-normalize reader range-coder) 94 | (with-accessors ((help range-coder-help) 95 | (low range-coder-low) 96 | (range range-coder-range)) 97 | range-coder 98 | (setf help (ash range (- shift))) 99 | (nth-value 0 (floor low help)))) 100 | 101 | (sera:-> range-decode-culfreq (octet-reader range-coder (ub 16)) 102 | (values (ub 16) &optional)) 103 | (defun range-decode-culfreq (reader range-coder tot-f) 104 | (declare (optimize (speed 3))) 105 | (range-dec-normalize reader range-coder) 106 | (with-accessors ((help range-coder-help) 107 | (low range-coder-low) 108 | (range range-coder-range)) 109 | range-coder 110 | (setf help (floor range tot-f)) 111 | (nth-value 0 (floor low help)))) 112 | 113 | (sera:-> range-decode-update (range-coder (ub 16) (ub 16)) 114 | (values &optional)) 115 | (defun range-decode-update (range-coder sy-f lt-f) 116 | (declare (optimize (speed 3))) 117 | (let ((help (range-coder-help range-coder))) 118 | (decf (range-coder-low range-coder) 119 | (* help lt-f)) 120 | (setf (range-coder-range range-coder) 121 | (* help sy-f))) 122 | (values)) 123 | 124 | (sera:-> range-get-symbol (octet-reader range-coder (sa-ub 16) (sa-ub 16)) 125 | (values (ub 16) &optional)) 126 | (defun range-get-symbol (reader range-coder counts counts-diff) 127 | (declare (optimize (speed 3))) 128 | (let ((cf (range-decode-culshift reader range-coder 16))) 129 | (cond 130 | ((> cf 65492) 131 | (range-decode-update range-coder 1 cf) 132 | (- cf (- 65535 63))) 133 | (t 134 | ;; Position never returns NIL here because cf is less than 65493 135 | (let ((symbol (max 0 (1- (position cf counts :test #'<))))) 136 | (range-decode-update 137 | range-coder 138 | (aref counts-diff symbol) 139 | (aref counts symbol)) 140 | symbol))))) 141 | 142 | (sera:-> range-decode-bits (octet-reader range-coder (integer 0 16)) 143 | (values (ub 16) &optional)) 144 | (defun range-decode-bits (reader range-coder n) 145 | (declare (optimize (speed 3))) 146 | (let ((sym (range-decode-culshift reader range-coder n))) 147 | (range-decode-update range-coder 1 sym) 148 | sym)) 149 | 150 | (sera:-> update-rice (rice-state (ub 32)) 151 | (values &optional)) 152 | (defun update-rice (rice-state x) 153 | (declare (optimize (speed 3))) 154 | (let* ((k (rice-state-k rice-state)) 155 | (%ksum (rice-state-ksum rice-state)) 156 | (lim (if (zerop k) 0 (ash 1 (+ 4 k)))) 157 | (ksum (+ %ksum (ash (1+ x) -1) 158 | (- (ash (+ %ksum 16) -5))))) 159 | (cond 160 | ((< ksum lim) 161 | (decf (rice-state-k rice-state))) 162 | ((and (< k 24) 163 | (>= ksum (ash 1 (+ k 5)))) 164 | (incf (rice-state-k rice-state)))) 165 | (setf (rice-state-ksum rice-state) ksum)) 166 | (values)) 167 | 168 | (sera:-> entropy-decode/3990 (octet-reader frame) 169 | (values frame &optional)) 170 | (defun entropy-decode/3990 (reader frame) 171 | (declare (optimize (speed 3))) 172 | (let ((entropy (frame-entropy frame)) 173 | (samples (frame-samples frame)) 174 | (range-coder (make-range-coder 175 | :buffer (frame-buffer frame) 176 | :low (ash (frame-buffer frame) 177 | (- +extra-bits+ 8))))) 178 | (flet ((read-value (rice-state) 179 | (let* ((%overflow (range-get-symbol 180 | reader range-coder 181 | +counts-3980+ +counts-diff-3980+)) 182 | (overflow (if (= %overflow 63) 183 | (let ((high (range-decode-bits reader range-coder 16)) 184 | (low (range-decode-bits reader range-coder 16))) 185 | (logior (ash high 16) low)) 186 | %overflow)) 187 | (pivot (max 1 (ash (rice-state-ksum rice-state) -5))) 188 | (base (cond 189 | ((< pivot #x10000) 190 | (let ((base (range-decode-culfreq reader range-coder pivot))) 191 | (range-decode-update range-coder 1 base) 192 | base)) 193 | (t 194 | (let* ((bbits (max 0 (- (integer-length pivot) 16))) 195 | (base-hi 196 | (let ((tmp (range-decode-culfreq 197 | reader range-coder 198 | (1+ (ash pivot (- bbits)))))) 199 | (range-decode-update range-coder 1 tmp) 200 | tmp)) 201 | (base-low 202 | (let ((tmp (range-decode-culfreq 203 | reader range-coder 204 | (ash 1 bbits)))) 205 | (range-decode-update range-coder 1 tmp) 206 | tmp))) 207 | (+ base-low (ash base-hi bbits)))))) 208 | (x (+ base (* overflow pivot)))) 209 | (update-rice rice-state x) 210 | (1+ (logxor (ash x -1) 211 | (1- (logand x 1))))))) 212 | 213 | (let ((rice-states (loop repeat (length entropy) 214 | collect (make-rice-state)))) 215 | (dotimes (i samples) 216 | (mapc 217 | (lambda (entropy rice-state) 218 | (declare (type (sa-sb 32) entropy)) 219 | (setf (aref entropy i) 220 | (read-value rice-state))) 221 | entropy rice-states))))) 222 | frame) 223 | 224 | (sera:-> entropy-decode (octet-reader frame (member :mono :stereo)) 225 | (values frame &optional)) 226 | (declaim (inline entropy-decode)) 227 | (defun entropy-decode (reader frame channels) 228 | (let ((version 229 | (find (frame-version frame) 230 | (ecase channels 231 | (:mono +mono-entropy-versions+) 232 | (:stereo +stereo-entropy-versions+)) 233 | :test #'>=))) 234 | (case version 235 | (3990 (entropy-decode/3990 reader frame)) 236 | (t (error 'ape-error 237 | :format-control "Unsupported frame version ~d" 238 | :format-arguments (list (frame-version frame))))))) 239 | 240 | (sera:-> read-stereo-entropy (octet-reader frame) 241 | (values frame &optional)) 242 | (defun read-stereo-entropy (reader frame) 243 | (let ((flags (frame-flags frame))) 244 | (if (all-bits-set-p flags +stereo-silence+) frame 245 | (entropy-decode 246 | reader frame :stereo)))) 247 | 248 | (sera:-> read-mono-entropy (octet-reader frame) 249 | (values frame &optional)) 250 | (defun read-mono-entropy (reader frame) 251 | (let ((flags (frame-flags frame))) 252 | ;; ffmpeg checks stereo silence here. Can 0x02 be set here? 253 | (if (some-bits-set-p flags +stereo-silence+) frame 254 | (entropy-decode 255 | reader frame :mono)))) 256 | 257 | (sera:-> read-crc-and-flags (octet-reader (ub 16)) 258 | (values (ub 32) (ub 32) &optional)) 259 | (declaim (inline read-crc-and-flags)) 260 | (defun read-crc-and-flags (reader version) 261 | ;; What's the difference between bytestream_get_[b|l]e32() and 262 | ;; get_bits_long()? 263 | (let ((crc (read-32 reader))) 264 | (if (and (> version 3820) 265 | (not (zerop (ldb (byte 1 31) crc)))) 266 | (values (logand crc (1- #x80000000)) 267 | (read-32 reader)) 268 | (values crc 0)))) 269 | 270 | (sera:-> %read-frame (octet-reader metadata &key (:last-frame-p boolean)) 271 | (values frame &optional)) 272 | (defun %read-frame (reader metadata &key last-frame-p) 273 | (let ((version (metadata-version metadata)) 274 | (bps (metadata-bps metadata)) 275 | ;; Calculate compression level 276 | (fset (1- (floor 277 | (metadata-compression-type metadata) 278 | 1000)))) 279 | ;; Read CRC and frame flags 280 | (multiple-value-bind (crc flags) 281 | (read-crc-and-flags reader version) 282 | (let* ((buffer 283 | (cond 284 | ((>= version 3900) 285 | ;; Drop the first 8 bits 286 | (funcall reader) 287 | (funcall reader)) 288 | (t 0))) 289 | ;; Initialize output buffer 290 | (samples (if last-frame-p 291 | (metadata-final-frame-blocks metadata) 292 | (metadata-blocks-per-frame metadata))) 293 | (pseudo-stereo-p (some-bits-set-p flags +pseudo-stereo+)) 294 | (entropy 295 | (loop repeat (if pseudo-stereo-p 1 (metadata-channels metadata)) 296 | collect 297 | (make-array samples 298 | :element-type '(signed-byte 32) 299 | :initial-element 0))) 300 | (frame (frame version fset samples bps flags buffer crc entropy))) 301 | ;; Read entropy 302 | (if (or pseudo-stereo-p (= (metadata-channels metadata) 1)) 303 | (read-mono-entropy reader frame) 304 | (read-stereo-entropy reader frame)))))) 305 | 306 | (sera:-> read-frame (reader metadata non-negative-fixnum) 307 | (values frame &optional)) 308 | (defun read-frame (reader metadata n) 309 | "Read the @c(n)-th audio frame from @c(reader). @c(metadata) is the 310 | metadata structure for this audio file." 311 | (multiple-value-bind (start skip) 312 | (frame-start metadata n) 313 | ;; Seek to the start of a frame 314 | (reader-position reader start) 315 | ;; Make that peculiar swapped-bytes reader needed to read a frame 316 | (let ((swapped-reader (make-swapped-reader reader))) 317 | ;; Skip some bytes from the beginning 318 | (loop repeat skip do (funcall swapped-reader)) 319 | ;; Read a frame 320 | (%read-frame 321 | swapped-reader metadata 322 | :last-frame-p (= n (1- (metadata-total-frames metadata))))))) 323 | -------------------------------------------------------------------------------- /ape/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.ape 2 | (:use #:cl 3 | #:alexandria 4 | #:easy-audio.bitreader 5 | #:easy-audio.core) 6 | (:local-nicknames (#:sera #:serapeum) 7 | (#:si #:stateless-iterators)) 8 | (:export 9 | ;; Conditions 10 | #:ape-error 11 | #:apev2-tag-error 12 | ;; Macros 13 | #:with-open-ape 14 | ;; APE tags 15 | #:apev2-tag-item 16 | #:apev2-tag-item-key 17 | #:apev2-tag-item-value 18 | #:apev2-tag-item-flags 19 | #:apev2-item-content-type 20 | #:read-apev2-tag 21 | #:read-apev2-tag-from-end 22 | #:*apev2-external-format* 23 | ;; APE audio format 24 | #:open-ape 25 | #:read-metadata 26 | #:read-frame 27 | #:decode-frame 28 | #:seconds=>frame-number 29 | ;; Metadata accessors 30 | #:metadata 31 | #:metadata-version 32 | #:metadata-compression-type 33 | #:metadata-blocks-per-frame 34 | #:metadata-final-frame-blocks 35 | #:metadata-total-frames 36 | #:metadata-bps 37 | #:metadata-channels 38 | #:metadata-samplerate 39 | #:metadata-total-samples 40 | #:frame-samples)) 41 | -------------------------------------------------------------------------------- /bitreader/crc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.bitreader) 2 | 3 | ;; Contains CRC functions used by easy-audio 4 | ;; Flac 5 | (declaim (type (sa-ub 16) +crc-table-0-8005+)) 6 | (define-constant +crc-table-0-8005+ 7 | (make-array 256 8 | :element-type '(ub 16) 9 | :initial-contents 10 | (flet ((crc-for-byte (byte) 11 | (labels ((%go (crc n) 12 | (if (zerop n) crc 13 | (%go 14 | (logand (if (zerop (logand #x8000 crc)) 15 | (ash crc 1) 16 | (logxor #x8005 (ash crc 1))) 17 | #xffff) 18 | (1- n))))) 19 | (%go (ash byte 8) 8)))) 20 | (loop for i below 256 collect (crc-for-byte i)))) 21 | :documentation "Precalculated CRC-16 table, starting with 0, 22 | polynomial generator #x8005. Used for FLAC." 23 | :test #'equalp) 24 | 25 | (serapeum:-> crc-0-8005 ((sa-ub 8) (ub 16) 26 | &key (:start t) (:end t)) 27 | (values (ub 16) &optional)) 28 | (defun crc-0-8005 (array accum &key (start 0) end) 29 | "CRC checksum used in FLAC frames" 30 | (declare (optimize (speed 3))) 31 | (flet ((accumulate-crc (crc x) 32 | (declare (type (ub 16) crc) 33 | (type (ub 8) x)) 34 | (logand #xffff 35 | (logxor (ash crc 8) 36 | (aref +crc-table-0-8005+ 37 | (logxor x (ash crc -8))))))) 38 | (reduce #'accumulate-crc array :initial-value accum :start start :end end))) 39 | 40 | ;; OGG 41 | (declaim (type (sa-ub 32) +crc-table-0-04c11db7+)) 42 | (define-constant +crc-table-0-04c11db7+ 43 | (make-array 256 44 | :element-type '(ub 32) 45 | :initial-contents 46 | (flet ((crc-for-byte (byte) 47 | (labels ((%go (crc n) 48 | (if (zerop n) crc 49 | (%go 50 | (logand (if (zerop (logand #x80000000 crc)) 51 | (ash crc 1) 52 | (logxor #x04c11db7 (ash crc 1))) 53 | #xffffffff) 54 | (1- n))))) 55 | (%go (ash byte 24) 8)))) 56 | (loop for i below 256 collect (crc-for-byte i)))) 57 | :documentation "Precalculated CRC-32 table, starting with 0, 58 | polynomial generator #x04c11db7. Used for OGG container." 59 | :test #'equalp) 60 | 61 | (serapeum:-> crc-0-04c11db7 ((sa-ub 8) (ub 32) 62 | &key (:start t) (:end t)) 63 | (values (ub 32) &optional)) 64 | (defun crc-0-04c11db7 (array accum &key (start 0) end) 65 | "CRC checksum used in OGG container" 66 | (declare (optimize (speed 3))) 67 | (flet ((accumulate-crc (crc x) 68 | (declare (type (ub 32) crc) 69 | (type (ub 8) x)) 70 | (logand #xffffffff 71 | (logxor (ash crc 8) 72 | (aref +crc-table-0-04c11db7+ 73 | (logxor x (logand #xff (ash crc -24)))))))) 74 | (reduce #'accumulate-crc array :initial-value accum :start start :end end))) 75 | -------------------------------------------------------------------------------- /bitreader/definitions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.bitreader) 2 | 3 | (declaim (type positive-fixnum *buffer-size*)) 4 | (defparameter *buffer-size* 4096) 5 | 6 | (define-condition bitreader-eof (error) 7 | ((bitreader :initarg :bitreader 8 | :reader bitreader-eof-bitreader))) 9 | 10 | (defstruct reader 11 | (ibit 0 :type bit-counter) 12 | (ibyte 0 :type non-negative-fixnum) 13 | (end 0 :type non-negative-fixnum) 14 | (buffer (make-array *buffer-size* 15 | :element-type '(ub 8)) 16 | :type (sa-ub 8)) 17 | (fill-buffer-fun 18 | #'read-buffer-from-stream 19 | :type function) 20 | #+easy-audio-check-crc 21 | (crc 0 :type (ub 32)) 22 | #+easy-audio-check-crc 23 | (crc-start 0 :type non-negative-fixnum) 24 | #+easy-audio-check-crc 25 | (crc-fun #'(lambda (array accum &key start end) 26 | (declare (ignore array accum start end)) 27 | 0) 28 | :type function) 29 | stream) 30 | -------------------------------------------------------------------------------- /bitreader/macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.bitreader) 2 | 3 | (defun make-reader-call (reader read-how read-how-many endianness) 4 | (cond 5 | ((eq read-how :custom) 6 | ;; READ-HOW-MANY contains a custom reader 7 | (assert (not endianness)) 8 | `(,read-how-many ,reader)) 9 | ((eq read-how :bit) 10 | (assert (not (or endianness read-how-many))) 11 | `(read-bit ,reader)) 12 | ((eq read-how :octet) 13 | (assert (not (or endianness read-how-many))) 14 | `(read-octet ,reader)) 15 | ((eq read-how :expr) 16 | (assert (not endianness)) 17 | ;; READ-HOW-MANY contains an expression 18 | read-how-many) 19 | (t 20 | (let ((function-name 21 | (ecase read-how 22 | (:octets 'read-octets) 23 | (:bits 'read-bits) 24 | (:octet-vector 'read-octet-vector/new)))) 25 | `(,function-name ,read-how-many ,reader 26 | ,@(if endianness `(:endianness ,endianness))))))) 27 | 28 | (defmacro defreader ((name &optional docstring) (&optional make-form (obj-sym (gensym) obj-sym-given)) 29 | &rest slots) 30 | "Generate a reader function to read data from bit-reader into an 31 | arbitrary object with accessor-like interface. NAME is the name of 32 | such function. The new function will accept two arguments: a 33 | bit-reader and an optional object to be modified. If no object is 34 | passed, it will be created with MAKE-FORM. You can assign a symbol 35 | OBJ-SYM to newly created instance. Each slot from SLOTS is a list. It 36 | has the following syntax: 37 | 38 | (ACCESSOR (:BIT)|(:OCTETS n)|(:BITS n)|(:OCTET-VECTOR v) 39 | [:ENDIANNESS :BIG|:LITTLE] [:FUNCTION FUNC-NAME] [:COND 40 | FORM]) 41 | 42 | (ACCESSOR object) must be a 'place' understandable for setf. One and 43 | only one of BITS, OCTETS or OCTET-VECTOR must be supplied. Endianness 44 | may be supplied and will be passed to low-level bitreader function. if 45 | FUNC-NAME is supplied, readed value will be passed to this function 46 | and then assigned to the slot. If COND is supplied, data will be read 47 | only if FORM evaluates to T. 48 | 49 | UPD: If ACCESSOR is NIL, no data will be stored to anywhere, but it 50 | will be read accordingly to specifications and then lost for good. 51 | 52 | If both OBJ-SYM is not given and MAKE-FORM is NIL, the bitreader 53 | itself will be returned from reader function." 54 | (let ((reader (gensym)) 55 | (only-reading (not (or obj-sym-given make-form)))) 56 | `(defun ,name ,(cond 57 | (only-reading (list reader)) 58 | (make-form `(,reader &optional (,obj-sym ,make-form))) 59 | (t (list reader obj-sym))) 60 | ,@(if docstring (list docstring) nil) 61 | ,@(loop for slot-spec in slots collect 62 | (destructuring-bind (accessor (read-how &optional read-how-many) 63 | &key endianness function cond) 64 | slot-spec 65 | (let* ((function-call 66 | (make-reader-call reader read-how read-how-many endianness)) 67 | (read-value 68 | (if function 69 | (list function function-call) function-call)) 70 | (read-form 71 | (if accessor 72 | (progn 73 | (when only-reading 74 | (error "There cannot be any accessors in this reader")) 75 | `(setf (,accessor ,obj-sym) ,read-value)) 76 | read-value))) 77 | (if cond `(if ,cond ,read-form) read-form)))) 78 | ,(if (or obj-sym-given make-form) obj-sym reader)))) 79 | 80 | (defmacro defreader* ((name ctor (&rest pass-args) (&rest args)) &body entries) 81 | "Like a DEFREADER but does not expand into SETFs. Can be used to 82 | read into read-only structures." 83 | (let* ((reader (gensym)) 84 | (decls (if (eq (caar entries) 'declare) 85 | (car entries))) 86 | (entries (if decls (cdr entries) entries)) 87 | ignored skipped) 88 | `(defun ,name (,reader ,@pass-args ,@args) 89 | ,@(if decls (list decls)) 90 | (let* ,(loop for entry in entries collect 91 | (destructuring-bind (variable 92 | (read-how &optional read-how-many) 93 | &key endianness function lambda cond ignore skip) 94 | entry 95 | (when ignore (push variable ignored)) 96 | (when skip (push variable skipped)) 97 | (when (and function lambda) 98 | (error "Specify at most only one of FUNCTION or LAMBDA")) 99 | (let* ((function-form 100 | (if lambda `(lambda ,@lambda) function)) 101 | (function-call (make-reader-call 102 | reader read-how read-how-many endianness)) 103 | (binding-form 104 | (if function-form 105 | `(,function-form ,function-call) 106 | function-call)) 107 | (final-form 108 | (if cond `(if ,cond ,binding-form) binding-form))) 109 | `(,variable ,final-form)))) 110 | ,@(if ignored `((declare (ignore ,@ignored)))) 111 | (,ctor ,@pass-args 112 | ,@(mapcar 113 | #'first (remove-if 114 | (lambda (var) 115 | (or (member var ignored) 116 | (member var skipped))) 117 | entries :key #'first))))))) 118 | -------------------------------------------------------------------------------- /bitreader/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.bitreader 2 | (:use #:cl #:easy-audio.core #:alexandria) 3 | (:export 4 | ;; Conditions 5 | #:bitreader-eof 6 | 7 | ;; Reader structure and accessors 8 | #:reader 9 | #:make-reader ; Obsolete 10 | #:make-reader-from-stream 11 | #:make-reader-from-buffer 12 | 13 | ;; "End user" functions 14 | #:read-bit #:read-bit-bw 15 | #:read-bits #:read-bits-bw 16 | #:read-octet 17 | #:read-octet-vector 18 | #:read-octet-vector/new 19 | #:read-octets 20 | #:read-to-byte-alignment 21 | #:count-zeros 22 | #:reader-position 23 | #:peek-octet 24 | #:reader-length 25 | 26 | #:*read-with-zeroing* 27 | #:with-crc 28 | #:with-skipping-crc 29 | 30 | #:defreader 31 | #:defreader* 32 | 33 | #+easy-audio-check-crc 34 | #:init-crc 35 | #+easy-audio-check-crc 36 | #:get-crc 37 | #+easy-audio-check-crc 38 | #:crc-0-8005 39 | #+easy-audio-check-crc 40 | #:crc-0-04c11db7)) 41 | -------------------------------------------------------------------------------- /bitreader/sbcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.bitreader) 2 | 3 | (sb-c:defknown read-bits ((integer 0 56) reader &key (:endianness symbol)) 4 | (unsigned-byte 56) 5 | () 6 | :overwrite-fndb-silently t) 7 | 8 | (sb-c:defknown read-octets ((integer 0 7) reader &key (:endianness symbol)) 9 | (unsigned-byte 56) 10 | () 11 | :overwrite-fndb-silently t) 12 | 13 | (defun make-ub-type (bits) 14 | (sb-kernel:make-numeric-type 15 | :class 'integer 16 | :complexp :real 17 | :low 0 18 | :high (1- (expt 2 bits)))) 19 | 20 | (sb-c:defoptimizer (read-bits sb-c:derive-type) ((n reader &key endianness)) 21 | (declare (ignore reader endianness)) 22 | (if (sb-c:constant-lvar-p n) 23 | (make-ub-type (sb-c:lvar-value n)) 24 | (make-ub-type 56))) 25 | 26 | (sb-c:defoptimizer (read-octets sb-c:derive-type) ((n reader &key endianness)) 27 | (declare (ignore reader endianness)) 28 | (if (sb-c:constant-lvar-p n) 29 | (make-ub-type (* 8 (sb-c:lvar-value n))) 30 | (make-ub-type 56))) 31 | -------------------------------------------------------------------------------- /core/core.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.core) 2 | 3 | ;; Types 4 | (deftype bit-counter () '(integer 0 8)) 5 | (deftype ub (n) `(unsigned-byte ,n)) 6 | (deftype sb (n) `(signed-byte ,n)) 7 | (deftype sa-ub (n) `(simple-array (ub ,n) (*))) 8 | (deftype sa-sb (n) `(simple-array (sb ,n) (*))) 9 | 10 | ;; For interactive restarts 11 | (sera:defvar-unbound *current-condition* 12 | "*CURRENT-CONDITION* is bound to signaled contition when debugger is 13 | invoked while within WITH-INTERACTIVE-DEBUG.") 14 | 15 | (defmacro with-interactive-debug (&body body) 16 | "If any condition is signaled and the debugger is invoked while 17 | within this macro, *CURRENT-CONDITION* will be bound to the condition 18 | signaled." 19 | (let ((debugger-hook (gensym))) 20 | `(let ((,debugger-hook *debugger-hook*)) 21 | (flet ((,debugger-hook (condition me) 22 | (declare (ignore me)) 23 | (let ((*debugger-hook* ,debugger-hook) 24 | (*current-condition* condition)) 25 | (invoke-debugger condition)))) 26 | 27 | (let ((*debugger-hook* #',debugger-hook)) 28 | ,@body))))) 29 | 30 | ;; Utility functions 31 | (sera:-> interleave-channels-n (list) 32 | (values (sa-sb 32) &optional)) 33 | (defun interleave-channels-n (buffers) 34 | (declare (optimize (speed 3))) 35 | (let* ((channels (length buffers)) 36 | (first-buffer (first buffers)) 37 | (samples (length first-buffer)) 38 | (output (make-array (* samples channels) :element-type '(sb 32)))) 39 | (declare (type (sa-sb 32) first-buffer)) 40 | (loop for s fixnum below samples 41 | for idx fixnum from 0 by channels do 42 | (loop for buffer of-type (sa-sb 32) in buffers 43 | for c fixnum from 0 by 1 do 44 | (setf (aref output (+ idx c)) 45 | (aref buffer s)))) 46 | output)) 47 | 48 | (sera:-> interleave-channels-2 ((sa-sb 32) (sa-sb 32)) 49 | (values (sa-sb 32) &optional)) 50 | (defun interleave-channels-2 (channel1 channel2) 51 | (declare (optimize (speed 3))) 52 | (loop with samples = (length channel1) 53 | with output = (make-array (* samples 2) :element-type '(sb 32)) 54 | for i below samples 55 | for j from 0 by 2 do 56 | (setf (aref output j) 57 | (aref channel1 i) 58 | (aref output (1+ j)) 59 | (aref channel2 i)) 60 | finally (return output))) 61 | 62 | (sera:-> interleave-channels (list) 63 | (values (sa-sb 32) &optional)) 64 | (defun interleave-channels (channels) 65 | "Interleave samples from separate channels into one buffer." 66 | (declare (optimize (speed 3))) 67 | (case (length channels) 68 | (2 (interleave-channels-2 (first channels) (second channels))) 69 | (t (interleave-channels-n channels)))) 70 | 71 | (defmacro define-documented-accessor (structure slot docstring) 72 | (let ((accessor (intern (format nil "~a-%~a" structure slot) 73 | (symbol-package structure))) 74 | (wrapper (intern (format nil "~a-~a" structure slot) 75 | (symbol-package structure)))) 76 | `(progn 77 | (declaim (inline ,wrapper)) 78 | (defun ,wrapper (,structure) 79 | ,docstring 80 | (,accessor ,structure))))) 81 | 82 | (defmacro define-documented-accessors (structure &body slots) 83 | `(progn 84 | ,@(loop for (slot docstring) in slots collect 85 | `(define-documented-accessor ,structure ,slot ,docstring)))) 86 | 87 | (declaim (inline all-bits-set-p)) 88 | (defun all-bits-set-p (value bits) 89 | (= (logand value bits) bits)) 90 | 91 | (declaim (inline some-bits-set-p)) 92 | (defun some-bits-set-p (value bits) 93 | (not (zerop (logand value bits)))) 94 | -------------------------------------------------------------------------------- /core/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.core 2 | (:use #:cl) 3 | (:local-nicknames (:sera :serapeum)) 4 | (:export 5 | ;; Restarts & conditions 6 | #:*current-condition* 7 | #:with-interactive-debug 8 | 9 | ;; Types 10 | #:bit-counter 11 | #:ub 12 | #:sb 13 | #:sa-ub 14 | #:sa-sb 15 | 16 | ;; Utility functions 17 | #:define-documented-accessor 18 | #:define-documented-accessors 19 | #:interleave-channels 20 | #:all-bits-set-p 21 | #:some-bits-set-p)) 22 | -------------------------------------------------------------------------------- /docs/manifest.lisp: -------------------------------------------------------------------------------- 1 | (:docstring-markup-format :scriba 2 | :systems (:easy-audio) 3 | :documents ((:title "Easy Audio" 4 | :authors ("Vasily Postnicov") 5 | :output-format (:type :multi-html 6 | :template :minima) 7 | :sources ("manual.scr")))) 8 | -------------------------------------------------------------------------------- /docs/manual.scr: -------------------------------------------------------------------------------- 1 | @begin[ref=index](section) 2 | @title(Overview) 3 | @c(easy-audio) is a collection of audio decoders and metadata readers. You 4 | can get it from @link[uri="http://github.com/shamazmazum/easy-audio"](GitHub). 5 | Here is the documentation covering various parts of this collection. All 6 | decoders work with binary streams with element type @c((unsigned-byte 8)). 7 | If this documenation is insufficient look at the examples in @c(examples) 8 | directory for each decoder. 9 | @end(section) 10 | 11 | @begin(section) 12 | @title(FLAC) 13 | To read and decode FLAC file or stream you need to follow these steps: 14 | @begin(enum) 15 | @item(Open a FLAC file/Get a stream with element type @c((unsigned-byte 8)).) 16 | @item(Pass the stream to @c(flac:open-flac) function which will create and 17 | return @c(bitreader:reader) object. This object allows 18 | @c(easy-audio) library to read not just octets, but any amount of 19 | bits from audio stream.) 20 | @item(Read metadata blocks from the stream, passing the object from previous 21 | step to @c(flac:read-metadata).) 22 | @item(Do whatever you want with metadata and read the first audio frame with 23 | @c(flac:read-frame).) 24 | @item(Decode the frame with @c(flac:decode-frame) and repeat previous step 25 | until all data is read and decoded.) 26 | @end(enum) 27 | 28 | @begin(section) 29 | @title(API) 30 | @u(Conditions). 31 | @cl:with-package[name="easy-audio.flac"]( 32 | @cl:doc(condition flac-error) 33 | @cl:doc(condition flac-bad-metadata) 34 | @cl:doc(condition flac-bad-frame) 35 | ) 36 | @u(Metadata blocks). 37 | @cl:with-package[name="easy-audio.flac"]( 38 | @cl:doc(defconstructor streaminfo) 39 | @cl:doc(function streaminfo-minblocksize) 40 | @cl:doc(function streaminfo-maxblocksize) 41 | @cl:doc(function streaminfo-minframesize) 42 | @cl:doc(function streaminfo-maxframesize) 43 | @cl:doc(function streaminfo-samplerate) 44 | @cl:doc(function streaminfo-channels) 45 | @cl:doc(function streaminfo-bitspersample) 46 | @cl:doc(function streaminfo-totalsamples) 47 | @cl:doc(function streaminfo-md5) 48 | @cl:doc(defconstructor padding) 49 | @cl:doc(defconstructor vorbis-comment) 50 | @cl:doc(defconstructor seektable) 51 | @cl:doc(defconstructor seekpoint) 52 | @cl:doc(defconstructor cuesheet) 53 | @cl:doc(function cuesheet-catalog-id) 54 | @cl:doc(function cuesheet-lead-in) 55 | @cl:doc(function cuesheet-cdp) 56 | @cl:doc(function cuesheet-tracks) 57 | @cl:doc(defconstructor cuesheet-track) 58 | @cl:doc(defconstructor cuesheet-index) 59 | @cl:doc(defconstructor picture) 60 | @cl:doc(function picture-type) 61 | @cl:doc(function picture-mime-type) 62 | @cl:doc(function picture-description) 63 | @cl:doc(function picture-width) 64 | @cl:doc(function picture-height) 65 | @cl:doc(function picture-depth) 66 | @cl:doc(function picture-color-num) 67 | @cl:doc(function picture-picture) 68 | ) 69 | @u(Working with audio frames). 70 | @cl:with-package[name="easy-audio.flac"]( 71 | @cl:doc(function read-frame) 72 | @cl:doc(function decode-frame) 73 | @cl:doc(type blocksize) 74 | @cl:doc(defconstructor frame) 75 | @cl:doc(function frame-blocking-strategy) 76 | @cl:doc(function frame-block-size) 77 | @cl:doc(function frame-sample-rate) 78 | @cl:doc(variable +left-side+) 79 | @cl:doc(variable +right-side+) 80 | @cl:doc(variable +mid-side+) 81 | @cl:doc(function frame-channel-assignment) 82 | @cl:doc(function frame-sample-size) 83 | @cl:doc(function frame-number) 84 | @cl:doc(function frame-crc-8) 85 | @cl:doc(function frame-subframes) 86 | @cl:doc(function frame-crc-16) 87 | ) 88 | @u(Other functions / helpers). 89 | @cl:with-package[name="easy-audio.flac"]( 90 | @cl:doc(function open-flac) 91 | @cl:doc(function read-metadata) 92 | @cl:doc(function seek-sample) 93 | @cl:doc(function metadata-find-seektable) 94 | ) 95 | It also can decode FLAC data from OGG container. There are 96 | @c(flac:open-ogg-flac), @c(flac:read-ogg-metadata) and @c(flac:read-ogg-frame) 97 | functions for that purpose. Seeking does not work with OGG container. 98 | @end(section) 99 | @end(section) 100 | 101 | @begin(section) 102 | @title(WavPack) 103 | WavPack decoder works in the same manner as FLAC decoder, with exception that 104 | there is no metadata blocks in the beggining of file, but metadata section in 105 | each WavPack block. This metadata is not as useful as FLAC metadata, 106 | though. Information about track title, album or performer is usualy stored in 107 | APEv2 tag in the end of file. So the algorithm for WavPack is usually this: 108 | @begin(enum) 109 | @item(Open a WavPack file/Get a stream with element type @c((unsigned-byte 110 | 8)). This step is the same as for FLAC format.) 111 | @item(Pass the stream to @c(wv:open-wv) function which will create and 112 | return @c(bitreader:reader) object. Again, this is what you do when 113 | working with FLAC, just the function name differs.) 114 | @item(Read the first WavPack block with @c(wv:read-wv-block). It contains 115 | all information about channels, samplerate, etc. If the stream/file 116 | contains more than 2 channels (i.e. 5.1 audio), you can read 117 | multiple stereo or mono blocks with @c(wv:read-wv-block-multichannel).) 118 | @item(Decode the block with @c(wv:decode-wv-block) and repeat previous step.) 119 | @end(enum) 120 | 121 | @begin(section) 122 | @title(API) 123 | @u(Conditions). 124 | @cl:with-package[name="easy-audio.wv"]( 125 | @cl:doc(condition wavpack-error) 126 | @cl:doc(condition wavpack-warning) 127 | @cl:doc(condition block-error) 128 | @cl:doc(condition lost-sync) 129 | @cl:doc(condition unknown-metadata) 130 | ) 131 | @u(Metadata). 132 | @cl:with-package[name="easy-audio.wv"]( 133 | @cl:doc(class metadata-riff-header) 134 | @cl:doc(class metadata-riff-trailer) 135 | ) 136 | @u(WavPack blocks). 137 | WavPack block class has readers/accessors in the form @c(BLOCK-SLOTNAME). 138 | @cl:with-package[name="easy-audio.wv"]( 139 | @cl:doc(struct wv-block) 140 | @cl:doc(function read-wv-block) 141 | @cl:doc(function read-wv-block-multichannel) 142 | @cl:doc(function decode-wv-block) 143 | @cl:doc(function block-samplerate) 144 | @cl:doc(function block-bps) 145 | @cl:doc(function block-channels) 146 | ) 147 | @u(Other stuff). 148 | @cl:with-package[name="easy-audio.wv"]( 149 | @cl:doc(function restore-sync) 150 | @cl:doc(function restore-sync-multichannel) 151 | @cl:doc(function seek-sample) 152 | @cl:doc(function open-wv) 153 | @cl:doc(function read-new-block) 154 | ) 155 | @end(section) 156 | @end(section) 157 | 158 | @begin(section) 159 | @title(Wav) 160 | This package is for reading Wav audio files (that is if you are lucky 161 | enough:). The working process is as simple as always: 162 | @begin(enum) 163 | @item(Open the audio stream as an ordinary input stream with element 164 | type @c((unsigned-byte 8)).) 165 | @item(Create a bitreader object with @c(open-wav).) 166 | @item(Read wav chunks with metadata calling @c(read-wav-header).) 167 | @item(Because the metadata can be placed @b(after) the audio data itself, 168 | rewind the reader to the beginning of audio data calling 169 | @c(reader-position-to-audio-data).) 170 | @item(Read audio samples with @c(read-wav-data).) 171 | @item(Optionaly, @c(decode-wav-data). Usually this step can be ommited because 172 | the audio stream already has uncompressed PCM data. @c(decode-wav-data) is 173 | no-op in this case.) 174 | @end(enum) 175 | Also you can write simple PCM WAV headers with @c(write-pcm-wav-header) 176 | function and @c(with-output-to-wav) macro. 177 | 178 | @begin(section) 179 | @title(API) 180 | @cl:with-package[name="easy-audio.wav"]( 181 | @cl:doc(function read-wav-header) 182 | @cl:doc(function reader-position-to-audio-data) 183 | @cl:doc(function read-wav-data) 184 | @cl:doc(function decode-wav-data) 185 | @cl:doc(function samples-num) 186 | @cl:doc(function get-info-metadata) 187 | @cl:doc(variable +wave-format-pcm+) 188 | @cl:doc(variable +wave-format-float+) 189 | @cl:doc(variable +wave-format-alaw+) 190 | @cl:doc(variable +wave-format-mulaw+) 191 | @cl:doc(variable +wave-format-extensible+) 192 | @cl:doc(class format-subchunk) 193 | @cl:doc(class data-subchunk) 194 | @cl:doc(class fact-subchunk) 195 | @cl:doc(class info-subchunk) 196 | @cl:doc(condition wav-error) 197 | @cl:doc(condition wav-error-chunk) 198 | @cl:doc(condition wav-warning) 199 | @cl:doc(condition wav-unknown-chunk) 200 | @cl:doc(function write-pcm-wav-header) 201 | @cl:doc(macro with-output-to-wav) 202 | ) 203 | @end(section) 204 | @end(section) 205 | 206 | @begin(section) 207 | @title(General decoders) 208 | Currently this package has only A-law and mu-law decoders. 209 | @begin(section) 210 | @title(API) 211 | @cl:with-package[name="easy-audio.general"]( 212 | @cl:doc(function g.711-ulaw-decode) 213 | @cl:doc(function g.711-alaw-decode) 214 | ) 215 | @end(section) 216 | @end(section) 217 | 218 | @begin[ref=ape](section) 219 | @title(Monkey's Audio) 220 | To read and decode Monkey's Audio you need to follow these steps (these steps 221 | are roughly the same as in the section dedicated to flac): 222 | @begin(enum) 223 | @item(Open an .ape file with element type @c((unsigned-byte 8)).) 224 | @item(Pass the stream to @c(ape:open-ape) function which will create and 225 | return @c(bitreader:reader) object.) 226 | @item(Read metadata blocks, passing the object from previous step to 227 | @c(ape:read-metadata).) 228 | @item(Read frames with @c(ape:read-frame). This method accept the number 229 | of frame you wish to be read as the third argument. Total number of 230 | frames in the file can be accessed through @c(metadata-total-frames) 231 | function.) 232 | @item(Decode the frame with @c(ape:decode-frame) and repeat the previous 233 | step until all data is read and decoded.) 234 | @end(enum) 235 | 236 | @begin(section) 237 | @title(API) 238 | @u(Conditions). 239 | @cl:with-package[name="easy-audio.ape"]( 240 | @cl:doc(condition ape-error) 241 | ) 242 | @u(Metadata structure). 243 | @cl:with-package[name="easy-audio.ape"]( 244 | @cl:doc(defconstructor metadata) 245 | ) 246 | @u(Reading and decoding). 247 | @cl:with-package[name="easy-audio.ape"]( 248 | @cl:doc(function open-ape) 249 | @cl:doc(function read-metadata) 250 | @cl:doc(function read-frame) 251 | @cl:doc(function decode-frame) 252 | ) 253 | @u(Helpers). 254 | @cl:with-package[name="easy-audio.ape"]( 255 | @cl:doc(macro with-open-ape) 256 | @cl:doc(function seconds=>frame-number) 257 | ) 258 | @end(section) 259 | @end(section) 260 | 261 | @begin(section) 262 | @title(APE tags) 263 | @c(easy-audio) also has support for APEv2 tags. You can read a tag 264 | from a current file position by @c(ape:read-apev2-tag) or from an 265 | end of a file with @c(ape:read-apev2-tag-from-end). Both of these 266 | functions accept a bitreader as their only argument. 267 | @begin(section) 268 | @title(API) 269 | @cl:with-package[name="easy-audio.ape"]( 270 | @cl:doc(function read-apev2-tag) 271 | @cl:doc(function read-apev2-tag-from-end) 272 | @cl:doc(defconstructor apev2-tag-item) 273 | @cl:doc(condition apev2-tag-error) 274 | @cl:doc(variable *apev2-external-format*) 275 | ) 276 | @end(section) 277 | @end(section) 278 | 279 | @begin(section) 280 | @title(Utility functions) 281 | Package @c(easy-audio.core) contains some useful functions. Here they are. 282 | @cl:with-package[name="easy-audio.core"]( 283 | @cl:doc(function interleave-channels) 284 | ) 285 | @end(section) 286 | -------------------------------------------------------------------------------- /easy-audio.asd: -------------------------------------------------------------------------------- 1 | ;; Comment it out if you do not want restrictions 2 | (eval-when (:load-toplevel :compile-toplevel :execute) 3 | (pushnew :easy-audio-check-crc *features*)) 4 | 5 | (defsystem :easy-audio/core 6 | :name :easy-audio/core 7 | :version "1.3" 8 | :author "Vasily Postnicov " 9 | :licence "2-clause BSD" 10 | :serial t 11 | :pathname "core" 12 | :depends-on (:serapeum) 13 | :components ((:file "package") 14 | (:file "core"))) 15 | 16 | (defsystem :easy-audio/general-decoders 17 | :name :easy-audio/general-decoders 18 | :version "1.3" 19 | :author "Vasily Postnicov " 20 | :licence "2-clause BSD" 21 | :serial t 22 | :pathname "general-decoders" 23 | :components ((:file "package") 24 | (:file "g.711")) 25 | :depends-on (:easy-audio/core)) 26 | 27 | (defsystem :easy-audio/bitreader 28 | :name :easy-audio/bitreader 29 | :version "1.3" 30 | :author "Vasily Postnicov " 31 | :licence "2-clause BSD" 32 | :serial t 33 | :pathname "bitreader" 34 | :components ((:file "package") 35 | (:file "definitions") 36 | (:file "sbcl" :if-feature :sbcl) 37 | (:file "bitreader") 38 | (:file "crc" :if-feature :easy-audio-check-crc) 39 | (:file "macros")) 40 | :depends-on (:easy-audio/core 41 | :alexandria)) 42 | 43 | (defsystem :easy-audio/ogg 44 | :name :easy-audio/ogg 45 | :version "1.3" 46 | :author "Vasily Postnicov " 47 | :licence "2-clause BSD" 48 | :serial t 49 | :pathname "ogg" 50 | :components ((:file "package") 51 | (:file "ogg")) 52 | :depends-on (:easy-audio/core 53 | :easy-audio/bitreader 54 | :alexandria)) 55 | 56 | (defsystem :easy-audio/flac 57 | :name :easy-audio/flac 58 | :version "1.3" 59 | :author "Vasily Postnicov " 60 | :licence "2-clause BSD" 61 | :serial t 62 | :pathname "flac" 63 | :components ((:file "package") 64 | (:file "definitions") 65 | (:file "flac-reader") 66 | (:file "metadata") 67 | (:file "frame") 68 | (:file "decode") 69 | (:file "flac") 70 | (:file "flac-ogg")) 71 | :depends-on (:easy-audio/core 72 | :easy-audio/bitreader 73 | :alexandria 74 | :serapeum 75 | :flexi-streams)) 76 | 77 | (defsystem :easy-audio/wav 78 | :name :easy-audio/wav 79 | :version "1.3" 80 | :author "Vasily Postnicov " 81 | :licence "2-clause BSD" 82 | :serial t 83 | :pathname "wav" 84 | :components ((:file "package") 85 | (:file "definitions") 86 | (:file "wav") 87 | (:file "write-header")) 88 | :depends-on (:easy-audio/core 89 | :easy-audio/bitreader 90 | :easy-audio/general-decoders 91 | :nibbles-streams 92 | :flexi-streams)) 93 | 94 | (defsystem :easy-audio/ape 95 | :name :easy-audio/ape 96 | :version "1.3" 97 | :author "Vasily Postnicov " 98 | :licence "2-clause BSD" 99 | :serial t 100 | :pathname "ape" 101 | :components ((:file "package") 102 | (:file "definitions") 103 | (:file "ape") 104 | (:file "frame") 105 | (:file "decode") 106 | (:file "ape-tags-v2")) 107 | :depends-on (:easy-audio/core 108 | :easy-audio/bitreader 109 | :alexandria 110 | :flexi-streams 111 | :stateless-iterators)) 112 | 113 | (defsystem :easy-audio/wv 114 | :name :easy-audio/wv 115 | :version "1.3" 116 | :author "Vasily Postnicov " 117 | :licence "2-clause BSD" 118 | :serial t 119 | :pathname "wv" 120 | :components ((:file "package") 121 | (:file "definitions") 122 | (:file "wavpack-reader") 123 | (:file "metadata") 124 | (:file "wv-block") 125 | (:file "wv-blocks-multichannel") 126 | (:file "decode")) 127 | :depends-on (:easy-audio/core 128 | :easy-audio/bitreader 129 | :alexandria 130 | :serapeum)) 131 | 132 | (defsystem :easy-audio 133 | :name :easy-audio 134 | :version "1.3" 135 | :author "Vasily Postnicov " 136 | :description "A pack of audio decoders for FLAC, WavPack and other formats" 137 | :licence "2-clause BSD" 138 | :in-order-to ((test-op (load-op "easy-audio/tests"))) 139 | :perform (test-op (op system) 140 | (declare (ignore op system)) 141 | (uiop:symbol-call :easy-audio-tests '#:run-tests)) 142 | :depends-on (:easy-audio/core 143 | :easy-audio/ogg 144 | :easy-audio/flac 145 | :easy-audio/wav 146 | :easy-audio/ape 147 | :easy-audio/wv)) 148 | 149 | (defsystem :easy-audio/examples 150 | :name :easy-audio/examples 151 | :version "1.3" 152 | :author "Vasily Postnicov " 153 | :components ((:file "flac/examples/package") 154 | (:file "flac/examples/flac2wav" :depends-on ("flac/examples/package")) 155 | (:file "flac/examples/ogg2wav" :depends-on ("flac/examples/package")) 156 | 157 | (:file "wav/examples/package") 158 | (:file "wav/examples/decode" :depends-on ("wav/examples/package")) 159 | 160 | (:file "ape/examples/package") 161 | (:file "ape/examples/ape2wav" :depends-on ("ape/examples/package")) 162 | 163 | (:file "wv/examples/package") 164 | (:file "wv/examples/wv2wav" :depends-on ("wv/examples/package"))) 165 | :depends-on (:easy-audio)) 166 | 167 | (defsystem :easy-audio/tests 168 | :name :easy-audio/tests 169 | :version "1.3" 170 | :author "Vasily Postnicov " 171 | :pathname "tests" 172 | :serial t 173 | :components ((:file "package") 174 | (:file "tests")) 175 | :depends-on (:easy-audio/examples 176 | :fiveam 177 | :md5)) 178 | -------------------------------------------------------------------------------- /flac/decode.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.flac) 2 | 3 | (sera:-> decode-subframe-postprocess (subframe-header (sa-sb 32)) 4 | (values (sa-sb 32) &optional)) 5 | (defun decode-subframe-postprocess (header output) 6 | (declare (optimize (speed 3))) 7 | (let ((wasted-bits (subframe-header-wasted-bps header))) 8 | (if (not (zerop wasted-bits)) 9 | (map-into output 10 | (lambda (sample) 11 | (ash sample wasted-bits)) 12 | output) 13 | output))) 14 | 15 | (sera:-> decode-subframe-constant (subframe-constant) 16 | (values (sa-sb 32) &optional)) 17 | (defun decode-subframe-constant (subframe) 18 | (declare (optimize (speed 3))) 19 | (let ((header (subframe-constant-header subframe))) 20 | (decode-subframe-postprocess 21 | header (make-array (subframe-header-block-size header) 22 | :element-type '(sb 32) 23 | :initial-element (subframe-constant-value subframe))))) 24 | 25 | (sera:-> decode-subframe-verbatim (subframe-verbatim) 26 | (values (sa-sb 32) &optional)) 27 | (defun decode-subframe-verbatim (subframe) 28 | (declare (optimize (speed 3))) 29 | (decode-subframe-postprocess 30 | (subframe-verbatim-header subframe) 31 | (subframe-verbatim-data subframe))) 32 | 33 | (sera:-> decode-subframe-fixed (subframe-fixed) 34 | (values (sa-sb 32) &optional)) 35 | (defun decode-subframe-fixed (subframe) 36 | ;; Decodes subframe destructively modifiying it 37 | (declare (optimize (speed 3))) 38 | (let* ((header (subframe-fixed-header subframe)) 39 | (residual (subframe-fixed-residual subframe)) 40 | (order (subframe-fixed-order subframe)) 41 | (blocksize (subframe-header-block-size header))) 42 | (decode-subframe-postprocess 43 | header 44 | (if (zerop order) 45 | (copy-seq residual) 46 | (let ((data (make-array blocksize :element-type '(sb 32)))) 47 | (replace data residual :end1 order) 48 | (cond 49 | ;; 0 - out-buf contains decoded data 50 | ((= order 1) 51 | (loop for i from 1 below blocksize do 52 | (setf (aref data i) 53 | (+ (aref residual i) 54 | (aref data (1- i)))))) 55 | ((= order 2) 56 | (loop for i from 2 below blocksize do 57 | (setf (aref data i) 58 | (+ 59 | (aref residual i) 60 | (+ (* (aref data (- i 1)) 2)) 61 | (- (* (aref data (- i 2)))))))) 62 | ((= order 3) 63 | (loop for i from 3 below blocksize do 64 | (setf (aref data i) 65 | (+ 66 | (aref residual i) 67 | (+ (* (aref data (- i 1)) 3)) 68 | (- (* (aref data (- i 2)) 3)) 69 | (+ (* (aref data (- i 3)))))))) 70 | ((= order 4) 71 | (loop for i from 4 below blocksize do 72 | (setf (aref data i) 73 | (+ 74 | (aref residual i) 75 | (+ (* (aref data (- i 1)) 4)) 76 | (- (* (aref data (- i 2)) 6)) 77 | (+ (* (aref data (- i 3)) 4)) 78 | (- (* (aref data (- i 4))))))))) 79 | data))))) 80 | 81 | (sera:-> decode-subframe-lpc (subframe-lpc) 82 | (values (sa-sb 32) &optional)) 83 | (defun decode-subframe-lpc (subframe) 84 | (declare (optimize (speed 3))) 85 | (let* ((header (subframe-lpc-header subframe)) 86 | (residual (subframe-lpc-residual subframe)) 87 | (shift (subframe-lpc-coeff-shift subframe)) 88 | (order (subframe-lpc-order subframe)) 89 | (coeff (subframe-lpc-predictor-coeff subframe)) 90 | (blocksize (subframe-header-block-size header)) 91 | (data (make-array blocksize :element-type '(sb 32)))) 92 | (replace data residual :end1 order) 93 | (loop for i from order below blocksize do 94 | (setf (aref data i) 95 | (+ (aref residual i) 96 | (the fixnum 97 | (ash 98 | (loop for j below order sum 99 | (* (aref coeff j) 100 | (aref data (- i j 1))) 101 | fixnum) 102 | (- shift)))))) 103 | (decode-subframe-postprocess header data))) 104 | 105 | (sera:-> decode-subframe (subframe) 106 | (values (sa-sb 32) &optional)) 107 | (declaim (inline decode-subframe)) 108 | (defun decode-subframe (subframe) 109 | (etypecase subframe 110 | (subframe-verbatim (decode-subframe-verbatim subframe)) 111 | (subframe-constant (decode-subframe-constant subframe)) 112 | (subframe-fixed (decode-subframe-fixed subframe)) 113 | (subframe-lpc (decode-subframe-lpc subframe)))) 114 | 115 | (defun decode-frame (frame) 116 | "Decode a frame. Returns list of decoded audio buffers (one buffer for each channel)." 117 | (declare (optimize (speed 3))) 118 | (let ((decoded-subframes 119 | (mapcar #'decode-subframe (frame-subframes frame))) 120 | (assignment (frame-channel-assignment frame))) 121 | (declare (type non-negative-fixnum assignment)) 122 | 123 | (when (<= assignment +max-channels+) 124 | (return-from decode-frame decoded-subframes)) 125 | (when (/= 2 (length decoded-subframes)) 126 | (error 'flac-error 127 | :format-control "Bad channel assignment/number of subframes")) 128 | 129 | (let ((left (first decoded-subframes)) 130 | (right (second decoded-subframes))) 131 | (declare (type (sa-sb 32) left right)) 132 | (cond 133 | ((= +left-side+ assignment) 134 | (map-into right #'- left right)) 135 | ((= +right-side+ assignment) 136 | (map-into left #'+ left right)) 137 | ((= +mid-side+ assignment) 138 | (loop for i below (frame-block-size frame) 139 | for side = (aref right i) 140 | for mid = (logior 141 | (ash (aref left i) 1) 142 | (logand side 1)) 143 | do 144 | (setf (aref left i) 145 | (ash (+ mid side) -1) 146 | (aref right i) 147 | (ash (- mid side) -1)))))) 148 | decoded-subframes)) 149 | -------------------------------------------------------------------------------- /flac/definitions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.flac) 2 | 3 | (define-condition flac-error (error simple-condition) () 4 | (:report (lambda (c s) 5 | (apply #'format s 6 | (concatenate 'string "General flac error: " 7 | (simple-condition-format-control c)) 8 | (simple-condition-format-arguments c)))) 9 | (:documentation "General (unspecified) flac error")) 10 | 11 | (define-condition flac-bad-metadata (flac-error) 12 | ((metadata :reader flac-metadata 13 | :initarg :metadata 14 | :documentation "Current metadata")) 15 | (:report (lambda (c s) 16 | (apply #'format s 17 | (concatenate 'string "Bad metadata: " 18 | (simple-condition-format-control c)) 19 | (simple-condition-format-arguments c)))) 20 | (:documentation "Flac metadata error")) 21 | 22 | (define-condition flac-bad-frame (flac-error) () 23 | (:report (lambda (c s) 24 | (apply #'format s 25 | (concatenate 'string "Bad frame: " 26 | (simple-condition-format-control c)) 27 | (simple-condition-format-arguments c)))) 28 | (:documentation "Bad flac frame")) 29 | 30 | ;; Metadata 31 | (sera:defconstructor metadata-header 32 | "Metadata block header" 33 | (start-position non-negative-integer) 34 | (last-block-p boolean) 35 | (type (unsigned-byte 7)) 36 | (length (unsigned-byte 24))) 37 | 38 | (sera:defconstructor unknown-metadata 39 | "Unknown metadata block" 40 | (rawdata (sa-ub 8))) 41 | 42 | (sera:defconstructor streaminfo 43 | "STREAMINFO metadata block. The most important metadata block in the 44 | file." 45 | (%minblocksize (unsigned-byte 16)) 46 | (%maxblocksize (unsigned-byte 16)) 47 | (%minframesize (unsigned-byte 24)) 48 | (%maxframesize (unsigned-byte 24)) 49 | (%samplerate positive-fixnum) 50 | (%channels (integer 1 8)) 51 | (%bitspersample (integer 4 32)) 52 | (%totalsamples (unsigned-byte 36)) 53 | (%md5 (sa-ub 8))) 54 | 55 | (define-documented-accessors streaminfo 56 | (minblocksize "The minimum block size (in samples) used in the stream.") 57 | (maxblocksize "The maximum block size (in samples) used in the stream.") 58 | (minframesize "The minimum frame size (in bytes) used in the stream.") 59 | (maxframesize "The maximum frame size (in bytes) used in the stream.") 60 | (samplerate "Sample rate in Hz.") 61 | (channels "The number of channels in a stream. May be from 1 to 8.") 62 | (bitspersample "Bits per sample (from 4 to 32).") 63 | (totalsamples "Total number of samples in a stream. May be 0 if unknown.") 64 | (md5 "MD5 checksum of the whole unencoded data.")) 65 | 66 | (sera:defconstructor padding "Zero padding") 67 | 68 | (sera:defconstructor vorbis-comment 69 | "VORBIS_COMMENT metadata block" 70 | (vendor string) 71 | (user list)) 72 | 73 | (sera:defconstructor seekpoint 74 | "A seekpoint (entry in a seektable)" 75 | (samplenum (ub 64)) 76 | (offset (ub 64)) 77 | (samples-in-frame (ub 16))) 78 | 79 | (sera:defconstructor seektable 80 | "SEEKTABLE metadata block" 81 | (seekpoints list)) 82 | 83 | (sera:defconstructor cuesheet-track 84 | "Represents a track in a cuesheet metadata" 85 | (offset (unsigned-byte 64)) 86 | (number (unsigned-byte 8)) 87 | (isrc string) 88 | (type (member :audio :non-audio)) 89 | (pre-emphasis boolean) 90 | (indices list)) 91 | 92 | (sera:defconstructor cuesheet-index 93 | "Represents an index into a track in a cuesheet metadata" 94 | (offset (unsigned-byte 64)) 95 | (number (unsigned-byte 8))) 96 | 97 | (sera:defconstructor cuesheet 98 | "CUESHEET metadata block" 99 | (%catalog-id string) 100 | (%lead-in (unsigned-byte 64)) 101 | (%cdp boolean) 102 | (%tracks list)) 103 | 104 | (define-documented-accessors cuesheet 105 | (catalog-id "Media catalog number.") 106 | (lead-in "For CD-DA cuesheets, the number of lead-in samples, 0 otherwise.") 107 | (cdp "@c(t) if cuesheet corresponds to a Compact Disk.") 108 | (tracks "A list of tracks.")) 109 | 110 | (sera:defconstructor picture 111 | "PICTURE metadata block" 112 | (%type (integer 0 20)) 113 | (%mime-type string) 114 | (%description string) 115 | (%width (unsigned-byte 32)) 116 | (%height (unsigned-byte 32)) 117 | (%depth (unsigned-byte 32)) 118 | (%color-num (unsigned-byte 32)) 119 | (%picture (sa-ub 8))) 120 | 121 | (define-documented-accessors picture 122 | (type "One of 21 picture types (see the flac format description).") 123 | (mime-type "A string with the MIME type.") 124 | (description "Picture description (an UTF-8 coded string).") 125 | (width "Width of the picture.") 126 | (height "Height of the picture.") 127 | (depth "Color depth of the picture.") 128 | (color-num "Number of colors in an indexed picture, 0 if the picture is non-indexed.") 129 | (picture "The picture itself as an array of octets.")) 130 | 131 | (deftype metadata () 132 | '(or unknown-metadata streaminfo padding vorbis-comment seektable cuesheet picture)) 133 | 134 | ;; Subframes 135 | (deftype blocksize () 136 | "Possible size of a frame in samples." 137 | '(and (unsigned-byte 16) (not (eql 0)))) 138 | 139 | (deftype subframe () 140 | '(or subframe-constant subframe-verbatim subframe-fixed subframe-lpc)) 141 | 142 | (sera:defconstructor subframe-header 143 | (wasted-bps non-negative-fixnum) 144 | (actual-bps (integer 4 33)) 145 | (block-size blocksize)) 146 | 147 | (sera:defconstructor subframe-constant 148 | (header subframe-header) 149 | (value (sb 32))) 150 | 151 | (sera:defconstructor subframe-verbatim 152 | (header subframe-header) 153 | (data (sa-sb 32))) 154 | 155 | (sera:defconstructor subframe-lpc 156 | (header subframe-header) 157 | (order (integer 1 32)) 158 | (precision fixnum) 159 | (coeff-shift (sb 32)) 160 | (predictor-coeff (sa-sb 32)) 161 | (residual (sa-sb 32))) 162 | 163 | (sera:defconstructor subframe-fixed 164 | (header subframe-header) 165 | (order (integer 0 4)) 166 | (residual (sa-sb 32))) 167 | 168 | ;; Add 1 to values described in FLAC specs 169 | (defconstant +left-side+ #b1001 ; 1000 in spec 170 | "The encoded frame contains data for the left channel + the 171 | difference with the right channel.") 172 | (defconstant +right-side+ #b1010 ; 1001 in spec 173 | "The encoded frame contains data for the right channel + the 174 | difference with the left channel.") 175 | (defconstant +mid-side+ #b1011 ; 1010 in spec 176 | "The encoded frame contains data for the left/right average + the 177 | difference with the left/right channels.") 178 | (defconstant +max-channels+ 8) 179 | 180 | ;; Frame 181 | (sera:defconstructor frame 182 | "Atomic element of audio data in the FLAC stream" 183 | (%blocking-strategy (member :fixed :variable)) 184 | (%block-size blocksize) 185 | (%sample-rate positive-fixnum) 186 | (%channel-assignment (integer 1 11)) 187 | (%sample-size (integer 4 32)) 188 | (%number unsigned-byte) 189 | (%crc-8 (ub 8)) 190 | (%subframes list) 191 | (%crc-16 (ub 16))) 192 | 193 | 194 | ;; Document accessors 195 | (define-documented-accessors frame 196 | (blocking-strategy 197 | "Is the blocking strategy :FIXED (frame header contains the frame 198 | number) or :VARIABLE (frame header contains the sample number)?") 199 | (block-size 200 | "Block size in samples.") 201 | (sample-rate 202 | "Block sample rate in Hertz.") 203 | (channel-assignment 204 | "Number of channels or one of @c(+mid-side+), @c(+left-side+), @c(+right-side+).") 205 | (sample-size 206 | "Bits per sample.") 207 | (number 208 | "Number of a frame or of the first sample in the frame.") 209 | (crc-8 210 | "CRC8 of a frame header (including the sync code).") 211 | (subframes 212 | "List of subframes (one for each channel).") 213 | (crc-16 214 | "CRC16 of the frame (back to and including the sync code).")) 215 | 216 | (defconstant +frame-sync-code+ 16382) ; 11111111111110 217 | (defconstant +seekpoint-placeholder+ #xFFFFFFFFFFFFFFFF) 218 | (define-constant +coded-sample-rates+ 219 | '(88200 ; 0001 220 | 176400 ; 0010 221 | 192000 ; 0011 222 | 8000 ; 0100 223 | 16000 ; 0101 224 | 22050 ; 0110 225 | 24000 ; 0111 226 | 32000 ; 1000 227 | 44100 ; 1001 228 | 48000 ; 1010 229 | 96000) ; 1011 230 | :test #'equalp) 231 | 232 | (define-constant +coded-sample-sizes+ 233 | '((#b001 . 8) 234 | (#b010 . 12) 235 | (#b100 . 16) 236 | (#b101 . 20) 237 | (#b110 . 24)) 238 | :test #'equalp) 239 | -------------------------------------------------------------------------------- /flac/examples/flac2wav.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.flac-examples) 2 | 3 | ;; Works only for 8 or 16 bps 4 | (defun flac2wav (flac-name wav-name) 5 | "Decodes flac to wav. Works only for 8 or 16 bps, 6 | fixed block size and if total samples in stream is known" 7 | (with-open-flac (in-reader flac-name) 8 | (let* ((blocks (read-metadata in-reader)) 9 | (streaminfo (the streaminfo (first blocks))) 10 | (minblocksize (streaminfo-minblocksize streaminfo)) 11 | (maxblocksize (streaminfo-maxblocksize streaminfo)) 12 | (totalsamples (streaminfo-totalsamples streaminfo)) 13 | (blocksize minblocksize) 14 | (bps (streaminfo-bitspersample streaminfo)) 15 | (channels (streaminfo-channels streaminfo)) 16 | (samplerate (streaminfo-samplerate streaminfo))) 17 | 18 | (when (zerop totalsamples) 19 | (error "Number of total samples is unknown")) 20 | (when (/= minblocksize maxblocksize) 21 | (error "Block size must be fixed")) 22 | (unless (or (= 8 bps) 23 | (= 16 bps) 24 | (= 24 bps)) 25 | (error "Bps must be 8, 16 or 24")) 26 | 27 | (with-output-to-wav (out-stream wav-name 28 | :supersede t 29 | :samplerate samplerate 30 | :channels channels 31 | :bps bps 32 | :totalsamples totalsamples) 33 | (loop for i below totalsamples by blocksize 34 | for bufsize = (min (- totalsamples i) blocksize) do 35 | (write-sequence 36 | (interleave-channels (decode-frame (read-frame in-reader streaminfo))) 37 | out-stream)))))) 38 | -------------------------------------------------------------------------------- /flac/examples/ogg2wav.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.flac-examples) 2 | 3 | ;; Works only for 8 or 16 bps 4 | (defun ogg2wav (ogg-name wav-name) 5 | "Decodes flac to wav. Works only for 8 or 16 bps, 6 | fixed block size and if total samples in stream is known" 7 | (with-open-ogg-flac (in-reader ogg-name) 8 | (let* ((blocks (read-ogg-metadata in-reader)) 9 | (streaminfo (the streaminfo (first blocks))) 10 | (minblocksize (streaminfo-minblocksize streaminfo)) 11 | (maxblocksize (streaminfo-maxblocksize streaminfo)) 12 | (totalsamples (streaminfo-totalsamples streaminfo)) 13 | (blocksize minblocksize) 14 | (bps (streaminfo-bitspersample streaminfo)) 15 | (channels (streaminfo-channels streaminfo)) 16 | (samplerate (streaminfo-samplerate streaminfo))) 17 | 18 | (when (zerop totalsamples) 19 | (error "Number of total samples is unknown")) 20 | (when (/= minblocksize maxblocksize) 21 | (error "Block size must be fixed")) 22 | 23 | (unless (or (= 8 bps) 24 | (= 16 bps)) 25 | (error "Bps must be 16 or 8")) 26 | 27 | (with-output-to-wav (out-stream wav-name 28 | :supersede t 29 | :samplerate samplerate 30 | :channels channels 31 | :bps bps 32 | :totalsamples totalsamples) 33 | (loop for i below totalsamples by blocksize 34 | for bufsize = (min (- totalsamples i) blocksize) do 35 | (write-sequence 36 | (interleave-channels (decode-frame (read-ogg-frame in-reader streaminfo))) 37 | out-stream)))))) 38 | -------------------------------------------------------------------------------- /flac/examples/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.flac-examples 2 | (:use #:cl 3 | #:easy-audio.flac 4 | #:easy-audio.wav 5 | #:easy-audio.core) 6 | (:nicknames #:flac-examples) 7 | (:export #:flac2wav 8 | #:ogg2wav)) 9 | -------------------------------------------------------------------------------- /flac/flac-ogg.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.flac) 2 | 3 | (defconstant +flac-ogg-id+ #x464c4143 4 | "`FLAC' signature") 5 | 6 | (defun open-ogg-flac (stream) 7 | "Return a @c(bitreader) handler of an ogg-encapsulated flac stream." 8 | (ogg:open-ogg stream)) 9 | 10 | (defmacro with-open-ogg-flac ((reader name &rest options) &body body) 11 | "A helper macro like @c(with-open-file). @c(reader) can be used as 12 | an argument to @c(read-ogg-metadata) or @c(read-ogg-frame) inside this 13 | macro." 14 | (let ((stream (gensym))) 15 | `(let* ((,stream (apply #'open ,name :element-type '(ub 8) ,options)) 16 | (,reader (open-ogg-flac ,stream))) 17 | (unwind-protect (progn ,@body) (close ,stream))))) 18 | 19 | (defun read-ogg-metadata (reader) 20 | "Return a list of metadata in an ogg-encapsulated stream." 21 | (let* ((packet (ogg:read-packet reader)) 22 | (packet-reader (make-reader-from-buffer packet))) 23 | (unless (and (ogg:ogg-bos reader) 24 | (= #x7f (read-octet packet-reader)) 25 | (= +flac-ogg-id+ (read-octets 4 packet-reader))) 26 | (error 'flac-error :format-control "The first page of stream is invalid")) 27 | ;; Major and minor versions of the mapping 28 | (read-octets 2 packet-reader) 29 | (let ((non-audio-packets (read-octets 2 packet-reader))) 30 | (unless (= +flac-id+ (read-octets 4 packet-reader)) 31 | (error 'flac-error :format-control "The stream is not a flac stream")) 32 | (let ((first-metadata (read-metadata-block packet-reader))) 33 | (unless (ogg:fresh-page reader) 34 | (error 'flac-error :format-control "There are other packets on the first page")) 35 | (let ((rest-metadata 36 | (loop repeat non-audio-packets 37 | for packet = (ogg:read-packet reader) 38 | for packet-reader = (make-reader-from-buffer packet) 39 | collect (read-metadata-block packet-reader)))) 40 | (unless (ogg:fresh-page reader) 41 | (error 'flac-error :format-control "Audio data must begin with a fresh page")) 42 | (cons first-metadata rest-metadata)))))) 43 | 44 | (defun read-ogg-frame (reader &optional streaminfo) 45 | "Read a flac frame from an ogg container." 46 | (let* ((packet (ogg:read-packet reader)) 47 | (packet-reader (make-reader-from-buffer 48 | packet 49 | #+easy-audio-check-crc 50 | :crc-fun 51 | #+easy-audio-check-crc 52 | #'crc-0-8005))) 53 | (read-frame packet-reader streaminfo))) 54 | -------------------------------------------------------------------------------- /flac/flac-reader.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.flac) 2 | 3 | (sera:-> unsigned-to-signed ((ub 32) (integer 0 32)) 4 | (values (sb 32) &optional)) 5 | (declaim (inline unsigned-to-signed)) 6 | (defun unsigned-to-signed (byte len) 7 | (let ((sign-mask (ash 1 (1- len)))) 8 | (if (< byte sign-mask) 9 | byte 10 | (- byte (ash sign-mask 1))))) 11 | 12 | (sera:-> read-bits-array (reader (sa-sb 32) non-negative-fixnum &key 13 | (:signed boolean) 14 | (:len non-negative-fixnum) 15 | (:offset non-negative-fixnum)) 16 | (values (sa-sb 32) &optional)) 17 | (defun read-bits-array (stream array size &key 18 | signed 19 | (len (length array)) 20 | (offset 0)) 21 | (declare (optimize (speed 3))) 22 | (loop for i from offset below len 23 | for val = (read-bits size stream) do 24 | (setf (aref array i) 25 | (if signed (unsigned-to-signed val size) val))) 26 | array) 27 | 28 | ;; TODO: rewrite 29 | (sera:-> read-utf8-u32 (reader) 30 | (values (ub 32) &optional)) 31 | (defun read-utf8-u32 (stream) 32 | "Read frame number from a stream" 33 | (declare (optimize (speed 3))) 34 | (labels ((nbytes (x) 35 | (cond 36 | (( = 0 (logand x #x80)) 37 | (values x 0)) 38 | ((and 39 | ( = 0 (logand x #x20)) 40 | (/= 0 (logand x #xC0))) 41 | (values (logand x #x1F) 1)) 42 | ((and 43 | ( = 0 (logand x #x10)) 44 | (/= 0 (logand x #xE0))) 45 | (values (logand x #x0F) 2)) 46 | ((and 47 | ( = 0 (logand x #x08)) 48 | (/= 0 (logand x #xF0))) 49 | (values (logand x #x07) 3)) 50 | ((and 51 | ( = 0 (logand x #x04)) 52 | (/= 0 (logand x #xF8))) 53 | (values (logand x #x03) 4)) 54 | ((and 55 | ( = 0 (logand x #x02)) 56 | (/= 0 (logand x #xFC))) 57 | (values (logand x #x01) 5)) 58 | (t (error 'flac-bad-frame 59 | :format-control "Error reading utf-8 coded value")))) 60 | (decode (v n) 61 | (if (zerop n) v 62 | (let ((x (read-octet stream))) 63 | (when (or (zerop (logand x #x80)) 64 | (not (zerop (logand x #x40)))) 65 | (error 'flac-bad-frame 66 | :format-control "Error reading utf-8 coded value")) 67 | (decode (logior (ash v 6) (logand x #x3f)) 68 | (1- n)))))) 69 | (declare (ftype (function ((ub 32) (integer 0 5)) (values (ub 32) &optional)) decode)) 70 | (multiple-value-call #'decode (nbytes (read-octet stream))))) 71 | 72 | (sera:-> read-rice-signed (reader (integer 0 30)) 73 | (values (sb 32) &optional)) 74 | (defun read-rice-signed (bitreader param) 75 | "Read signed rice-coded value" 76 | (declare (optimize (speed 3))) 77 | (let* ((unary (count-zeros bitreader)) 78 | (binary (read-bits param bitreader)) 79 | (val (logior (ash unary param) binary))) 80 | (declare (type (ub 32) unary)) 81 | (if (zerop (logand val 1)) 82 | (ash val -1) 83 | (- -1 (ash val -1))))) 84 | 85 | (sera:-> restore-sync (reader &optional (or streaminfo null)) 86 | (values unsigned-byte &optional)) 87 | (defun restore-sync (bitreader &optional streaminfo) 88 | "Restores lost sync and returns number of frame to be read" 89 | (declare (optimize (speed 3))) 90 | ;; Make sure, we are byte aligned. We must be, but anyway 91 | (read-to-byte-alignment bitreader) 92 | ;; Search first #xff octet 93 | (peek-octet bitreader #xff) 94 | (let ((pos (reader-position bitreader))) 95 | (handler-case 96 | (prog1 97 | (frame-number (read-frame bitreader streaminfo)) 98 | (reader-position bitreader pos)) 99 | (flac-bad-frame () 100 | (reader-position bitreader (1+ pos)) 101 | (restore-sync bitreader streaminfo))))) 102 | -------------------------------------------------------------------------------- /flac/flac.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.flac) 2 | 3 | (defconstant +flac-id+ #x664C6143) ; "fLaC" 4 | 5 | (defun fix-stream-position/start (bitreader header) 6 | "Set stream position to end of the malformed metadata block" 7 | (reader-position 8 | bitreader 9 | (+ (metadata-header-start-position header) 4))) 10 | 11 | (defun fix-stream-position/end (bitreader header) 12 | "Set stream position to end of the malformed metadata block" 13 | (reader-position 14 | bitreader 15 | (+ (metadata-header-start-position header) 16 | (metadata-header-length header) 17 | 4))) 18 | 19 | (defun open-flac (stream) 20 | "Return @c(bitreader) handler of flac stream" 21 | (make-reader :stream stream 22 | #+easy-audio-check-crc 23 | :crc-fun 24 | #+easy-audio-check-crc 25 | #'crc-0-8005)) 26 | 27 | (defmacro with-open-flac ((reader name &rest options) &body body) 28 | "A helper macro like WITH-OPEN-FILE. READER can be used as an 29 | argument to READ-METADATA or READ-FRAME inside this macro." 30 | (let ((stream (gensym))) 31 | `(let* ((,stream (open ,name :element-type '(ub 8) ,@options)) 32 | (,reader (open-flac ,stream))) 33 | (unwind-protect (progn ,@body) (close ,stream))))) 34 | 35 | (defun read-metadata (bitreader) 36 | "Return list of metadata blocks in the stream" 37 | ;; Checking if stream is a flac stream 38 | (unless (= +flac-id+ (read-octets 4 bitreader)) 39 | (error 'flac-error :format-control "This stream is not a flac stream")) 40 | 41 | (do (last-block metadata-list) 42 | (last-block (reverse metadata-list)) 43 | (setq last-block 44 | (with-interactive-debug 45 | (restart-case 46 | (multiple-value-bind (metadata last-block-p) 47 | (read-metadata-block bitreader) 48 | (push metadata metadata-list) 49 | last-block-p) 50 | 51 | (skip-malformed-metadata (c) 52 | :interactive (lambda () (list *current-condition*)) 53 | :report "Skip malformed metadata" 54 | (let ((header (flac-metadata c))) 55 | (fix-stream-position/end bitreader header) 56 | (metadata-header-last-block-p header))) 57 | 58 | (read-raw-block (c) 59 | :interactive (lambda () (list *current-condition*)) 60 | :report "Interprete as unknown metadata block" 61 | (let ((header (flac-metadata c))) 62 | (fix-stream-position/start bitreader header) 63 | (push (read-body-unknown bitreader header) metadata-list) 64 | (metadata-header-last-block-p header)))))))) 65 | -------------------------------------------------------------------------------- /flac/metadata.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.flac) 2 | 3 | ;; READ-OCTETS can read mostly 4 octets at once 4 | (sera:-> read-eight-octets (reader) 5 | (values (unsigned-byte 64) &optional)) 6 | (declaim (inline read-eight-octets)) 7 | (defun read-eight-octets (stream) 8 | (logior (ash (read-octets 4 stream) 32) 9 | (ash (read-octets 4 stream) 0))) 10 | 11 | (declaim (inline check-reserved-field)) 12 | (defun check-reserved-field (x metadata string) 13 | (unless (or (and (numberp x) (zerop x)) 14 | (and (arrayp x) (every #'zerop x))) 15 | (error 'flac-bad-metadata 16 | :format-control string 17 | :metadata metadata)) 18 | x) 19 | 20 | (sera:-> read-metadata-header (reader) 21 | (values metadata-header &optional)) 22 | (defun read-metadata-header (stream) 23 | "Returns (values START-POSITION LAST-BLOCK-P TYPE LENGTH)" 24 | (metadata-header (reader-position stream) 25 | (not (zerop (read-bit stream))) 26 | (read-bits 7 stream) 27 | (read-bits 24 stream))) 28 | 29 | (sera:-> read-body-dummy (reader metadata-header) 30 | (values &optional)) 31 | (defun read-body-dummy (reader header) 32 | (declare (ignore reader)) 33 | (error 'flac-bad-metadata 34 | :format-control "Unknown metadata block" 35 | :metadata header) 36 | (values)) 37 | 38 | (sera:-> read-body-unknown (reader metadata-header) 39 | (values unknown-metadata &optional)) 40 | (defun read-body-unknown (reader header) 41 | (unknown-metadata 42 | (read-octet-vector/new 43 | (metadata-header-length header) 44 | reader))) 45 | 46 | (sera:-> read-body-streaminfo (reader metadata-header) 47 | (values streaminfo &optional)) 48 | (defreader* (read-body-streaminfo streaminfo () (header)) 49 | (declare (ignore header)) 50 | (streaminfo-minblocksize (:octets 2)) 51 | (streaminfo-maxblocksize (:octets 2)) 52 | (streaminfo-minframesize (:octets 3)) 53 | (streaminfo-maxframesize (:octets 3)) 54 | (streaminfo-samplerate (:bits 20)) 55 | (streaminfo-channels (:bits 3) :function 1+) 56 | (streaminfo-bitspersample (:bits 5) :function 1+) 57 | (streaminfo-totalsamples (:bits 36)) 58 | (streaminfo-md5 (:octet-vector 16))) 59 | 60 | (sera:-> read-body-padding (reader metadata-header) 61 | (values padding &optional)) 62 | (defreader* (read-body-padding padding () (header)) 63 | (padding (:octet-vector (metadata-header-length header)) 64 | :lambda ((x) (check-reserved-field 65 | x header 66 | "Padding bytes are not zero")) 67 | :ignore t)) 68 | 69 | (sera:-> read-body-vorbis-comment (reader metadata-header) 70 | (values vorbis-comment &optional)) 71 | (defun read-body-vorbis-comment (stream header) 72 | (declare (ignore header)) 73 | (flet ((read-comment-string (stream) 74 | (let ((buffer (read-octet-vector/new 75 | (read-bits 32 stream :endianness :little) 76 | stream))) 77 | (flexi-streams:octets-to-string 78 | buffer :external-format :utf-8)))) 79 | (vorbis-comment 80 | (read-comment-string stream) 81 | (let ((comments-num (read-bits 32 stream :endianness :little))) 82 | (loop for i below comments-num collect 83 | (read-comment-string stream)))))) 84 | 85 | (sera:-> read-body-seektable (reader metadata-header) 86 | (values seektable &optional)) 87 | (defun read-body-seektable (stream header) 88 | (flet ((read-seekpoint (stream) 89 | (let ((samplenum (read-eight-octets stream))) 90 | (if (/= samplenum +seekpoint-placeholder+) 91 | (let ((offset (read-eight-octets stream)) 92 | (samples-in-frame (read-bits 16 stream))) 93 | (seekpoint samplenum offset samples-in-frame)))))) 94 | (multiple-value-bind (seekpoints-num remainder) 95 | (floor (metadata-header-length header) 18) 96 | (check-reserved-field remainder header "Bad seektable") 97 | (seektable 98 | (loop for i below seekpoints-num collect 99 | (read-seekpoint stream)))))) 100 | 101 | (sera:-> read-cuesheet-string ((sa-ub 8)) 102 | (values string &optional)) 103 | (defun read-cuesheet-string (vector) 104 | (let ((pos (position 0 vector))) 105 | (flexi-streams:octets-to-string 106 | (subseq vector 0 pos)))) 107 | 108 | (defreader* (read-cuesheet-index cuesheet-index () (data)) 109 | (offset (:custom read-eight-octets)) 110 | (number (:octet)) 111 | (reserved (:bits 24) 112 | :lambda ((x) (check-reserved-field x data "Bad cuesheet index")) 113 | :ignore t)) 114 | 115 | (defreader* (read-cuesheet-track cuesheet-track () (data)) 116 | (offset (:custom read-eight-octets)) 117 | (number (:octet)) 118 | (isrc (:octet-vector 12) 119 | :function read-cuesheet-string) 120 | (type (:bit) :lambda ((x) (if (zerop x) :audio :non-audio))) 121 | (pre-emphasis (:bit) :lambda ((x) (not (zerop x)))) 122 | (reserved1 (:bits 6) 123 | :lambda ((x) (check-reserved-field x data "Bad cuesheet track")) 124 | :ignore t) 125 | (reserved2 (:octet-vector 13) 126 | :lambda ((x) (check-reserved-field x data "Bad cuesheet track")) 127 | :ignore t) 128 | (indices (:custom (lambda (r) (loop repeat (read-octet r) collect 129 | (read-cuesheet-index r data)))))) 130 | 131 | (sera:-> read-body-cuesheet (reader metadata-header) 132 | (values cuesheet &optional)) 133 | (defreader* (read-body-cuesheet cuesheet () (data)) 134 | (catalog-id (:octet-vector 128) 135 | :function read-cuesheet-string) 136 | (lead-in (:custom read-eight-octets)) 137 | (cdp (:bit) 138 | :lambda ((x) (not (zerop x)))) 139 | (reserved1 (:bits 7) 140 | :lambda ((x) (check-reserved-field x data "Bad cuesheet")) 141 | :ignore t) 142 | (reserved2 (:octet-vector 258) 143 | :lambda ((x) (check-reserved-field x data "Bad cuesheet")) 144 | :ignore t) 145 | (tracks (:custom (lambda (r) (loop repeat (read-octet r) collect 146 | (read-cuesheet-track r data)))))) 147 | 148 | (sera:-> read-body-picture (reader metadata-header) 149 | (values picture &optional)) 150 | (defreader* (read-body-picture picture () (header)) 151 | (type (:octets 4) 152 | :lambda 153 | ((x) 154 | (unless (<= x 20) 155 | (error 'flac-bad-metadata 156 | :format-control "Bad picture type" 157 | :metadata header)) 158 | x)) 159 | (mime-type-len (:octets 4) :skip t) 160 | (mime-type (:octet-vector mime-type-len) 161 | :lambda 162 | ((xs) 163 | (unless (every 164 | #'(lambda (char) 165 | (and (>= char #x20) 166 | (<= char #x7e))) 167 | xs) 168 | (error 'flac-bad-metadata 169 | :format-control "MIME type must be an ASCII string" 170 | :metadata header)) 171 | (flexi-streams:octets-to-string xs))) 172 | (description-len (:octets 4) :skip t) 173 | (description (:octet-vector description-len) 174 | :lambda ((xs) (flexi-streams:octets-to-string 175 | xs :external-format :utf-8))) 176 | (width (:octets 4)) 177 | (height (:octets 4)) 178 | (depth (:octets 4)) 179 | (color-num (:octets 4)) 180 | (picture-len (:octets 4) :skip t) 181 | (picture (:octet-vector picture-len))) 182 | 183 | (defparameter *block-readers* 184 | `((0 . ,#'read-body-streaminfo) 185 | (1 . ,#'read-body-padding) 186 | (3 . ,#'read-body-seektable) 187 | (4 . ,#'read-body-vorbis-comment) 188 | (5 . ,#'read-body-cuesheet) 189 | (6 . ,#'read-body-picture))) 190 | 191 | (sera:-> get-metadata-reader (integer) 192 | (values (sera:-> (reader metadata-header) (values metadata &optional)) &optional)) 193 | (defun get-metadata-reader (code) 194 | "Get metadata reader by its type code" 195 | (let ((reader (assoc code *block-readers*))) 196 | (if reader (cdr reader) #'read-body-dummy))) 197 | 198 | (sera:-> read-metadata-block (reader) 199 | (values metadata boolean &optional)) 200 | (defun read-metadata-block (stream) 201 | "Read one metadata block from STREAM" 202 | (let* ((header (read-metadata-header stream)) 203 | (reader (get-metadata-reader (metadata-header-type header)))) 204 | (values 205 | (funcall reader stream header) 206 | (metadata-header-last-block-p header)))) 207 | 208 | (serapeum:-> metadata-find-seektable (list) 209 | (values (or null seektable) &optional)) 210 | (defun metadata-find-seektable (metadata) 211 | "Return a seektable from metadata list if any" 212 | (find 'seektable metadata :key #'type-of)) 213 | -------------------------------------------------------------------------------- /flac/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.flac 2 | (:use #:cl 3 | #:easy-audio.bitreader 4 | #:easy-audio.core 5 | #:alexandria) 6 | (:local-nicknames (:sera :serapeum) 7 | (:ogg :easy-audio.ogg)) 8 | (:export #:streaminfo ; Metadata 9 | #:streaminfo-minblocksize 10 | #:streaminfo-maxblocksize 11 | #:streaminfo-minframesize 12 | #:streaminfo-maxframesize 13 | #:streaminfo-samplerate 14 | #:streaminfo-channels 15 | #:streaminfo-bitspersample 16 | #:streaminfo-totalsamples 17 | #:streaminfo-md5 18 | 19 | #:seekpoint 20 | #:seekpoint-samplenum 21 | #:seekpoint-offset 22 | #:seekpoint-samples-in-frame 23 | #:seektable 24 | #:seektable-seekpoints 25 | 26 | #:vorbis-comment 27 | #:vorbis-comment-vendor 28 | #:vorbis-comment-user 29 | 30 | #:cuesheet 31 | #:cuesheet-catalog-id 32 | #:cuesheet-lead-in 33 | #:cuesheet-cdp 34 | #:cuesheet-tracks 35 | 36 | #:cuesheet-track 37 | #:cuesheet-track-offset 38 | #:cuesheet-track-number 39 | #:cuesheet-track-isrc 40 | #:cuesheet-track-type 41 | #:cuesheet-track-pre-emphasis 42 | #:cuesheet-track-indices 43 | 44 | #:cuesheet-index 45 | #:cuesheet-index-offset 46 | #:cuesheet-index-number 47 | 48 | #:picture 49 | #:picture-type 50 | #:picture-mime-type 51 | #:picture-description 52 | #:picture-width 53 | #:picture-height 54 | #:picture-depth 55 | #:picture-color-num 56 | #:picture-picture 57 | 58 | ;; And so on with metadata classes 59 | ;; Frame and its slots 60 | #:blocksize 61 | #:frame 62 | #:frame-streaminfo 63 | #:frame-blocking-strategy 64 | #:frame-block-size 65 | #:frame-sample-rate 66 | #:frame-channel-assignment 67 | #:frame-sample-size 68 | #:frame-number 69 | #:frame-crc-8 70 | #:frame-subframes 71 | #:frame-crc-16 72 | 73 | ;; Functions 74 | #:open-flac 75 | #:read-metadata 76 | #:read-frame 77 | #:open-ogg-flac 78 | #:read-ogg-metadata 79 | #:read-ogg-frame 80 | #:decode-frame 81 | #:seek-sample 82 | #:metadata-find-seektable 83 | 84 | ;; Macros 85 | #:with-open-flac 86 | #:with-open-ogg-flac 87 | 88 | ;; Conditions 89 | #:flac-error 90 | #:flac-bad-metadata 91 | #:flac-bad-frame 92 | 93 | ;; Restarts 94 | #:skip-malformed-metadata 95 | #:skip-malformed-frame 96 | #:stop-reading-frame 97 | #:read-raw-block)) 98 | -------------------------------------------------------------------------------- /general-decoders/g.711.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.general) 2 | 3 | (declaim (optimize (speed 3))) 4 | 5 | (declaim (ftype (function ((ub 8)) (sb 16)) g.711-alaw-decode)) 6 | (defun g.711-alaw-decode (coded-value) 7 | "Decode 8-bit unsigned A-law coded data to 16-bit signed data" 8 | (let* ((toggled-bits (logxor coded-value #x55)) 9 | (mantissa (ldb (byte 4 0) toggled-bits)) 10 | (exp (ldb (byte 3 4) toggled-bits)) 11 | (res 12 | (if (= exp 0) (+ (ash mantissa 4) #x8) 13 | (ash (+ (ash mantissa 4) #x108) 14 | (1- exp))))) 15 | 16 | (if (> coded-value #x7f) res (- res)))) 17 | 18 | (declaim (ftype (function ((ub 8)) (sb 16)) g.711-ulaw-decode)) 19 | (defun g.711-ulaw-decode (coded-value) 20 | "Decode 8-bit unsigned mu-law coded data to 16-bit signed data" 21 | (let* ((inv (- #xff coded-value)) 22 | (exp (ldb (byte 3 4) inv)) 23 | (mantissa (ldb (byte 4 0) inv)) 24 | (res (ash (+ (ash mantissa 3) #x84) exp))) 25 | 26 | (if (> coded-value #x7f) 27 | (- res #x84) 28 | (- #x84 res)))) 29 | -------------------------------------------------------------------------------- /general-decoders/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :easy-audio.general 2 | (:use #:cl #:easy-audio.core) 3 | (:export #:g.711-alaw-decode 4 | #:g.711-ulaw-decode)) 5 | -------------------------------------------------------------------------------- /ogg/ogg.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.ogg) 2 | 3 | (define-condition ogg-error (error simple-condition) () 4 | (:report (lambda (c s) 5 | (apply #'format s 6 | (concatenate 'string "General ogg error: " 7 | (simple-condition-format-control c)) 8 | (simple-condition-format-arguments c)))) 9 | (:documentation "General (unspecified) ogg error")) 10 | 11 | (defconstant +ogg-page-id+ #x4f676753 12 | "OggS page identificator") 13 | (defconstant +continued-packet+ #b1 14 | "Continued packet flag") 15 | (defconstant +begining-of-stream+ #b10 16 | "First page of logical bitstream") 17 | (defconstant +end-of-stream+ #b100 18 | "Last page of logical bitstream") 19 | 20 | (defstruct (ogg-reader (:conc-name #:ogg-) 21 | (:include reader)) 22 | (is-continued nil :type boolean) 23 | (bos nil :type boolean) 24 | (eos nil :type boolean) 25 | (granule-position 0 :type (or (integer -1 -1) 26 | non-negative-integer)) 27 | (stream-serial 0 :type (ub 32)) 28 | (page-number 0 :type (ub 32)) 29 | #+easy-audio-check-crc 30 | (page-crc 0 :type (ub 32)) 31 | (segment-table nil :type list) 32 | (will-be-continued nil :type boolean) 33 | (reader-position 0 :type (ub 8))) 34 | 35 | 36 | (defun read-ogg-segment-table (reader segments) 37 | "Read an OGG page segment table and return two values: 38 | lengths of packets on this page and a boolean value. 39 | If this value is T the last packet will be continued on 40 | the next page" 41 | (loop for segment below segments 42 | for lacing-val = (read-octet reader) 43 | sum lacing-val into segment-len 44 | when (< lacing-val 255) collect 45 | (prog1 46 | segment-len 47 | (setq segment-len 0)) 48 | into packet-sizes 49 | finally 50 | (return 51 | (if (= lacing-val 255) 52 | (values (append packet-sizes (list segment-len)) t) 53 | (values packet-sizes nil))))) 54 | 55 | (defun read-page-header (reader) 56 | "Read OGG page header" 57 | #+easy-audio-check-crc 58 | (init-crc reader) 59 | (unless (= (read-octets 4 reader) +ogg-page-id+) 60 | (error 'ogg-error :format-control "Wrong page ID")) 61 | (unless (zerop (read-octet reader)) 62 | (error 'ogg-error :format-control "Wrong stream structure version")) 63 | (let* ((flags (read-octet reader)) 64 | (is-continued (/= 0 (logand flags +continued-packet+))) 65 | (bos (not (zerop (logand flags +begining-of-stream+)))) 66 | (eos (not (zerop (logand flags +end-of-stream+))))) 67 | 68 | (setf (ogg-is-continued reader) is-continued 69 | (ogg-bos reader) bos 70 | (ogg-eos reader) eos 71 | 72 | (ogg-granule-position reader) 73 | (logior (ash (read-octets 2 reader :endianness :little) 0) 74 | (ash (read-octets 2 reader :endianness :little) 16) 75 | (ash (read-octets 2 reader :endianness :little) 24) 76 | (ash (read-octets 2 reader :endianness :little) 32)) 77 | 78 | (ogg-stream-serial reader) (read-octets 4 reader :endianness :little) 79 | (ogg-page-number reader) (read-octets 4 reader :endianness :little) 80 | (ogg-reader-position reader) 0)) 81 | 82 | #+easy-audio-check-crc 83 | (setf (ogg-page-crc reader) 84 | (let ((*read-with-zeroing* t)) 85 | (read-octets 4 reader :endianness :little))) 86 | #-easy-audio-check-crc 87 | (read-octets 4 reader) 88 | 89 | (let ((segments (read-octet reader))) 90 | (multiple-value-bind (segment-table will-be-continued) 91 | (read-ogg-segment-table reader segments) 92 | (setf (ogg-segment-table reader) segment-table 93 | (ogg-will-be-continued reader) will-be-continued)))) 94 | 95 | (defun read-packet-pages (reader &optional previous-page-num pages) 96 | "Read n chunks of a packet where n is a number of pages the packet belongs to" 97 | (with-accessors ((segment-table ogg-segment-table) 98 | (position ogg-reader-position)) reader 99 | 100 | (when (= position (length segment-table)) 101 | (read-page-header reader)) 102 | 103 | (unless (or (not previous-page-num) 104 | (and (= (- (ogg-page-number reader) 105 | previous-page-num) 106 | 1) 107 | (ogg-is-continued reader))) 108 | (error 'ogg-error :format-control "Lost sync")) 109 | 110 | (let ((packet (make-array (nth position segment-table) :element-type '(ub 8)))) 111 | (read-octet-vector packet reader) 112 | (incf position) 113 | #+easy-audio-check-crc 114 | (when (and (= position (length segment-table)) 115 | (/= (ogg-page-crc reader) (get-crc reader))) 116 | (error 'ogg-error :format-control "CRC mismatch")) 117 | (if (and (ogg-will-be-continued reader) 118 | (= position (length segment-table))) 119 | (read-packet-pages reader 120 | (ogg-page-number reader) 121 | (cons packet pages)) 122 | (cons packet pages))))) 123 | 124 | (defun read-packet (reader) 125 | "Reads a packet from OGG stream" 126 | (let ((segments (read-packet-pages reader))) 127 | (if (= (length segments) 1) (car segments) 128 | (let ((packet (make-array (reduce #'+ segments :key #'length) 129 | :element-type '(ub 8)))) 130 | (loop with start = 0 131 | for segment in (nreverse segments) do 132 | (setq packet (replace packet segment :start1 start) 133 | start (+ start (length segment)))) 134 | packet)))) 135 | 136 | (defun fresh-page (reader) 137 | "Returns T if no packets were read on this page yet" 138 | (let ((position (ogg-reader-position reader))) 139 | (or (= position (length (ogg-segment-table reader))) 140 | (= position 0)))) 141 | 142 | (defun open-ogg (stream) 143 | (make-ogg-reader :stream stream 144 | #+easy-audio-check-crc 145 | :crc-fun 146 | #+easy-audio-check-crc 147 | #'crc-0-04c11db7)) 148 | 149 | (defun restore-sync (reader) 150 | "restore sync bringing a reader position to 151 | the beginning of a new page" 152 | (read-to-byte-alignment reader) 153 | ;; Reset Ogg reader state 154 | (setf (ogg-segment-table reader) nil 155 | (ogg-reader-position reader) 0) 156 | (peek-octet reader #x4f) ; Letter "O" in OggS 157 | (let ((pos (reader-position reader))) 158 | (handler-case 159 | (progn 160 | (read-packet-pages reader) 161 | (reader-position reader pos)) 162 | (ogg-error () 163 | (reader-position reader (1+ pos)) 164 | (restore-sync reader))))) 165 | -------------------------------------------------------------------------------- /ogg/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.ogg 2 | (:use #:cl 3 | #:easy-audio.core 4 | #:easy-audio.bitreader 5 | #:alexandria) 6 | (:export #:read-packet 7 | #:fresh-page 8 | #:open-ogg 9 | #:restore-sync 10 | 11 | #:ogg-is-continued 12 | #:ogg-bos 13 | #:ogg-eos 14 | #:ogg-granule-position 15 | #:ogg-stream-serial 16 | #:ogg-page-number 17 | #:ogg-will-be-continued)) 18 | -------------------------------------------------------------------------------- /tests/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio-tests 2 | (:use :cl :fiveam :flexi-streams) 3 | (:local-nicknames (:core :easy-audio.core) 4 | (:bitreader :easy-audio.bitreader) 5 | (:flac :easy-audio.flac) 6 | (:wv :easy-audio.wv) 7 | (:ogg :easy-audio.ogg) 8 | (:ape :easy-audio.ape) 9 | (:general :easy-audio.general)) 10 | (:export #:run-tests)) 11 | -------------------------------------------------------------------------------- /tests/sample-mono.ape: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-mono.ape -------------------------------------------------------------------------------- /tests/sample-mono.flac: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-mono.flac -------------------------------------------------------------------------------- /tests/sample-mono.oga: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-mono.oga -------------------------------------------------------------------------------- /tests/sample-mono.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-mono.wav -------------------------------------------------------------------------------- /tests/sample-mono.wv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-mono.wv -------------------------------------------------------------------------------- /tests/sample-stereo-low.flac: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-stereo-low.flac -------------------------------------------------------------------------------- /tests/sample-stereo.ape: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-stereo.ape -------------------------------------------------------------------------------- /tests/sample-stereo.flac: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-stereo.flac -------------------------------------------------------------------------------- /tests/sample-stereo.oga: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-stereo.oga -------------------------------------------------------------------------------- /tests/sample-stereo.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-stereo.wav -------------------------------------------------------------------------------- /tests/sample-stereo.wv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample-stereo.wv -------------------------------------------------------------------------------- /tests/sample32-mono.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample32-mono.wav -------------------------------------------------------------------------------- /tests/sample32-mono.wv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample32-mono.wv -------------------------------------------------------------------------------- /tests/sample32-stereo.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample32-stereo.wav -------------------------------------------------------------------------------- /tests/sample32-stereo.wv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample32-stereo.wv -------------------------------------------------------------------------------- /tests/sample32-upsample.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample32-upsample.wav -------------------------------------------------------------------------------- /tests/sample32-upsample.wv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shamazmazum/easy-audio/615534128299e5d198c8ba19ab260dfca54922bc/tests/sample32-upsample.wv -------------------------------------------------------------------------------- /tests/tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio-tests) 2 | 3 | (def-suite bitreader :description "Bitreader tests") 4 | (def-suite flac :description "Flac decoder tests") 5 | (def-suite ogg :description "OGG container tests") 6 | (def-suite decoders :description "General decoders tests") 7 | (def-suite wavpack :description "Wavpack tests") 8 | (def-suite ape :description "Ape tests") 9 | (def-suite core :description "Core tests") 10 | 11 | (defun prepare-input (&rest args) 12 | (apply #'concatenate 13 | 'vector 14 | (mapcar (lambda (elem) 15 | (if (atom elem) (list elem) elem)) 16 | args))) 17 | 18 | ;; Can it be done with FiveAM itself? 19 | ;; Maybe it's good idea to create suite registry here? 20 | (defun run-tests () 21 | "Run all tests and return T if all tests have passed" 22 | (every #'identity 23 | (mapcar (lambda (suite) 24 | (let ((status (run suite))) 25 | (explain! status) 26 | (results-status status))) 27 | '(bitreader flac ogg decoders wavpack ape core)))) 28 | 29 | (in-suite bitreader) 30 | (test bitreader-tests 31 | "Test low-level bitreader functions" 32 | (with-input-from-sequence (input #(1 2 3 128 129 4 1 2 #xc5 #x00 #x0c)) 33 | ;; Set internal buffer size low to check buffer refill 34 | (let ((bitreader::*buffer-size* 3) 35 | (reader (bitreader:make-reader :stream input))) 36 | ;; "Not associated with file" blah-blah 37 | ;; (is (= (bitreader:reader-length reader) 6)) 38 | (is (= (bitreader:read-octet reader) 1)) 39 | (is (= (bitreader:read-bits 16 reader) 515)) 40 | (is (= (bitreader:reader-position reader) 3)) 41 | (is (= (bitreader:read-bit reader) 1)) 42 | (is (= (bitreader:read-bit reader) 0)) 43 | (is (= (bitreader:read-to-byte-alignment reader) 0)) 44 | (is (= (bitreader:read-bit reader) 1)) 45 | (is (= (bitreader:read-to-byte-alignment reader) 1)) 46 | (is (= (bitreader:read-bits 8 reader) 4)) 47 | (is (= (bitreader:read-octets 2 reader) 258)) 48 | ;; Test zero counter 49 | (is (= (bitreader:read-bits 2 reader) 3)) 50 | (is (= (bitreader:count-zeros reader) 3)) 51 | (is (= (bitreader:read-bits 2 reader) 1)) 52 | ;; And with multiple octets 53 | (is (= (bitreader:count-zeros reader) 12)) 54 | (is (= (bitreader:read-to-byte-alignment reader) 4))))) 55 | 56 | (test reader-position 57 | "Test READER-POSITION function" 58 | (with-input-from-sequence (input #(1 2 3 4 5 6 7 8 9 10)) 59 | ;; Set internal buffer size low to check buffer refill 60 | (let ((bitreader::*buffer-size* 4) 61 | (reader (bitreader:make-reader :stream input))) 62 | (is (= (bitreader:read-octet reader) 1)) 63 | (is (= (bitreader:reader-position reader) 1)) 64 | (is (= (bitreader:read-octet reader) 2)) 65 | (is (= (bitreader:reader-position reader) 2)) 66 | ;; Short jump backwards 67 | (bitreader:reader-position reader 1) 68 | (is (= (bitreader:read-octet reader) 2)) 69 | (is (= (bitreader:reader-position reader) 2)) 70 | ;; Short jump forwards 71 | (bitreader:reader-position reader 3) 72 | (is (= (bitreader:read-octet reader) 4)) 73 | (is (= (bitreader:reader-position reader) 4)) 74 | ;; Long jump forwards 75 | (bitreader:reader-position reader 9) 76 | (is (= (bitreader:read-octet reader) 10)) 77 | (is (= (bitreader:reader-position reader) 10)) 78 | ;; Long jump backwards 79 | (bitreader:reader-position reader 2) 80 | (is (= (bitreader:read-octet reader) 3)) 81 | (is (= (bitreader:reader-position reader) 3))))) 82 | 83 | (test bitreader-little-endian 84 | "Test low-level bitreader functions" 85 | (with-input-from-sequence (input #(2 1 3 128)) 86 | ;; Set internal buffer size low to check buffer refill 87 | (let ((bitreader::*buffer-size* 3) 88 | (reader (bitreader:make-reader :stream input))) 89 | ;; "Not associated with file" blah-blah 90 | ;; (is (= (bitreader:reader-length reader) 6)) 91 | (is (= (bitreader:read-octets 2 reader :endianness :little) 258)) 92 | (is (= (bitreader:read-bits 16 reader :endianness :little) 32771))))) 93 | 94 | #+easy-audio-check-crc 95 | (test bitreader-check-crc 96 | "Check CRC functions" 97 | (let ((funcs-and-crcs (list (cons #'bitreader:crc-0-8005 #x0c1e) 98 | (cons #'bitreader:crc-0-04c11db7 #xac691451)))) 99 | (loop for (func . crc) in funcs-and-crcs do 100 | (with-input-from-sequence (input #(1 2 3)) 101 | ;; Set internal buffer size low to check buffer refill 102 | (let ((reader (bitreader:make-reader :stream input 103 | :crc-fun func))) 104 | (bitreader:init-crc reader) 105 | (bitreader:read-octet reader) 106 | (bitreader:read-octet reader) 107 | (bitreader:read-octet reader) 108 | (is (= crc (bitreader:get-crc reader)))))))) 109 | 110 | (in-suite flac) 111 | (test flac-decode 112 | "Decode flac audio" 113 | (flet ((check-file (wav flac) 114 | (let ((tmp-name (asdf:system-relative-pathname 115 | :easy-audio/tests "tests/tmp.wav")) 116 | (wav-name (asdf:system-relative-pathname 117 | :easy-audio/tests wav)) 118 | (flac-name (asdf:system-relative-pathname 119 | :easy-audio/tests flac))) 120 | (flac-examples:flac2wav flac-name tmp-name) 121 | (is (equalp (md5:md5sum-file wav-name) 122 | (md5:md5sum-file tmp-name)))))) 123 | (check-file "tests/sample-mono.wav" "tests/sample-mono.flac") 124 | (check-file "tests/sample-stereo.wav" "tests/sample-stereo.flac") 125 | (check-file "tests/sample-stereo.wav" "tests/sample-stereo-low.flac"))) 126 | 127 | (test flac-seek 128 | "Test frame seek" 129 | (with-open-file (in (asdf:system-relative-pathname 130 | :easy-audio/tests "tests/sample-stereo.flac") 131 | :element-type '(unsigned-byte 8)) 132 | (let ((reader (flac:open-flac in))) 133 | (map nil 134 | (lambda (n) (finishes (flac:seek-sample reader n))) 135 | '(10000 20000 30000 40000 50000))))) 136 | 137 | (in-suite ogg) 138 | (test ogg-restore-sync 139 | "Test restore sync ability" 140 | (with-input-from-sequence (input (prepare-input 141 | 1 #x4f 3 ; Junk 142 | #x4f #x67 #x67 #x53 ; OggS 143 | #x00 #x02 ; First page of logical bitstream 144 | #x00 #x00 #x00 #x00 145 | #x00 #x00 #x00 #x00 ; 0 absolute granule position 146 | #xbe #xba #xfe #xca ; Stream serial number 147 | #x00 #x00 #x00 #x00 ; Page number 148 | #x1d #xc7 #x2d #x0a ; CRC 149 | #x01 ; 1 segment 150 | #x01 ; with length of 1 byte 151 | #x03)) ; Content 152 | (let ((reader (ogg:open-ogg input))) 153 | (is (= (ogg:restore-sync reader) 3)) 154 | (is (equalp #(#x03) (ogg:read-packet reader)))))) 155 | 156 | (test ogg-decode 157 | "Decode ogg audio file" 158 | (flet ((check-file (wav flac) 159 | (let ((tmp-name (asdf:system-relative-pathname 160 | :easy-audio/tests "tests/tmp.wav")) 161 | (wav-name (asdf:system-relative-pathname 162 | :easy-audio/tests wav)) 163 | (flac-name (asdf:system-relative-pathname 164 | :easy-audio/tests flac))) 165 | (flac-examples:ogg2wav flac-name tmp-name) 166 | (is (equalp (md5:md5sum-file wav-name) 167 | (md5:md5sum-file tmp-name)))))) 168 | (check-file "tests/sample-mono.wav" "tests/sample-mono.oga") 169 | (check-file "tests/sample-stereo.wav" "tests/sample-stereo.oga"))) 170 | 171 | (in-suite decoders) 172 | (test g.711-ulaw 173 | "Test g.711 uLaw decoder" 174 | (is (= (general:g.711-ulaw-decode #xff) 0)) 175 | (is (= (general:g.711-ulaw-decode #xea) #xd4)) 176 | (is (= (general:g.711-ulaw-decode #xda) #x022c)) 177 | (is (= (general:g.711-ulaw-decode #xca) #x04dc))) ; And so on... 178 | 179 | (test g.711-alaw 180 | "Test g.711 A-Law decoder" 181 | (is (= (general:g.711-alaw-decode #x55) -8)) 182 | (is (= (general:g.711-alaw-decode #x54) -24)) 183 | (is (= (general:g.711-alaw-decode #x40) #x-158)) 184 | (is (= (general:g.711-alaw-decode #x70) #x-2b0))) 185 | 186 | (in-suite wavpack) 187 | (test wv-decode 188 | "Decode audio file" 189 | (flet ((check-file (wav wv) 190 | (let ((tmp-name (asdf:system-relative-pathname 191 | :easy-audio/tests "tests/tmp.wav")) 192 | (wav-name (asdf:system-relative-pathname 193 | :easy-audio/tests wav)) 194 | (wv-name (asdf:system-relative-pathname 195 | :easy-audio/tests wv))) 196 | (handler-bind 197 | ((warning #'muffle-warning)) 198 | (wv-examples:wv2wav wv-name tmp-name)) 199 | (is (equalp (md5:md5sum-file wav-name) 200 | (md5:md5sum-file tmp-name)))))) 201 | (check-file "tests/sample-mono.wav" "tests/sample-mono.wv") 202 | (check-file "tests/sample32-mono.wav" "tests/sample32-mono.wv") 203 | (check-file "tests/sample-stereo.wav" "tests/sample-stereo.wv") 204 | (check-file "tests/sample32-stereo.wav" "tests/sample32-stereo.wv") 205 | (check-file "tests/sample32-upsample.wav" "tests/sample32-upsample.wv"))) 206 | 207 | (test wv-seek 208 | "Test frame seek" 209 | (with-open-file (in (asdf:system-relative-pathname 210 | :easy-audio/tests "tests/sample-stereo.wv") 211 | :element-type '(unsigned-byte 8)) 212 | (let ((reader (wv:open-wv in))) 213 | (loop for n in '(10000 20000 30000 40000 50000) do 214 | (finishes 215 | (handler-bind 216 | ((warning #'muffle-warning)) 217 | (wv:seek-sample reader n))))))) 218 | 219 | (in-suite ape) 220 | (test ape-decode 221 | "Decode ape sample file" 222 | (flet ((check-file (wav ape) 223 | (let ((tmp-name (asdf:system-relative-pathname 224 | :easy-audio/tests "tests/tmp.wav")) 225 | (wav-name (asdf:system-relative-pathname 226 | :easy-audio/tests wav)) 227 | (ape-name (asdf:system-relative-pathname 228 | :easy-audio/tests ape))) 229 | (ape-examples:ape2wav ape-name tmp-name) 230 | (is (equalp (md5:md5sum-file wav-name) 231 | (md5:md5sum-file tmp-name)))))) 232 | (check-file "tests/sample-stereo.wav" "tests/sample-stereo.ape") 233 | (check-file "tests/sample-mono.wav" "tests/sample-mono.ape"))) 234 | 235 | (test apev2-tags 236 | "Test apev2 tags reader" 237 | (with-open-file (input (asdf:system-relative-pathname 238 | :easy-audio/tests "tests/sample-stereo.wv") 239 | :element-type '(unsigned-byte 8)) 240 | (let* ((reader (wv:open-wv input)) 241 | (items (ape:read-apev2-tag-from-end reader)) 242 | (item1 (find "Key1" items :key #'ape:apev2-tag-item-key :test #'string=)) 243 | (item2 (find "Key2" items :key #'ape:apev2-tag-item-key :test #'string=))) 244 | (is-true (and item1 (string= (ape:apev2-tag-item-value item1) "Value1"))) 245 | (is-true (and item2 (string= (ape:apev2-tag-item-value item2) "Value2")))))) 246 | 247 | (in-suite core) 248 | (defun mixed-correctly-p (output a1 a2) 249 | (every #'identity 250 | (loop for i below (length a1) 251 | for j from 0 by 2 252 | collect 253 | (and (= (aref output j) (aref a1 i)) 254 | (= (aref output (1+ j)) 255 | (aref a2 i)))))) 256 | 257 | (test mixchannels-2 258 | "Test MIXCHANNELS-2 special case" 259 | (let ((data1 (make-array 522 :element-type '(signed-byte 32) 260 | :initial-contents 261 | (loop repeat 522 collect (- (random 1000) 2000)))) 262 | (data2 (make-array 522 :element-type '(signed-byte 32) 263 | :initial-contents 264 | (loop repeat 522 collect (- (random 1000) 2000))))) 265 | (is-true (mixed-correctly-p (core:interleave-channels (list data1 data2)) data1 data2)))) 266 | -------------------------------------------------------------------------------- /tests/travis.lisp: -------------------------------------------------------------------------------- 1 | (defun do-all() 2 | (ql:quickload :easy-audio/tests) 3 | (uiop:quit 4 | (if (uiop:call-function "easy-audio-tests:run-tests") 5 | 0 1))) 6 | 7 | (do-all) 8 | -------------------------------------------------------------------------------- /wav/definitions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.wav) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (defun string=>code (string) 5 | (let ((codes (flexi-streams:string-to-octets string))) 6 | (loop 7 | for code across codes 8 | for shift from 0 by 1 9 | for mul = (ash 1 (* 8 (- (length codes) 1 shift))) 10 | sum 11 | (* code mul))))) 12 | 13 | (defun code=>string (type) 14 | (flexi-streams:octets-to-string 15 | (reverse 16 | (loop while (/= type 0) collect 17 | (prog1 18 | (logand type #xff) 19 | (setq type (ash type -8))))))) 20 | 21 | (declaim 22 | (type (ub 32) 23 | +wav-id+ +wav-format+ 24 | +format-subchunk+ +data-subchunk+ 25 | +fact-subchunk+ 26 | +list-chunk+)) 27 | 28 | ;; General constants 29 | (defconstant +wav-id+ (string=>code "RIFF") 30 | "Wav format identifier (`RIFF')") 31 | 32 | (defconstant +wav-format+ (string=>code "WAVE") 33 | "Letters (`WAVE')") 34 | 35 | (defconstant +format-subchunk+ (string=>code "fmt ") 36 | "Format subchunk identifier. Contains letters `fmt '") 37 | 38 | (defconstant +data-subchunk+ (string=>code "data") 39 | "Data subchunk identifier. Contains letters `data'") 40 | 41 | (defconstant +fact-subchunk+ (string=>code "fact") 42 | "Fact subchunk identifier. Contains letters `fact'") 43 | 44 | (defconstant +list-chunk+ (string=>code "LIST") 45 | "List chunk (services as a container for other subchunks). 46 | Contants letters `LIST'") 47 | 48 | (defconstant +list-info+ (string=>code "INFO") 49 | "INFO list chunk") 50 | 51 | (defconstant +info-name+ (string=>code "INAM") 52 | "INAM (name) subchunk") 53 | (defconstant +info-subject+ (string=>code "ISBJ") 54 | "ISBJ (subject) subchunk") 55 | (defconstant +info-artist+ (string=>code "IART") 56 | "IART (artist) subchunk") 57 | (defconstant +info-comment+ (string=>code "ICMT") 58 | "ICMT (comment) subchunk") 59 | (defconstant +info-keywords+ (string=>code "IKEY") 60 | "IKEY (keywords) subchunk") 61 | (defconstant +info-software+ (string=>code "ISFT") 62 | "ISFT (software) subchunk") 63 | (defconstant +info-engineer+ (string=>code "IENG") 64 | "IENG (engineer) subchunk") 65 | (defconstant +info-technician+ (string=>code "ITCH") 66 | "ITCH (technician) subchunk") 67 | (defconstant +info-creation+ (string=>code "ICRD") 68 | "ICRD (creation) subchunk") 69 | (defconstant +info-genre+ (string=>code "GENR") 70 | "GENR (genre) subchunk") 71 | (defconstant +info-copyright+ (string=>code "ICOP") 72 | "ICOP (copyright) subchunk") 73 | 74 | (declaim 75 | (type (ub 16) 76 | +wave-format-unknown+ +wave-format-pcm+ 77 | +wave-format-float+ +wave-format-alaw+ 78 | +wave-format-mulaw+ +wave-format-extensible+)) 79 | ;; Audio formats 80 | (defconstant +wave-format-unknown+ #x0000) 81 | (defconstant +wave-format-pcm+ #x0001 82 | "PCM audio format") 83 | (defconstant +wave-format-float+ #x0003 84 | "Float audio format") 85 | (defconstant +wave-format-alaw+ #x0006 86 | "A-law coded audio") 87 | (defconstant +wave-format-mulaw+ #x0007 88 | "Mu-law coded audio") 89 | (defconstant +wave-format-extensible+ #xfffe 90 | "Extensible audio format") 91 | (defparameter +wave-format-extensible-magick+ 92 | (make-array 14 93 | :element-type '(ub 8) 94 | :initial-contents '(#x00 #x00 #x00 #x00 #x10 #x00 #x80 #x00 #x00 #xAA #x00 #x38 #x9B #x71))) 95 | 96 | (defclass data-chunk () 97 | ((type :initarg :type 98 | :type (ub 32) 99 | :accessor riff-type) 100 | (size :initarg :size 101 | :type (ub 32) 102 | :accessor riff-size)) 103 | (:documentation "Chunk of data with size DATA-SIZE")) 104 | 105 | (defclass riff-chunk (data-chunk) 106 | ((subtype :initarg :subtype 107 | :type (ub 32) 108 | :accessor riff-subtype) 109 | (subchunks :initform nil 110 | :type list 111 | :accessor riff-subchunks)) 112 | (:documentation "RIFF chunk, such as WAVE or LIST chunks")) 113 | 114 | (defclass wave-chunk (riff-chunk) () 115 | (:documentation "Main chunk in the .wav file")) 116 | (defclass list-chunk (riff-chunk) () 117 | (:documentation "Auxiliary container chunk")) 118 | 119 | (defclass subchunk (data-chunk) () 120 | (:documentation "Subchunk of data")) 121 | 122 | (defclass info-subchunk (data-chunk) 123 | ((key :initarg :key 124 | :accessor info-key 125 | :type (or symbol string) 126 | :documentation "Key of an info subchunk") 127 | (value :initarg :value 128 | :accessor info-value 129 | :type string 130 | :documentation "Value of an info subchunk")) 131 | (:documentation "LIST INFO subchunk. Together they constitue key-value metadata 132 | for the audio stream")) 133 | 134 | (defclass format-subchunk (subchunk) 135 | ((audio-format :type (ub 16) 136 | :accessor format-audio-format 137 | :documentation "Audio format") 138 | (channels-num :type (ub 16) 139 | :accessor format-channels-num 140 | :documentation "Number of channels in the stream") 141 | (samplerate :type (ub 32) 142 | :accessor format-samplerate 143 | :documentation "Samplerate in Hertz") 144 | (byte-rate :type (ub 32) 145 | :accessor format-byte-rate) 146 | (block-align :type (ub 16) 147 | :accessor format-block-align) 148 | (bps :type (ub 16) 149 | :accessor format-bps 150 | :documentation "Bits per sample") 151 | ;; Extended format 152 | (valid-bps :type (ub 16) 153 | :accessor format-valid-bps 154 | :documentation "Valid bits per sample") 155 | (channel-mask :type (ub 32) 156 | :accessor format-channel-mask 157 | :documentation "Channel mask of used channels") 158 | (subformat :type (sa-ub 8) 159 | :accessor format-subformat 160 | :documentation "Extended audio format")) 161 | (:documentation "Audio format subchunk")) 162 | 163 | (defclass data-subchunk (subchunk) 164 | ((audio-position :type unsigned-byte 165 | :accessor data-audio-position 166 | :initarg :audio-position)) 167 | (:documentation "Audio data subchunk")) 168 | 169 | (defclass fact-subchunk (subchunk) 170 | ((samples-num :type (ub 32) 171 | :accessor fact-samples-num 172 | :documentation "Number of interchannel samples")) 173 | (:documentation "Subchunk with actual number of samples")) 174 | 175 | (defgeneric read-chunk-body (reader chunk) 176 | (:documentation "Read the chunk's body from the stream")) 177 | (defgeneric chunk-sanity-checks (chunk) 178 | (:documentation "Sanity checks for a chunk")) 179 | (defgeneric read-chunk-header (reader parent-chunk) 180 | (:documentation "Read WAV chunk type and size")) 181 | 182 | ;; Condition 183 | (define-condition wav-error (error simple-condition) 184 | () 185 | (:report (lambda (c s) 186 | (apply #'format s 187 | (concatenate 'string 188 | "Wav decoder error: " 189 | (simple-condition-format-control c)) 190 | (simple-condition-format-arguments c)))) 191 | (:documentation "General Wav error")) 192 | 193 | (define-condition wav-error-chunk (wav-error) 194 | ((reader :initarg :reader 195 | :reader wav-error-reader) 196 | (rest-bytes :initarg :rest-bytes 197 | :reader wav-error-rest-bytes) 198 | (chunk :initarg :chunk 199 | :reader wav-error-chunk)) 200 | (:documentation "Error while reading a chunk")) 201 | 202 | (define-condition wav-warning (warning simple-condition) 203 | () 204 | (:report (lambda (c s) 205 | (apply #'format s 206 | (concatenate 'string 207 | "Wav decoder warning: " 208 | (simple-condition-format-control c)) 209 | (simple-condition-format-arguments c)))) 210 | (:documentation "General Wav warning")) 211 | 212 | (define-condition wav-unknown-chunk (wav-warning) 213 | ((chunk :initarg :chunk 214 | :reader wav-warning-chunk)) 215 | (:documentation "Unknown chunk warning")) 216 | -------------------------------------------------------------------------------- /wav/examples/decode.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.wav-examples) 2 | 3 | (defun decode-wav (name-in name-out) 4 | "Decode coded (with a-law, mu-law) wav files" 5 | (with-open-file (in name-in :element-type '(unsigned-byte 8)) 6 | (let* ((reader (open-wav in)) 7 | (subchunks (read-wav-header reader)) 8 | (format (car subchunks)) 9 | (audio-format (format-audio-format format))) 10 | 11 | (when (= audio-format +wave-format-pcm+) 12 | (error "Already contains decoded pcm data")) 13 | (when (and (/= audio-format +wave-format-alaw+) 14 | (/= audio-format +wave-format-mulaw+)) 15 | (error "Wav is not coded with g.711")) 16 | (reader-position-to-audio-data reader subchunks) 17 | 18 | (with-output-to-wav (out name-out 19 | :supersede t 20 | :samplerate (format-samplerate format) 21 | :channels (format-channels-num format) 22 | :bps 16 23 | :totalsamples (samples-num subchunks)) 24 | (write-sequence 25 | (decode-wav-data 26 | format 27 | (read-wav-data reader format (samples-num subchunks))) 28 | out)))) 29 | t) 30 | -------------------------------------------------------------------------------- /wav/examples/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.wav-examples 2 | (:use #:cl 3 | #:easy-audio.wav 4 | #:easy-audio.core 5 | #:easy-audio.general) 6 | (:nicknames #:wav-examples) 7 | (:export #:decode-wav)) 8 | -------------------------------------------------------------------------------- /wav/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.wav 2 | (:use #:cl 3 | #:easy-audio.bitreader 4 | #:easy-audio.core) 5 | (:local-nicknames (:ns :nibbles-streams)) 6 | (:export #:+wav-id+ ; Useful constants which can be used in examples 7 | #:+wav-format+ 8 | #:+format-subchunk+ 9 | #:+data-subchunk+ 10 | 11 | #:+wave-format-pcm+ 12 | #:+wave-format-float+ 13 | #:+wave-format-alaw+ 14 | #:+wave-format-mulaw+ 15 | #:+wave-format-extensible+ 16 | 17 | #:data-chunk ; A typed container 18 | #:riff-type 19 | #:riff-size 20 | 21 | #:riff-chunk ; Riff chunk (a container) 22 | #:riff-subchunks 23 | #:riff-subtype 24 | 25 | #:format-audio-format ; Format subchunk and accessors 26 | #:format-channels-num 27 | #:format-samplerate 28 | #:format-bps 29 | #:format-valid-bps 30 | #:format-channel-mask 31 | #:format-subchunk 32 | 33 | #:data-subchunk ; Data subchunk and accessors 34 | #:data-size 35 | #:data-audio-position 36 | 37 | #:fact-subchunk ; Fact subchunk and accessors 38 | #:fact-samples-num 39 | 40 | #:info-subchunk ; INFO subchunk and accessors 41 | #:info-key 42 | #:info-value 43 | 44 | #:wav-error ; Conditions 45 | #:wav-error-chunk 46 | #:wav-warning 47 | #:wav-unknown-chunk 48 | 49 | #:skip-subchunk ; Restarts 50 | 51 | #:open-wav 52 | #:read-wav-header 53 | #:read-wav-data 54 | #:decode-wav-data 55 | #:reader-position-to-audio-data 56 | 57 | #:samples-num ; Helper functions 58 | #:get-info-metadata 59 | 60 | #:write-pcm-wav-header ;; Simple writing 61 | #:with-output-to-wav)) 62 | -------------------------------------------------------------------------------- /wav/wav.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.wav) 2 | 3 | (defun skip-subchunk (c) 4 | "Invoke @c(skip-subchank) restart" 5 | (invoke-restart 'skip-subchunk c)) 6 | 7 | (defmacro number-case (keyform &body cases) 8 | (let ((sym (gensym))) 9 | `(let ((,sym ,keyform)) 10 | (cond 11 | ,@(loop for case in cases collect 12 | (let ((test (car case))) 13 | (if (eq test t) 14 | `(t ,@(cdr case)) 15 | `((= ,sym ,test) ,@(cdr case))))))))) 16 | 17 | (defun chunk-class (chunk) 18 | (let ((type (riff-type chunk))) 19 | (number-case type 20 | (+wav-id+ 'wave-chunk) 21 | (+format-subchunk+ 'format-subchunk) 22 | (+data-subchunk+ 'data-subchunk) 23 | (+fact-subchunk+ 'fact-subchunk) 24 | (+list-chunk+ 'list-chunk) 25 | (t (warn 'wav-unknown-chunk 26 | :format-control "Unknown chunk type ~x (~s)" 27 | :format-arguments (list type 28 | (code=>string type)) 29 | :chunk chunk) 30 | 'data-chunk)))) 31 | 32 | (defun info-subchunk-key (type) 33 | (number-case type 34 | (+info-name+ :name) 35 | (+info-subject+ :subject) 36 | (+info-artist+ :artist) 37 | (+info-comment+ :comment) 38 | (+info-keywords+ :keywords) 39 | (+info-software+ :software) 40 | (+info-engineer+ :engineer) 41 | (+info-technician+ :technician) 42 | (+info-creation+ :creation-time) 43 | (+info-genre+ :genre) 44 | (+info-copyright+ :copyright) 45 | (t (intern (code=>string type) 46 | (find-package :keyword))))) 47 | 48 | (defmethod read-chunk-header (reader (parent-chunk t)) 49 | (declare (ignore parent-chunk)) 50 | (let* ((type (read-octets 4 reader)) 51 | (size (read-octets 4 reader :endianness :little)) 52 | (chunk (make-instance 'data-chunk :type type :size size))) 53 | (change-class chunk (chunk-class chunk)))) 54 | 55 | ;; FIXME: INFO subchunk size is rounded to closest even bigger than (or equal to) 56 | ;; the value in a file. 57 | (defmethod read-chunk-header (reader (parent-chunk list-chunk)) 58 | (if (= (riff-subtype parent-chunk) 59 | +list-info+) 60 | (let ((type (read-octets 4 reader)) 61 | (size (read-octets 4 reader :endianness :little))) 62 | (make-instance 'info-subchunk 63 | :type type 64 | :size (+ size (logand 1 size)))) 65 | (call-next-method))) 66 | 67 | (defmethod chunk-sanity-checks ((chunk wave-chunk)) 68 | (when (/= (riff-subtype chunk) +wav-format+) 69 | (error 'wav-error :format-control "Not a WAV stream")) 70 | chunk) 71 | 72 | (defmethod chunk-sanity-checks ((chunk list-chunk)) 73 | (let ((subtype (riff-subtype chunk))) 74 | (when (/= subtype +list-info+) 75 | (warn 'wav-unknown-chunk 76 | :format-control "LIST chunk of unusual subtype ~x (~s)" 77 | :format-arguments (list subtype (code=>string subtype)) 78 | :chunk chunk)))) 79 | 80 | (defmethod chunk-sanity-checks ((chunk data-chunk)) 81 | chunk) 82 | 83 | ;; FIXME: For debugging 84 | #+nil 85 | (defmethod read-body :before (reader (chunk data-chunk)) 86 | (declare (ignore chunk)) 87 | (format t "Reader pos: ~x~%" (reader-position reader)) 88 | (force-output t)) 89 | 90 | (defmethod read-body (reader (chunk data-chunk)) 91 | (reader-position reader (+ (riff-size chunk) 92 | (reader-position reader))) 93 | chunk) 94 | 95 | (defmethod read-body :before (reader (chunk data-subchunk)) 96 | (setf (data-audio-position chunk) 97 | (reader-position reader))) 98 | 99 | (defmethod read-body (reader (chunk info-subchunk)) 100 | (setf (info-key chunk) (info-subchunk-key (riff-type chunk))) 101 | (let ((string-buffer (read-octet-vector (make-array (riff-size chunk) 102 | :element-type '(ub 8)) 103 | reader))) 104 | (when (or (every #'zerop string-buffer) 105 | (not (zerop (aref string-buffer (1- (riff-size chunk)))))) 106 | (error 'wav-error-chunk 107 | :format-control "Value in INFO subchunk is not a null-terminated string" 108 | :rest-bytes 0 109 | :chunk chunk)) 110 | (setf (info-value chunk) 111 | (flexi-streams:octets-to-string 112 | (subseq string-buffer 0 (1+ (position 0 string-buffer :from-end t :test #'/=)))))) 113 | chunk) 114 | 115 | (defreader (read-format-subchunk) (t) 116 | (format-audio-format (:octets 2) :endianness :little) 117 | (format-channels-num (:octets 2) :endianness :little) 118 | (format-samplerate (:octets 4) :endianness :little) 119 | (format-byte-rate (:octets 4) :endianness :little) 120 | (format-block-align (:octets 2) :endianness :little) 121 | (format-bps (:octets 2) :endianness :little)) 122 | 123 | (defreader (read-extended-format) (t) 124 | (format-valid-bps (:octets 2) :endianness :little) 125 | (format-channel-mask (:octets 4) :endianness :little) 126 | (format-subformat (:octet-vector 16))) 127 | 128 | (defun check-extensible-audio-format (format) 129 | "Check extensible audio format magick" 130 | (if (= (format-audio-format format) 131 | +wave-format-extensible+) 132 | (let ((subformat (format-subformat format))) 133 | (when (not (equalp (subseq subformat 2) +wave-format-extensible-magick+)) 134 | (error 'wav-error-chunk 135 | :format-control "Invalid extensible format magick" 136 | :rest-bytes 0 137 | :chunk format)) 138 | (setf (format-audio-format format) 139 | (logior (aref subformat 0) 140 | (ash (aref subformat 1) 8))))) 141 | format) 142 | 143 | (defmethod read-body (reader (chunk format-subchunk)) 144 | (read-format-subchunk reader chunk) 145 | (let ((size (riff-size chunk))) 146 | (if (= size 16) chunk 147 | (let ((extended-size (read-octets 2 reader :endianness :little))) 148 | ;; Sanity checks 149 | (unless (or (and (zerop extended-size) (= size 18)) 150 | (and (= extended-size 22) (= size 40))) 151 | (error 'wav-error-chunk 152 | :format-control "Malformed format subchunk" 153 | :rest-bytes (- size 18) 154 | :reader reader 155 | :chunk chunk)) 156 | 157 | (when (not (zerop extended-size)) 158 | (read-extended-format reader chunk) 159 | (check-extensible-audio-format chunk)))) 160 | chunk)) 161 | 162 | (defmethod read-body (reader (chunk fact-subchunk)) 163 | (setf (fact-samples-num chunk) (read-octets 4 reader :endianness :little)) 164 | (when (/= (riff-size chunk) 4) 165 | (error 'wav-error-chunk 166 | :format-control "Fact subchunk size is not 4. Do not know what to do" 167 | :rest-bytes (- (riff-size chunk) 4) 168 | :chunk chunk)) 169 | chunk) 170 | 171 | (defmethod read-body (reader (chunk riff-chunk)) 172 | (setf (riff-subtype chunk) (read-octets 4 reader)) 173 | (chunk-sanity-checks chunk) 174 | 175 | (setf (riff-subchunks chunk) 176 | (with-interactive-debug 177 | (loop 178 | with data-read = 8 179 | with subchunks = nil 180 | while (< data-read (riff-size chunk)) 181 | do 182 | (restart-case 183 | (let ((subchunk (read-body reader (read-chunk-header reader chunk)))) 184 | (incf data-read (+ 8 (riff-size subchunk))) 185 | (push subchunk subchunks)) 186 | (skip-subchunk (c) 187 | :interactive (lambda () (list *current-condition*)) 188 | :report "Skip reading subchunk" 189 | (unless (zerop (wav-error-rest-bytes c)) 190 | (read-octets (wav-error-rest-bytes c) 191 | (wav-error-reader c))) 192 | (incf data-read (+ 8 (riff-size (wav-error-chunk c)))))) 193 | finally (return (reverse subchunks))))) 194 | chunk) 195 | 196 | (defun open-wav (stream) 197 | "Opens a wav stream and returns a bit reader object" 198 | (make-reader :stream stream)) 199 | 200 | (defun read-wav-header (reader) 201 | "Read RIFF chunks from an audio stream" 202 | (let ((riff-chunk (read-chunk-header reader nil))) 203 | (unless (typep riff-chunk 'wave-chunk) 204 | (error 'wav-error :format-control "Not a WAV stream")) 205 | (read-body reader riff-chunk) 206 | 207 | ;; Sanity checks 208 | (let* ((subchunks (riff-subchunks riff-chunk)) 209 | (format-subchunk (car subchunks))) 210 | (unless (typep format-subchunk 'format-subchunk) 211 | (error 'wav-error :format-control "First subchunk is not a format subchunk")) 212 | (unless (or (= (format-audio-format format-subchunk) +wave-format-pcm+) 213 | (find-if #'(lambda (x) (typep x 'fact-subchunk)) subchunks)) 214 | (error 'wav-error :format-control "No fact subchunk in compressed wav")) 215 | subchunks))) 216 | 217 | ;; Helper function(s) 218 | (defun samples-num (subchunks) 219 | "Returns a number of interchannel samples in the stream." 220 | (let ((fact (find 'fact-subchunk subchunks :key #'type-of)) 221 | (data (find 'data-subchunk subchunks :key #'type-of)) 222 | (format (find 'format-subchunk subchunks :key #'type-of))) 223 | (if fact 224 | (fact-samples-num fact) 225 | (/ (riff-size data) (format-channels-num format) 226 | (ash (format-bps format) -3))))) 227 | 228 | (defun get-info-metadata (subchunks) 229 | "Return metadata in the LIST INFO subchunks as an association list" 230 | (let* ((list-chunk (find 'list-chunk subchunks :key #'type-of)) 231 | (info-subchunks (remove 'info-subchunk (riff-subchunks list-chunk) 232 | :test-not #'eql 233 | :key #'type-of))) 234 | (mapcar (lambda (info-subchunk) 235 | (cons (info-key info-subchunk) 236 | (info-value info-subchunk))) 237 | info-subchunks))) 238 | 239 | (defun reader-position-to-audio-data (reader subchunks) 240 | "Set the reader's position to beginning of audio data" 241 | (let ((data (find 'data-subchunk subchunks :key #'type-of))) 242 | (reader-position reader (data-audio-position data)))) 243 | 244 | (defun decompose (buffer channel-buffers) 245 | (let ((nsamples (length (car channel-buffers))) 246 | (channels (length channel-buffers))) 247 | (loop for i below nsamples 248 | for idx from 0 by channels do 249 | (loop for channel in channel-buffers 250 | for offset from 0 by 1 do 251 | (setf (aref channel i) 252 | (aref buffer (+ idx offset)))))) 253 | channel-buffers) 254 | 255 | (declaim 256 | (ftype 257 | (function ((unsigned-byte 32) (integer 0 32)) (signed-byte 32)) 258 | unsigned->signed)) 259 | (defun unsigned->signed (x bps) 260 | "Unsigned to signed converter" 261 | (declare (optimize (speed 3)) 262 | (type (integer 0 32) bps) 263 | (type (unsigned-byte 32) x)) 264 | (if (zerop (ldb (byte 1 (1- bps)) x)) x 265 | (- (1+ (logxor (1- (ash 1 bps)) x))))) 266 | 267 | (defun read-wav-data (reader format nsamples &key decompose) 268 | "Read a portion of audio data in the wav stream. Requires a @c(bitreader) and 269 | @c(format) subchunk. Reads exactly @c(nsamples) interchannel 270 | samples. Optionally, decomposes them into different by-channel arrays if 271 | @c(decompose) is @c(T)." 272 | (let* ((channels (format-channels-num format)) 273 | (bps (format-bps format)) 274 | (audio-format (format-audio-format format)) 275 | (buffer (make-array (* nsamples channels) :element-type '(signed-byte 32)))) 276 | (loop for i below (length buffer) do 277 | (setf (aref buffer i) 278 | (let ((sample (read-bits bps reader :endianness :little))) 279 | (if (and (= audio-format +wave-format-pcm+) 280 | (/= bps 8)) 281 | (unsigned->signed sample bps) sample)))) 282 | (if decompose 283 | (decompose buffer 284 | (loop repeat channels collect 285 | (make-array nsamples :element-type '(signed-byte 32)))) 286 | buffer))) 287 | 288 | (defun decode-wav-data (format buffer) 289 | "Decodes wav audio data in the @c(buffer). Often, in the case of uncompressed 290 | data, it simply returns the @c(buffer) unmodified." 291 | (let ((audio-format (format-audio-format format))) 292 | (cond 293 | ((= audio-format +wave-format-pcm+) buffer) 294 | ((= audio-format +wave-format-alaw+) 295 | (map-into buffer #'easy-audio.general:g.711-alaw-decode buffer)) 296 | ((= audio-format +wave-format-mulaw+) 297 | (map-into buffer #'easy-audio.general:g.711-ulaw-decode buffer)) 298 | (t (error 'wav-error 299 | :format-control "Unknown audio encoding: ~d" 300 | :format-arguments (list audio-format)))))) 301 | -------------------------------------------------------------------------------- /wav/write-header.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.wav) 2 | 3 | (defun write-pcm-wav-header (out-stream &key samplerate channels bps totalsamples) 4 | "Writes header of uncompressed wav into stream" 5 | (let ((size (/ (* bps channels totalsamples) 8))) 6 | (nibbles:write-ub32/be +wav-id+ out-stream) 7 | (nibbles:write-ub32/le (+ 36 size) out-stream) 8 | (nibbles:write-ub32/be +wav-format+ out-stream) 9 | 10 | ;; Subchunk 1 11 | (nibbles:write-ub32/be +format-subchunk+ out-stream) 12 | (nibbles:write-ub32/le 16 out-stream) 13 | (nibbles:write-ub16/le +wave-format-pcm+ out-stream) 14 | (nibbles:write-ub16/le channels out-stream) 15 | (nibbles:write-ub32/le samplerate out-stream) 16 | 17 | (nibbles:write-ub32/le (/ (* samplerate channels bps) 8) out-stream) 18 | (nibbles:write-ub16/le (/ (* channels bps) 8) out-stream) 19 | (nibbles:write-ub16/le bps out-stream) 20 | 21 | ;; Subchunk 2 22 | (nibbles:write-ub32/be +data-subchunk+ out-stream) 23 | (nibbles:write-ub32/le size out-stream)) 24 | (values)) 25 | 26 | (defmacro with-output-to-wav ((stream filename 27 | &key supersede samplerate channels bps totalsamples) 28 | &body body) 29 | "Opens a STREAM and writes PCM-coded (uncompressed) WAV header to a file with filename FILENAME" 30 | (let ((file-stream (gensym))) 31 | `(with-open-file (,file-stream ,filename 32 | :direction :output 33 | :element-type '(unsigned-byte 8) 34 | ,@(if supersede '(:if-exists :supersede)) 35 | :if-does-not-exist :create) 36 | (write-pcm-wav-header ,file-stream 37 | :samplerate ,samplerate 38 | :channels ,channels 39 | :bps ,bps 40 | :totalsamples ,totalsamples) 41 | (let ((,stream (make-instance 'ns:nibbles-output-stream 42 | :stream ,file-stream 43 | :element-type (list 'signed-byte ,bps)))) 44 | ,@body)))) 45 | -------------------------------------------------------------------------------- /wv/decode.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.wv) 2 | 3 | ;; NB: multiplication of weight and sample may be a bignum 4 | (sera:-> apply-weight ((sb 32) (sb 32)) 5 | (values (sb 32) &optional)) 6 | (declaim (inline apply-weight)) 7 | (defun apply-weight (weight sample) 8 | (ash (+ 512 (* weight sample)) -10)) 9 | 10 | (sera:-> update-weight ((sb 32) (sb 32) (sb 32) (sb 32)) 11 | (values (sb 32) &optional)) 12 | (declaim (inline update-weight)) 13 | (defun update-weight (weight delta source result) 14 | (if (or (zerop source) 15 | (zerop result)) 16 | weight 17 | (let ((sign (ash (logxor source result) -31))) 18 | (+ (logxor delta sign) weight (- sign))))) 19 | 20 | (sera:-> update-weight-clip ((sb 32) (sb 32) (sb 32) (sb 32)) 21 | (values (sb 32) &optional)) 22 | (declaim (inline update-weight-clip)) 23 | (defun update-weight-clip (weight delta source result) 24 | (if (or (zerop source) 25 | (zerop result)) 26 | weight 27 | (let* ((sign (ash (logxor source result) -31)) 28 | (weight (+ (logxor weight sign) (- delta sign)))) 29 | (- (logxor (min weight 1024) sign) sign)))) 30 | 31 | (sera:-> correlate-sample/w-term-17 ((sb 32) (sb 32)) 32 | (values (sb 32) &optional)) 33 | (declaim (inline correlate-sample/w-term-17)) 34 | (defun correlate-sample/w-term-17 (i-1 i-2) 35 | (- (* 2 i-1) i-2)) 36 | 37 | (sera:-> correlate-sample/w-term-18 ((sb 32) (sb 32)) 38 | (values (sb 32) &optional)) 39 | (declaim (inline correlate-sample/w-term-18)) 40 | (defun correlate-sample/w-term-18 (i-1 i-2) 41 | (+ i-1 (ash (- i-1 i-2) -1))) 42 | 43 | (defmacro correlate-sample (sample-form result-place weight-place update-method) 44 | ;; Must be called with 'delta'in the scope 45 | (let ((sample-sym (gensym))) 46 | `(let ((,sample-sym ,sample-form)) 47 | (psetf ,result-place 48 | (+ (apply-weight ,weight-place ,sample-sym) ,result-place) 49 | ,weight-place 50 | (,update-method ,weight-place delta ,sample-sym ,result-place))))) 51 | 52 | (macrolet ((define-correlation-pass/w-term>8 (name correlate-sample-name) 53 | `(progn 54 | (sera:-> ,name ((sa-sb 32) (sb 32) (sb 32) integer (maybe (sa-sb 32))) 55 | (values (sb 32) &optional)) 56 | (defun ,name (residual delta weight term decorr-samples) 57 | (declare (optimize (speed 3)) 58 | (ignore term)) 59 | (cond 60 | (decorr-samples 61 | ;; The first sample in the block 62 | (correlate-sample (,correlate-sample-name 63 | (aref decorr-samples 0) 64 | (aref decorr-samples 1)) 65 | (aref residual 0) 66 | weight update-weight) 67 | ;; The second sample in the block 68 | (correlate-sample (,correlate-sample-name 69 | (aref residual 0) 70 | (aref decorr-samples 0)) 71 | (aref residual 1) 72 | weight update-weight)) 73 | (t 74 | (correlate-sample (,correlate-sample-name 75 | (aref residual 0) 76 | 0) 77 | (aref residual 1) 78 | weight update-weight))) 79 | (loop for j from 2 below (length residual) do 80 | (correlate-sample (,correlate-sample-name 81 | (aref residual (- j 1)) 82 | (aref residual (- j 2))) 83 | (aref residual j) 84 | weight update-weight)) 85 | weight)))) 86 | 87 | (define-correlation-pass/w-term>8 correlation-pass/w-term-17 correlate-sample/w-term-17) 88 | (define-correlation-pass/w-term>8 correlation-pass/w-term-18 correlate-sample/w-term-18)) 89 | 90 | (sera:-> correlation-pass/w-term-i 91 | ((sa-sb 32) (sb 32) (sb 32) (integer 1 8) (maybe (sa-sb 32))) 92 | (values (sb 32) &optional)) 93 | (defun correlation-pass/w-term-i (residual delta weight term decorr-samples) 94 | (declare (optimize (speed 3))) 95 | (when decorr-samples 96 | (loop for j below term do 97 | (correlate-sample (aref decorr-samples j) 98 | (aref residual j) 99 | weight update-weight))) 100 | (loop for j from term below (length residual) do 101 | (correlate-sample (aref residual (- j term)) 102 | (aref residual j) 103 | weight update-weight)) 104 | weight) 105 | 106 | (sera:-> correlation-pass/w-term--1 107 | ((sa-sb 32) (sa-sb 32) (sb 32) (sa-sb 32) list) 108 | (values &optional)) 109 | (defun correlation-pass/w-term--1 (residual-1 residual-2 delta weights decorr-samples) 110 | (declare (optimize (speed 3))) 111 | (when decorr-samples 112 | (correlate-sample (first decorr-samples) 113 | (aref residual-1 0) 114 | (aref weights 0) 115 | update-weight-clip)) 116 | 117 | (correlate-sample (aref residual-1 0) 118 | (aref residual-2 0) 119 | (aref weights 1) 120 | update-weight-clip) 121 | 122 | (loop for i from 1 below (length residual-1) do 123 | (correlate-sample 124 | (aref residual-2 (1- i)) 125 | (aref residual-1 i) 126 | (aref weights 0) 127 | update-weight-clip) 128 | (correlate-sample 129 | (aref residual-1 i) 130 | (aref residual-2 i) 131 | (aref weights 1) 132 | update-weight-clip)) 133 | (values)) 134 | 135 | (sera:-> correlation-pass/w-term--2 136 | ((sa-sb 32) (sa-sb 32) (sb 32) (sa-sb 32) list) 137 | (values &optional)) 138 | (defun correlation-pass/w-term--2 (residual-1 residual-2 delta weights decorr-samples) 139 | (declare (optimize (speed 3))) 140 | (when decorr-samples 141 | (correlate-sample (second decorr-samples) 142 | (aref residual-2 0) 143 | (aref weights 1) 144 | update-weight-clip)) 145 | 146 | (correlate-sample (aref residual-2 0) 147 | (aref residual-1 0) 148 | (aref weights 0) 149 | update-weight-clip) 150 | 151 | (loop for i from 1 below (length residual-1) do 152 | (correlate-sample 153 | (aref residual-1 (1- i)) 154 | (aref residual-2 i) 155 | (aref weights 1) 156 | update-weight-clip) 157 | (correlate-sample 158 | (aref residual-2 i) 159 | (aref residual-1 i) 160 | (aref weights 0) 161 | update-weight-clip)) 162 | (values)) 163 | 164 | (sera:-> correlation-pass/w-term--3 165 | ((sa-sb 32) (sa-sb 32) (sb 32) (sa-sb 32) list) 166 | (values &optional)) 167 | (defun correlation-pass/w-term--3 (residual-1 residual-2 delta weights decorr-samples) 168 | (declare (optimize (speed 3))) 169 | (when decorr-samples 170 | (correlate-sample 171 | (first decorr-samples) 172 | (aref residual-1 0) 173 | (aref weights 0) 174 | update-weight-clip) 175 | (correlate-sample 176 | (second decorr-samples) 177 | (aref residual-1 1) 178 | (aref weights 1) 179 | update-weight-clip)) 180 | 181 | (loop for i from 1 below (length residual-1) do 182 | (correlate-sample 183 | (aref residual-1 (1- i)) 184 | (aref residual-2 i) 185 | (aref weights 1) 186 | update-weight-clip) 187 | (correlate-sample 188 | (aref residual-2 (1- i)) 189 | (aref residual-1 i) 190 | (aref weights 0) 191 | update-weight-clip)) 192 | (values)) 193 | 194 | (sera:-> restore-joint-stereo ((sa-sb 32) (sa-sb 32)) 195 | (values (sa-sb 32) &optional)) 196 | (defun restore-joint-stereo (residual-1 residual-2) 197 | (declare (optimize (speed 3))) 198 | (map-into residual-2 199 | (lambda (sample-1 sample-2) 200 | (- sample-2 (ash sample-1 -1))) 201 | residual-1 residual-2) 202 | (map-into residual-1 #'+ 203 | residual-1 residual-2)) 204 | 205 | ;; TODO: Refactor 206 | (defun int32-fixup (wv-block) 207 | "Do samples fixup if sample size is > 24 bits" 208 | (declare (optimize (speed 3))) 209 | ;; How slow is this? 210 | (let ((int32-info (block-int32-info wv-block)) 211 | (wvx-bits (block-wvx-bits wv-block))) 212 | (unless int32-info 213 | (error 'block-error 214 | :format-control "sample size is > 24 bits and no int32-info metadata block")) 215 | (let ((sent-bits (metadata-sent-bits int32-info)) 216 | (zeros (metadata-zeros int32-info)) 217 | (ones (metadata-ones int32-info)) 218 | (dups (metadata-dups int32-info)) 219 | (shift-add 0)) 220 | (declare (type (ub 8) sent-bits zeros ones dups shift-add)) 221 | (labels ((fixup-sample (sample) 222 | (declare (type (sb 32) sample)) 223 | (cond 224 | ((/= zeros 0) 225 | (the (sb 32) (ash sample zeros))) 226 | ((/= ones 0) 227 | (1- (the (sb 32) (ash (1+ sample) ones)))) 228 | ((/= dups 0) 229 | (- (the (sb 32) (ash (+ sample (logand sample 1)) dups)) 230 | (logand sample 1))) 231 | (t sample))) 232 | (fixup-sample-wvx (sample fixup) 233 | (declare (type (sb 32) sample fixup)) 234 | (fixup-sample (logior (the (sb 32) (ash sample sent-bits)) fixup)))) 235 | (cond 236 | (wvx-bits 237 | (labels ((fixup-channel (channel wvx-bits) 238 | (declare (type (sa-sb 32) channel wvx-bits)) 239 | (map-into channel #'fixup-sample-wvx channel wvx-bits))) 240 | (mapc #'fixup-channel (block-residual wv-block) wvx-bits))) 241 | ((and (= sent-bits 0) 242 | (or (/= zeros 0) 243 | (/= ones 0) 244 | (/= dups 0))) 245 | (labels ((fixup-channel (channel) 246 | (declare (type (sa-sb 32) channel)) 247 | (map-into channel #'fixup-sample channel))) 248 | (mapc #'fixup-channel (block-residual wv-block)))) 249 | (t (setq shift-add (+ zeros sent-bits ones dups))))) 250 | shift-add))) 251 | 252 | (defun decode-wv-block (wv-block) 253 | "Decode a wavpack block, destructively modifying it. This function 254 | returns a list of simple-arrays, each correspoding to a separate 255 | channel." 256 | (declare (optimize (speed 3))) 257 | (let ((decorr-samples (block-decorr-samples wv-block)) 258 | (decorr-passes (block-decorr-passes wv-block)) 259 | (residual (block-residual wv-block))) ; Will be destructively modified to output 260 | 261 | (when (flag-set-p wv-block +flags-hybrid-mode+) 262 | (error 'block-error :format-control "Hybrid encoding is not supported")) 263 | 264 | (flet ((correlation-pass (pass &optional decorr-samples) 265 | (let ((term (decorr-pass-term pass)) 266 | (delta (decorr-pass-delta pass)) 267 | (weights (decorr-pass-weight pass))) 268 | (if (> term 0) 269 | (do ((i 0 (1+ i)) 270 | (r residual (cdr r)) 271 | (ds decorr-samples (cdr ds))) 272 | ((null r)) 273 | (setf (aref weights i) 274 | (funcall 275 | (cond 276 | ((= term 18) #'correlation-pass/w-term-18) 277 | ((= term 17) #'correlation-pass/w-term-17) 278 | (t #'correlation-pass/w-term-i)) 279 | (car r) delta (aref weights i) term 280 | (car ds)))) 281 | (funcall 282 | (cond 283 | ((= term -1) #'correlation-pass/w-term--1) 284 | ((= term -2) #'correlation-pass/w-term--2) 285 | ((= term -3) #'correlation-pass/w-term--3)) 286 | (first residual) (second residual) delta weights decorr-samples))) 287 | (values))) 288 | 289 | (when decorr-passes 290 | (destructuring-bind (last . first) decorr-passes 291 | (mapc #'correlation-pass (reverse first)) 292 | (correlation-pass last decorr-samples)))) 293 | 294 | (when (flag-set-p wv-block +flags-stereo-joint+) 295 | (restore-joint-stereo (first residual) (second residual))) 296 | 297 | (let ((shift (left-shift-amount wv-block))) 298 | (declare (type (ub 8) shift)) 299 | (when (flag-set-p wv-block +flags-shifted-int+) 300 | (incf shift (int32-fixup wv-block))) 301 | (labels ((shift-sample (sample) 302 | (ash sample shift)) 303 | (shift-channel (channel-out) 304 | (declare (type (sa-sb 32) channel-out)) 305 | (map-into channel-out #'shift-sample channel-out))) 306 | (unless (zerop shift) 307 | (mapc #'shift-channel residual)))) 308 | 309 | (if (flag-set-p wv-block +flags-pseudo-stereo+) 310 | (list (first residual) (first residual)) 311 | residual))) 312 | -------------------------------------------------------------------------------- /wv/definitions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.wv) 2 | 3 | ;; TODO: Figure out why I need this 4 | (deftype maybe (type) `(or null ,type)) 5 | 6 | ;; Conditions 7 | (define-condition wavpack-condition (simple-condition) () 8 | (:report (lambda (c s) 9 | (apply #'format s 10 | (concatenate 'string "WavPack: " 11 | (simple-condition-format-control c)) 12 | (simple-condition-format-arguments c)))) 13 | (:documentation "General (unspecified) WavPack condition")) 14 | 15 | (define-condition wavpack-error (wavpack-condition error) () 16 | (:documentation "General WavPack error")) 17 | (define-condition wavpack-warning (wavpack-condition warning) () 18 | (:documentation "General WavPack warning")) 19 | 20 | (define-condition block-error (wavpack-error) () ; A large part of currently generated conditions is of this type 21 | (:documentation "Error associated with block reader/decoder error")) 22 | 23 | (define-condition lost-sync (block-error) () 24 | (:documentation "Error signaled when sync is obviously lost 25 | (e.g. first 4 bytes in block are not Wavpack ID). Errors signalled 26 | when reading a block which cause loss of sync are not of this type, 27 | but of @c(block-error). Useful for skipping garbage in audio files")) 28 | 29 | (define-condition unknown-metadata (wavpack-warning) 30 | ((metadata :reader unknown-metadata 31 | :initarg :metadata 32 | :documentation "Metadata object")) 33 | (:report (lambda (c s) 34 | (format s "WavPack: cannot understand metadata (id=~d)" 35 | (metadata-id (unknown-metadata c))))) 36 | (:documentation "The reader does not know how to read metadata")) 37 | ;; -------- 38 | ;; Metadata 39 | ;; -------- 40 | (defclass metadata () 41 | ((id :accessor metadata-id 42 | :type (ub 8) 43 | :documentation "An ID number designating this metadata") 44 | (size :accessor metadata-size 45 | :type (ub 24) 46 | :documentation "Size of this metadata on disk in bytes") 47 | (actual-size :accessor metadata-actual-size 48 | :type (ub 24) 49 | :documentation "Actual size of metadata. Can be size or size-1") 50 | (data :accessor metadata-data 51 | :documentation "Raw metadata. Usually this slot is not bound")) 52 | (:documentation "General class for storing metadata. If 53 | instantiated, the metadata reader will only read raw metadata to data 54 | slot")) 55 | 56 | (defclass metadata-ignorable (metadata) () 57 | (:documentation "Known metadata block for which we have no special 58 | primary reader method. Not to be instantiated.")) 59 | 60 | (defclass metadata-decorr (metadata) 61 | ((decorr-passes :accessor metadata-decorr-passes)) 62 | (:documentation "General class for everything (de)correlation-related. 63 | This class is not instantiated")) 64 | 65 | (defclass metadata-decorr-terms (metadata-decorr) ()) 66 | (defclass metadata-decorr-weights (metadata-decorr) ()) 67 | (defclass metadata-decorr-samples (metadata-decorr) 68 | ((decorr-samples :accessor metadata-decorr-samples))) 69 | 70 | (defclass metadata-entropy (metadata) 71 | ((entropy-median :accessor metadata-entropy-median))) 72 | 73 | ;; We can do nothing with residual metadata block 74 | ;; in the moment when READ-METADATA-BODY is called, 75 | ;; so set it to -IGNORABLE 76 | (defclass metadata-residual (metadata-ignorable) 77 | ((reader :type reader 78 | :accessor metadata-residual-reader))) 79 | (defclass metadata-wv-residual (metadata-residual) ()) 80 | 81 | (defclass metadata-wvx-bits (metadata) 82 | ((crc32 :accessor metadata-crc32 83 | :type (ub 32)) 84 | (bits :accessor metadata-bits)) 85 | (:documentation "This block may be present when sample size is > 24")) 86 | 87 | (defclass metadata-riff-header (metadata-ignorable) () 88 | (:documentation "Contents the original RIFF header in DATA slot")) 89 | 90 | (defclass metadata-riff-trailer (metadata-ignorable) () 91 | (:documentation "Contents the original RIFF trailer in DATA slot")) 92 | 93 | (defclass metadata-int32-info (metadata) 94 | ((sent-bits :accessor metadata-sent-bits 95 | :type (ub 8)) 96 | (zeros :accessor metadata-zeros 97 | :type (ub 8)) 98 | (ones :accessor metadata-ones 99 | :type (ub 8)) 100 | (dups :accessor metadata-dups 101 | :type (ub 8))) 102 | (:documentation "This block is present when sample size is > 24")) 103 | 104 | (defgeneric read-metadata-body (metadata reader)) 105 | 106 | ;; Metadata id masks 107 | (defconstant +meta-id-function+ #x1f) 108 | (defconstant +meta-id-useless-for-decoder+ #x20) 109 | (defconstant +meta-id-data-length--1+ #x40) 110 | (defconstant +meta-id-large-block+ #x80) 111 | 112 | ;; Assigned metadata ids 113 | (defconstant +meta-id-dummy+ #x0) 114 | (defconstant +meta-id-decorr-terms+ #x2) 115 | (defconstant +meta-id-decorr-weights+ #x3) 116 | (defconstant +meta-id-decorr-samples+ #x4) 117 | (defconstant +meta-id-entropy-vars+ #x5) 118 | (defconstant +meta-id-hybrid-profile+ #x6) 119 | (defconstant +meta-id-shaping-weights+ #x7) 120 | (defconstant +meta-id-float-info+ #x8) 121 | (defconstant +meta-id-int32-info+ #x9) 122 | (defconstant +meta-id-wv-bitstream+ #xa) 123 | (defconstant +meta-id-wvc-bitstream+ #xb) 124 | (defconstant +meta-id-wvx-bitstream+ #xc) 125 | (defconstant +meta-id-channel-info+ #xd) 126 | 127 | ;; Metadata ids of metadata needless for decoder 128 | (defconstant +meta-id-riff-header+ #x21) 129 | (defconstant +meta-id-riff-trailer+ #x22) 130 | (defconstant +meta-id-config-block+ #x25) 131 | (defconstant +meta-id-md5-checksum+ #x26) 132 | (defconstant +meta-id-samplerate+ #x27) 133 | 134 | ;; -------------- 135 | ;; WavPack blocks 136 | ;; -------------- 137 | (defconstant +wv-id+ #x7776706b) 138 | (defconstant +wv-id/first-octet+ #x77) 139 | 140 | (defstruct decorr-pass 141 | (term 0 :type (sb 32)) 142 | (delta 0 :type (sb 32)) 143 | (weight (make-array 2 :element-type '(sb 32) :initial-element 0) 144 | :type (sa-sb 32)) 145 | #|aweight sum|#) 146 | 147 | (defstruct (wv-block (:conc-name block-) 148 | (:print-function 149 | (lambda (struct stream k) 150 | (declare (ignore k)) 151 | (print-unreadable-object (struct stream 152 | :type t :identity t) 153 | (format stream "samples ~d..~d" 154 | (block-block-index struct) 155 | (+ (block-block-index struct) 156 | (block-block-samples struct))))))) 157 | "WavPack block structure" 158 | (id 0 :type (ub 32)) 159 | (size 0 :type (ub 32)) 160 | 161 | (version 0 :type (ub 16)) 162 | (track-number 0 :type (ub 8)) 163 | (index-number 0 :type (ub 8)) 164 | (total-samples 0 :type (ub 32)) 165 | (block-index 0 :type (ub 32)) 166 | (block-samples 0 :type (ub 32)) 167 | (flags 0 :type (ub 32)) 168 | (crc 0 :type (ub 32)) 169 | metadata 170 | ;; These are mostly copy of metadata values for easy access 171 | decorr-passes 172 | decorr-samples 173 | entropy-median 174 | residual 175 | int32-info 176 | wvx-bits) 177 | 178 | (sera:defvar-unbound *current-block* 179 | "Bound to block currently being readed by block reader") 180 | 181 | (defconstant +flags-1-byte/sample+ #x00000000) 182 | (defconstant +flags-2-byte/sample+ #x00000001) 183 | (defconstant +flags-3-byte/sample+ #x00000002) 184 | (defconstant +flags-4-byte/sample+ #x00000003) 185 | 186 | (defconstant +flags-mono-output+ #x00000004) 187 | (defconstant +flags-hybrid-mode+ #x00000008) 188 | (defconstant +flags-stereo-joint+ #x00000010) 189 | (defconstant +flags-channels-decor+ #x00000020) 190 | (defconstant +flags-noise-shaping+ #x00000040) 191 | (defconstant +flags-data-float+ #x00000080) 192 | (defconstant +flags-shifted-int+ #x00000100) 193 | (defconstant +flags-hybrid-param/bitrate+ #x00000200) 194 | (defconstant +flags-hybrid-noise-balanced+ #x00000400) 195 | (defconstant +flags-initial-block+ #x00000800) 196 | (defconstant +flags-final-block+ #x00001000) 197 | (defconstant +flags-pseudo-stereo+ #x40000000) 198 | 199 | (defconstant +flags-left-shift-amount-mask+ #x0003e000) 200 | (defconstant +flags-left-shift-amount-shift+ -13) 201 | 202 | (defconstant +flags-max-magnitude-mask+ #x007c0000) 203 | (defconstant +flags-max-magnitude-shift+ -18) 204 | 205 | (defconstant +flags-samplerate-mask+ #x07800000) 206 | (defconstant +flags-samplerate-shift+ -23) 207 | 208 | ;; Bits 27-28 are ignored 209 | 210 | (defconstant +flags-use-iir+ #x20000000) 211 | (defconstant +flags-false-stereo+ #x40000000) 212 | (defconstant +flags-reserved-zero+ #x80000000) 213 | 214 | (defmacro define-get-value/shift+mask (name-spec) 215 | "Define value-getting function. This function will accept an integer 216 | number and extract a value using defined mask and shift values like 217 | so: (ash (logand number mask) shift). 218 | 219 | NAME-SPEC can be a list (NAME SYM) or just a symbol NAME. NAME is the 220 | name of the function to be defined. Mask and shift values used must 221 | have names +FLAGS-NAME-MASK+ and +FLAGS-NAME-SHIFT+ or 222 | +FLAGS-SYM-MASK+ and +FLAGS-SYM-SHIFT+ if SYM is supplied." 223 | (let* ((name (if (atom name-spec) name-spec (first name-spec))) 224 | (sym (if (atom name-spec) name-spec (second name-spec))) 225 | (mask (intern (concatenate 'string "+FLAGS-" (symbol-name sym) "-MASK+"))) 226 | (shift (intern (concatenate 'string "+FLAGS-" (symbol-name sym) "-SHIFT+")))) 227 | `(defun ,name (wv-block) 228 | (ash (logand (block-flags wv-block) ,mask) ,shift)))) 229 | 230 | (define-get-value/shift+mask left-shift-amount) 231 | (define-get-value/shift+mask max-magnitude) 232 | (define-get-value/shift+mask (%block-samplerate samplerate)) 233 | 234 | (declaim (inline flag-mask-set-p)) 235 | (defun flag-mask-set-p (wv-block mask) 236 | (all-bits-set-p (block-flags wv-block) mask)) 237 | 238 | (declaim (inline flag-set-p)) 239 | (defun flag-set-p (wv-block mask) 240 | (some-bits-set-p (block-flags wv-block) mask)) 241 | 242 | ;; Place these here too 243 | (define-constant +samplerate-list+ 244 | '(6000 8000 9600 245 | 11025 12000 16000 246 | 22050 24000 32000 247 | 44100 48000 64000 248 | 88200 96000 192000) 249 | :test #'equalp) 250 | 251 | (defun block-samplerate (wv-block) 252 | "Return a sample rate of a block." 253 | (let ((samplerate (%block-samplerate wv-block))) 254 | (nth samplerate +samplerate-list+))) 255 | 256 | (sera:-> block-bps (wv-block) 257 | (values (member 8 16 24 32) &optional)) 258 | (defun block-bps (wv-block) 259 | "Return bits per second of a block." 260 | (cond 261 | ((flag-mask-set-p wv-block +flags-4-byte/sample+) 32) 262 | ((flag-mask-set-p wv-block +flags-3-byte/sample+) 24) 263 | ((flag-mask-set-p wv-block +flags-2-byte/sample+) 16) 264 | (t 8))) 265 | 266 | (sera:-> block-channels (wv-block) 267 | (values (integer 1 2) &optional)) 268 | (defun block-channels (wv-block) 269 | "Return a number of channels (a block can have 1 or 2 channels)." 270 | (if (flag-set-p wv-block +flags-mono-output+) 1 2)) 271 | 272 | (sera:-> block-data-channels (wv-block) 273 | (values (integer 1 2) &optional)) 274 | (defun block-data-channels (wv-block) 275 | "Return a number of channels (a block can have 1 or 2 channels)." 276 | (if (flag-set-p wv-block (logior +flags-pseudo-stereo+ +flags-mono-output+)) 1 2)) 277 | -------------------------------------------------------------------------------- /wv/examples/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.wv-examples 2 | (:use #:cl 3 | #:easy-audio.wv 4 | #:easy-audio.wav 5 | #:easy-audio.core 6 | #:easy-audio.bitreader) 7 | (:nicknames #:wv-examples) 8 | (:export #:wv2wav)) 9 | -------------------------------------------------------------------------------- /wv/examples/wv2wav.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.wv-examples) 2 | 3 | (defun wv2wav (wv-name wav-name) 4 | "Decode wavpack to wav." 5 | (with-open-wv (reader wv-name) 6 | (let* ((first-block (read-wv-block reader)) 7 | (channels (block-channels first-block)) 8 | (bps (block-bps first-block)) 9 | (total-samples (block-total-samples first-block)) 10 | (samplerate (block-samplerate first-block))) 11 | 12 | (reader-position reader 0) 13 | (restore-sync reader) 14 | 15 | (with-output-to-wav (out-stream wav-name 16 | :supersede t 17 | :samplerate samplerate 18 | :channels channels 19 | :bps bps 20 | :totalsamples total-samples) 21 | (handler-case 22 | (loop with samples-written = 0 23 | while (< samples-written total-samples) 24 | for block = (read-wv-block reader) 25 | for samples = (block-block-samples block) do 26 | (incf samples-written samples) 27 | (write-sequence 28 | (interleave-channels (decode-wv-block block)) out-stream))))))) 29 | -------------------------------------------------------------------------------- /wv/metadata.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.wv) 2 | 3 | ;; Metadata body readers 4 | (defmethod read-metadata-body ((metadata metadata) reader) 5 | (let ((data (make-array (list (metadata-actual-size metadata)) 6 | :element-type '(ub 8)))) 7 | (setf (metadata-data metadata) 8 | (read-octet-vector data reader))) 9 | (warn 'unknown-metadata :metadata metadata) 10 | metadata) 11 | 12 | (defmethod read-metadata-body :after ((metadata metadata) reader) 13 | (unless (= (metadata-size metadata) 14 | (metadata-actual-size metadata)) 15 | (read-octet reader))) 16 | 17 | (defmethod read-metadata-body :before ((metadata metadata-decorr) reader) 18 | (let ((decorr-passes (block-decorr-passes *current-block*)) 19 | (data-length (metadata-actual-size metadata))) 20 | (setf (metadata-decorr-passes metadata) 21 | (if decorr-passes decorr-passes 22 | (setf (block-decorr-passes *current-block*) 23 | (loop repeat data-length collect (make-decorr-pass))))))) 24 | 25 | (defmethod read-metadata-body ((metadata metadata-decorr-terms) reader) 26 | ;; NB: in wavpack lib data is filled in backward order. We do not do this. 27 | (let ((data-length (metadata-actual-size metadata))) 28 | (when (or (> data-length 16) 29 | (/= data-length (length (metadata-decorr-passes metadata)))) 30 | (error 'block-error 31 | :format-control "Size of metadata sub-block ~a is incorrect" 32 | :format-arguments (list metadata)))) 33 | 34 | (loop for decorr-pass in (metadata-decorr-passes metadata) do 35 | (let* ((octet (read-octet reader)) 36 | (term (- (logand octet #x1f) 5)) 37 | (delta (logand (ash octet -5) #x7))) 38 | (when (or (= term 0) 39 | (< term -3) 40 | (and (> term 8) (< term 17)) 41 | (> term 18)) 42 | (error 'block-error 43 | :format-control "Invalid term in metadata sub-block ~a" 44 | :format-arguments (list metadata))) 45 | (setf (decorr-pass-term decorr-pass) term 46 | (decorr-pass-delta decorr-pass) delta))) 47 | metadata) 48 | 49 | (defmethod read-metadata-body ((metadata metadata-decorr-weights) reader) 50 | (declare (optimize (speed 3))) 51 | (let* ((data-size (metadata-actual-size metadata)) 52 | (channels (block-data-channels *current-block*)) 53 | (term-number (floor data-size channels)) 54 | (decorr-passes (metadata-decorr-passes metadata))) 55 | (declare (type (ub 24) data-size) 56 | (type list decorr-passes)) 57 | (when (> term-number (length decorr-passes)) 58 | (error 'block-error 59 | :format-control "Size of metadata sub-block ~a is too big" 60 | :format-arguments (list metadata))) 61 | (flet ((restore-weight (weight) 62 | (if (< weight #x80) 63 | (let ((val (ash weight 3))) 64 | (+ val (ash (+ val 64) -7))) 65 | (- (ash (- #x100 weight) 3))))) 66 | (loop for decorr-pass in decorr-passes 67 | repeat term-number do 68 | (loop for channel below channels do 69 | (setf (aref (decorr-pass-weight decorr-pass) channel) 70 | (restore-weight (read-octet reader))))))) 71 | metadata) 72 | 73 | (defmethod read-metadata-body ((metadata metadata-decorr-samples) reader) 74 | (when (and (= (block-version *current-block*) #x402) 75 | (flag-set-p *current-block* +flags-hybrid-mode+)) 76 | (error 'block-error :format-control "Hybrid encoding is not supported")) 77 | 78 | (let ((first-pass (first (metadata-decorr-passes metadata)))) 79 | (when first-pass 80 | (let ((channels (block-data-channels *current-block*)) 81 | (first-term (decorr-pass-term first-pass)) 82 | (bytes-read 0)) 83 | (when (and (< first-term 0) 84 | (= channels 1)) 85 | (error 'block-error :format-control "decorrelation term < 0 and mono audio")) 86 | (let ((decorr-samples 87 | (cond 88 | ((> first-term 8) 89 | (let ((decorr-samples 90 | (loop repeat channels collect 91 | (make-array (list 2) :element-type '(sb 32))))) 92 | (loop for samples in decorr-samples do 93 | (setf (aref samples 0) 94 | (exp2s (read-octets 2 reader :endianness :little)) 95 | (aref samples 1) 96 | (exp2s (read-octets 2 reader :endianness :little))) 97 | (incf bytes-read 4)) 98 | decorr-samples)) 99 | ((< first-term 0) 100 | (loop for i below channels do (incf bytes-read 2) collect 101 | (exp2s (read-octets 2 reader :endianness :little)))) 102 | (t 103 | (let ((decorr-samples 104 | (loop repeat channels collect 105 | (make-array (list first-term) :element-type '(sb 32))))) 106 | (loop for i below first-term do 107 | (loop for samples in decorr-samples do 108 | (setf (aref samples i) 109 | (exp2s (read-octets 2 reader :endianness :little))) 110 | (incf bytes-read 2))) 111 | decorr-samples))))) 112 | 113 | (unless (= bytes-read (metadata-actual-size metadata)) 114 | (error 'block-error 115 | :format-control "Size of metadata sub-block ~a is invalid" 116 | :format-arguments (list metadata))) 117 | (setf (metadata-decorr-samples metadata) decorr-samples 118 | (block-decorr-samples *current-block*) decorr-samples))))) 119 | metadata) 120 | 121 | (defmethod read-metadata-body ((metadata metadata-entropy) reader) 122 | (let ((data-size (metadata-actual-size metadata)) 123 | (channels (block-data-channels *current-block*))) 124 | (unless (= data-size (* 6 channels)) 125 | (error 'block-error 126 | :format-control "Size of metadata sub-block ~a is invalid" 127 | :format-arguments (list metadata))) 128 | (setf (metadata-entropy-median metadata) 129 | (loop repeat channels collect 130 | (let ((median (make-array 3 :element-type '(ub 32)))) 131 | (loop for i below 3 do 132 | (setf (aref median i) 133 | (exp2s (read-octets 2 reader :endianness :little)))) 134 | median)) 135 | (block-entropy-median *current-block*) 136 | (metadata-entropy-median metadata))) 137 | metadata) 138 | 139 | (defmethod read-metadata-body ((metadata metadata-int32-info) reader) 140 | (let ((data-size (metadata-actual-size metadata))) 141 | (unless (= data-size 4) 142 | (error 'block-error 143 | :format-control "Size of metadata sub-block ~a is invalid" 144 | :format-arguments (list metadata)))) 145 | (setf (metadata-sent-bits metadata) (read-octet reader) 146 | (metadata-zeros metadata) (read-octet reader) 147 | (metadata-ones metadata) (read-octet reader) 148 | (metadata-dups metadata) (read-octet reader) 149 | (block-int32-info *current-block*) metadata) 150 | metadata) 151 | 152 | (defmethod read-metadata-body ((metadata metadata-wvx-bits) reader) 153 | (let ((int32-info (find 'metadata-int32-info (block-metadata *current-block*) 154 | :key #'type-of))) 155 | (unless int32-info 156 | (error 'block-error :format-control "No int32-info prior to wvx-bitstream")) 157 | (let* ((block-samples (block-block-samples *current-block*)) 158 | (channels (block-data-channels *current-block*)) 159 | (sent-bits (metadata-sent-bits int32-info)) 160 | (size (metadata-actual-size metadata)) 161 | (expected-size (+ (* channels block-samples sent-bits) 32))) 162 | (unless (= expected-size (* size 8)) 163 | (error 'block-error :format-control "This wvx-bitstream has unexpected size")) 164 | (setf (metadata-crc32 metadata) 165 | (read-octets 4 reader :endianness :little)) 166 | (let ((bits (loop repeat channels collect 167 | (make-array (list block-samples) :element-type '(sb 32))))) 168 | (loop for i below block-samples do 169 | (loop for j below channels do 170 | (setf (aref (nth j bits) i) 171 | (read-bits-bw sent-bits reader)))) 172 | (setf (metadata-bits metadata) bits 173 | ;; Make a copy for easy access 174 | (block-wvx-bits *current-block*) bits)))) 175 | metadata) 176 | 177 | (defmethod read-metadata-body :around ((metadata metadata-ignorable) reader) 178 | (declare (ignore reader)) 179 | (handler-bind 180 | ((unknown-metadata #'muffle-warning)) 181 | (call-next-method))) 182 | 183 | ;; We do not have primary reader method for residual block, as we cannot do 184 | ;; anything with it at the moment when READ-METADATA-BODY is called. We 185 | ;; only create additional residual reader in the following method. 186 | (defmethod read-metadata-body :after ((metadata metadata-residual) reader) 187 | (declare (ignore reader)) 188 | (setf (metadata-residual-reader metadata) 189 | (make-reader-from-buffer (metadata-data metadata)))) 190 | 191 | ;; Metadata reader 192 | (defreader (%read-metadata) ((make-instance 'metadata) metadata) 193 | (metadata-id (:octets 1)) 194 | (metadata-size (:octets (if (all-bits-set-p (metadata-id metadata) 195 | +meta-id-large-block+) 196 | 3 1)) 197 | :endianness :little 198 | :function (lambda (x) (* x 2)))) 199 | 200 | (defun read-metadata (reader) 201 | (let ((metadata (%read-metadata reader))) 202 | (setf (metadata-actual-size metadata) 203 | (let ((size (metadata-size metadata))) 204 | (if (all-bits-set-p (metadata-id metadata) +meta-id-data-length--1+) 205 | (1- size) size))) 206 | (let* ((id (metadata-id metadata)) 207 | (useless (all-bits-set-p id +meta-id-useless-for-decoder+)) 208 | (useful (not useless)) 209 | (function (logand id (logior +meta-id-useless-for-decoder+ 210 | +meta-id-function+)))) 211 | (change-class 212 | metadata 213 | (cond 214 | ((and useful (= function +meta-id-decorr-terms+)) 'metadata-decorr-terms) 215 | ((and useful (= function +meta-id-decorr-weights+)) 'metadata-decorr-weights) 216 | ((and useful (= function +meta-id-decorr-samples+)) 'metadata-decorr-samples) 217 | ((and useful (= function +meta-id-entropy-vars+)) 'metadata-entropy) 218 | ((and useful (= function +meta-id-wv-bitstream+)) 'metadata-wv-residual) 219 | ((and useful (= function +meta-id-int32-info+)) 'metadata-int32-info) 220 | ((and useful (= function +meta-id-wvx-bitstream+)) 'metadata-wvx-bits) 221 | ((and useless (= function +meta-id-riff-header+)) 'metadata-riff-header) 222 | ((and useless (= function +meta-id-riff-trailer+)) 'metadata-riff-trailer) 223 | (t 'metadata)))) 224 | (read-metadata-body metadata reader))) 225 | -------------------------------------------------------------------------------- /wv/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage easy-audio.wv 2 | (:use #:cl 3 | #:alexandria 4 | #:easy-audio.bitreader 5 | #:easy-audio.core) 6 | (:local-nicknames (:sera :serapeum)) 7 | (:export #:wavpack-error ; Conditions 8 | #:wavpack-warning 9 | #:block-error 10 | #:lost-sync 11 | #:unknown-metadata 12 | 13 | #:read-new-block-single ; Restarts and recovery from errors 14 | #:read-new-block-multichannel 15 | #:read-new-block 16 | 17 | #:metadata-riff-header ; Metadata types 18 | #:metadata-riff-trailer 19 | 20 | #:block-samplerate ; Block parameters 21 | #:block-bps 22 | #:block-channels 23 | #:block-track-number ; Unused in current format specification 24 | #:block-index-number ; Unused in current format specification 25 | #:block-total-samples 26 | #:block-block-index 27 | #:block-block-samples 28 | #:block-metadata 29 | #:metadata-data 30 | #:flag-set-p 31 | 32 | #:read-wv-block ; Functions 33 | #:read-wv-block-multichannel 34 | #:decode-wv-block 35 | #:restore-sync 36 | #:restore-sync-multichannel 37 | #:seek-sample 38 | #:open-wv 39 | 40 | #:with-open-wv)) ;; Macros 41 | -------------------------------------------------------------------------------- /wv/wavpack-reader.lisp: -------------------------------------------------------------------------------- 1 | ;; This is actually utility functions just like in flac/flac-reader.lisp 2 | (in-package :easy-audio.wv) 3 | 4 | (declaim (type (sa-ub 8) +exp2-table+)) 5 | (define-constant +exp2-table+ 6 | (make-array (list 256) 7 | :element-type '(ub 8) 8 | :initial-contents 9 | (flet ((calc (x) 10 | (let* ((val (* 256 (1- (expt 2 (/ x 256.0))))) 11 | (int-val (floor val))) 12 | (if (< (- val int-val) 13 | (- int-val val -1)) 14 | int-val (1+ int-val))))) 15 | (loop for x below 256 collect (calc x)))) 16 | :test #'equalp) 17 | 18 | (sera:-> exp2s ((ub 16)) 19 | (values (sb 32) &optional)) 20 | (defun exp2s (val) 21 | (declare (optimize (speed 3))) 22 | (if (< val #x8000) 23 | (let ((m (logior (aref +exp2-table+ 24 | (logand val #xff)) 25 | #x100)) 26 | (exp (ash val -8))) 27 | (ash m (- exp 9))) 28 | (- (exp2s (1+ (logxor #xffff val)))))) 29 | 30 | ;; From flac reader 31 | (sera:-> read-unary-coded-integer (reader &optional (or non-negative-fixnum null)) 32 | (values non-negative-fixnum &optional)) 33 | (defun read-unary-coded-integer (bitreader &optional limit) 34 | "Read an unary coded integer from bitreader 1 bit is considered as 35 | arithmetical 1, 0 bit signals termination." 36 | (declare (optimize (speed 3))) 37 | (loop for res fixnum from 0 by 1 38 | until (or (zerop (read-bit-bw bitreader)) 39 | (and limit (= res limit))) 40 | finally (return res))) 41 | 42 | (sera:-> read-elias-code (reader) 43 | (values non-negative-fixnum &optional)) 44 | (defun read-elias-code (reader) 45 | (declare (optimize (speed 3))) 46 | (let ((ones-num (read-unary-coded-integer reader))) 47 | (declare (type (integer 0 32) ones-num)) 48 | (if (zerop ones-num) 0 49 | (let ((shift (1- ones-num))) 50 | (logior (ash 1 shift) 51 | (read-bits-bw shift reader)))))) 52 | 53 | (sera:-> read-code (reader non-negative-fixnum) 54 | (values non-negative-fixnum &optional)) 55 | (defun read-code (reader maxvalue) 56 | (declare (optimize (speed 3))) 57 | (cond 58 | ((= maxvalue 0) 0) 59 | ((= maxvalue 1) 60 | (read-bit-bw reader)) 61 | (t 62 | (let* ((bits (integer-length maxvalue)) 63 | (extra (- (ash 1 bits) maxvalue 1)) 64 | (res (read-bits-bw (1- bits) reader))) 65 | (if (< res extra) res 66 | (+ (ash res 1) (read-bit-bw reader) (- extra))))))) 67 | -------------------------------------------------------------------------------- /wv/wv-block.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.wv) 2 | 3 | (declaim (inline get-med)) 4 | (defun get-med (median) 5 | (1+ (ash median -4))) 6 | 7 | (declaim (inline inc-med)) 8 | (defun inc-med (median amount) 9 | (+ median (* 5 (floor (+ amount median) amount)))) 10 | 11 | (declaim (inline dec-med)) 12 | (defun dec-med (median amount) 13 | (- median (* 2 (floor (+ amount median -2) amount)))) 14 | 15 | (defun decode-residual (wv-block) 16 | (declare (optimize (speed 3))) 17 | (when (flag-set-p wv-block +flags-hybrid-mode+) 18 | (error 'block-error :format-control "Cannot work with hybrid mode")) 19 | (let ((metadata-residual (find 'metadata-wv-residual (the list (block-metadata wv-block)) 20 | :key #'type-of)) 21 | (channels (block-data-channels wv-block)) 22 | (samples (block-block-samples wv-block))) 23 | (when metadata-residual 24 | (let ((residual (loop repeat channels collect 25 | (make-array samples 26 | :element-type '(sb 32) 27 | :initial-element 0))) 28 | (coded-residual-reader (metadata-residual-reader metadata-residual)) 29 | (medians (block-entropy-median wv-block)) 30 | holding-one holding-zero zero-run-met) 31 | 32 | (do* ((i 0) 33 | (sample 0 (ash i (- 1 channels))) 34 | (channel 0 (logand i (1- channels)))) 35 | ((= sample samples) sample) 36 | (declare (type (ub 32) i sample channel)) 37 | 38 | (when (> sample samples) 39 | (error 'block-error :format-control "Accidentally read too much samples")) 40 | (cond 41 | ((and (< (aref (the (sa-ub 32) (first medians)) 0) 2) 42 | (or (null (second medians)) 43 | (< (aref (the (sa-ub 32) (second medians)) 0) 2)) 44 | (not holding-one) 45 | (not holding-zero) 46 | (not zero-run-met)) 47 | ;; Run of zeros - do nothing 48 | (let ((zero-length (read-elias-code coded-residual-reader))) 49 | (when (/= zero-length 0) 50 | (incf i zero-length) 51 | (mapc (lambda (median) 52 | (declare (type (sa-ub 32) median)) 53 | (fill median 0)) medians))) 54 | (setq zero-run-met t)) 55 | 56 | (t 57 | (setq zero-run-met nil) 58 | (let ((ones-count 0)) 59 | (declare (type non-negative-fixnum ones-count)) 60 | (cond 61 | (holding-zero (setq holding-zero nil)) 62 | (t 63 | (setq ones-count (read-unary-coded-integer coded-residual-reader (1+ 16))) 64 | (when (>= ones-count 16) 65 | (when (= ones-count 17) 66 | (error 'block-error :format-control "Invalid residual code")) 67 | (incf ones-count (read-elias-code coded-residual-reader))) 68 | (psetq 69 | holding-one (/= (logand ones-count 1) 0) 70 | ones-count (+ (ash ones-count -1) (if holding-one 1 0))) 71 | (setq holding-zero (not holding-one)))) 72 | 73 | (let ((median (nth channel medians)) 74 | (low 0) 75 | (high 0)) 76 | (declare (type (sb 32) low high) 77 | (type (sa-ub 32) median)) 78 | (cond 79 | ((= ones-count 0) 80 | (setq high (1- (get-med (aref median 0)))) 81 | (setf (aref median 0) (dec-med (aref median 0) 128))) 82 | (t 83 | (setq low (get-med (aref median 0))) 84 | (setf (aref median 0) (inc-med (aref median 0) 128)) 85 | (cond 86 | ((= ones-count 1) 87 | (setq high (+ low (get-med (aref median 1)) -1)) 88 | (setf (aref median 1) (dec-med (aref median 1) 64))) 89 | (t 90 | (setq low (+ low (get-med (aref median 1)))) 91 | (setf (aref median 1) (inc-med (aref median 1) 64)) 92 | (cond 93 | ((= ones-count 2) 94 | (setq high (+ low (get-med (aref median 2)) -1)) 95 | (setf (aref median 2) (dec-med (aref median 2) 32))) 96 | (t 97 | (setq low (+ low (the (sb 32) 98 | (* (get-med (aref median 2)) 99 | (- ones-count 2)))) 100 | high (+ low (get-med (aref median 2)) -1)) 101 | (setf (aref median 2) (inc-med (aref median 2) 32)))))))) 102 | (incf low (read-code coded-residual-reader (- high low))) 103 | (setf (aref (the (sa-sb 32) (nth channel residual)) sample) 104 | (if (= (read-bit-bw coded-residual-reader) 1) 105 | (lognot low) low)))) 106 | (incf i)))) 107 | (read-to-byte-alignment coded-residual-reader) 108 | ;; For some reason residual reader looses some useful ("actual") data at the end 109 | ;; and it seems to be OK. But check if we loose too much 110 | (when (> (- (reader-length coded-residual-reader) 111 | (reader-position coded-residual-reader)) 112 | 1) 113 | (error 'block-error 114 | :format-control "Too much useful data is lost in residual reader")) 115 | (setf (block-residual wv-block) residual)))) 116 | wv-block) 117 | 118 | ;; Coding guide to myself: 119 | 120 | ;; 1) When I need to check if flag (bit) is set, use all-bits-set-p function 121 | ;; 2) When I need to choose which flag in the set is set, use cond 122 | ;; macro with (logand x mask) 123 | ;; 3) When I need to get a value from flags using masks and shifts, use 124 | ;; automatically generated special functions 125 | 126 | (defreader (%%read-wv-block) ((make-wv-block)) 127 | (block-id (:octets 4) :endianness :big) 128 | (block-size (:octets 4) :endianness :little) 129 | (block-version (:octets 2) :endianness :little) 130 | (block-track-number (:octets 1)) 131 | (block-index-number (:octets 1)) 132 | (block-total-samples (:octets 4) :endianness :little) 133 | (block-block-index (:octets 4) :endianness :little) 134 | (block-block-samples (:octets 4) :endianness :little) 135 | (block-flags (:octets 4) :endianness :little) 136 | (block-crc (:octets 4) :endianness :little)) 137 | 138 | (defun %read-wv-block (reader) 139 | (declare (optimize (speed 3))) 140 | (let ((wv-block (%%read-wv-block reader))) 141 | (unless (= (block-id wv-block) +wv-id+) 142 | (error 'lost-sync :format-control "WavPack ckID /= 'wvpk'")) 143 | 144 | (let ((version (block-version wv-block))) 145 | (when (or (< version #x402) ; FIXME: is this range inclusive? 146 | (> version #x410)) 147 | (error 'block-error :format-control "Unsupported WavPack block version"))) 148 | 149 | (when (flag-set-p wv-block +flags-reserved-zero+) 150 | ;; Specification says we should "refuse to decode if set" 151 | (error 'block-error :format-control "Reserved flag is set to 1")) 152 | 153 | (let ((sub-blocks-size (- (block-size wv-block) 24)) 154 | (*current-block* wv-block)) 155 | (when (< sub-blocks-size 0) 156 | (error 'block-error :format-control "Sub-blocks size is less than 0")) 157 | (loop with bytes-read fixnum = 0 158 | while (< bytes-read sub-blocks-size) 159 | for metadata = (read-metadata reader) 160 | do (incf bytes-read (+ 1 (if (all-bits-set-p (metadata-id metadata) 161 | +meta-id-large-block+) 162 | 3 1) 163 | (the (ub 24) (metadata-size metadata)))) 164 | (push metadata (block-metadata wv-block)) 165 | finally 166 | (when (> bytes-read sub-blocks-size) 167 | (error 'block-error :format-control "Read more sub-block bytes than needed")))) 168 | 169 | (decode-residual wv-block))) 170 | 171 | (defun read-wv-block (reader) 172 | "Read the next block in the stream. @c(reader)'s position must be set to the 173 | beginning of this block explicitly (e.g. by calling @c(restore-sync))." 174 | (restart-case 175 | (%read-wv-block reader) 176 | (read-new-block-single () 177 | :report "Restore sync and read a new block" 178 | (restore-sync reader) 179 | (read-wv-block reader)))) 180 | 181 | (defun restore-sync (reader) 182 | "Restore the reader's position to the first occurring block in the 183 | stream." 184 | (peek-octet reader +wv-id/first-octet+) 185 | (let ((position (reader-position reader))) 186 | (handler-case 187 | (prog1 188 | (block-block-index (read-wv-block reader)) 189 | (reader-position reader position)) 190 | (lost-sync () 191 | (reader-position reader (1+ position)) 192 | (restore-sync reader))))) 193 | 194 | (defun seek-sample (reader number) 195 | (declare (type (integer 0) number)) 196 | "Set reader position to beginning of the block which contains a 197 | sample with the specified number. Works for readers associated with 198 | files. Return a position of the sample in the block." 199 | ;; Reset position of the reader 200 | (reader-position reader 0) 201 | (restore-sync reader) 202 | 203 | (let* ((file-length (reader-length reader)) 204 | (test-block (read-wv-block reader)) 205 | (total-samples (block-total-samples test-block)) 206 | (block-samples (block-block-samples test-block))) 207 | 208 | (when (> number total-samples) 209 | (error 'wavpack-error 210 | :format-control "Requested sample number is too big")) 211 | 212 | (multiple-value-bind (complete-blocks remainder) 213 | (floor number block-samples) 214 | (let ((block-starting-number (* block-samples complete-blocks))) 215 | (labels ((binary-search (start end) 216 | (let* ((middle (+ start (floor (- end start) 2))) 217 | (first-half (progn 218 | (reader-position reader start) 219 | (restore-sync reader))) 220 | (second-half (progn 221 | (reader-position reader (1- middle)) 222 | (restore-sync reader)))) 223 | (when (< block-starting-number first-half) 224 | (error 'wavpack-error 225 | :format-control "Seeking error: wrong half chosen")) 226 | (cond 227 | ((< block-starting-number second-half) 228 | (binary-search start middle)) 229 | ((> block-starting-number second-half) 230 | (binary-search middle end)) 231 | (t t))))) 232 | (binary-search 0 file-length)) 233 | remainder)))) 234 | 235 | (defun open-wv (stream) 236 | "Return @c(bitreader) handle of Wavpack stream." 237 | (make-reader-from-stream stream)) 238 | 239 | (defmacro with-open-wv ((reader name &rest options) &body body) 240 | "Binds READER to an open wavpack stream associated with a file with 241 | the name NAME." 242 | (let ((stream (gensym))) 243 | `(let* ((,stream (open ,name :element-type '(ub 8) ,@options)) 244 | (,reader (open-wv ,stream))) 245 | (unwind-protect (progn ,@body) (close ,stream))))) 246 | -------------------------------------------------------------------------------- /wv/wv-blocks-multichannel.lisp: -------------------------------------------------------------------------------- 1 | (in-package :easy-audio.wv) 2 | 3 | (defun read-wv-block-multichannel% (reader) 4 | (let ((first-block (read-wv-block reader))) 5 | (when (not (flag-set-p first-block +flags-initial-block+)) 6 | (error 'lost-sync 7 | :format-control 8 | "Lost sync: the first block in multichannel configuration is not initial")) 9 | (if (flag-set-p first-block +flags-final-block+) 10 | (list first-block) 11 | (cons first-block 12 | (loop for wv-block = (read-wv-block reader) 13 | collect wv-block 14 | until (flag-set-p wv-block +flags-final-block+)))))) 15 | 16 | (defun read-wv-block-multichannel (reader) 17 | "Read a list of Wavpack blocks in an multichannel configuration 18 | different from 1.0 or 2.0. Each block in the list can itself 19 | be mono or stereo. Read the format specification for the 20 | details." 21 | (restart-case 22 | (read-wv-block-multichannel% reader) 23 | (read-new-block-multichannel () 24 | :report "Restore sync and read a new multichannel blocks list" 25 | (restore-sync-multichannel reader) 26 | (read-wv-block-multichannel reader)))) 27 | 28 | (defun restore-sync-multichannel (reader) 29 | "Restore sync in multichannel configuration. 30 | The reader position is set to the beginning of the first channel block." 31 | (restore-sync reader) 32 | (labels ((restore-sync-multichannel% (reader) 33 | (let ((reader-position (reader-position reader))) 34 | (handler-case 35 | (prog1 36 | (block-block-index (first 37 | (read-wv-block-multichannel reader))) 38 | (reader-position reader reader-position)) 39 | (lost-sync () 40 | (reader-position reader (1+ reader-position)) 41 | (restore-sync-multichannel% reader)))))) 42 | (restore-sync-multichannel% reader))) 43 | 44 | (defun read-new-block (c) 45 | "Function to be supplied to @c(handler-bind) in order to deal with @c(lost-sync) 46 | condition. It transfers control to @c(read-new-block-single) or to 47 | @c(read-new-block-multichannel) depending on the situation. A newly read block or a 48 | list of blocks is always returned from @c(handler-bind) if @c(bitreader-eof) is not 49 | signalled." 50 | (declare (ignore c)) 51 | (if (find-restart 'read-new-block-multichannel) 52 | (invoke-restart 'read-new-block-multichannel) 53 | (invoke-restart 'read-new-block-single))) 54 | --------------------------------------------------------------------------------