WIP decoder

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)))

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,7 +41,6 @@
             metadata-block-header-length
 
             make-metadata-padding
-
 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
@@ -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 <subframe-header>
+  (%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 <subframe>
+  (%make-subframe header data)
+  subframe?
+  (header subframe-header)
+  (data subframe-data))
+
+(define-record-type <subframe-verbatim>
+  (%make-subframe-verbatim value)
+  subframe-verbatim?
+  (value subframe-verbatim-value))
+
+(define-record-type <subframe-constant>
+  (%make-subframe-constant value)
+  subframe-constant?
+  (value subframe-constant-value))
+
 (define-record-type <frame-header>
   (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 <frame-footer>
+  (%make-frame-footer crc)
+  frame-footer?
+  (crc frame-footer-crc))
+
+(define-record-type <frame>
+  (%make-frame header subframes footer)
+  frame?
+  (header frame-header)
+  (subframes frame-subframes)
+  (footer frame-footer))
+
 ; metadata
 
 (define flac-metadata-type

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))
@@ -105,4 +112,5 @@
 
 (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))))

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))