not quite right but close
parent
9965f317b1
commit
f2a62a3990
88
src/flac.scm
88
src/flac.scm
|
|
@ -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)))))))
|
||||
|
|
@ -9,7 +9,8 @@
|
|||
#:use-module (rnrs arithmetic bitwise)
|
||||
|
||||
#: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)
|
||||
(unless (= #b111111111111100 (flac-read-uint 15))
|
||||
|
|
@ -25,50 +26,50 @@
|
|||
(enum-lookup
|
||||
flac-channel-assignment-type
|
||||
(cond
|
||||
[(between? raw #b0000 #b0111) 0]
|
||||
[(= raw #b1000) 1]
|
||||
[(= raw #b1001) 2]
|
||||
[(= raw #b1010) 3]
|
||||
[else #f])))
|
||||
((between? raw #b0000 #b0111) 0)
|
||||
((= raw #b1000) 1)
|
||||
((= raw #b1001) 2)
|
||||
((= raw #b1010) 3)
|
||||
(else #f))))
|
||||
|
||||
(define (decode-block-size raw)
|
||||
(cond
|
||||
[(= raw #b0000) 'reserved]
|
||||
[(= raw #b0001) 192]
|
||||
[(between? raw #b0010 #b0101) (* 576 (expt 2 (- raw 2)))]
|
||||
[(= raw #b0110) (+ 1 (flac-read-uint 8))]
|
||||
[(= raw #b0111) (+ 1 (flac-read-uint 16))]
|
||||
[(between? raw #b1000 #b1111) (* 256 (expt 2 (- raw 8)))]))
|
||||
((= raw #b0000) 'reserved)
|
||||
((= raw #b0001) 192)
|
||||
((between? raw #b0010 #b0101) (* 576 (expt 2 (- raw 2))))
|
||||
((= raw #b0110) (+ 1 (flac-read-uint 8)))
|
||||
((= raw #b0111) (+ 1 (flac-read-uint 16)))
|
||||
((between? raw #b1000 #b1111) (* 256 (expt 2 (- raw 8))))))
|
||||
|
||||
(define (decode-sample-rate stream-info raw)
|
||||
(case raw
|
||||
[(#b0000) (stream-info-sample-rate stream-info)]
|
||||
[(#b0001) 88200]
|
||||
[(#b0010) 17640]
|
||||
[(#b0011) 19200]
|
||||
[(#b0100) 8000]
|
||||
[(#b0101) 16000]
|
||||
[(#b0110) 22050]
|
||||
[(#b0111) 24000]
|
||||
[(#b1000) 32000]
|
||||
[(#b1001) 44100]
|
||||
[(#b1010) 48000]
|
||||
[(#b1011) 96000]
|
||||
[(#b1100) (* 1000 (flac-read-uint 8))] ; sample rate in kHz
|
||||
[(#b1101) (flac-read-uint 16)] ; sample rate in Hz
|
||||
[(#b1110) (* 10 (flac-read-uint 16))] ; sample rate in tens of Hz
|
||||
[(#b1111) 'invalid]))
|
||||
((#b0000) (stream-info-sample-rate stream-info))
|
||||
((#b0001) 88200)
|
||||
((#b0010) 17640)
|
||||
((#b0011) 19200)
|
||||
((#b0100) 8000)
|
||||
((#b0101) 16000)
|
||||
((#b0110) 22050)
|
||||
((#b0111) 24000)
|
||||
((#b1000) 32000)
|
||||
((#b1001) 44100)
|
||||
((#b1010) 48000)
|
||||
((#b1011) 96000)
|
||||
((#b1100) (* 1000 (flac-read-uint 8)) ; sample rate in kHz
|
||||
((#b1101) (flac-read-uint 16)) ; sample rate in Hz
|
||||
((#b1110) (* 10 (flac-read-uint 16))) ; sample rate in tens of Hz
|
||||
((#b1111) 'invalid))))
|
||||
|
||||
(define (decode-bits-per-sample stream-info raw)
|
||||
(case raw
|
||||
[(#b000) (stream-info-bits-per-sample stream-info)]
|
||||
[(#b001) 8]
|
||||
[(#b010) 12]
|
||||
[(#b011) 'reserved]
|
||||
[(#b100) 16]
|
||||
[(#b101) 20]
|
||||
[(#b110) 24]
|
||||
[(#b111) 'reserved]))
|
||||
((#b000) (stream-info-bits-per-sample stream-info))
|
||||
((#b001) 8)
|
||||
((#b010) 12)
|
||||
((#b011) 'reserved)
|
||||
((#b100) 16)
|
||||
((#b101) 20)
|
||||
((#b110) 24)
|
||||
((#b111) 'reserved)))
|
||||
|
||||
(define (read/assert-subframe-sync)
|
||||
(when (= 1 (flac-read-uint 1))
|
||||
|
|
@ -92,12 +93,12 @@
|
|||
|
||||
(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)))))
|
||||
(list subframe (subframe-constant-value subframe))))
|
||||
(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)))))
|
||||
(list subframe (subframe-verbatim-value subframe))))
|
||||
(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)))
|
||||
|
|
@ -144,7 +145,7 @@
|
|||
(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)))
|
||||
(list
|
||||
(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)))))
|
||||
|
||||
|
|
@ -154,7 +155,7 @@
|
|||
(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)))
|
||||
(list
|
||||
(values
|
||||
(%make-subframe-lpc entropy-coding-method lpc-order precision shift coefs warmup residual)
|
||||
(restore-linear-prediction warmup residual coefs lpc-order shift)))))
|
||||
|
||||
|
|
@ -182,12 +183,12 @@
|
|||
;;; 01xxxx reserved
|
||||
;;; 1xxxxx lpc xxxxx = order - 1
|
||||
(define (read-subframe-type)
|
||||
(let ([raw (flac-read-uint 6)])
|
||||
(let ((raw (flac-read-uint 6)))
|
||||
(cond
|
||||
[(= raw #b000000) (values #f 'constant)]
|
||||
[(= raw #b000001) (values #f 'verbatim)]
|
||||
[(between? raw #b001000 #b001100) (values (bit-extract raw 0 3) 'fixed)]
|
||||
[(between? raw #b100000 #b111111) (values (+ 1 (bit-extract raw 0 5)) 'lpc)]
|
||||
((= raw #b000000) (values #f 'constant))
|
||||
((= raw #b000001) (values #f 'verbatim))
|
||||
((between? raw #b001000 #b001100) (values (bit-extract raw 0 3) 'fixed))
|
||||
((between? raw #b100000 #b111111) (values (+ 1 (bit-extract raw 0 5)) 'lpc))
|
||||
(else (values #f #f)))))
|
||||
|
||||
(define (read-subframe-header)
|
||||
|
|
@ -197,45 +198,60 @@
|
|||
(%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)]
|
||||
[predictor-order (subframe-header-predictor-order subframe-header)]
|
||||
[sample-depth (calculate-sample-depth
|
||||
(let* ((subframe-header (read-subframe-header))
|
||||
(wasted-bits (subframe-header-wasted-bits subframe-header))
|
||||
(predictor-order (subframe-header-predictor-order 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
|
||||
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))))))
|
||||
('lpc (read-subframe-lpc predictor-order blocksize sample-depth)))))
|
||||
(values
|
||||
(%make-subframe subframe-header subframe)
|
||||
samples))))
|
||||
|
||||
(define (read-subframes stream-info frame-header)
|
||||
(let* ([channels (stream-info-channels stream-info)]
|
||||
[subframes (map
|
||||
(λ (header channel)
|
||||
(read-subframe header channel))
|
||||
(make-list channels frame-header)
|
||||
(iota channels))])
|
||||
(let ((channels (stream-info-channels stream-info)))
|
||||
(let subframe-loop ((channel 0)
|
||||
(subframes '())
|
||||
(samples '()))
|
||||
(if (>= channel channels)
|
||||
(begin
|
||||
(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)
|
||||
(read/assert-frame-sync-code)
|
||||
(let* ([blocking-strategy (decode-blocking-strategy (flac-read-uint 1))]
|
||||
[raw-blocksize (flac-read-uint 4)]
|
||||
[raw-sample-rate (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))]
|
||||
[ignore-reserved (flac-read-uint 1)]
|
||||
[frame/sample-number (flac-read-coded-number)]
|
||||
[blocksize (decode-block-size raw-blocksize)]
|
||||
[sample-rate (decode-sample-rate stream-info raw-sample-rate)]
|
||||
[crc (flac-read-uint 8)])
|
||||
(let* ((blocking-strategy (decode-blocking-strategy (flac-read-uint 1)))
|
||||
(raw-blocksize (flac-read-uint 4))
|
||||
(raw-sample-rate (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)))
|
||||
(ignore-reserved (flac-read-uint 1))
|
||||
(frame/sample-number (flac-read-coded-number))
|
||||
(blocksize (decode-block-size raw-blocksize))
|
||||
(sample-rate (decode-sample-rate stream-info raw-sample-rate))
|
||||
(crc (flac-read-uint 8)))
|
||||
(make-frame-header
|
||||
blocking-strategy
|
||||
blocksize
|
||||
|
|
@ -249,8 +265,8 @@
|
|||
(define (read-frame-footer)
|
||||
(flac-read-uint 16))
|
||||
|
||||
(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)))
|
||||
(define (read-flac-frame stream-info)
|
||||
(let ((header (read-frame-header stream-info)))
|
||||
(let-values (((subframes samples) (read-subframes stream-info header)))
|
||||
(let ((footer (read-frame-footer)))
|
||||
(%make-frame header subframes footer samples)))))
|
||||
|
|
|
|||
|
|
@ -19,7 +19,8 @@
|
|||
frame-header-frame/sample-number frame-header-crc
|
||||
|
||||
%make-subframe
|
||||
subframe-header subframe-data
|
||||
subframe?
|
||||
subframe-header subframe-data subframe-samples
|
||||
|
||||
%make-subframe-header
|
||||
subframe-header-subframe-type subframe-header-predictor-order subframe-header-wasted-bits
|
||||
|
|
@ -28,7 +29,7 @@
|
|||
frame-footer-crc
|
||||
|
||||
%make-frame
|
||||
frame-header frame-subframes frame-footer
|
||||
frame-header frame-subframes frame-footer frame-samples
|
||||
|
||||
%make-subframe-constant
|
||||
subframe-constant-value
|
||||
|
|
@ -48,7 +49,6 @@
|
|||
entropy-coding-method-partitioned-rice-contents-parameters
|
||||
entropy-coding-method-partitioned-rice-contents-raw-bits
|
||||
entropy-coding-method-partitioned-rice-contents?
|
||||
entropy-codi
|
||||
|
||||
%make-subframe-fixed
|
||||
subframe-fixed-entropy-coding-method
|
||||
|
|
@ -62,7 +62,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
|
||||
|
|
@ -120,6 +120,7 @@ make-metadata-stream-info metadata-stream-info?
|
|||
(header subframe-header)
|
||||
(data subframe-data))
|
||||
|
||||
|
||||
(define-record-type <subframe-lpc>
|
||||
(%make-subframe-lpc entropy-coding-method order qlp-coefficient-precision quantization-level qlp-coefficients warmup residual)
|
||||
subframe-lpc?
|
||||
|
|
@ -186,11 +187,12 @@ make-metadata-stream-info metadata-stream-info?
|
|||
(crc frame-footer-crc))
|
||||
|
||||
(define-record-type <frame>
|
||||
(%make-frame header subframes footer)
|
||||
(%make-frame header subframes footer samples)
|
||||
frame?
|
||||
(header frame-header)
|
||||
(subframes frame-subframes)
|
||||
(footer frame-footer))
|
||||
(footer frame-footer)
|
||||
(samples frame-samples))
|
||||
|
||||
; metadata
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
#:use-module (rnrs bytevectors)
|
||||
#: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)
|
||||
(make-metadata-block-header
|
||||
|
|
|
|||
Loading…
Reference in New Issue