steve
/
guile-flac
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

not quite right but close

main
Steve Ayerhart 2022-08-12 01:28:11 -04:00
parent 9965f317b1
commit f2a62a3990
No known key found for this signature in database
GPG Key ID: 4CB33EB9BB156C97
4 changed files with 194 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
src/flac.scm
View File

@ -0,0 +1,88 @@
(define-module (flac)
#:use-module (flac reader)
#:use-module (flac decoder)
#:use-module (flac metadata)
#:use-module (flac format)
#:use-module (bytestructures guile)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:export (decode-flac-file))
(define header-struct
(bs:struct `((filetype ,(bs:string 4 'utf8))
(filesize ,uint32)
(filetype-header ,(bs:string 4 'utf8))
(format-chunk-marker ,(bs:string 4 'utf8))
(format-chunk-length ,uint32)
(format-type ,uint16)
(num-channels ,uint16)
(sample-freq ,uint32)
(bytes/sec ,uint32)
(block-alignment ,uint16)
(bits-per-sample ,uint16)
(data-chunk-header ,(bs:string 4 'utf8))
(data-chunk-size ,uint32))))
(define (write-frame frame channels)
(let* ((header (frame-header frame))
(total-bytes (floor-quotient (frame-header-bits-per-sample header) 8))
(addend (if (= 8 (frame-header-bits-per-sample header)) 128 0))
(data-bv (make-bytevector 4)))
(for-each
(lambda (block)
(for-each
(lambda (channel)
(bytevector-s32-set! data-bv
0
(+ addend (list-ref (list-ref (frame-samples frame) channel) block))
(endianness little))
(put-bytevector (current-output-port) data-bv))
(iota channels)))
(iota (frame-header-blocksize header)))))
(define (decode-flac-file infile outfile)
(with-input-from-file infile
(λ ()
(with-flac-input-port (current-input-port)
(λ ()
(let* ((stream-info (flac-metadata-stream-info (read-flac-metadata)))
(sample-data-length (* (stream-info-samples stream-info)
(stream-info-channels stream-info)
(floor-quotient (stream-info-bits-per-sample stream-info) 8)))
(wav-header (bytestructure
header-struct
`((filetype "RIFF")
(filesize ,(+ 36 (* (stream-info-samples stream-info)
(stream-info-channels stream-info)
(floor-quotient (stream-info-bits-per-sample stream-info) 8))))
(filetype-header "WAVE")
(format-chunk-marker "fmt ")
(format-chunk-length 16)
(format-type #x0001)
(num-channels ,(stream-info-channels stream-info))
(sample-freq ,(stream-info-sample-rate stream-info))
(bytes/sec ,(* (stream-info-sample-rate stream-info)
(stream-info-channels stream-info)
(floor-quotient (stream-info-bits-per-sample stream-info) 8)))
(block-alignment ,(* (stream-info-channels stream-info)
(floor-quotient (stream-info-bits-per-sample stream-info) 8)))
(bits-per-sample ,(stream-info-bits-per-sample stream-info))
(data-chunk-header "data")
(data-chunk-size ,(* (stream-info-samples stream-info)
(stream-info-channels stream-info)
(floor-quotient (stream-info-bits-per-sample stream-info) 8)))))))
(format #t "SAMPLES: ~a\n" (stream-info-samples stream-info))
(with-output-to-file outfile
(lambda ()
(put-bytevector (current-output-port) (bytestructure-unwrap wav-header))
(let frame-loop ((frame-number 0)
(frame (read-flac-frame stream-info)))
(if (= (stream-info-samples stream-info) frame-number)
#t
(begin
(write-frame frame (stream-info-channels stream-info))
(frame-loop (+ 1 frame-number)
(read-flac-frame stream-info))))))
#:binary #t)))))))

178
src/flac/decoder.scm
View File

@ -9,7 +9,8 @@
#:use-module (rnrs arithmetic bitwise) #:use-module (rnrs arithmetic bitwise)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 receive)) #:use-module (ice-9 receive)
#:export (read-flac-frame))
(define (read/assert-frame-sync-code) (define (read/assert-frame-sync-code)
(unless (= #b111111111111100 (flac-read-uint 15)) (unless (= #b111111111111100 (flac-read-uint 15))
@ -25,50 +26,50 @@
(enum-lookup (enum-lookup
flac-channel-assignment-type flac-channel-assignment-type
(cond (cond
[(between? raw #b0000 #b0111) 0] ((between? raw #b0000 #b0111) 0)
[(= raw #b1000) 1] ((= raw #b1000) 1)
[(= raw #b1001) 2] ((= raw #b1001) 2)
[(= raw #b1010) 3] ((= raw #b1010) 3)
[else #f]))) (else #f))))
(define (decode-block-size raw) (define (decode-block-size raw)
(cond (cond
[(= raw #b0000) 'reserved] ((= raw #b0000) 'reserved)
[(= raw #b0001) 192] ((= raw #b0001) 192)
[(between? raw #b0010 #b0101) (* 576 (expt 2 (- raw 2)))] ((between? raw #b0010 #b0101) (* 576 (expt 2 (- raw 2))))
[(= raw #b0110) (+ 1 (flac-read-uint 8))] ((= raw #b0110) (+ 1 (flac-read-uint 8)))
[(= raw #b0111) (+ 1 (flac-read-uint 16))] ((= raw #b0111) (+ 1 (flac-read-uint 16)))
[(between? raw #b1000 #b1111) (* 256 (expt 2 (- raw 8)))])) ((between? raw #b1000 #b1111) (* 256 (expt 2 (- raw 8))))))
(define (decode-sample-rate stream-info raw) (define (decode-sample-rate stream-info raw)
(case raw (case raw
[(#b0000) (stream-info-sample-rate stream-info)] ((#b0000) (stream-info-sample-rate stream-info))
[(#b0001) 88200] ((#b0001) 88200)
[(#b0010) 17640] ((#b0010) 17640)
[(#b0011) 19200] ((#b0011) 19200)
[(#b0100) 8000] ((#b0100) 8000)
[(#b0101) 16000] ((#b0101) 16000)
[(#b0110) 22050] ((#b0110) 22050)
[(#b0111) 24000] ((#b0111) 24000)
[(#b1000) 32000] ((#b1000) 32000)
[(#b1001) 44100] ((#b1001) 44100)
[(#b1010) 48000] ((#b1010) 48000)
[(#b1011) 96000] ((#b1011) 96000)
[(#b1100) (* 1000 (flac-read-uint 8))] ; sample rate in kHz ((#b1100) (* 1000 (flac-read-uint 8)) ; sample rate in kHz
[(#b1101) (flac-read-uint 16)] ; sample rate in Hz ((#b1101) (flac-read-uint 16)) ; sample rate in Hz
[(#b1110) (* 10 (flac-read-uint 16))] ; sample rate in tens of Hz ((#b1110) (* 10 (flac-read-uint 16))) ; sample rate in tens of Hz
[(#b1111) 'invalid])) ((#b1111) 'invalid))))
(define (decode-bits-per-sample stream-info raw) (define (decode-bits-per-sample stream-info raw)
(case raw (case raw
[(#b000) (stream-info-bits-per-sample stream-info)] ((#b000) (stream-info-bits-per-sample stream-info))
[(#b001) 8] ((#b001) 8)
[(#b010) 12] ((#b010) 12)
[(#b011) 'reserved] ((#b011) 'reserved)
[(#b100) 16] ((#b100) 16)
[(#b101) 20] ((#b101) 20)
[(#b110) 24] ((#b110) 24)
[(#b111) 'reserved])) ((#b111) 'reserved)))
(define (read/assert-subframe-sync) (define (read/assert-subframe-sync)
(when (= 1 (flac-read-uint 1)) (when (= 1 (flac-read-uint 1))
@ -92,12 +93,12 @@
(define (read-subframe-constant blocksize sample-depth wasted-bits) (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))))) (let ((subframe (%make-subframe-constant (make-list blocksize (bitwise-arithmetic-shift (flac-read-sint sample-depth) wasted-bits)))))
(list subframe (subframe-constant-value subframe)))) (values subframe (subframe-constant-value subframe))))
(define (read-subframe-verbatim blocksize sample-depth wasted-bits) (define (read-subframe-verbatim blocksize sample-depth wasted-bits)
(let ((subframe (%make-subframe-verbatim (let ((subframe (%make-subframe-verbatim
(list-ec (: b blocksize) (bitwise-arithmetic-shift (flac-read-sint sample-depth) wasted-bits))))) (list-ec (: b blocksize) (bitwise-arithmetic-shift (flac-read-sint sample-depth) wasted-bits)))))
(list subframe (subframe-verbatim-value subframe)))) (values subframe (subframe-verbatim-value subframe))))
(define (read-entropy-coding-method-info) (define (read-entropy-coding-method-info)
(values (case (flac-read-uint 2) [(#b00) 'rice] [(#b01) 'rice2]) (flac-read-uint 4))) (values (case (flac-read-uint 2) [(#b00) 'rice] [(#b01) 'rice2]) (flac-read-uint 4)))
@ -144,7 +145,7 @@
(let ((warmup (list-ec (: o predictor-order) (flac-read-sint 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)))) (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))) (let-values (((entropy-coding-method residual) (read-residual-partiioned-rice blocksize predictor-order)))
(list (values
(%make-subframe-fixed entropy-coding-method predictor-order warmup residual) (%make-subframe-fixed entropy-coding-method predictor-order warmup residual)
(restore-linear-prediction warmup residual (list-ref fixed-coefficients predictor-order) predictor-order 0))))) (restore-linear-prediction warmup residual (list-ref fixed-coefficients predictor-order) predictor-order 0)))))
@ -154,7 +155,7 @@
(shift (flac-read-sint 5)) (shift (flac-read-sint 5))
(coefs (reverse (list-ec (: o lpc-order) (flac-read-sint precision))))) (coefs (reverse (list-ec (: o lpc-order) (flac-read-sint precision)))))
(let-values (((entropy-coding-method residual) (read-residual-partiioned-rice blocksize lpc-order))) (let-values (((entropy-coding-method residual) (read-residual-partiioned-rice blocksize lpc-order)))
(list (values
(%make-subframe-lpc entropy-coding-method lpc-order precision shift coefs warmup residual) (%make-subframe-lpc entropy-coding-method lpc-order precision shift coefs warmup residual)
(restore-linear-prediction warmup residual coefs lpc-order shift))))) (restore-linear-prediction warmup residual coefs lpc-order shift)))))
@ -182,12 +183,12 @@
;;; 01xxxx reserved ;;; 01xxxx reserved
;;; 1xxxxx lpc xxxxx = order - 1 ;;; 1xxxxx lpc xxxxx = order - 1
(define (read-subframe-type) (define (read-subframe-type)
(let ([raw (flac-read-uint 6)]) (let ((raw (flac-read-uint 6)))
(cond (cond
[(= raw #b000000) (values #f 'constant)] ((= raw #b000000) (values #f 'constant))
[(= raw #b000001) (values #f 'verbatim)] ((= raw #b000001) (values #f 'verbatim))
[(between? raw #b001000 #b001100) (values (bit-extract raw 0 3) 'fixed)] ((between? raw #b001000 #b001100) (values (bit-extract raw 0 3) 'fixed))
[(between? raw #b100000 #b111111) (values (+ 1 (bit-extract raw 0 5)) 'lpc)] ((between? raw #b100000 #b111111) (values (+ 1 (bit-extract raw 0 5)) 'lpc))
(else (values #f #f))))) (else (values #f #f)))))
(define (read-subframe-header) (define (read-subframe-header)
@ -197,45 +198,60 @@
(%make-subframe-header type order (read-subframe-wasted-bits)))) (%make-subframe-header type order (read-subframe-wasted-bits))))
(define (read-subframe frame-header channel) (define (read-subframe frame-header channel)
(let* ([subframe-header (read-subframe-header)] (let* ((subframe-header (read-subframe-header))
[wasted-bits (subframe-header-wasted-bits subframe-header)] (wasted-bits (subframe-header-wasted-bits subframe-header))
[predictor-order (subframe-header-predictor-order subframe-header)] (predictor-order (subframe-header-predictor-order subframe-header))
[sample-depth (calculate-sample-depth (sample-depth (calculate-sample-depth
(frame-header-bits-per-sample frame-header) (frame-header-bits-per-sample frame-header)
wasted-bits wasted-bits
(frame-header-channel-assignment frame-header) (frame-header-channel-assignment frame-header)
channel)] channel))
[blocksize (frame-header-blocksize frame-header)]) (blocksize (frame-header-blocksize frame-header)))
(%make-subframe (let-values (((subframe samples)
subframe-header (match (subframe-header-subframe-type subframe-header)
(match (subframe-header-subframe-type subframe-header) ('constant (read-subframe-constant blocksize sample-depth wasted-bits))
('constant (read-subframe-constant blocksize sample-depth wasted-bits)) ('verbatim (read-subframe-verbatim blocksize sample-depth wasted-bits))
('verbatim (read-subframe-verbatim blocksize sample-depth wasted-bits)) ('fixed (read-subframe-fixed predictor-order blocksize sample-depth))
('fixed (read-subframe-fixed predictor-order blocksize sample-depth)) ('lpc (read-subframe-lpc predictor-order blocksize sample-depth)))))
('lpc (read-subframe-lpc predictor-order blocksize sample-depth)))))) (values
(%make-subframe subframe-header subframe)
samples))))
(define (read-subframes stream-info frame-header) (define (read-subframes stream-info frame-header)
(let* ([channels (stream-info-channels stream-info)] (let ((channels (stream-info-channels stream-info)))
[subframes (map (let subframe-loop ((channel 0)
(λ (header channel) (subframes '())
(read-subframe header channel)) (samples '()))
(make-list channels frame-header) (if (>= channel channels)
(iota channels))]) (begin
(align-to-byte) (align-to-byte)
subframes)) (values subframes samples))
(let-values (((subframe subframe-samples)
(read-subframe frame-header channel)))
(subframe-loop (+ 1 channel)
(cons subframe subframes)
(cons subframe-samples samples)))))))
; (subframes (map
; (λ (header channel)
; (read-subframe header channel))
; (make-list channels frame-header)
; (iota channels))))
; (align-to-byte)
; subframes))
(define-public (read-frame-header stream-info) (define-public (read-frame-header stream-info)
(read/assert-frame-sync-code) (read/assert-frame-sync-code)
(let* ([blocking-strategy (decode-blocking-strategy (flac-read-uint 1))] (let* ((blocking-strategy (decode-blocking-strategy (flac-read-uint 1)))
[raw-blocksize (flac-read-uint 4)] (raw-blocksize (flac-read-uint 4))
[raw-sample-rate (flac-read-uint 4)] (raw-sample-rate (flac-read-uint 4))
[channel-assignment (decode-channel-assignment (flac-read-uint 4))] (channel-assignment (decode-channel-assignment (flac-read-uint 4)))
[bits-per-sample (decode-bits-per-sample stream-info (flac-read-uint 3))] (bits-per-sample (decode-bits-per-sample stream-info (flac-read-uint 3)))
[ignore-reserved (flac-read-uint 1)] (ignore-reserved (flac-read-uint 1))
[frame/sample-number (flac-read-coded-number)] (frame/sample-number (flac-read-coded-number))
[blocksize (decode-block-size raw-blocksize)] (blocksize (decode-block-size raw-blocksize))
[sample-rate (decode-sample-rate stream-info raw-sample-rate)] (sample-rate (decode-sample-rate stream-info raw-sample-rate))
[crc (flac-read-uint 8)]) (crc (flac-read-uint 8)))
(make-frame-header (make-frame-header
blocking-strategy blocking-strategy
blocksize blocksize
@ -249,8 +265,8 @@
(define (read-frame-footer) (define (read-frame-footer)
(flac-read-uint 16)) (flac-read-uint 16))
(define-public (read-flac-frame stream-info) (define (read-flac-frame stream-info)
(let* ([header (read-frame-header stream-info)] (let ((header (read-frame-header stream-info)))
[subframes (read-subframes stream-info header)] (let-values (((subframes samples) (read-subframes stream-info header)))
[footer (read-frame-footer)]) (let ((footer (read-frame-footer)))
(%make-frame header subframes footer))) (%make-frame header subframes footer samples)))))

14
src/flac/format.scm
View File

@ -19,7 +19,8 @@
frame-header-frame/sample-number frame-header-crc frame-header-frame/sample-number frame-header-crc
%make-subframe %make-subframe
subframe-header subframe-data subframe?
subframe-header subframe-data subframe-samples
%make-subframe-header %make-subframe-header
subframe-header-subframe-type subframe-header-predictor-order subframe-header-wasted-bits subframe-header-subframe-type subframe-header-predictor-order subframe-header-wasted-bits
@ -28,7 +29,7 @@
frame-footer-crc frame-footer-crc
%make-frame %make-frame
frame-header frame-subframes frame-footer frame-header frame-subframes frame-footer frame-samples
%make-subframe-constant %make-subframe-constant
subframe-constant-value subframe-constant-value
@ -48,7 +49,6 @@
entropy-coding-method-partitioned-rice-contents-parameters entropy-coding-method-partitioned-rice-contents-parameters
entropy-coding-method-partitioned-rice-contents-raw-bits entropy-coding-method-partitioned-rice-contents-raw-bits
entropy-coding-method-partitioned-rice-contents? entropy-coding-method-partitioned-rice-contents?
entropy-codi
%make-subframe-fixed %make-subframe-fixed
subframe-fixed-entropy-coding-method subframe-fixed-entropy-coding-method
@ -62,7 +62,7 @@
metadata-block-header-length metadata-block-header-length
make-metadata-padding 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-block-size stream-info-max-block-size
stream-info-min-frame-size stream-info-max-frame-size stream-info-min-frame-size stream-info-max-frame-size
stream-info-sample-rate stream-info-channels stream-info-sample-rate stream-info-channels
@ -120,6 +120,7 @@ make-metadata-stream-info metadata-stream-info?
(header subframe-header) (header subframe-header)
(data subframe-data)) (data subframe-data))
(define-record-type <subframe-lpc> (define-record-type <subframe-lpc>
(%make-subframe-lpc entropy-coding-method order qlp-coefficient-precision quantization-level qlp-coefficients warmup residual) (%make-subframe-lpc entropy-coding-method order qlp-coefficient-precision quantization-level qlp-coefficients warmup residual)
subframe-lpc? subframe-lpc?
@ -186,11 +187,12 @@ make-metadata-stream-info metadata-stream-info?
(crc frame-footer-crc)) (crc frame-footer-crc))
(define-record-type <frame> (define-record-type <frame>
(%make-frame header subframes footer) (%make-frame header subframes footer samples)
frame? frame?
(header frame-header) (header frame-header)
(subframes frame-subframes) (subframes frame-subframes)
(footer frame-footer)) (footer frame-footer)
(samples frame-samples))
; metadata ; metadata

2
src/flac/metadata.scm
View File

@ -8,7 +8,7 @@
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:export (flac-metadata flac-file-metadata)) #:export (read-flac-metadata flac-metadata flac-file-metadata))
(define (read-metadata-block-header) (define (read-metadata-block-header)
(make-metadata-block-header (make-metadata-block-header