diff --git a/src/flac/decoder.scm b/src/flac/decoder.scm index 4ca5032..d3e9335 100644 --- a/src/flac/decoder.scm +++ b/src/flac/decoder.scm @@ -1,6 +1,13 @@ (define-module (flac decoder) #:use-module (flac reader) - #:use-module (flac format)) + #:use-module (flac format) + + #:use-module (srfi srfi-42) + + #:use-module (rnrs arithmetic bitwise) + + #:use-module (ice-9 match) + #:use-module (ice-9 receive)) (define (read/assert-frame-sync-code) (unless (= #b111111111111100 (flac-read-uint 15)) @@ -61,7 +68,85 @@ [(#b110) 24] [(#b111) 'reserved])) -(define (read-frame-header stream-info) +(define (read/assert-subframe-sync) + (when (= 1 (flac-read-uint 1)) + (error "invalid subframe sync"))) + +(define (read-subframe-wasted-bits) + (if (= 1 (flac-read-uint 1)) + (let wasted-loop ([unary 0]) + (if (= 0 (flac-read-uint 1)) + (wasted-loop (+ 1 unary)) + (+ 1 unary))) + 0)) + +(define (calculate-sample-depth bps wasted-bits channel-assignment channel) + (+ (- bps wasted-bits) + (match channel-assignment + ('left (if (= channel 1) 1 0)) + ('right (if (= channel 0) 1 0)) + ('mid (if (= channel 1) 1 0)) + (_ 0)))) + +(define (read-subframe-constant blocksize sample-depth wasted-bits) + (%make-subframe-constant (make-list blocksize (bitwise-arithmetic-shift (flac-read-sint sample-depth) wasted-bits)))) + +(define (read-subframe-verbatim blocksize sample-depth wasted-bits) + (%make-subframe-verbatim + (list-ec (: b blocksize) (bitwise-arithmetic-shift (flac-read-sint sample-depth) wasted-bits)))) + +(define (read-subframe-fixed) #f) + +(define (read-subframe-lpc) #f) + +;;; 000000 constant +;;; 000001 verbatim +;;; 00001x reserved +;;; 0001xx reserved +;;; 001xxx if xxx <= 4 fixed, xxx = order ; else reserved +;;; 01xxxx reserved +;;; 1xxxxx lpc xxxxx = order - 1 +(define (read-subframe-type) + (let ([raw (flac-read-uint 6)]) + (cond + [(= raw #b000000) (values #f 'constant)] + [(= raw #b000001) (values #f 'verbatim)] + [(between? raw #b0010000 #b001100) (values (bit-extract raw 0 4) 'fixed)] + [(between? raw #b1000000 #b111111) (values (bit-extract raw 0 6) 'lpc)] + (else (values #f #f))))) + +(define (read-subframe-header) + (read/assert-subframe-sync) + (receive (order type) + (read-subframe-type) + (%make-subframe-header type order (read-subframe-wasted-bits)))) + +(define (read-subframe frame-header channel) + (let* ([subframe-header (read-subframe-header)] + [wasted-bits (subframe-header-wasted-bits subframe-header)] + [sample-depth (calculate-sample-depth + (frame-header-bits-per-sample frame-header) + wasted-bits + (frame-header-channel-assignment frame-header) + channel)] + [blocksize (frame-header-blocksize frame-header)]) + (%make-subframe + subframe-header + (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)) + ('lpx (read-subframe-lpc)))))) + +(define (read-subframes stream-info frame-header) + (let ([channels (stream-info-channels stream-info)]) + (map + (λ (header channel) + (read-subframe header channel)) + (make-list channels frame-header) + (iota channels)))) + +(define-public (read-frame-header stream-info) (read/assert-frame-sync-code) (let* ([blocking-strategy (decode-blocking-strategy (flac-read-uint 1))] [raw-blocksize (flac-read-uint 4)] @@ -81,3 +166,11 @@ bits-per-sample frame/sample-number crc))) + +(define (read-frame-footer) #f) + +(define-public (read-flac-frame stream-info) + (let* ([header (read-frame-header stream-info)] + [subframes (read-subframes stream-info header)] + [footer (read-frame-footer)]) + (%make-frame header subframes footer))) diff --git a/src/flac/format.scm b/src/flac/format.scm index f0a5232..ffbd349 100644 --- a/src/flac/format.scm +++ b/src/flac/format.scm @@ -18,6 +18,22 @@ frame-header-channel-assignment frame-header-bits-per-sample frame-header-frame/sample-number frame-header-crc + %make-subframe + subframe-header subframe-data + + %make-subframe-header + subframe-header-subframe-type subframe-header-predictor-order subframe-header-wasted-bits + + %make-frame-footer + frame-footer-crc + + %make-frame + frame-header frame-subframes frame-footer + + %make-subframe-constant + subframe-constant-value + %make-subframe-verbatim + subframe-verbatim-data make-metadata-block-header metadata-block-header-last? @@ -25,8 +41,7 @@ metadata-block-header-length make-metadata-padding - - make-metadata-stream-info metadata-stream-info? +make-metadata-stream-info metadata-stream-info? stream-info-min-block-size stream-info-max-block-size stream-info-min-frame-size stream-info-max-frame-size stream-info-sample-rate stream-info-channels @@ -53,7 +68,6 @@ (define FLAC-MAGIC #x664c6143) ; fLaC - (define (enum-lookup enum int) (list-ref (enum-set->list enum) int)) @@ -63,7 +77,7 @@ (define flac-frame-number-type (make-enumeration '(frame sample))) -(define channel-assignment-type +(define flac-channel-assignment-type (make-enumeration '(independent left right mid))) (define flac-subframe-type @@ -79,6 +93,29 @@ (raw-bits entropy-coding-method-partitioned-rice-contents-raw-bits) (capacity-by-order entropy-coding-method-partitioned-rice-contents-capacity-by-order)) +(define-record-type + (%make-subframe-header subframe-type predictor-order wasted-bits) + subframe-header? + (subframe-type subframe-header-subframe-type) + (predictor-order subframe-header-predictor-order) + (wasted-bits subframe-header-wasted-bits)) + +(define-record-type + (%make-subframe header data) + subframe? + (header subframe-header) + (data subframe-data)) + +(define-record-type + (%make-subframe-verbatim value) + subframe-verbatim? + (value subframe-verbatim-value)) + +(define-record-type + (%make-subframe-constant value) + subframe-constant? + (value subframe-constant-value)) + (define-record-type (make-frame-header blocking-strategy blocksize sample-rate channel-assignment bits-per-sample frame/sample-number crc) frame-header? @@ -90,6 +127,18 @@ (frame/sample-number frame-header-frame/sample-number) (crc frame-header-crc)) +(define-record-type + (%make-frame-footer crc) + frame-footer? + (crc frame-footer-crc)) + +(define-record-type + (%make-frame header subframes footer) + frame? + (header frame-header) + (subframes frame-subframes) + (footer frame-footer)) + ; metadata (define flac-metadata-type diff --git a/src/flac/metadata.scm b/src/flac/metadata.scm index 823a4a0..7753f3b 100644 --- a/src/flac/metadata.scm +++ b/src/flac/metadata.scm @@ -58,21 +58,28 @@ (flac-read-uint 32) (flac-read-bytes (flac-read-uint 32)))) +(define (add-picture! metadata) + (if (flac-metadata-pictures metadata) + (set-flac-metadata-pictures! + metadata + (cons (read-metadata-block-picture) + (flac-metadata-pictures metadata))) + (set-flac-metadata-pictures! + metadata + (list (read-metadata-block-picture))))) + (define (read-metadata-block metadata length type) (match type ('stream-info (set-flac-metadata-stream-info! metadata (read-metadata-block-stream-info))) ('seek-table (set-flac-metadata-seek-table! metadata (read-metadata-block-seek-table length))) ('vorbis-comment (set-flac-metadata-vorbis-comment! metadata (read-metadata-block-vorbis-comment))) - ('picture (set-flac-metadata-pictures! - metadata - (cons (read-metadata-block-picture) - (flac-metadata-pictures metadata)))) + ('picture (add-picture! metadata)) ('padding (set-flac-metadata-padding! metadata (read-metadata-block-padding length)))) metadata) (define (read-flac-metadata) (flac-read/assert-magic) - (let metadata-loop ((metadata (make-flac-metadata #f #f #f #f #f #f '())) + (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)) @@ -100,9 +107,10 @@ (with-flac-input-port port (λ () (if (symbol? type) - (read-flac-metadata-type type) - (read-flac-metadata))))) + (read-flac-metadata-type type) + (read-flac-metadata))))) (define* (flac-file-metadata filename #:optional (type #f)) (with-flac-input-port (open-input-file filename #:binary #t) - (λ () (flac-metadata (current-input-port) type)) #:binary #t)) + (λ () + (flac-metadata (current-input-port) type)))) diff --git a/src/flac/reader.scm b/src/flac/reader.scm index e65e267..f3a71b1 100644 --- a/src/flac/reader.scm +++ b/src/flac/reader.scm @@ -8,6 +8,7 @@ #:use-module (rnrs arithmetic bitwise) #:export (flac-read-uint + flac-read-sint flac-read-bytes flac-read-coded-number with-flac-input-port @@ -61,6 +62,10 @@ (define (flac-read-uint bits) (flac-read-bits (current-flac-reader) bits)) +(define (flac-read-sint bits) + (let ([uint (flac-read-uint bits)]) + (- uint (bitwise-arithmetic-shift (bitwise-arithmetic-shift-right uint (- bits 1)) bits)))) + (define (flac-read/assert-magic) (unless (= FLAC-MAGIC (flac-read-uint 32)) #f))