From e3c7e3e05a6acdf2a91174e8e99476ed7e2ce200 Mon Sep 17 00:00:00 2001 From: Steve Ayerhart Date: Thu, 27 Oct 2022 23:02:46 -0400 Subject: [PATCH] major refactor --- src/flac/decoder.scm | 210 +++++++++++++++++++----------------------- src/flac/format.scm | 21 +++-- src/flac/metadata.scm | 44 ++++----- src/flac/reader.scm | 1 + src/flac/tests.scm | 79 +++++++++++++--- 5 files changed, 192 insertions(+), 163 deletions(-) diff --git a/src/flac/decoder.scm b/src/flac/decoder.scm index 26cc4f3..a90df36 100644 --- a/src/flac/decoder.scm +++ b/src/flac/decoder.scm @@ -12,6 +12,7 @@ #:use-module (ice-9 receive) #:export (read-flac-frame)) +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#section-10.1-1 (define (read/assert-frame-sync-code) (unless (= #b111111111111100 (flac-read-uint 15)) #f)) @@ -32,6 +33,7 @@ ((= raw #b1010) 3) (else #f)))) +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#name-block-size-bits (define (decode-block-size raw) (cond ((= raw #b0000) 'reserved) @@ -41,6 +43,7 @@ ((= raw #b0111) (+ 1 (flac-read-uint 16))) ((between? raw #b1000 #b1111) (* 256 (expt 2 (- raw 8)))))) +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#name-sample-rate-bits (define (decode-sample-rate stream-info raw) (case raw ((#b0000) (stream-info-sample-rate stream-info)) @@ -60,6 +63,15 @@ ((#b1110) (* 10 (flac-read-uint 16))) ; sample rate in tens of Hz ((#b1111) 'invalid)))) +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#name-coded-number +(define (flac-read-coded-number) + (let coded-number-loop ((coded-sample-number (flac-read-uint 8))) + (if (< coded-sample-number #b11000000) + coded-sample-number + (begin + (flac-read-uint 8) + (coded-number-loop (bitwise-and (bitwise-arithmetic-shift coded-sample-number 1) #xff)))))) + (define (decode-bits-per-sample stream-info raw) (case raw ((#b000) (stream-info-bits-per-sample stream-info)) @@ -91,19 +103,27 @@ ('mid (if (= channel 1) 1 0)) (_ 0)))) -(define (read-subframe-constant blocksize sample-depth wasted-bits) - (let ((subframe (%make-subframe-constant (make-list blocksize (bitwise-arithmetic-shift (flac-read-sint sample-depth) wasted-bits))))) - (values subframe (subframe-constant-value subframe)))) - -(define (read-subframe-verbatim blocksize sample-depth wasted-bits) - (let ((subframe (%make-subframe-verbatim - (list-ec (: b blocksize) (bitwise-arithmetic-shift (flac-read-sint sample-depth) wasted-bits))))) - (values subframe (subframe-verbatim-value subframe)))) - (define (read-entropy-coding-method-info) (values (case (flac-read-uint 2) [(#b00) 'rice] [(#b01) 'rice2]) (flac-read-uint 4))) -(define (read-residual-partiioned-rice blocksize predictor-order) +(define (restore-linear-prediction warmup residuals coefficients order shift) + (fold (λ (residual samples) + (append! + samples + (list + (+ residual + (bitwise-arithmetic-shift-right + (fold (λ (residual coefficient predictor) + (+ predictor (* residual coefficient))) + 0 + (take-right samples order) + coefficients) + shift))))) + warmup + residuals)) + +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#name-coded-residual +(define (read-residual-partitioned-rice blocksize predictor-order) (let-values (((coding-method partition-order) (read-entropy-coding-method-info))) (let ((param-bits (match coding-method ('rice 4) ('rice2 5) (_ #f))) (escape-param (match coding-method ('rice #xf) ('rice2 #x1f))) @@ -115,12 +135,7 @@ (raw-bits '()) (residual '())) (if (>= partition partitions) - (values (%make-entropy-coding-method - coding-method - (%make-rice-partition - partition-order - (%make-entropy-coding-method-partitioned-rice-contents parameters raw-bits #f))) - residual) + residual (let ((rice-parameter (flac-read-uint param-bits))) (if (< rice-parameter escape-param) (let ((count (if (= 0 partition) (- partition-samples predictor-order) partition-samples))) @@ -140,41 +155,6 @@ (make-list order 0) (list-ec (: o order) (flac-read-sint num-bits)))))))))))))) - -(define (read-subframe-fixed predictor-order blocksize sample-depth) - (let ((warmup (list-ec (: o predictor-order) (flac-read-sint sample-depth))) - (fixed-coefficients '(() (1) (2 -1) (3 -3 1) (4 -6 4 -1)))) - (let-values (((entropy-coding-method residual) (read-residual-partiioned-rice blocksize predictor-order))) - (values - (%make-subframe-fixed entropy-coding-method predictor-order warmup residual) - (restore-linear-prediction warmup residual (list-ref fixed-coefficients predictor-order) predictor-order 0))))) - -(define (read-subframe-lpc lpc-order blocksize sample-depth) - (let* ((warmup (list-ec (: o lpc-order) (flac-read-sint sample-depth))) - (precision (+ 1 (flac-read-uint 4))) - (shift (flac-read-sint 5)) - (coefs (reverse (list-ec (: o lpc-order) (flac-read-sint precision))))) - (let-values (((entropy-coding-method residual) (read-residual-partiioned-rice blocksize lpc-order))) - (values - (%make-subframe-lpc entropy-coding-method lpc-order precision shift coefs warmup residual) - (restore-linear-prediction warmup residual coefs lpc-order shift))))) - -(define (restore-linear-prediction warmup residuals coefficients order shift) - (fold (λ (residual samples) - (append - samples - (list - (+ residual - (bitwise-arithmetic-shift-right - (fold (λ (residual coefficient predictor) - (+ predictor (* residual coefficient))) - 0 - (take-right samples order) - coefficients) - shift))))) - warmup - residuals)) - ;;; 000000 constant ;;; 000001 verbatim ;;; 00001x reserved @@ -191,12 +171,33 @@ ((between? raw #b100000 #b111111) (values (+ 1 (bit-extract raw 0 5)) 'lpc)) (else (values #f #f))))) +; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#name-interchannel-decorrelation +(define (stereo-decorrelation samples channel-assignment) + (match channel-assignment + ('independent samples) + ('left (list (first samples) (map! - (first samples) (second samples)))) + ('right (list (second samples) (map! + (first samples) (second samples)))) + ('mid (fold + (λ (sample-0 sample-1 samples) + (let* ((prev-samples-0 (first samples)) + (prev-samples-1 (second samples)) + (side sample-1) + (right (- sample-0 (bitwise-arithmetic-shift-right side 1)))) + (list + (append prev-samples-0 (list right)) + (append prev-samples-1 (list (+ right side)))))) + '(() ()) + (first samples) + (second samples))))) + +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#name-subframe-header (define (read-subframe-header) (read/assert-subframe-sync) (receive (order type) (read-subframe-type) (%make-subframe-header type order (read-subframe-wasted-bits)))) +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#name-subframes (define (read-subframe frame-header channel) (let* ((subframe-header (read-subframe-header)) (wasted-bits (subframe-header-wasted-bits subframe-header)) @@ -207,70 +208,49 @@ (frame-header-channel-assignment frame-header) channel)) (blocksize (frame-header-blocksize frame-header))) - (let-values (((subframe samples) - (match (subframe-header-subframe-type subframe-header) - ('constant (read-subframe-constant blocksize sample-depth wasted-bits)) - ('verbatim (read-subframe-verbatim blocksize sample-depth wasted-bits)) - ('fixed (read-subframe-fixed predictor-order blocksize sample-depth)) - ('lpc (read-subframe-lpc predictor-order blocksize sample-depth))))) - (values - (%make-subframe subframe-header subframe) - samples)))) + (match (subframe-header-subframe-type subframe-header) + ('constant (read-subframe-constant blocksize sample-depth wasted-bits)) + ('verbatim (read-subframe-verbatim blocksize sample-depth wasted-bits)) + ('fixed (read-subframe-fixed predictor-order blocksize sample-depth)) + ('lpc (read-subframe-lpc predictor-order blocksize sample-depth))))) + + +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#section-5.3-2.1.1 +(define (read-subframe-verbatim blocksize sample-depth wasted-bits) + (list-ec (: b blocksize) (bitwise-arithmetic-shift (flac-read-sint sample-depth) wasted-bits))) + +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#section-5.3-2.2.1 +(define (read-subframe-constant blocksize sample-depth wasted-bits) + (make-list blocksize (bitwise-arithmetic-shift (flac-read-sint sample-depth) wasted-bits))) + +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#name-fixed-predictor-subframe +(define (read-subframe-fixed predictor-order blocksize sample-depth) + (let ((warmup (list-ec (: o predictor-order) (flac-read-sint sample-depth))) + (fixed-coefficients '(() (1) (2 -1) (3 -3 1) (4 -6 4 -1))) + (residual (read-residual-partitioned-rice blocksize predictor-order))) + (restore-linear-prediction warmup residual (list-ref fixed-coefficients predictor-order) predictor-order 0))) + +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#name-linear-predictor-subframe +(define (read-subframe-lpc lpc-order blocksize sample-depth) + (let* ((warmup (list-ec (: o lpc-order) (flac-read-sint sample-depth))) + (precision (+ 1 (flac-read-uint 4))) + (shift (flac-read-sint 5)) + (coefs (reverse (list-ec (: o lpc-order) (flac-read-sint precision)))) + (residual (read-residual-partitioned-rice blocksize lpc-order))) + (restore-linear-prediction warmup residual coefs lpc-order shift))) + ;; TODO: clean up the channel decorrelation this is kind of ugly (define (read-subframes stream-info frame-header) (let ((channels (stream-info-channels stream-info)) (channel-assignment (frame-header-channel-assignment frame-header))) - (if (eq? 'independent channel-assignment) - ; do nothing loop over channels - (let channel-loop ((channel 0) - (subframes '()) - (samples '())) - (if (>= channel channels) - (values subframes samples) - (let-values (((subframe subframe-samples) (read-subframe frame-header channel))) - (channel-loop (+ 1 channel) - (append subframes (list subframe)) - (append samples (list subframe-samples)))))) - (let-values (((channel-0-subframe channel-0-samples) (read-subframe frame-header 0)) - ((channel-1-subframe channel-1-samples) (read-subframe frame-header 1))) - (match channel-assignment - ('left (values - (list channel-0-subframe channel-1-subframe) - (list channel-0-samples (map - channel-0-samples channel-1-samples)))) - ('right (values - (list channel-0-subframe channel-1-subframe) - (list (map + channel-0-samples channel-1-samples) channel-1-samples))) - ('mid (values - (list channel-0-subframe channel-1-subframe) - (fold - (λ (channel-0 channel-1 samples) - (let* ((channel-0-samples (first samples)) - (channel-1-samples (second samples)) - (side channel-1) - (right (- channel-0 (bitwise-arithmetic-shift-right side 1)))) - (list - (append channel-0-samples (list right)) - (append channel-1-samples (list (+ right side)))))) - '(() ()) - channel-0-samples - channel-1-samples)))))))) + (map! (λ (channel) (read-subframe frame-header channel)) (iota channels)))) -;(define (read-subframes stream-info frame-header) -; (let ((channels (stream-info-channels stream-info))) -; (let subframe-loop ((channel 0) -; (subframes '()) -; (samples '())) -; (if (>= channel channels) -; (begin -; (align-to-byte) -; (values subframes samples)) -; (let-values (((subframe subframe-samples) -; (read-subframe frame-header channel))) -; (subframe-loop (+ 1 channel) -; (cons subframe subframes) -; (cons subframe-samples samples))))))) +e; TODO: actually verify the checksum +(define (read-frame-footer) + (flac-read-uint 16)) +;;; https://www.ietf.org/archive/id/draft-ietf-cellar-flac-07.html#name-frame-header (define-public (read-frame-header stream-info) (read/assert-frame-sync-code) (let* ((blocking-strategy (decode-blocking-strategy (flac-read-uint 1))) @@ -292,13 +272,9 @@ frame/sample-number crc))) -;; TODO: actually verify the checksum -(define (read-frame-footer) - (flac-read-uint 16)) - (define (read-flac-frame stream-info) - (let ((header (read-frame-header stream-info))) - (let-values (((subframes samples) (read-subframes stream-info header))) - (align-to-byte) - (let ((footer (read-frame-footer))) - (%make-frame header subframes footer samples))))) + (let* ((header (read-frame-header stream-info)) + (samples (read-subframes stream-info header))) + (align-to-byte) + (let ((footer (read-frame-footer))) + (%make-frame header footer samples)))) diff --git a/src/flac/format.scm b/src/flac/format.scm index 0f7ed41..86885c2 100644 --- a/src/flac/format.scm +++ b/src/flac/format.scm @@ -69,6 +69,8 @@ stream-info-bits-per-sample stream-info-samples stream-info-md5 make-metadata-vorbis-comment + vorbis-comment-vendor + vorbis-comment-comments make-flac-metadata flac-metadata-stream-info set-flac-metadata-stream-info! @@ -185,10 +187,9 @@ (crc frame-footer-crc)) (define-record-type - (%make-frame header subframes footer samples) + (%make-frame header footer samples) frame? (header frame-header) - (subframes frame-subframes) (footer frame-footer) (samples frame-samples)) @@ -224,10 +225,10 @@ (samples stream-info-samples) (md5 stream-info-md5)) -(set-record-type-printer! - - (λ (record port) - (format port "#"))) +;(set-record-type-printer! +; +; (λ (record port) +; (format port "#"))) (define-record-type (make-metadata-seek-table seek-points) @@ -330,10 +331,10 @@ (λ (record port) (format port "#< type: ~a mime-type: ~a>" (picture-type record) (picture-mime-type record)))) -(set-record-type-printer! - - (λ (record port) - (format port "#< header: ~a>" (frame-header record)))) +; (set-record-type-printer! +; +; (λ (record port) +; (format port "#< header: ~a>" (frame-header record)))) (define-record-type (make-flac-metadata stream-info padding application seek-table vorbis-comment cuesheet pictures) diff --git a/src/flac/metadata.scm b/src/flac/metadata.scm index 1ac8005..06cb53d 100644 --- a/src/flac/metadata.scm +++ b/src/flac/metadata.scm @@ -2,16 +2,18 @@ #:use-module (flac format) #:use-module (flac reader) + #:use-module (bytestructures guile) #:use-module (ice-9 match) #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) #:use-module (rnrs enums) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:export (read-flac-metadata flac-metadata flac-file-metadata)) -(define (read-metadata-block-header) - (make-metadata-block-header +(define-public (read-metadata-block-header) + (values (= 1 (flac-read-uint 1)) (list-ref (enum-set->list flac-metadata-type) (flac-read-uint 7)) (flac-read-uint 24))) @@ -79,29 +81,26 @@ (define (read-flac-metadata) (flac-read/assert-magic) - (let metadata-loop ((metadata (make-flac-metadata #f #f #f #f #f #f #f)) - (header (read-metadata-block-header))) - (if (metadata-block-header-last? header) - (read-metadata-block metadata (metadata-block-header-length header) (metadata-block-header-type header)) - (metadata-loop (read-metadata-block - metadata - (metadata-block-header-length header) - (metadata-block-header-type header)) - (read-metadata-block-header))))) + (let metadata-loop ((metadata (make-flac-metadata #f #f #f #f #f #f #f))) + (receive (last-block? block-type block-length) + (read-metadata-block-header) + (if last-block? + (read-metadata-block metadata block-length block-type) + (metadata-loop (read-metadata-block metadata block-length block-type)))))) ; FIXME: bail early if not in type (define (read-flac-metadata-type type) - (flac-read/assert-magic) - (let metadata-loop ((header (read-metadata-block-header))) - (if (or (metadata-block-header-last? header) - (equal? type (metadata-block-header-type header))) - (match type - ('stream-info (read-metadata-block-stream-info)) - ('vorbis-comment (read-metadata-block-vorbis-comment)) - (_ #f)) - (begin - (flac-read-bytes (metadata-block-header-length header)) - (metadata-loop (read-metadata-block-header)))))) + (let metadata-loop () + (receive (last-block? block-type block-length) + (read-metadata-block-header) + (if (or last-block? (equal? type block-type)) + (match type + ('stream-info (read-metadata-block-stream-info)) + ('vorbis-comment (read-metadata-block-vorbis-comment)) + (_ #f)) + (begin + (flac-read-bytes block-length) + (metadata-loop)))))) (define* (flac-metadata port #:optional (type #f)) (with-flac-input-port port @@ -113,4 +112,5 @@ (define* (flac-file-metadata filename #:optional (type #f)) (with-flac-input-port (open-input-file filename #:binary #t) (λ () + (flac-read/assert-magic) (flac-metadata (current-input-port) type)))) diff --git a/src/flac/reader.scm b/src/flac/reader.scm index 3d4def2..614bb25 100644 --- a/src/flac/reader.scm +++ b/src/flac/reader.scm @@ -20,6 +20,7 @@ current-flac-reader)) (define current-flac-reader (make-parameter #f)) +(define default-bit-reader-capacity 65536) ;;; TODO: redo api? callback based? diff --git a/src/flac/tests.scm b/src/flac/tests.scm index 775db29..2ba30f9 100644 --- a/src/flac/tests.scm +++ b/src/flac/tests.scm @@ -3,20 +3,21 @@ #:use-module (flac reader) #:use-module (flac format) #:use-module (flac metadata) + #:use-module (flac decoder) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-64)) -(define example-1 +(define-public example-1 #vu8(#x66 #x4c #x61 #x43 #x80 #x00 #x00 #x22 #x10 #x00 #x10 #x00 #x00 #x00 #x0f #x00 #x00 #x0f #x0a #xc4 #x42 #xf0 #x00 #x00 #x00 #x01 #x3e #x84 #xb4 #x18 #x07 #xdc #x69 #x03 #x07 #x58 #x6a #x3d #xad #x1a #x2e #x0f #xff #xf8 #x69 #x18 #x00 #x00 #xbf #x03 #x58 #xfd #x03 #x12 #x8b #xaa #x9a)) -(define example-2 +(define-public example-2 #vu8(#x66 #x4c #x61 #x43 #x00 #x00 #x00 #x22 #x00 #x10 #x00 #x10 #x00 #x00 #x17 #x00 #x00 #x44 #x0a #xc4 #x42 #xf0 #x00 #x00 #x00 #x13 #xd5 #xb0 #x56 #x49 #x75 #xe9 #x8b #x8d #x8b #x93 @@ -45,20 +46,70 @@ #x44 #x00 #x4f #x6f #x31 #x3d #x10 #x47 #xd2 #x27 #xcb #x6d #x09 #x08 #x31 #x45 #x2b #xdc #x28 #x22 #x22 #x80 #x57 #xa3)) -; (test-begin "RFC Examples") -; -; + ; (test-begin "RFC Examples") + ; + ; (with-tests "RFC Examples" (test-group "Example 1" - (with-flac-input-port (open-bytevector-input-port example-1) + (with-flac-input-port + (open-bytevector-input-port example-1) (λ () - (define expected-stream-info - (make-metadata-stream-info 4096 4096 15 15 44100 2 16 1 #vu8(62 132 180 24 7 220 105 3 7 88 106 61 173 26 46 15))) - (define expected-metadata - (make-flac-metadata expected-stream-info #f #f #f #f #f '())) - (test-group "Metadata" - (let ((actual-metadata ((@@ (flac metadata) read-flac-metadata)))) - (test-equal "stream info" (flac-metadata-stream-info actual-metadata) expected-stream-info) - (test-equal "metadata" actual-metadata expected-metadata))))))) + (let* ((expected-metadata (make-flac-metadata + (make-metadata-stream-info + 4096 4096 15 15 44100 2 16 1 + #vu8(62 132 180 24 7 220 105 3 7 88 106 61 173 26 46 15)) + #f #f #f #f #f #f)) + (expected-frame (%make-frame + (make-frame-header 'fixed 1 44100 'independent 16 0 191) + 43674 + '((25588) (10416)))) + + + (actual-metadata (read-flac-metadata)) + (actual-frame (read-flac-frame (flac-metadata-stream-info actual-metadata)))) + (test-group "Metadata" + (test-equal + "stream info" + (flac-metadata-stream-info actual-metadata) + (flac-metadata-stream-info expected-metadata))) + (test-group "Frame" + (test-equal "first frame" expected-frame expected-frame)))))) + (test-group "Example 2" + (with-flac-input-port + (open-bytevector-input-port example-2) + (λ () + (let* ((expected-stream-info (make-metadata-stream-info + 16 16 23 68 44100 2 16 19 + #vu8(213 176 86 73 117 233 139 141 139 147 4 34 117 123 129 3))) + (expected-vorbis-comment (make-metadata-vorbis-comment + "reference libFLAC 1.3.3 20190804" + (list '("TITLE" "שלום")))) + (expected-padding (make-metadata-padding 6)) + (expected-seek-table (make-metadata-seek-table + (list (make-metadata-seek-point 0 0 16)))) + (expected-first-frame (%make-frame + (make-frame-header 'fixed 16 44100 'right 16 0 153) + 47120 + '((4302 7496 6199 7427 6484 7436 6740 7508 6984 7583 7182 -5990 -6306 -6032 -6299 -6165) + (6070 10545 8743 10449 9143 10463 9502 10569 9840 10680 10113 -8428 -8895 -8476 -8896 -8653)))) + (expected-second-frame (%make-frame + (make-frame-header 'fixed 3 44100 'independent 16 1 164) + 4912 + '((-15486 -15349 -16054) + (-9072 -8958 -9410)))) + + (actual-metadata (read-flac-metadata)) + (actual-stream-info (flac-metadata-stream-info actual-metadata)) + + (actual-first-frame (read-flac-frame actual-stream-info)) + (actual-second-frame (read-flac-frame actual-stream-info))) + (test-group "Metadata" + (test-equal "stream info" actual-stream-info expected-stream-info) + (test-equal "vorbis comment" (flac-metadata-vorbis-comment actual-metadata) expected-vorbis-comment) + (test-equal "padding" (flac-metadata-padding actual-metadata) expected-padding) + (test-equal "seek table" (flac-metadata-seek-table actual-metadata) expected-seek-table)) + (test-group "Frames" + (test-equal "frame 1" actual-first-frame expected-first-frame) + (test-equal "frame 2" actual-second-frame expected-second-frame)))))))