├── .gitignore
├── info.rkt
├── test.jpg
├── gui.rkt
├── bit-ports.rkt
├── main.rkt
├── huffman.rkt
├── dct.rkt
├── exif.rkt
├── pixbufs.rkt
└── jfif.rkt


/.gitignore:
--------------------------------------------------------------------------------
1 | compiled/
2 | 


--------------------------------------------------------------------------------
/info.rkt:
--------------------------------------------------------------------------------
1 | #lang info
2 | (define collection "jpeg")
3 | 


--------------------------------------------------------------------------------
/test.jpg:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wingo/racket-jpeg/HEAD/test.jpg


--------------------------------------------------------------------------------
/gui.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | ;; racket-jpeg
 3 | ;; Copyright (C) 2016 Andy Wingo <wingo at pobox dot com>
 4 | 
 5 | ;; This library is free software; you can redistribute it and/or modify
 6 | ;; it under the terms of the GNU General Public License as published by
 7 | ;; the Free Software Foundation; either version 3 of the License, or (at
 8 | ;; your option) any later version.
 9 | ;;
10 | ;; This library is distributed in the hope that it will be useful, but
11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 | ;; General Public License for more details.
14 | ;;
15 | ;; You should have received a copy of the GNU General Public License
16 | ;; along with this library; if not, see <http://www.gnu.org/licenses/>.
17 | 
18 | (require rnrs/bytevectors-6
19 |          racket/gui
20 |          jpeg/pixbufs
21 |          jpeg)
22 | (provide rgb->bitmap
23 |          jpeg->bitmap
24 |          bitmap->rgb
25 |          bitmap->jpeg)
26 | 
27 | (define (swap-u32-byte-order pixels)
28 |   (let ((out (bytes-copy pixels)))
29 |     (for ((i (in-range 0 (bytes-length pixels) 4)))
30 |       (let ((u32 (bytevector-u32-ref pixels i (endianness big))))
31 |         (bytevector-u32-set! out i u32 (endianness little))))
32 |     out))
33 | 
34 | (define (maybe-swap-u32-byte-order pixels)
35 |   (if (eq? (native-endianness) (endianness big))
36 |       pixels
37 |       (swap-u32-byte-order pixels)))
38 | 
39 | (define (rgb->bitmap image)
40 |   (match image
41 |     ((interleaved-image width height 4 stride pixels)
42 |      (unless (= stride (* 4 width))
43 |        (error "implement me"))
44 |      (let ((bitmap (make-bitmap width height))
45 |            (argb-pixels (maybe-swap-u32-byte-order pixels)))
46 |        (send bitmap set-argb-pixels 0 0 width height argb-pixels)
47 |        bitmap))
48 |     ((interleaved-image width height 3 stride pixels)
49 |      (rgb->bitmap (rgb->argb image)))))
50 | 
51 | (define (bitmap->rgb bitmap)
52 |   (let* ((width (send bitmap get-width))
53 |          (height (send bitmap get-height))
54 |          (argb-pixels (make-bytes (* width height 4))))
55 |     (send bitmap get-argb-pixels 0 0 width height argb-pixels)
56 |     (interleaved-image width height 4 (* width 4) argb-pixels)))
57 | 
58 | (define (jpeg->bitmap jpeg)
59 |   (rgb->bitmap (jpeg->rgb jpeg #:argb? #f)))
60 | 
61 | (define (bitmap->jpeg bitmap #:quality (quality 50))
62 |   (rgb->jpeg (bitmap->rgb bitmap) #:quality quality))
63 | 
64 | (module+ test
65 |   (require rackunit)
66 |   (let-values (((width height) (jpeg-dimensions "./test.jpg")))
67 |     (let ((bitmap (jpeg->bitmap "./test.jpg")))
68 |       (check-eqv? (send bitmap get-width) width)
69 |       (check-eqv? (send bitmap get-height) height))))
70 | 


--------------------------------------------------------------------------------
/bit-ports.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ;; racket-jpeg
  3 | ;; Copyright (C) 2014 Andy Wingo <wingo at pobox dot com>
  4 | 
  5 | ;; This library is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3 of the License, or (at
  8 | ;; your option) any later version.
  9 | ;;
 10 | ;; This library is distributed in the hope that it will be useful, but
 11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 13 | ;; General Public License for more details.
 14 | ;;
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this library; if not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Commentary:
 19 | ;;
 20 | ;; A layer on top of ports for reading and writing bits in the
 21 | ;; entropy-coded section of a JPEG.  This isn't a general bit-port
 22 | ;; facility because it handles byte stuffing.
 23 | ;;
 24 | ;;; Code:
 25 | 
 26 | (provide make-bit-port
 27 |          read-bits
 28 |          read-bit
 29 |          read-signed-bits
 30 |          write-bits
 31 |          flush-bits)
 32 | 
 33 | (define (make-bit-port port)
 34 |   ;; Bit count, values, and the port
 35 |   (vector 0 0 port))
 36 | 
 37 | (define (next-u8 port)
 38 |   (let ((u8 (read-byte port)))
 39 |     (cond 
 40 |      ((eof-object? u8)
 41 |       (error "Got EOF while reading bits"))
 42 |      ((eqv? u8 #xff)
 43 |       (let ((u8 (read-byte port)))
 44 |         (unless (eqv? 0 u8)
 45 |           (if (eof-object? u8)
 46 |               (error "Got EOF while reading bits")
 47 |               (error "Found marker while reading bits"))))))
 48 |     u8))
 49 | 
 50 | (define (read-bits bit-port n)
 51 |   (match bit-port
 52 |     ((vector count bits port)
 53 |      (let lp ((count count) (bits bits))
 54 |        (cond
 55 |         ((<= n count)
 56 |          (vector-set! bit-port 0 (- count n))
 57 |          (bitwise-and (arithmetic-shift bits (- n count))
 58 |                       (sub1 (arithmetic-shift 1 n))))
 59 |         (else
 60 |          (let* ((u8 (next-u8 port))
 61 |                 ;; We never need more than 16 bits in the buffer.
 62 |                 (bits (+ (bitwise-and (arithmetic-shift bits 8) #xffff) u8)))
 63 |            (vector-set! bit-port 1 bits)
 64 |            (lp (+ count 8) bits))))))))
 65 | 
 66 | (define (read-bit bit-port)
 67 |   (read-bits bit-port 1))
 68 | 
 69 | (define (read-signed-bits bit-port n)
 70 |   (let ((bits (read-bits bit-port n)))
 71 |     (if (< bits (arithmetic-shift 1 (sub1 n)))
 72 |         (+ (arithmetic-shift -1 n) 1 bits)
 73 |         bits)))
 74 | 
 75 | (define (write-byte/stuff u8 port)
 76 |   (write-byte u8 port)
 77 |   (when (eqv? u8 #xff)
 78 |     (write-byte 0 port)))
 79 | 
 80 | (define (write-bits bit-port bits len)
 81 |   (cond
 82 |    ((negative? bits)
 83 |     (write-bits bit-port (- bits (add1 (arithmetic-shift -1 len))) len))
 84 |    (else
 85 |     (match bit-port
 86 |       ((vector count buf port)
 87 |        (let lp ((count count) (buf buf) (bits bits) (len len))
 88 |          (cond
 89 |           ((< (+ count len) 8)
 90 |            (vector-set! bit-port 0 (+ count len))
 91 |            (vector-set! bit-port 1
 92 |                         (bitwise-ior (arithmetic-shift buf len) bits)))
 93 |           (else
 94 |            (let* ((head-len (- 8 count))
 95 |                   (head-bits (bitwise-and
 96 |                               (arithmetic-shift bits (- head-len len))
 97 |                               (sub1 (arithmetic-shift 1 head-len))))
 98 |                   (tail-len (- len head-len))
 99 |                   (tail-bits (bitwise-and
100 |                               bits
101 |                               (sub1 (arithmetic-shift 1 tail-len)))))
102 |              (write-byte/stuff
103 |               (bitwise-ior (arithmetic-shift buf head-len) head-bits)
104 |               port)
105 |              (lp 0 0 tail-bits tail-len))))))))))
106 | 
107 | (define (flush-bits bit-port)
108 |   (match bit-port
109 |     ((vector count bits port)
110 |      (unless (zero? count)
111 |        ;; Pad remaining bits with 1, and stuff as needed.
112 |        (let ((bits (bitwise-ior (arithmetic-shift bits (- 8 count))
113 |                                 (sub1 (arithmetic-shift 1 (- 8 count))))))
114 |          (write-byte/stuff bits port))
115 |        (vector-set! bit-port 0 0)
116 |        (vector-set! bit-port 1 0)))))
117 | 


--------------------------------------------------------------------------------
/main.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ;; guile-jpeg
  3 | ;; Copyright (C) 2014 Andy Wingo <wingo at pobox dot com>
  4 | 
  5 | ;; This library is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3 of the License, or (at
  8 | ;; your option) any later version.
  9 | ;;
 10 | ;; This library is distributed in the hope that it will be useful, but
 11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 13 | ;; General Public License for more details.
 14 | ;;
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this library; if not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Commentary:
 19 | ;;
 20 | ;; A parser for JPEG.
 21 | ;;
 22 | ;;; Code:
 23 | 
 24 | (provide jpeg-dimensions
 25 |          jpeg-dimensions-and-exif
 26 |          jpeg->rgb
 27 |          rgb->jpeg
 28 |          rgb-buffer->jpeg
 29 |          read-jpeg
 30 |          write-jpeg)
 31 | (require jpeg/jfif jpeg/exif jpeg/dct jpeg/pixbufs)
 32 | 
 33 | (define (jpeg-dimensions jpeg)
 34 |   (let* ((jfif (if (jfif? jpeg)
 35 |                    jpeg
 36 |                    (read-jfif jpeg #:with-body? #f #:with-misc-sections? #f)))
 37 |          (frame (jfif-frame jfif)))
 38 |     (values (frame-x frame)
 39 |             (frame-y frame))))
 40 | 
 41 | (define (read-jpeg jpeg)
 42 |   (read-jfif jpeg))
 43 | 
 44 | (define (write-jpeg port jpeg)
 45 |   (write-jfif port jpeg))
 46 | 
 47 | (define (find-exif misc-segments)
 48 |   (define (bv-prefix? prefix bv)
 49 |     (and (>= (bytes-length bv) (bytes-length prefix))
 50 |          (let lp ((n 0))
 51 |            (or (= n (bytes-length prefix))
 52 |                (and (eqv? (bytes-ref prefix n) (bytes-ref bv n))
 53 |                     (lp (add1 n)))))))
 54 |   (filter-map (lambda (misc)
 55 |                 (and (= (misc-marker misc) #xffe1) ; APP1
 56 |                      (bv-prefix? (bytes 69 120 105 102 0 0) (misc-bytes misc))
 57 |                      (parse-exif (subbytes (misc-bytes misc) 6))))
 58 |               misc-segments))
 59 | 
 60 | (define (jpeg-dimensions-and-exif jpeg)
 61 |   (let* ((jfif (if (jfif? jpeg)
 62 |                    jpeg
 63 |                    (read-jfif jpeg #:with-body? #f)))
 64 |          (frame (jfif-frame jfif)))
 65 |     (values (frame-x frame)
 66 |             (frame-y frame)
 67 |             (match (find-exif (jfif-misc-segments jfif))
 68 |               ((list (list main thumbnail)) main)
 69 |               ((list (list main)) main)
 70 |               (_ '())))))
 71 | 
 72 | (define (jpeg->rgb in
 73 |                    #:argb? (argb? #f)
 74 |                    #:stride-for-width (stride-for-width
 75 |                                        (lambda (width)
 76 |                                          (* width (if argb? 4 3)))))
 77 |   (let ((jfif (if (jfif? in) in (read-jfif in))))
 78 |     (yuv->rgb (jpeg->planar-image jfif)
 79 |               #:argb? argb?
 80 |               #:stride (stride-for-width (frame-x (jfif-frame jfif))))))
 81 | 
 82 | (define (rgb->jpeg rgb #:samp-x (samp-x 2) #:samp-y (samp-y 2)
 83 |                    #:quality (quality 85))
 84 |   (planar-image->jpeg (rgb->yuv rgb #:samp-x samp-x #:samp-y samp-y)
 85 |                       #:quality quality))
 86 | 
 87 | (define (rgb-buffer->jpeg buffer width height #:stride (stride (* width 3))
 88 |                           #:samp-x (samp-x 2) #:samp-y (samp-y 2)
 89 |                           #:quality (quality 85) #:argb? (argb? #f))
 90 |   (rgb->jpeg (interleaved-image width height (if argb? 4 3) stride
 91 |                                 buffer)
 92 |              #:samp-x samp-x #:samp-y samp-y #:quality quality))
 93 | 
 94 | (module+ test
 95 |   (require rackunit)
 96 |   (define test-file-name "./test.jpg")
 97 |   (define expected-width 500)
 98 |   (define expected-height 375)
 99 |   (define expected-exif
100 |     `((make . "CAMERA                   ")
101 |       (model . "DC2302                 ")
102 |       (x-resolution 72 . 1)
103 |       (y-resolution 72 . 1)
104 |       (resolution-unit . "Inches")
105 |       (software . "f-spot version 0.1.11")
106 |       (date-time . "2006:05:14 20:55:54")
107 |       (y-cb-cr-positioning . "Co-sited")
108 |       (exposure-time 1 . 198)
109 |       (f-number 971 . 100)
110 |       (photographic-sensitivity . 50)
111 |       (exif-version . ,(bytes 48 50 49 48))
112 |       (date-time-original . "2004:10:31 03:03:17")
113 |       (date-time-digitized . "2004:10:30 12:03:17")
114 |       (components-configuration . ,(bytes 1 2 3 0))
115 |       (shutter-speed-value 77 . 10)
116 |       (aperture-value 5 . 1)
117 |       (flash (fired? . #f)
118 |              (return-light . "Not available")
119 |              (mode . "Unknown")
120 |              (present? . #f)
121 |              (red-eye? . #f))
122 |       (user-comment . ,(bytes 65 83 67 73 73 0 0 0))
123 |       (flashpix-version . ,(bytes 48 49 48 48))
124 |       (color-space . "sRGB")
125 |       (pixel-x-dimension . 1600)
126 |       (pixel-y-dimension . 1200)
127 |       ;; This is an interoperability offset but because it is before the
128 |       ;; EXIF segment we don't visit it; otherwise we would be exposed to
129 |       ;; loop-like attacks.
130 |       (40965 . 508)))
131 | 
132 |   (define-values (width height exif)
133 |     (jpeg-dimensions-and-exif test-file-name))
134 | 
135 |   (check-eqv? width expected-width)
136 |   (check-eqv? height expected-height)
137 |   (check-equal? exif expected-exif)
138 |   (let* ((j1 (read-jpeg test-file-name))
139 |          (j2 (call-with-input-bytes
140 |                  (call-with-output-bytes
141 |                    (lambda (port) (write-jpeg port j1)))
142 |                (lambda (port)
143 |                  (read-jpeg port)))))
144 |     (check-equal? j1 j2)
145 |     (let ((ppm (call-with-output-bytes
146 |                 (lambda (p) (write-ppm p (jpeg->rgb j1))))))
147 |       (check-true (bytes? ppm))
148 |       (check-true (> (bytes-length ppm) (* width height 3))))))
149 | 


--------------------------------------------------------------------------------
/huffman.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ;; guile-jpeg
  3 | ;; Copyright (C) 2014 Andy Wingo <wingo at pobox dot com>
  4 | 
  5 | ;; This library is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3 of the License, or (at
  8 | ;; your option) any later version.
  9 | ;;
 10 | ;; This library is distributed in the hope that it will be useful, but
 11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 13 | ;; General Public License for more details.
 14 | ;;
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this library; if not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Commentary:
 19 | ;;
 20 | ;; JPEG Huffman coding.
 21 | ;;
 22 | ;;; Code:
 23 | 
 24 | (require jpeg/bit-ports)
 25 | (provide make-huffman-table
 26 |          print-huffman-table
 27 |          read-huffman-coded-value
 28 |          compute-huffman-table-for-freqs)
 29 | 
 30 | (define (make-huffman-table size-counts values)
 31 |   (let* ((count (bytes-length values))
 32 |          (size-offsets (make-vector 16 #f))
 33 |          (sizes (make-bytes count 0))
 34 |          (codes (make-vector count #f))
 35 |          (value-indexes (make-vector 256 #f))
 36 |          (max-codes (make-vector 16 -1)))
 37 |     ;; A reverse map from value to index.
 38 |     (for ((i (in-naturals))
 39 |           (value values))
 40 |       (vector-set! value-indexes value i))
 41 |     ;; Compute sizes for each value.
 42 |     (let lp ((size 0) (offset 0))
 43 |       (when (< size 16)
 44 |         (vector-set! size-offsets size offset)
 45 |         (let ((size-count (bytes-ref size-counts size)))
 46 |           (let lp ((i 0))
 47 |             (when (< i size-count)
 48 |               (bytes-set! sizes (+ offset i) (add1 size))
 49 |               (lp (add1 i))))
 50 |           (lp (add1 size) (+ offset size-count)))))
 51 |     ;; Compute codes.  This is the algorithm from Annex C, verbatim.
 52 |     (let lp ((k 0) (code 0) (si (bytes-ref sizes 0)))
 53 |       (vector-set! max-codes (sub1 si) code)
 54 |       (vector-set! codes k code)
 55 |       (let ((code (add1 code)) (k (add1 k)))
 56 |         (when (< k (bytes-length sizes))
 57 |           (let lp2 ((code code) (si si))
 58 |             (if (= (bytes-ref sizes k) si)
 59 |                 (lp k code si)
 60 |                 (lp2 (arithmetic-shift code 1) (add1 si)))))))
 61 |     ;; Done.
 62 |     (vector size-counts size-offsets
 63 |             values value-indexes sizes codes max-codes)))
 64 | 
 65 | (define (print-huffman-table table)
 66 |   (match table
 67 |     ((vector size-counts size-offsets
 68 |              values value-indexes sizes codes max-codes)
 69 |      (let lp ((n 0))
 70 |        (when (< n (bytes-length values))
 71 |          (let ((si (bytes-ref sizes n))
 72 |                (code (vector-ref codes n))
 73 |                (value (bytes-ref values n)))
 74 |            (printf "~a: ~a ~a ~a\n" n si code value)
 75 |            (lp (add1 n))))))))
 76 | 
 77 | (define (read-huffman-coded-value bit-port table)
 78 |   ;(print-huffman-table table)
 79 |   (match table
 80 |     ((vector size-counts size-offsets
 81 |              values value-indexes sizes codes max-codes)
 82 |      (let lp ((size-idx 0) (code (read-bit bit-port)))
 83 |        (cond
 84 |         ((<= code (vector-ref max-codes size-idx))
 85 |          (let* ((size-offset (vector-ref size-offsets size-idx))
 86 |                 (idx (+ size-offset (- code (vector-ref codes size-offset)))))
 87 |            (unless (>= code (vector-ref codes size-offset))
 88 |              (error "impossaurus"))
 89 |            (bytes-ref values idx)))
 90 |         (else
 91 |          (lp (add1 size-idx)
 92 |              (+ (arithmetic-shift code 1) (read-bit bit-port)))))))))
 93 | 
 94 | (define (vector-inc! v idx addend)
 95 |   (vector-set! v idx (+ (vector-ref v idx) addend)))
 96 | 
 97 | (define (compute-huffman-code-sizes-for-freqs freqs)
 98 |   (let ((sizes (make-bytes 257 0))
 99 |         (others (make-vector 257 #f))
100 |         (max-size 0))
101 |     (define (inc-size! code)
102 |       (let ((size (add1 (bytes-ref sizes code))))
103 |         (bytes-set! sizes code size)
104 |         (when (< max-size size)
105 |           (set! max-size size))))
106 |     (define (find-least-idx)
107 |       (let lp ((i 0) (least-idx #f))
108 |         (if (< i 257)
109 |             (lp (add1 i)
110 |                 (let ((x (vector-ref freqs i)))
111 |                   (cond ((zero? x) least-idx)
112 |                         ((not least-idx) i)
113 |                         ((<= x (vector-ref freqs least-idx)) i)
114 |                         (else least-idx))))
115 |             least-idx)))
116 |     (define (find-next-least least-idx)
117 |       (let lp ((i 0) (next-least-idx #f))
118 |         (if (< i 257)
119 |             (lp (add1 i)
120 |                 (let ((x (vector-ref freqs i)))
121 |                   (cond ((zero? x) next-least-idx)
122 |                         ((= i least-idx) next-least-idx)
123 |                         ((not next-least-idx) i)
124 |                         ((<= x (vector-ref freqs next-least-idx)) i)
125 |                         (else next-least-idx))))
126 |             next-least-idx)))
127 |     (let lp ((v1 256))
128 |       (cond
129 |        ((find-next-least v1)
130 |         => (lambda (v2)
131 |              (vector-inc! freqs v1 (vector-ref freqs v2))
132 |              (vector-set! freqs v2 0)
133 |              (let lp ((v1 v1))
134 |                (inc-size! v1)
135 |                (cond
136 |                 ((vector-ref others v1) => lp)
137 |                 (else
138 |                  (vector-set! others v1 v2)
139 |                  (let lp ((v2 v2))
140 |                    (inc-size! v2)
141 |                    (cond
142 |                     ((vector-ref others v2) => lp))))))
143 |              (lp (find-least-idx))))
144 |        (else (values sizes max-size))))))
145 | 
146 | (define (compute-huffman-table-for-freqs freqs)
147 |   (define (bytes-truncate bv len)
148 |     (if (< len (bytes-length bv))
149 |         (subbytes bv 0 len)
150 |         bv))
151 |   (call-with-values (lambda ()
152 |                       (let ((copy (make-vector 257)))
153 |                         (vector-copy! copy 0 freqs)
154 |                         ;; Add dummy entry.
155 |                         (vector-set! copy 256 1)
156 |                         (compute-huffman-code-sizes-for-freqs copy)))
157 |     (lambda (sizes max-size)
158 |       (let ((size-counts (make-bytes (max max-size 16) 0)))
159 |         (define (inc-size-count! size n)
160 |           (bytes-set! size-counts size
161 |                               (+ (bytes-ref size-counts size) n)))
162 |         (let count-bits ((i 0))
163 |           (when (< i 257)
164 |             (let ((size (bytes-ref sizes i)))
165 |               (unless (zero? size)
166 |                 (inc-size-count! (sub1 size) 1)))
167 |             (count-bits (add1 i))))
168 |         (let adjust-bits ((i (sub1 max-size)))
169 |           (cond
170 |            ((zero? (bytes-ref size-counts i))
171 |             (adjust-bits (sub1 i)))
172 |            ((< i 16)
173 |             ;; We're done.  Remove the dummy entry.
174 |             (inc-size-count! i -1))
175 |            (else
176 |             ;; We have a code that is > 16 bits long.  Reshuffle the
177 |             ;; tree to fit the code into 16 bits.
178 |             (let lp ((j (- i 2)))
179 |               (cond
180 |                ((zero? (bytes-ref size-counts j))
181 |                 (lp (sub1 j)))
182 |                (else
183 |                 (inc-size-count! i -2)
184 |                 (inc-size-count! (sub1 i) 1)
185 |                 (inc-size-count! (add1 j) 2)
186 |                 (inc-size-count! j -1))))
187 |             (adjust-bits i))))
188 |         ;; Sort values, then compute codes.
189 |         (let* ((count (for/fold ((sum 0)) ((count size-counts))
190 |                         (+ sum count)))
191 |                (values (make-bytes count 0)))
192 |           (let visit-size ((size 1) (k 0))
193 |             (when (<= size max-size)
194 |               (let visit-values ((j 0) (k k))
195 |                 (cond
196 |                  ((= j 256)
197 |                   (visit-size (add1 size) k))
198 |                  ((= (bytes-ref sizes j) size)
199 |                   (bytes-set! values k j)
200 |                   (visit-values (add1 j) (add1 k)))
201 |                  (else
202 |                   (visit-values (add1 j) k))))))
203 |           (make-huffman-table (bytes-truncate size-counts 16)
204 |                               values))))))
205 | 


--------------------------------------------------------------------------------
/dct.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ;; guile-jpeg
  3 | ;; Copyright (C) 2014 Andy Wingo <wingo at pobox dot com>
  4 | 
  5 | ;; This library is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3 of the License, or (at
  8 | ;; your option) any later version.
  9 | ;;
 10 | ;; This library is distributed in the hope that it will be useful, but
 11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 13 | ;; General Public License for more details.
 14 | ;;
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this library; if not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Commentary:
 19 | ;;
 20 | ;; Forward and inverse JPEG discrete cosine transforms.
 21 | ;;
 22 | ;;; Code:
 23 | 
 24 | (require math/array jpeg/jfif jpeg/pixbufs rnrs/bytevectors-6)
 25 | 
 26 | (provide jpeg->planar-image planar-image->jpeg)
 27 | 
 28 | (define fdct-coefficients
 29 |   (let ((pi (* 2 (acos 0))))
 30 |     (build-array
 31 |      #(8 8)
 32 |      (match-lambda
 33 |        ((vector u v)
 34 |         ;; FIXME: Produce literal f32vector here.
 35 |         (for/vector ((k (in-range (* 8 8))))
 36 |           (call-with-values (lambda ()
 37 |                               (values (quotient k 8) (remainder k 8)))
 38 |             (lambda (i j)
 39 |               (let ((Cu (if (zero? u) (/ 1 (sqrt 2)) 1))
 40 |                     (Cv (if (zero? v) (/ 1 (sqrt 2)) 1)))
 41 |                 (* 1/4 Cu Cv
 42 |                    (cos (/ (* (+ (* 2 i) 1) u pi) 16))
 43 |                    (cos (/ (* (+ (* 2 j) 1) v pi) 16))))))))))))
 44 | 
 45 | (define idct-coefficients
 46 |   (let ((pi (* 2 (acos 0))))
 47 |     (build-array
 48 |      #(8 8)
 49 |      (match-lambda
 50 |        ((vector i j)
 51 |         (for/vector ((k (in-range (* 8 8))))
 52 |           (call-with-values (lambda ()
 53 |                               (values (quotient k 8) (remainder k 8)))
 54 |             (lambda (u v)
 55 |               (let ((Cu (if (zero? u) (/ 1 (sqrt 2)) 1))
 56 |                     (Cv (if (zero? v) (/ 1 (sqrt 2)) 1)))
 57 |                 (* 1/4 Cu Cv
 58 |                    (cos (/ (* (+ (* 2 i) 1) u pi) 16))
 59 |                    (cos (/ (* (+ (* 2 j) 1) v pi) 16))))))))))))
 60 | 
 61 | (define (idct-block block plane pos stride)
 62 |   (define (idct i j)
 63 |     (let ((coeffs (array-ref idct-coefficients (vector i j))))
 64 |       (let lp ((k 0) (sum 0.0))
 65 |         (if (< k 64)
 66 |             (let ((Suv (vector-ref block k)))
 67 |               (lp (add1 k)
 68 |                   (if (zero? Suv)
 69 |                       sum
 70 |                       (+ sum (* (vector-ref coeffs k) Suv)))))
 71 |             sum))))
 72 |   (let lp ((i 0) (pos pos))
 73 |     (when (< i 8)
 74 |       (let lp ((j 0))
 75 |         (when (< j 8)
 76 |           (let* ((s (idct i j))
 77 |                  (sq (cond
 78 |                       ((< s -128.0) 0)
 79 |                       ((> s 127.0) 255)
 80 |                       (else (+ 128 (inexact->exact (round s)))))))
 81 |             (bytevector-u8-set! plane (+ pos j) sq))
 82 |           (lp (add1 j))))
 83 |       (lp (add1 i) (+ pos stride)))))
 84 | 
 85 | (define (jpeg->planar-image jpeg)
 86 |   (match jpeg
 87 |     ((jfif frame misc-segments mcu-array)
 88 |      (let ((mcu-width (frame-mcu-width frame))
 89 |            (mcu-height (frame-mcu-height frame)))
 90 |        (planar-image
 91 |         (frame-x frame)
 92 |         (frame-y frame)
 93 |         (* mcu-width (frame-samp-x frame) 8)
 94 |         (* mcu-height (frame-samp-y frame) 8)
 95 |         (for/vector ((k (in-naturals))
 96 |                      (component (in-vector (frame-components frame))))
 97 |           (let* ((samp-x (component-samp-x component))
 98 |                  (samp-y (component-samp-y component))
 99 |                  (block-width (* mcu-width samp-x))
100 |                  (block-height (* mcu-height samp-y))
101 |                  (sample-width (* block-width 8))
102 |                  (sample-height (* block-height 8))
103 |                  (p (make-bytevector (* sample-width sample-height) 0)))
104 |             (for ((mcu-idx (in-naturals)) (mcu (in-array mcu-array)))
105 |               (let* ((i (quotient mcu-idx mcu-width))
106 |                      (j (remainder mcu-idx mcu-width))
107 |                      (mcu-y (* i samp-y 8))
108 |                      (mcu-x  (* j samp-x 8))
109 |                      (offset (+ (* mcu-y sample-width) mcu-x)))
110 |                 (for ((block-idx (in-naturals))
111 |                       (block (in-array (vector-ref mcu k))))
112 |                   (let* ((block-i (quotient block-idx samp-x))
113 |                          (block-j (remainder block-idx samp-y))
114 |                          (offset (+ offset (* block-i 8 sample-width)
115 |                                     (* block-j 8))))
116 |                     (idct-block block p offset sample-width)))))
117 |             (plane sample-width sample-height p))))))))
118 | 
119 | ;; Tables K.1 and K.2 from the JPEG specification.
120 | (define *standard-luminance-q-table*
121 |   #(16 11 10 16 24 40 51 61
122 |     12 12 14 19 26 58 60 55
123 |     14 13 16 24 40 57 69 56
124 |     14 17 22 29 51 87 80 62
125 |     18 22 37 56 68 109 103 77
126 |     24 35 55 64 81 104 113 92
127 |     49 64 78 87 103 121 120 101
128 |     72 92 95 98 112 100 103 99))
129 | 
130 | (define *standard-chrominance-q-table*
131 |   #(17 18 24 47 99 99 99 99
132 |     18 21 26 66 99 99 99 99
133 |     24 26 56 99 99 99 99 99
134 |     47 66 99 99 99 99 99 99
135 |     99 99 99 99 99 99 99 99
136 |     99 99 99 99 99 99 99 99
137 |     99 99 99 99 99 99 99 99
138 |     99 99 99 99 99 99 99 99))
139 | 
140 | ;; As libjpeg does, we consider the above tables to be quality 50, on a
141 | ;; scale from 1 (terrible) to 100 (great).  We linearly scale the values
142 | ;; so that at quality 100, all values are 1, and at quality 1 all values
143 | ;; are 255.
144 | (define (q-tables-for-quality quality)
145 |   ;; This mapping of quality to a linear scale is also from libjpeg.
146 |   (let* ((quality (exact->inexact quality)) ;; allow divide by zero -> inf
147 |          (linear-scale (if (< quality 50)
148 |                            (/ 50. quality)
149 |                            (- 1 (/ (- quality 50) 50)))))
150 |     (define (scale x)
151 |       (let ((x (* x linear-scale)))
152 |         (cond
153 |          ((< x 1) 1)
154 |          ((> x 255) 255)
155 |          (else (inexact->exact (round x))))))
156 |     (vector (vector-map scale *standard-luminance-q-table*)
157 |             (vector-map scale *standard-chrominance-q-table*)
158 |             #f
159 |             #f)))
160 | 
161 | (define (fdct-block plane pos stride q-table)
162 |   (define (fdct v u)
163 |     (let ((coeffs (array-ref fdct-coefficients (vector v u))))
164 |       (let lp ((i 0) (pos pos) (sum 0.0))
165 |         (if (< i 8)
166 |             (lp (add1 i)
167 |                 (+ pos stride)
168 |                 (let lp ((j 0) (k (* i 8)) (pos pos) (sum sum))
169 |                   (if (< j 8)
170 |                       (let ((coeff (vector-ref coeffs k))
171 |                             (sample (- (bytevector-u8-ref plane pos) 128)))
172 |                         (lp (add1 j)
173 |                             (add1 k)
174 |                             (add1 pos)
175 |                             (+ sum (* coeff sample))))
176 |                       sum)))
177 |             sum))))
178 |   (for/vector ((k (in-range (* 8 8))))
179 |     (let ((v (arithmetic-shift k -3))
180 |           (u (bitwise-and k 7))
181 |           (q (vector-ref q-table k)))
182 |       (let ((Svu (fdct v u)))
183 |         (* q (inexact->exact (round (/ Svu q))))))))
184 | 
185 | (define (planar-image->jpeg yuv
186 |                             #:quality (quality 85)
187 |                             #:q-tables (q-tables (q-tables-for-quality quality))
188 |                             ;; In JFIF baseline JPEG images, component
189 |                             ;; 0 is Y', and components 1 and 2 are Cb
190 |                             ;; and Cr.  Assign the first quantization
191 |                             ;; table for luminance, and the second for
192 |                             ;; chrominance.
193 |                             #:plane-q-table (plane-q-table (lambda (i) (if (zero? i) 0 1))))
194 |   (match yuv
195 |     ((planar-image width height canvas-width canvas-height planes)
196 |      (let ((samp-x (for/fold ((samp-x 1)) ((plane (in-vector planes)))
197 |                      (lcm samp-x (/ canvas-width (plane-width plane)))))
198 |            (samp-y (for/fold ((samp-x 1)) ((plane (in-vector planes)))
199 |                      (lcm samp-x (/ canvas-height (plane-height plane))))))
200 |        (define (plane-samp-x plane)
201 |          (* samp-x (/ (plane-width plane) canvas-width)))
202 |        (define (plane-samp-y plane)
203 |          (* samp-y (/ (plane-height plane) canvas-height)))
204 |        (let ((components
205 |               (for/vector ((plane (in-vector planes))
206 |                            (i (in-naturals)))
207 |                 (component i i
208 |                            (plane-samp-x plane) (plane-samp-y plane)
209 |                            (plane-q-table i)))))
210 |          (jfif
211 |           (frame #f 8 height width components samp-x samp-y)
212 |           '()
213 |           (build-array
214 |            (vector (/ canvas-height 8 samp-y) (/ canvas-width 8 samp-x))
215 |            (match-lambda
216 |              ((vector i j)
217 |               (for/vector ((component (in-vector components)))
218 |                 (match (vector-ref planes (component-index component))
219 |                   ((plane plane-width plane-height samples)
220 |                    (let ((samp-y (component-samp-y component))
221 |                          (samp-x (component-samp-x component)))
222 |                      (build-array
223 |                       (vector samp-y samp-x)
224 |                       (match-lambda
225 |                         ((vector y x)
226 |                          (let* ((pos (+ (* (+ (* i samp-y) y) 8 plane-width)
227 |                                         (* (+ (* j samp-x) x) 8)))
228 |                                 (q-table-index (component-q-table component))
229 |                                 (q-table (vector-ref q-tables q-table-index)))
230 |                            (fdct-block samples pos plane-width q-table))))))))))))))))))
231 | 


--------------------------------------------------------------------------------
/exif.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ;; racket-jpeg
  3 | ;; Copyright (C) 2014 Andy Wingo <wingo at pobox dot com>
  4 | 
  5 | ;; This library is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3 of the License, or (at
  8 | ;; your option) any later version.
  9 | ;;
 10 | ;; This library is distributed in the hope that it will be useful, but
 11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 13 | ;; General Public License for more details.
 14 | ;;
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this library; if not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Commentary:
 19 | ;;
 20 | ;; A parser for EXIF.
 21 | ;;
 22 | ;;; Code:
 23 | 
 24 | (provide parse-exif)
 25 | (require rnrs/bytevectors-6)
 26 | 
 27 | ;; Exif version 2.3:
 28 | ;; http://www.cipa.jp/std/documents/e/DC-008-2012_E.pdf
 29 | 
 30 | (define *exif-tag-names* (make-hasheqv))
 31 | 
 32 | (define-syntax-rule (define-exif-tags table (value name) ...)
 33 |   (begin
 34 |     (hash-set! table value 'name)
 35 |     ...))
 36 | 
 37 | ;; EXIF v2.3, table 4.
 38 | (define-exif-tags *exif-tag-names*
 39 |   ;; Image structure.
 40 |   (#x100 image-width)
 41 |   (#x101 image-length)
 42 |   (#x102 bits-per-sample)
 43 |   (#x103 compression)
 44 |   (#x106 photometric-interpretation)
 45 |   (#x112 orientation)
 46 |   (#x115 samples-per-pixel)
 47 |   (#x11c planar-configuration)
 48 |   (#x212 y-cb-cr-sub-sampling)
 49 |   (#x213 y-cb-cr-positioning)
 50 |   (#x11a x-resolution)
 51 |   (#x11b y-resolution)
 52 |   (#x128 resolution-unit)
 53 |   ;; Offsets.
 54 |   (#x111 strip-offsets)
 55 |   (#x116 rows-per-strip)
 56 |   (#x117 strip-byte-counts)
 57 |   (#x201 jpeg-interchange-format)
 58 |   (#x202 jpeg-interchange-format-length)
 59 |   ;; Image data characteristics.
 60 |   (#x12d transfer-function)
 61 |   (#x13e white-point)
 62 |   (#x13f primary-chromaticities)
 63 |   (#x211 y-cb-cr-coefficients)
 64 |   (#x214 reference-black-white)
 65 |   ;; Other tags.
 66 |   (#x132 date-time)
 67 |   (#x10e image-description)
 68 |   (#x10f make)
 69 |   (#x110 model)
 70 |   (#x131 software)
 71 |   (#x13b artist)
 72 |   (#x8298 copyright))
 73 | 
 74 | ;; EXIF v2.3, table 7.
 75 | (define-exif-tags *exif-tag-names*
 76 |   ;; Version
 77 |   (#x9000 exif-version)
 78 |   (#xa000 flashpix-version)
 79 |   ;; Image data characteristics.
 80 |   (#xa001 color-space)
 81 |   (#xa500 gamma)
 82 |   ;; Image configuration.
 83 |   (#x9101 components-configuration)
 84 |   (#x9102 compressed-bits-per-pixel)
 85 |   (#xa002 pixel-x-dimension)
 86 |   (#xa003 pixel-y-dimension)
 87 |   ;; User information.
 88 |   (#x927c maker-note)
 89 |   (#x9286 user-comment)
 90 |   ;; Related files.
 91 |   (#xa004 related-sound-file)
 92 |   ;; Date and time.
 93 |   (#x9003 date-time-original)
 94 |   (#x9004 date-time-digitized)
 95 |   (#x9290 sub-sec-time)
 96 |   (#x9291 sub-sec-time-original)
 97 |   (#x9292 sub-sec-time-digitized)
 98 |   ;; Other.
 99 |   (#xa420 image-unique-id)
100 |   (#xa430 camera-owner-name)
101 |   (#xa431 body-serial-number)
102 |   (#xa432 lens-specification)
103 |   (#xa433 lens-make)
104 |   (#xa434 lens-model)
105 |   (#xa435 lens-serial-number))
106 | 
107 | ;; EXIF v2.3, table 8.
108 | (define-exif-tags *exif-tag-names*
109 |   ;; Picture-taking conditions.
110 |   (#x829a exposure-time)
111 |   (#x829d f-number)
112 |   (#x8822 exposure-program)
113 |   (#x8824 spectral-sensitivity)
114 |   (#x8827 photographic-sensitivity)
115 |   (#x8828 oecf)
116 |   (#x8830 sensitivity-type)
117 |   (#x8831 standard-output-sensitivity)
118 |   (#x8832 recommended-exposureindex)
119 |   (#x8833 iso-speed)
120 |   (#x8834 iso-speed-latitude-yyy)
121 |   (#x8835 iso-speed-latitude-zzz)
122 |   (#x9201 shutter-speed-value)
123 |   (#x9202 aperture-value)
124 |   (#x9203 brightness-value)
125 |   (#x9204 exposure-bias-value)
126 |   (#x9205 max-aperture-value)
127 |   (#x9206 subject-distance)
128 |   (#x9207 metering-mode)
129 |   (#x9208 light-source)
130 |   (#x9209 flash)
131 |   (#x920a focal-length)
132 |   (#x9214 subject-area)
133 |   (#xa20b flash-energy)
134 |   (#xa20c spatial-frequency-response)
135 |   (#xa20e focal-plane-x-resolution)
136 |   (#xa20f focal-plane-y-resolution)
137 |   (#xa210 focal-plane-resolution-unit)
138 |   (#xa214 subject-location)
139 |   (#xa215 exposure-index)
140 |   (#xa217 sensing-method)
141 |   (#xa300 file-source)
142 |   (#xa301 scene-type)
143 |   (#xa302 cfa-pattern)
144 |   (#xa401 custom-rendered)
145 |   (#xa402 exposure-mode)
146 |   (#xa403 white-balance)
147 |   (#xa404 digital-zoom-ratio)
148 |   (#xa405 focal-length-in-35mm-film)
149 |   (#xa406 scene-capture-type)
150 |   (#xa407 gain-control)
151 |   (#xa408 contrast)
152 |   (#xa409 saturation)
153 |   (#xa40a sharpness)
154 |   (#xa40b device-settings-description)
155 |   (#xa40c subject-distance-range))
156 | 
157 | (define *type-widths*
158 |   #(#f ; 0 is unused.
159 |     1 1 2 4 8 ; BYTE ASCII SHORT LONG RATIONAL
160 |     1 1 2 4 8 ; SBYTE UNDEFINED SSHORT SLONG SRATIONAL
161 |     4 8 ; FLOAT DOUBLE
162 |     ))
163 | 
164 | (define *type-parsers*
165 |   (vector
166 |    #f                                                  ; 0 is unused.
167 |    (lambda (bv pos order) (bytevector-u8-ref bv pos))  ; BYTE
168 |    (lambda (bv pos order) (error "unreachable"))       ; ASCII
169 |    (lambda (bv pos order) (bytevector-u16-ref bv pos order))  ; SHORT
170 |    (lambda (bv pos order) (bytevector-u32-ref bv pos order))  ; LONG
171 |    (lambda (bv pos order)
172 |      (cons (bytevector-u32-ref bv pos order)
173 |            (bytevector-u32-ref bv (+ pos 4) order)))   ; RATIONAL
174 |    (lambda (bv pos order) (bytevector-s8-ref bv pos))  ; SBYTE
175 |    (lambda (bv pos order) (error "unreachable"))       ; UNDEFINED
176 |    (lambda (bv pos order) (bytevector-s16-ref bv pos order))  ; SSHORT
177 |    (lambda (bv pos order) (bytevector-s32-ref bv pos order))  ; SLONG
178 |    (lambda (bv pos order)
179 |      (cons (bytevector-u32-ref bv pos order)
180 |            (bytevector-u32-ref bv (+ pos 4) order))) ; SRATIONAL
181 |    (lambda (bv pos order) (bytevector-ieee-single-ref bv pos order)) ; FLOAT
182 |    (lambda (bv pos order) (bytevector-ieee-double-ref bv pos order)) ; DOUBLE
183 |    ))
184 | 
185 | (define (type-width type)
186 |   (and (< type (vector-length *type-widths*))
187 |        (vector-ref *type-widths* type)))
188 | 
189 | (define (type-parser type)
190 |   (and (< type (vector-length *type-parsers*))
191 |        (vector-ref *type-parsers* type)))
192 | 
193 | (define (read-value bv pos order type count)
194 |   (case type
195 |     ((2) ; ASCII
196 |      (if (> count 0)
197 |          ;; Trim trailing NUL byte.
198 |          (let ((res (make-bytevector (sub1 count))))
199 |            (bytevector-copy! bv pos res 0 (sub1 count))
200 |            (utf8->string res))
201 |          ""))
202 |     ((7) ; UNDEFINED
203 |      (let ((res (make-bytevector count)))
204 |        (bytevector-copy! bv pos res 0 count)
205 |        res))
206 |     (else
207 |      (let ((parser (type-parser type)))
208 |        (and parser
209 |             (if (= count 1)
210 |                 (parser bv pos order)
211 |                 (let ((res (make-vector count))
212 |                       (width (type-width type)))
213 |                   (let lp ((n 0) (pos pos))
214 |                     (if (< n count)
215 |                         (begin
216 |                           (vector-set! res n (parser bv pos order))
217 |                           (lp (add1 n) (+ pos width)))
218 |                         res)))))))))
219 | 
220 | (define *value-interpreters* (make-hasheq))
221 | 
222 | (define-syntax-rule (define-value-interpreter (name value) body ...)
223 |   (hash-set! *value-interpreters* 'name
224 |              (lambda (value) body ...)))
225 | 
226 | (define-value-interpreter (orientation value)
227 |   (case value
228 |     ((1) "Normal")
229 |     ((2) "Mirrored")
230 |     ((3) "Rotated 180 degrees")
231 |     ((4) "Rotated 180 degrees then mirrored")
232 |     ((5) "Rotated 90 degrees clockwise then mirrored")
233 |     ((6) "Rotated 90 degrees clockwise")
234 |     ((7) "Rotated 90 degrees counter-clockwise then mirrored")
235 |     ((8) "Rotated 90 degrees counter-clockwise")))
236 | 
237 | (define-value-interpreter (photometric-interpretation value)
238 |   (case value
239 |     ((2) "RGB")
240 |     ((6) "YCbCr")
241 |     (else value)))
242 | 
243 | (define-value-interpreter (planar-configuratino value)
244 |   (case value
245 |     ((1) "Chunky")
246 |     ((2) "Planar")
247 |     (else value)))
248 | 
249 | (define-value-interpreter (y-cb-cr-positioning value)
250 |   (case value
251 |     ((1) "Centered")
252 |     ((2) "Co-sited")
253 |     (else value)))
254 | 
255 | (define-value-interpreter (resolution-unit value)
256 |   (case value
257 |     ((2) "Inches")
258 |     ((3) "Centimeters")
259 |     (else value)))
260 | 
261 | (define-value-interpreter (focal-plane-resolution-unit value)
262 |   (case value
263 |     ((2) "Inches")
264 |     ((3) "Centimeters")
265 |     (else value)))
266 | 
267 | (define-value-interpreter (compression value)
268 |   (case value
269 |     ((1) "Uncompressed")
270 |     ((6) "JPEG")
271 |     (else value)))
272 | 
273 | (define-value-interpreter (color-space value)
274 |   (case value
275 |     ((1) "sRGB")
276 |     ((#xffff) "Uncalibrated")
277 |     (else value)))
278 | 
279 | (define-value-interpreter (exposure-program value)
280 |   (case value
281 |     ((1) "Manual")
282 |     ((2) "Normal")
283 |     ((3) "Aperture priority")
284 |     ((4) "Shutter priority")
285 |     ((5) "Creative")
286 |     ((6) "Action")
287 |     ((7) "Portrait")
288 |     ((8) "Landscape")
289 |     (else value)))
290 | 
291 | (define-value-interpreter (sensitivity-type value)
292 |   (case value
293 |     ((1) "SOS")
294 |     ((2) "REI")
295 |     ((3) "ISO")
296 |     ((4) "SOS+REI")
297 |     ((5) "SOS+ISO")
298 |     ((6) "REI+ISO")
299 |     ((7) "SOS+REI+ISO")
300 |     (else value)))
301 | 
302 | (define-value-interpreter (metering-mode value)
303 |   (case value
304 |     ((1) "Average")
305 |     ((2) "Center-weighted average")
306 |     ((3) "Spot")
307 |     ((4) "Multi-spot")
308 |     ((5) "Pattern")
309 |     ((6) "Partial")
310 |     (else value)))
311 | 
312 | (define-value-interpreter (light-source value)
313 |   (case value
314 |     ((1) "Daylight")
315 |     ((2) "Flourescent")
316 |     ((3) "Tungsten")
317 |     ((4) "Flash")
318 |     ((9) "Fine weather")
319 |     ((10) "Cloudy weather")
320 |     ((11) "Shade")
321 |     ((12) "Daylight flourescent")
322 |     ((13) "Day white flourescent")
323 |     ((14) "Cool white flourescent")
324 |     ((15) "White flourescent")
325 |     ((16) "Warm white flourescent")
326 |     ((17) "Standard light A")
327 |     ((18) "Standard light B")
328 |     ((19) "Standard light C")
329 |     ((20) "D55")
330 |     ((21) "D65")
331 |     ((22) "D75")
332 |     ((23) "D50")
333 |     ((24) "ISO studio tungsten")
334 |     (else value)))
335 | 
336 | (define-value-interpreter (flash value)
337 |   (let ((fired? (bitwise-bit-set? value 0))
338 |         (return (bitwise-and #b11 (arithmetic-shift value -1)))
339 |         (mode (bitwise-and #b11 (arithmetic-shift value -3)))
340 |         (present? (bitwise-bit-set? value 5))
341 |         (red-eye? (bitwise-bit-set? value 6)))
342 |     `((fired? . ,fired?)
343 |       (return-light . ,(case return
344 |                          ((0) "Not available")
345 |                          ((1) "Unknown")
346 |                          ((2) "Not detected")
347 |                          ((3) "Detected")))
348 |       (mode . ,(case mode
349 |                  ((0) "Unknown")
350 |                  ((1) "Compulsory firing")
351 |                  ((2) "Compulsury suppression")
352 |                  ((3) "Auto")))
353 |       (present? . ,present?)
354 |       (red-eye? . ,red-eye?))))
355 | 
356 | (define-value-interpreter (sensing-method value)
357 |   (case value
358 |     ((1) "Not defined")
359 |     ((2) "One chip color area")
360 |     ((3) "Two chip color area")
361 |     ((4) "Three chip color area")
362 |     ((5) "Color sequental area")
363 |     ((6) "Trilinear")
364 |     ((7) "Color sequental linear")
365 |     (else value)))
366 | 
367 | (define-value-interpreter (file-source value)
368 |   (case value
369 |     ((1) "Transparent scanner")
370 |     ((2) "Reflex scanner")
371 |     ((3) "DSC")
372 |     (else value)))
373 | 
374 | (define-value-interpreter (custom-rendered value)
375 |   (case value
376 |     ((1) "Normal")
377 |     ((2) "Custom")
378 |     (else value)))
379 | 
380 | (define-value-interpreter (exposure-mode value)
381 |   (case value
382 |     ((0) "Auto")
383 |     ((1) "Manual")
384 |     ((2) "Auto bracket")
385 |     (else value)))
386 | 
387 | (define-value-interpreter (white-balance value)
388 |   (case value
389 |     ((0) "Auto")
390 |     ((1) "Manual")
391 |     (else value)))
392 | 
393 | (define-value-interpreter (screen-capture-type value)
394 |   (case value
395 |     ((0) "Standard")
396 |     ((1) "Landscape")
397 |     ((2) "Portrait")
398 |     ((3) "Night")
399 |     (else value)))
400 | 
401 | (define-value-interpreter (gain-control value)
402 |   (case value
403 |     ((0) "None")
404 |     ((1) "Low gain up")
405 |     ((2) "High gain up")
406 |     ((3) "Low gain down")
407 |     ((4) "High gain down")
408 |     (else value)))
409 | 
410 | (define-value-interpreter (contrast value)
411 |   (case value
412 |     ((0) "Normal")
413 |     ((1) "Soft")
414 |     ((2) "Hard")
415 |     (else value)))
416 | 
417 | (define-value-interpreter (saturation value)
418 |   (case value
419 |     ((0) "Normal")
420 |     ((1) "Low")
421 |     ((2) "High")
422 |     (else value)))
423 | 
424 | (define-value-interpreter (sharpness value)
425 |   (case value
426 |     ((0) "Normal")
427 |     ((1) "Soft")
428 |     ((2) "Hard")
429 |     (else value)))
430 | 
431 | (define-value-interpreter (subject-distance-range value)
432 |   (case value
433 |     ((1) "Macro")
434 |     ((2) "Close")
435 |     ((3) "Distant")
436 |     (else value)))
437 | 
438 | (define (interpret-value name value)
439 |   (let ((interpret (hash-ref *value-interpreters* name #f)))
440 |     (if interpret
441 |         (interpret value)
442 |         value)))
443 | 
444 | (define (parse-ifd-chain bv pos order max-depth)
445 |   (define (inline-value? type count)
446 |     (let ((byte-width (and (< type (vector-length *type-widths*))
447 |                            (vector-ref *type-widths* type))))
448 |       (and byte-width (<= (* byte-width count) 4))))
449 |   (define (parse-tags tag-count)
450 |     (let lp ((n 0))
451 |       (if (< n tag-count)
452 |           (let* ((pos (+ pos 2 (* n 12)))
453 |                  (tag (bytevector-u16-ref bv pos order))
454 |                  (name (hash-ref *exif-tag-names* tag tag))
455 |                  (type (bytevector-u16-ref bv (+ pos 2) order))
456 |                  (count (bytevector-u32-ref bv (+ pos 4) order))
457 |                  (offset (if (inline-value? type count)
458 |                              (+ pos 8)
459 |                              (bytevector-u32-ref bv (+ pos 8) order)))
460 |                  (value (read-value bv offset order type count)))
461 |             (if (and (eqv? tag #x8769) ;; Nested EXIF information.
462 |                      (integer? value)
463 |                      (positive? max-depth))
464 |                 (match (parse-ifd-chain bv value order (sub1 max-depth))
465 |                   ((list alist)
466 |                    (append alist (lp (add1 n)))))
467 |                 (let ((value* (interpret-value name value)))
468 |                   (cons (cons name value*) (lp (add1 n))))))
469 |           '())))
470 |   (let* ((tag-count (bytevector-u16-ref bv pos order))
471 |          (next-pos-offset (+ pos 2 (* tag-count 12)))
472 |          (next-pos (bytevector-u32-ref bv next-pos-offset order)))
473 |     (cons (parse-tags tag-count)
474 |           (cond
475 |            ((or (zero? next-pos) (not (positive? max-depth))) '())
476 |            (else (parse-ifd-chain bv next-pos order (sub1 max-depth)))))))
477 | 
478 | (define (parse-exif bv)
479 |   (define (parse-byte-order b0 b1)
480 |     (unless (= b0 b1) (error "Bad TIFF header prefix"))
481 |     (case (integer->char b0)
482 |       ((#\I) (endianness little))
483 |       ((#\M) (endianness big))
484 |       (else (error "Bad TIFF header byte order"))))
485 |   (let ((order (parse-byte-order (bytevector-u8-ref bv 0)
486 |                                  (bytevector-u8-ref bv 1))))
487 |     (unless (= 42 (bytevector-u16-ref bv 2 order))
488 |       (error "Bad TIFF header magic value"))
489 |     (let ((ifd0 (bytevector-u32-ref bv 4 order)))
490 |       ;; Root IFD -> embedded EXIF -> one more
491 |       (define *max-exif-depth* 3)
492 |       (parse-ifd-chain bv ifd0 order *max-exif-depth*))))
493 | 


--------------------------------------------------------------------------------
/pixbufs.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ;; guile-jpeg
  3 | ;; Copyright (C) 2014 Andy Wingo <wingo at pobox dot com>
  4 | 
  5 | ;; This library is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3 of the License, or (at
  8 | ;; your option) any later version.
  9 | ;;
 10 | ;; This library is distributed in the hope that it will be useful, but
 11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 13 | ;; General Public License for more details.
 14 | ;;
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this library; if not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Commentary:
 19 | ;;
 20 | ;; A parser for JPEG.
 21 | ;;
 22 | ;;; Code:
 23 | 
 24 | (require rnrs/bytevectors-6)
 25 | ;; FIXME: These constructors should verify that the
 26 | ;; parameters are valid (e.g. that plane width and height
 27 | ;; agree with the size of the samples array)
 28 | (provide planar-image planar-image?
 29 |          planar-image-width planar-image-height
 30 |          planar-image-canvas-width planar-image-canvas-height
 31 |          planar-image-planes
 32 | 
 33 |          plane plane?
 34 |          plane-width plane-height plane-samples
 35 | 
 36 |          interleaved-image interleaved-image?
 37 |          interleaved-image-width interleaved-image-height
 38 |          interleaved-image-component-count interleaved-image-stride
 39 |          interleaved-image-buffer
 40 | 
 41 |          rgb->argb argb->rgb
 42 | 
 43 |          yuv->rgb rgb->yuv
 44 | 
 45 |          write-ppm write-pgm)
 46 | 
 47 | (struct planar-image
 48 |   (width height canvas-width canvas-height planes))
 49 | 
 50 | (struct plane
 51 |   (width height samples))
 52 | 
 53 | (struct interleaved-image
 54 |   (width height component-count stride buffer))
 55 | 
 56 | (define (shrink-plane-width-by-two/centered in width height)
 57 |   (let* ((half-width (/ width 2))
 58 |          (out (make-bytevector (* half-width height) 0)))
 59 |     (let lp ((i 0))
 60 |       (when (< i height)
 61 |         (let ((in-pos (* i width))
 62 |               (out-pos (* i half-width)))
 63 |           (let lp ((j 0))
 64 |             (when (< j half-width)
 65 |               (let* ((in- (bytevector-u8-ref in (+ in-pos (* j 2))))
 66 |                      (in+ (bytevector-u8-ref in (+ in-pos (* j 2) 1)))
 67 |                      ;; Dither rounding alternately by column.
 68 |                      (out* (arithmetic-shift (+ in- in+ (bitwise-and j 1))
 69 |                                              -1)))
 70 |                 (bytevector-u8-set! out (+ out-pos j) out*)
 71 |                 (lp (add1 j))))))
 72 |         (lp (add1 i))))
 73 |     out))
 74 | 
 75 | (define (shrink-plane-height-by-two/centered in width height)
 76 |   (let* ((half-height (/ height 2))
 77 |          (out (make-bytevector (* width half-height) 0)))
 78 |     (let lp ((i 0))
 79 |       (when (< i half-height)
 80 |         (let ((in-pos (* i 2 width))
 81 |               (out-pos (* i width)))
 82 |           (let lp ((j 0))
 83 |             (when (< j width)
 84 |               (let* ((in- (bytevector-u8-ref in (+ in-pos j)))
 85 |                      (in+ (bytevector-u8-ref in (+ in-pos j width)))
 86 |                      ;; Dither rounding alternately by column.
 87 |                      (out* (arithmetic-shift (+ in- in+ (bitwise-and j 1))
 88 |                                              -1)))
 89 |                 (bytevector-u8-set! out (+ out-pos j) out*)
 90 |                 (lp (add1 j))))))
 91 |         (lp (add1 i))))
 92 |     out))
 93 | 
 94 | (define (pad-interleaved-horizontally in width height stride new-width ncomps)
 95 |   (let* ((new-stride (* new-width ncomps))
 96 |          (out (make-bytevector (* new-stride height) 0)))
 97 |     (let lp ((i 0))
 98 |       (when (< i height)
 99 |         (let ((in-pos (* i stride))
100 |               (out-pos (* i new-stride)))
101 |           (bytevector-copy! in in-pos out out-pos (* width ncomps))
102 |           (let lp ((j (* width ncomps)))
103 |             (when (< j new-stride)
104 |               (let ((x (bytevector-u8-ref out (+ out-pos j (- ncomps)))))
105 |                 (bytevector-u8-set! out (+ out-pos j) x)
106 |                 (lp (add1 j))))))
107 |         (lp (add1 i))))
108 |     out))
109 | 
110 | (define (pad-interleaved-vertically in width height stride new-height ncomps)
111 |   (let* ((new-stride (* width ncomps))
112 |          (out (make-bytevector (* new-stride new-height) 0)))
113 |     (let lp ((i 0))
114 |       (when (< i height)
115 |         (let ((in-pos (* i stride))
116 |               (out-pos (* i new-stride)))
117 |           (bytevector-copy! in in-pos out out-pos (* width ncomps))
118 |           (lp (add1 i)))))
119 |     (let lp ((i height))
120 |       (when (< i new-height)
121 |         (let ((prev-pos (* (sub1 i) new-stride))
122 |               (out-pos (* i new-stride)))
123 |           (bytevector-copy! out prev-pos out out-pos new-stride)
124 |           (lp (add1 i)))))
125 |     out))
126 | 
127 | (define (expand-plane-width-by-two/centered in width height)
128 |   (let* ((out (make-bytevector (* width 2 height) 0)))
129 |     (let lp ((i 0))
130 |       (when (< i height)
131 |         (let ((in-pos (* i width))
132 |               (out-pos (* i width 2)))
133 |           ;; Special case for first column.
134 |           (let* ((j 0)
135 |                  (in (bytevector-u8-ref in (+ in-pos j))))
136 |             (bytevector-u8-set! out (+ out-pos 0) in))
137 |           (let lp ((j 0))
138 |             (when (< j (sub1 width))
139 |               ;; (3x + y + 2) >> 2 is the same as 3x/4 + y/4.  Since
140 |               ;; we're dealing with integers though, we don't want to
141 |               ;; introduce bias by having all 0.5 values round to 1, so
142 |               ;; we add 1 or 2 to the value being shifted, alternating
143 |               ;; by row.
144 |               (let* ((in- (bytevector-u8-ref in (+ in-pos j)))
145 |                      (in+ (bytevector-u8-ref in (+ in-pos (add1 j))))
146 |                      (out- (arithmetic-shift (+ (* 3 in-) in+ 2) -2))
147 |                      (out+ (arithmetic-shift (+ in- (* 3 in+) 1) -2)))
148 |                 (bytevector-u8-set! out (+ out-pos j j 1) out-)
149 |                 (bytevector-u8-set! out (+ out-pos j j 2) out+)
150 |                 (lp (+ j 1)))))
151 |           ;; Special case for last column.
152 |           (let* ((j (sub1 width))
153 |                  (in (bytevector-u8-ref in (+ in-pos j))))
154 |             (bytevector-u8-set! out (+ out-pos width width -1) in)))
155 |         (lp (add1 i))))
156 |     out))
157 | 
158 | (define (expand-plane-height-by-two/centered in width height)
159 |   (let* ((out (make-bytevector (* width 2 height) 0)))
160 |     ;; Special case for first row.
161 |     (let lp ((j 0))
162 |       (when (< j width)
163 |         (let ((in (bytevector-u8-ref in j)))
164 |           (bytevector-u8-set! out j in)
165 |           (lp (add1 j)))))
166 |     ;; The height-1 spaces between samples.
167 |     (let lp ((i 0))
168 |       (when (< i (sub1 height))
169 |         (let ((in-pos (* i width))
170 |               (out-pos (+ width (* i 2 width))))
171 |           (let lp ((j 0))
172 |             (when (< j width)
173 |               (let* ((in- (bytevector-u8-ref in (+ in-pos j)))
174 |                      (in+ (bytevector-u8-ref in (+ in-pos width j)))
175 |                      ;; Interpolate output; see comment in previous
176 |                      ;; function.
177 |                      (out- (arithmetic-shift (+ (* 3 in-) in+ 2) -2))
178 |                      (out+ (arithmetic-shift (+ in- (* 3 in+) 1) -2)))
179 |                 (bytevector-u8-set! out (+ out-pos j) out-)
180 |                 (bytevector-u8-set! out (+ out-pos width j) out+)
181 |                 (lp (add1 j)))))
182 |           (lp (add1 i)))))
183 |     ;; Special case for the last row.
184 |     (let* ((i (sub1 height))
185 |            (in-pos (* i width))
186 |            (out-pos (+ width (* i 2 width))))
187 |       (let lp ((j 0))
188 |         (when (< j width)
189 |           (let ((in (bytevector-u8-ref in (+ in-pos j))))
190 |             (bytevector-u8-set! out (+ out-pos j) in)
191 |             (lp (add1 j))))))
192 |     out))
193 | 
194 | (define (upsample-4:2:2 width height y-width y-height y cb cr)
195 |   (define (expand in)
196 |     (expand-plane-width-by-two/centered in (/ y-width 2) y-height))
197 |   (planar-image
198 |    width height y-width y-height
199 |    (vector (plane y-width y-height y)
200 |            (plane y-width y-height (expand cb))
201 |            (plane y-width y-height (expand cr)))))
202 | 
203 | (define (upsample-4:2:0 width height y-width y-height y cb cr)
204 |   (define (expand in)
205 |     (expand-plane-height-by-two/centered in (/ y-width 2) (/ y-height 2)))
206 |   (upsample-4:2:2 width height y-width y-height y (expand cb) (expand cr)))
207 | 
208 | (define (convert-yuv out width height stride y cb cr y-stride)
209 |   (let lp ((i 0))
210 |     (when (< i height)
211 |       (let lp ((j 0) (in-pos (* i y-stride)) (out-pos (* i stride)))
212 |         (when (< j width)
213 |           (let ((y (bytevector-u8-ref y in-pos))
214 |                 (cb (- (bytevector-u8-ref cb in-pos) 128))
215 |                 (cr (- (bytevector-u8-ref cr in-pos) 128)))
216 |             (define (->u8 x)
217 |               (cond ((< x 0) 0)
218 |                     ((> x 255) 255)
219 |                     (else (inexact->exact (round x)))))
220 |             ;; See ITU recommendataion ITU-T T.871, "JPEG File
221 |             ;; Interchange Format (JFIF)", section 7.
222 |             (let ((r (->u8 (+ y (* 1.402 cr))))
223 |                   (g (->u8 (- y (/ (+ (* 0.114 1.772 cb)
224 |                                       (* 0.299 1.402 cr))
225 |                                    0.587))))
226 |                   (b (->u8 (+ y (* 1.772 cb)))))
227 |               (bytevector-u8-set! out (+ out-pos 0) r)
228 |               (bytevector-u8-set! out (+ out-pos 1) g)
229 |               (bytevector-u8-set! out (+ out-pos 2) b)
230 |               (lp (add1 j) (add1 in-pos) (+ out-pos 3))))))
231 |       (lp (add1 i)))))
232 | 
233 | ;; in and out might be the same
234 | (define (rgb-pixels->argb-pixels in out width height in-stride out-stride)
235 |   (let lp ((i 0))
236 |     (when (< i height)
237 |       (let ((in-pos (* i in-stride))
238 |             (out-pos (* i out-stride)))
239 |         (let lp ((j (sub1 width)))
240 |           (when (<= 0 j)
241 |             (let ((in-pos (+ in-pos (* 3 j)))
242 |                   (out-pos (+ out-pos (* 4 j))))
243 |               (let ((a #xff)
244 |                     (r (bytevector-u8-ref in (+ in-pos 0)))
245 |                     (g (bytevector-u8-ref in (+ in-pos 1)))
246 |                     (b (bytevector-u8-ref in (+ in-pos 2))))
247 |                 (let ((argb (bitwise-ior (arithmetic-shift a 24)
248 |                                          (arithmetic-shift r 16)
249 |                                          (arithmetic-shift g 8)
250 |                                          (arithmetic-shift b 0))))
251 |                   (bytevector-u32-native-set! out out-pos argb))
252 |                 (lp (sub1 j)))))))
253 |       (lp (add1 i)))))
254 | 
255 | (define (argb-pixels->rgb-pixels in out width height in-stride out-stride)
256 |   (let lp ((i 0))
257 |     (when (< i height)
258 |       (let ((in-pos (* i in-stride))
259 |             (out-pos (* i out-stride)))
260 |         (let lp ((j 0))
261 |           (when (< j width)
262 |             (let ((in-pos (+ in-pos (* 4 j)))
263 |                   (out-pos (+ out-pos (* 3 j))))
264 |               (let ((r (bytevector-u8-ref in (+ in-pos 1)))
265 |                     (g (bytevector-u8-ref in (+ in-pos 2)))
266 |                     (b (bytevector-u8-ref in (+ in-pos 3))))
267 |                 (bytevector-u8-set! out (+ out-pos 0) r)
268 |                 (bytevector-u8-set! out (+ out-pos 1) g)
269 |                 (bytevector-u8-set! out (+ out-pos 2) b)
270 |                 (lp (add1 j)))))))
271 |       (lp (add1 i)))))
272 | 
273 | (define (argb->rgb image)
274 |   (match image
275 |     ((interleaved-image width height 4 stride argb-pixels)
276 |      (unless (= stride (* 4 width))
277 |        (error "implement me"))
278 |      (let ((rgb-pixels (make-bytes (* 3 width height))))
279 |        (argb-pixels->rgb-pixels argb-pixels rgb-pixels width height
280 |                                 stride (* 3 width))
281 |        (interleaved-image width height 3 (* 3 width) rgb-pixels)))))
282 | 
283 | (define (rgb->argb image)
284 |   (match image
285 |     ((interleaved-image width height 3 stride rgb-pixels)
286 |      (unless (= stride (* 3 width))
287 |        (error "implement me"))
288 |      (let ((argb-pixels (make-bytes (* 4 width height))))
289 |        (rgb-pixels->argb-pixels rgb-pixels argb-pixels width height
290 |                                 stride (* 4 width))
291 |        (interleaved-image width height 4 (* 4 width) argb-pixels)))))
292 | 
293 | (define (yuv->rgb yuv
294 |                    #:argb? (argb? #f)
295 |                    #:stride (stride (* (planar-image-width yuv) (if argb? 4 3))))
296 |   (match yuv
297 |     ((planar-image width height canvas-width canvas-height planes)
298 |      (match planes
299 |        ((vector (plane y-width y-height y))
300 |         (error "greyscale unimplemented"))
301 |        ((vector (plane y-width y-height y)
302 |                 (plane cb-width cb-height cb)
303 |                 (plane cr-width cr-height cr))
304 |         (unless (and (= y-width canvas-width) (= y-height canvas-height))
305 |           (error "Expected Y' to have same dimensions as canvas"))
306 |         (match (vector (/ y-width cb-width) (/ y-height cb-height)
307 |                        (/ y-width cr-width) (/ y-height cr-height))
308 |           ((vector 2 2 2 2)                   ; 4:2:0
309 |            (yuv->rgb (upsample-4:2:0 width height y-width y-height y cb cr)
310 |                      #:argb? argb? #:stride stride))
311 |           ((vector 2 1 2 1)                   ; 4:2:2
312 |            (yuv->rgb (upsample-4:2:2 width height y-width y-height y cb cr)
313 |                      #:argb? argb? #:stride stride))
314 |           ((vector 1 1 1 1)                   ; 4:4:4
315 |            (unless (<= (* width (if argb? 4 3)) stride)
316 |              (error "invalid stride" stride))
317 |            (let ((buffer (make-bytevector (* stride height) 0)))
318 |              (convert-yuv buffer width height stride y cb cr y-width)
319 |              (when argb?
320 |                (rgb-pixels->argb-pixels buffer buffer width height
321 |                                         stride stride))
322 |              (interleaved-image width height
323 |                                 (if argb? 4 3) stride buffer)))
324 |           ((vector x y z w)                   ; ?
325 |            (error "subsampling unimplemented" x y z w))))
326 |        (_ (error "unknown colorspace"))))))
327 | 
328 | (define (convert-rgb rgb width height stride)
329 |   (let ((y (make-bytevector (* width height)))
330 |         (cb (make-bytevector (* width height)))
331 |         (cr (make-bytevector (* width height))))
332 |     (let lp ((i 0))
333 |       (when (< i height)
334 |         (let lp ((j 0) (in-pos (* i stride)) (out-pos (* i width)))
335 |           (when (< j width)
336 |             (let ((r (bytevector-u8-ref rgb (+ in-pos 0)))
337 |                   (g (bytevector-u8-ref rgb (+ in-pos 1)))
338 |                   (b (bytevector-u8-ref rgb (+ in-pos 2))))
339 |               (define (->u8 x)
340 |                 (cond ((< x 0) 0)
341 |                       ((> x 255) 255)
342 |                       (else (inexact->exact (round x)))))
343 |               ;; See ITU recommendataion ITU-T T.871, "JPEG File
344 |               ;; Interchange Format (JFIF)", section 7.
345 |               (let ((y* (->u8 (+ (* 0.299 r) (* 0.587 g) (* 0.114 b))))
346 |                     (cb* (->u8 (+ (/ (+ (* -0.299 r) (* -0.587 g) (* 0.886 b))
347 |                                      1.772)
348 |                                   128)))
349 |                     (cr* (->u8 (+ (/ (+ (* 0.701 r) (* -0.587 g) (* -0.114 b))
350 |                                      1.402)
351 |                                   128))))
352 |                 (bytevector-u8-set! y out-pos y*)
353 |                 (bytevector-u8-set! cb out-pos cb*)
354 |                 (bytevector-u8-set! cr out-pos cr*)
355 |                 (lp (add1 j) (+ in-pos 3) (add1 out-pos))))))
356 |         (lp (add1 i))))
357 |     (values y cb cr)))
358 | 
359 | (define (ceiling/ a b)
360 |   (inexact->exact (ceiling (/ a b))))
361 | 
362 | (define (rgb->yuv rgb #:samp-x (samp-x 2) #:samp-y (samp-y 2))
363 |   (define (round-up x y) (* (ceiling/ x y) y))
364 |   (match rgb
365 |     ((interleaved-image width height 4 stride argb)
366 |      (let* ((new-stride (* width 3))
367 |             (rgb (make-bytevector (* height new-stride) 0)))
368 |        (argb-pixels->rgb-pixels argb rgb width height stride new-stride)
369 |        (rgb->yuv (interleaved-image width height 3 new-stride rgb)
370 |         #:samp-x samp-x #:samp-y samp-y)))
371 |     ((interleaved-image width height 3 stride rgb)
372 |      (let pad ((rgb rgb)
373 |                (canvas-width width)
374 |                (canvas-height height)
375 |                (stride stride))
376 |        (cond
377 |         ((not (integer? (/ canvas-width 8 samp-x)))
378 |          (let ((new-canvas-width (round-up canvas-width (* 8 samp-x))))
379 |            (pad (pad-interleaved-horizontally rgb canvas-width canvas-height
380 |                                               stride new-canvas-width 3)
381 |                 new-canvas-width canvas-height (* new-canvas-width 3))))
382 |         ((not (integer? (/ canvas-height 8 samp-y)))
383 |          (let ((new-canvas-height (round-up canvas-height (* 8 samp-y))))
384 |            (pad (pad-interleaved-vertically rgb canvas-width canvas-height
385 |                                             stride new-canvas-height 3)
386 |                 canvas-width new-canvas-height (* canvas-width 3))))
387 |         (else
388 |          (call-with-values (lambda ()
389 |                              (convert-rgb rgb canvas-width canvas-height stride))
390 |            (lambda (y cb cr)
391 |              (let lp ((cb cb) (cr cr)
392 |                       (samp-w canvas-width) (samp-h canvas-height))
393 |                (cond
394 |                 ((< canvas-width (* samp-w samp-x))
395 |                  (lp (shrink-plane-width-by-two/centered cb samp-w samp-h)
396 |                      (shrink-plane-width-by-two/centered cr samp-w samp-h)
397 |                      (/ samp-w 2)
398 |                      samp-h))
399 |                 ((< canvas-height (* samp-h samp-y))
400 |                  (lp (shrink-plane-height-by-two/centered cb samp-w samp-h)
401 |                      (shrink-plane-height-by-two/centered cr samp-w samp-h)
402 |                      samp-w
403 |                      (/ samp-h 2)))
404 |                 (else
405 |                  (planar-image
406 |                   width height canvas-width canvas-height
407 |                   (vector (plane canvas-width canvas-height y)
408 |                           (plane samp-w samp-h cb)
409 |                           (plane samp-w samp-h cr))))))))))))))
410 | 
411 | (define (write-ppm port rgb)
412 |   (match rgb
413 |     ((interleaved-image width height 3 stride buffer)
414 |      (unless (= stride (* 3 width))
415 |        (error "implement me"))
416 |      (fprintf port "P6\n~a ~a\n255\n" width height)
417 |      (write-bytes buffer port))))
418 | 
419 | (define (write-pgm port p)
420 |   (match p
421 |     ((plane width height samples)
422 |      (fprintf port "P5\n~a ~a\n255\n" width height)
423 |      (write-bytes samples port))))
424 | 


--------------------------------------------------------------------------------
/jfif.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ;; racket-jpeg
  3 | ;; Copyright (C) 2014 Andy Wingo <wingo at pobox dot com>
  4 | 
  5 | ;; This library is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3 of the License, or (at
  8 | ;; your option) any later version.
  9 | ;;
 10 | ;; This library is distributed in the hope that it will be useful, but
 11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 13 | ;; General Public License for more details.
 14 | ;;
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this library; if not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Commentary:
 19 | ;;
 20 | ;; Readers and writers for the JPEG File Interchange Format (JFIF)
 21 | ;;
 22 | ;;; Code:
 23 | 
 24 | (require math/array jpeg/bit-ports jpeg/huffman)
 25 | 
 26 | (provide jfif jfif? jfif-frame jfif-misc-segments jfif-mcu-array
 27 | 
 28 |          frame frame?
 29 |          frame-marker frame-precision frame-y frame-x frame-components
 30 |          frame-samp-x frame-samp-y
 31 | 
 32 |          frame-baseline? frame-sequential? frame-progressive?
 33 |          frame-huffman-coded? frame-arithmetic-coded? frame-lossless?
 34 |          frame-dct?
 35 | 
 36 |          frame-component-count frame-mcu-width frame-mcu-height
 37 | 
 38 |          component component?
 39 |          component-id component-index component-samp-x component-samp-y
 40 |          component-q-table
 41 | 
 42 |          misc misc? misc-marker misc-bytes
 43 | 
 44 |          read-jfif
 45 |          write-jfif)
 46 | 
 47 | 
 48 | ;; See http://www.w3.org/Graphics/JPEG/itu-t81.pdf for ITU
 49 | ;; recommendation T.81, which is a freely-available version of the JPEG
 50 | ;; specification.
 51 | 
 52 | ;; JPEG := SOI FRAME EOI
 53 | ;; FRAME := MISC* FHEADER SCAN DNL? SCAN ... 
 54 | ;; SCAN := MISC* SHEADER ECS (RST ECS)*
 55 | ;; FHEADER := SOF LEN PRECISION Y X COMP0 COMP1 ...
 56 | ;; MISC := (DQT | DHT | DAC | DRI | COM | APP) LEN payload...
 57 | ;; SHEADER := SOS LEN NCOMPONENTS SCOMP0 SCOMP1 ... SS SE A
 58 | 
 59 | (struct jfif
 60 |   (frame misc-segments mcu-array)
 61 |   #:transparent)
 62 | 
 63 | (struct frame
 64 |   (marker precision y x components samp-x samp-y)
 65 |   #:transparent)
 66 | 
 67 | (struct component
 68 |   (id index samp-x samp-y q-table)
 69 |   #:transparent)
 70 | 
 71 | (struct misc
 72 |   (marker bytes)
 73 |   #:transparent)
 74 | 
 75 | (struct params
 76 |   (q-tables dc-tables ac-tables restart-interval misc-segments)
 77 |   #:transparent)
 78 | 
 79 | (define (read-marker port)
 80 |   (let ((u8 (read-byte port)))
 81 |     (unless (eqv? u8 #xff)
 82 |       (error "Unexpected byte while reading marker" u8)))
 83 |   (let lp ()
 84 |     (let ((u8 (read-byte port)))
 85 |       (when (eof-object? u8)
 86 |         (error "End of file while reading marker"))
 87 |       (case u8
 88 |         ((#xff) (lp))
 89 |         ((0) (error "Expected a marker, got #xFF00"))
 90 |         (else (bitwise-ior #xff00 u8))))))
 91 | 
 92 | (define (assert-marker port expected-marker)
 93 |   (let ((marker (read-marker port)))
 94 |     (unless (eqv? expected-marker marker)
 95 |       (error "Unexpected marker" marker expected-marker))))
 96 | 
 97 | (define (read-u8 port)
 98 |   (let* ((u8 (read-byte port)))
 99 |     (when (eof-object? u8)
100 |       (error "EOF while reading byte from port"))
101 |     u8))
102 | 
103 | (define (read-u16 port)
104 |   (let* ((msb (read-byte port))
105 |          (lsb (read-byte port)))
106 |     (when (eof-object? lsb)
107 |       (error "EOF while reading two-byte value"))
108 |     (bitwise-ior (arithmetic-shift msb 8) lsb)))
109 | 
110 | (define (read-bytes/exactly n port)
111 |   (let ((bytes (read-bytes n port)))
112 |     (unless (= (bytes-length bytes) n)
113 |       (error "EOF while reading bytes" n))
114 |     bytes))
115 | 
116 | (define (read-soi port)
117 |   (assert-marker port #xffd8))
118 | 
119 | (define-syntax eval-at-compile-time
120 |   (lambda (x)
121 |     (syntax-case x ()
122 |       ((eval-at-compile-time expr)
123 |        (datum->syntax #'eval-at-compile-time
124 |                       (eval (syntax->datum #'expr)))))))
125 | 
126 | (define normal-order
127 |   (eval-at-compile-time
128 |    (let* ((width 8)
129 |           (height 8)
130 |           ;; The padding is to allow the 4-bit offsets in the AC
131 |           ;; coefficient decode loop to increment "k" beyond 63.
132 |           ;; Strictly speaking, at that point we should signal an error,
133 |           ;; but perhaps it's better to keep on trucking.  This trick
134 |           ;; was taken from libjpeg.
135 |           (padding 16)
136 |           (len (* width height))
137 |           (res (make-bytes (+ len padding) (sub1 len))))
138 |      (let lp ((x 0) (y 0) (x-inc 1) (y-inc -1) (pos 0))
139 |        (when (< pos len)
140 |          (cond
141 |           ((< x 0) (lp 0 y (- x-inc) (- y-inc) pos))
142 |           ((< y 0) (lp x 0 (- x-inc) (- y-inc) pos))
143 |           ((and (< x width) (< y height))
144 |            (bytes-set! res pos (+ (* y height) x))
145 |            (lp (+ x x-inc) (+ y y-inc) x-inc y-inc (add1 pos)))
146 |           (else
147 |            (lp (+ x x-inc) (+ y y-inc) x-inc y-inc pos)))))
148 |      res)))
149 | 
150 | (define (read-q-table port len q-tables)
151 |   (unless (> len 2)
152 |     (error "Invalid DQT segment length" len))
153 |   (let lp ((remaining (- len 2)))
154 |     (unless (zero? remaining)
155 |       (unless (>= remaining 1)
156 |         (error "Invalid DQT segment length" len))
157 |       (let* ((PT (read-u8 port))
158 |              (Pq (arithmetic-shift PT -4))
159 |              (Tq (bitwise-and PT #xf))
160 |              (table (make-vector 64 #f))
161 |              (remaining (- remaining (+ 1 (* 64 (add1 Pq))))))
162 |         (define (zigzag->normal idx) (bytes-ref normal-order idx))
163 |         (unless (< Tq 4)
164 |           (error "Bad Tq value" Tq))
165 |         (when (negative? remaining)
166 |           (error "Invalid DQT segment length" len))
167 |         (case Pq
168 |           ((0)
169 |            (let lp ((n 0))
170 |              (when (< n 64)
171 |                (vector-set! table (zigzag->normal n) (read-u8 port))
172 |                (lp (add1 n)))))
173 |           ((1)
174 |            (let lp ((n 0))
175 |              (when (< n 64)
176 |                (vector-set! table (zigzag->normal n) (read-u16 port))
177 |                (lp (add1 n)))))
178 |           (else
179 |            (error "Bad Pq value" Pq)))
180 |         (vector-set! q-tables Tq table)
181 |         (lp remaining)))))
182 | 
183 | (define (read-huffman-table port len dc-tables ac-tables)
184 |   (unless (> len 2)
185 |     (error "Invalid DHT segment length" len))
186 |   (let lp ((remaining (- len 2)))
187 |     (unless (zero? remaining)
188 |       (unless (>= remaining 17)
189 |         (error "Invalid DHT segment length" len))
190 |       (let* ((T (read-u8 port))
191 |              (Tc (arithmetic-shift T -4))
192 |              (Th (bitwise-and T #xf))
193 |              (size-counts (read-bytes/exactly 16 port))
194 |              (count (for/fold ((sum 0)) ((count size-counts))
195 |                       (+ sum count)))
196 |              (remaining (- remaining (+ 17 count))))
197 |         (unless (< Th 4)
198 |           (error "Bad Th value" Th))
199 |         (when (negative? remaining)
200 |           (error "Invalid DHT segment length" len))
201 |         (let* ((values (read-bytes/exactly count port))
202 |                (table (make-huffman-table size-counts values)))
203 |           (match Tc
204 |             (0 (vector-set! dc-tables Th table))
205 |             (1 (vector-set! ac-tables Th table))
206 |             (_ (error "Bad Tc value" Tc))))
207 |         (lp remaining)))))
208 | 
209 | (define *initial-params*
210 |   (params (make-vector 4 #f)
211 |           (make-vector 4 #f)
212 |           (make-vector 4 #f)
213 |           0
214 |           '()))
215 | 
216 | (define (read-params port previous-params with-misc-sections?)
217 |   (let* ((q-tables (vector-copy (params-q-tables previous-params)))
218 |          (dc-tables (vector-copy (params-dc-tables previous-params)))
219 |          (ac-tables (vector-copy (params-ac-tables previous-params)))
220 |          (restart-interval (params-restart-interval previous-params))
221 |          (misc-segments '())) ;; No sense inheriting this.
222 |     (let lp ()
223 |       (let ((marker (read-marker port)))
224 |         (case marker
225 |           ((#xffdb)                     ; DQT
226 |            (let* ((len (read-u16 port)))
227 |              (read-q-table port len q-tables)
228 |              (lp)))
229 |           ((#xffc4)                     ; DHT
230 |            (let* ((len (read-u16 port)))
231 |              (read-huffman-table port len dc-tables ac-tables)
232 |              (lp)))
233 |           ((#xffcc)                     ; DAC
234 |            (error "Arithmetic coding currently unsupported."))
235 |           ((#xffdd)                     ; DRI
236 |            (let ((len (read-u16 port)))
237 |              (unless (= len 4)
238 |                (error "Unexpected DRI len" len))
239 |              (set! restart-interval (read-u16 port))
240 |              (lp)))
241 |           ((#xfffe                      ; COM
242 |             #xffe0 #xffe1 #xffe2 #xffe3 #xffe4 #xffe5 #xffe6 #xffe7 ; APP0-APP7
243 |             #xffe8 #xffe9 #xffea #xffeb #xffec #xffed #xffee #xffef) ; APP8-APP15
244 |            (let* ((len (read-u16 port))
245 |                   (payload-len (- len 2)))
246 |              (unless (>= payload-len 0)
247 |                (error "Invalid comment/app segment length" marker len))
248 |              (let ((misc (misc marker (read-bytes/exactly payload-len port))))
249 |                (set! misc-segments (cons misc misc-segments))
250 |                (lp))))
251 |           (else
252 |            (values (params q-tables dc-tables ac-tables restart-interval
253 |                            (reverse misc-segments))
254 |                    marker)))))))
255 | 
256 | (define (skip-params port)
257 |   (let ((marker (read-marker port)))
258 |     (case marker
259 |       ((#xffdb ; DQT
260 |         #xffc4 ; DHT
261 |         #xffcc ; DAC
262 |         #xffdd ; DRI
263 |         #xfffe ; COM
264 |         #xffe0 #xffe1 #xffe2 #xffe3 #xffe4 #xffe5 #xffe6 #xffe7 ; APP0-APP7
265 |         #xffe8 #xffe9 #xffea #xffeb #xffec #xffed #xffee #xffef) ; APP8-APP15
266 |        (let* ((len (read-u16 port))
267 |               (payload-len (- len 2)))
268 |          (unless (>= payload-len 0)
269 |            (error "Invalid marker segment length" marker len))
270 |          (file-position port (+ (file-position port) payload-len))
271 |          (skip-params port)))
272 |       (else marker))))
273 | 
274 | (define (frame-baseline? frame)
275 |   (case (frame-marker frame)
276 |     ((#xffc0) #t)                       ; SOF0
277 |     (else #f)))
278 | 
279 | (define (frame-sequential? frame)
280 |   (case (frame-marker frame)
281 |     ((#xffc0 #xffc1 #xffc3 #xffc9 #xffcb) #t) ; SOF0,SOF1,SOF3,SOF9,SOF11
282 |     (else #f)))
283 | 
284 | (define (frame-progressive? frame)
285 |   (case (frame-marker frame)
286 |     ((#xffc2 #xffca) #t)                ; SOF2,SOF10
287 |     (else #f)))
288 | 
289 | (define (frame-huffman-coded? frame)
290 |   (case (frame-marker frame)
291 |     ((#xffc0 #xffc1 #xffc2 #xffc3) #t)  ; SOF0,SOF1,SOF2,SOF3
292 |     (else #f)))
293 | 
294 | (define (frame-arithmetic-coded? frame)
295 |   (case (frame-marker frame)
296 |     ((#xffc9 #xffca #xffcb) #t)         ; SOF9,SOF10,SOF11
297 |     (else #f)))
298 | 
299 | (define (frame-lossless? frame)
300 |   (case (frame-marker frame)
301 |     ((#xffc3 #xffcb) #t)                ; SOF3,SOF11
302 |     (else #f)))
303 | 
304 | (define (frame-dct? frame)
305 |   (case (frame-marker frame)
306 |     ((#xffc0 #xffc1 #xffc2 #xffc9 #xffca) #t) ; SOF0,SOF1,SOF2,SOF9,SOF10
307 |     (else #f)))
308 | 
309 | (define (frame-component-count frame)
310 |   (vector-length (frame-components frame)))
311 | 
312 | (define (ceiling/ a b)
313 |   (inexact->exact (ceiling (/ a b))))
314 | (define (frame-mcu-width frame)
315 |   (ceiling/ (frame-x frame) (* (frame-samp-x frame) 8)))
316 | 
317 | (define (frame-mcu-height frame)
318 |   (ceiling/ (frame-y frame) (* (frame-samp-y frame) 8)))
319 | 
320 | (define (read-frame-header port sof)
321 |   (case sof
322 |     ;; There is no SOF8.
323 |     ((#xffc0 #xffc1 #xffc2 #xffc3 #xffc4 #xffc5 #xffc6 #xffc7 ; SOF0-SOF7
324 |              #xffc9 #xffca #xffcb #xffcc #xffcd #xffce #xffcf) ; SOF9-SOF15
325 |      (let* ((len (read-u16 port)))
326 |        (unless (>= len 8)
327 |          (error "Invalid frame header segment length" sof len))
328 |        (let* ((precision (read-u8 port))
329 |               (y (read-u16 port))
330 |               (x (read-u16 port))
331 |               (component-count (read-u8 port)))
332 |          (unless (= len (+ 8 (* component-count 3)))
333 |            (error "Invalid frame header segment length" sof len))
334 |          (unless (> component-count 0)
335 |            (error "No components in frame"))
336 |          (when (zero? x)
337 |            (error "Invalid zero-width image"))
338 |          (when (zero? y)
339 |            (error "DNL not supported"))
340 |          (let* ((components
341 |                  (for/vector ((n (in-range component-count)))
342 |                    (let* ((id (read-u8 port))
343 |                           (samp (read-u8 port))
344 |                           (samp-x (arithmetic-shift samp -4))
345 |                           (samp-y (bitwise-and samp #xf))
346 |                           (table (read-u8 port)))
347 |                      ;; Although 3 is technically permitted, it's
348 |                      ;; pretty bogus.
349 |                      (unless (memv samp-x '(1 2 4))
350 |                        (error "Bad horizontal sampling value" samp-x))
351 |                      (unless (memv samp-x '(1 2 4))
352 |                        (error "Bad vertical sampling value" samp-y))
353 |                      (unless (< table 4)
354 |                        (error "Bad quantization table value" table))
355 |                      (component id n samp-x samp-y table))))
356 |                 (samp-x (for/fold ((samp-x 1)) ((c components))
357 |                           (max samp-x (component-samp-y c))))
358 |                 (samp-y (for/fold ((samp-y 1)) ((c components))
359 |                           (max samp-y (component-samp-y c)))))
360 |            (frame sof precision y x components samp-x samp-y)))))
361 |     (else (error "Invalid start-of-frame marker" sof))))
362 | 
363 | (define (allocate-dct-matrix frame)
364 |   (build-array
365 |    (vector (frame-mcu-height frame) (frame-mcu-width frame))
366 |    (match-lambda
367 |      ((vector i j)
368 |       (for/vector ((component (frame-components frame)))
369 |         (build-array
370 |          (vector (component-samp-y component) (component-samp-x component))
371 |          (match-lambda
372 |            ((vector i j)
373 |             (make-vector (* 8 8) 0)))))))))
374 | 
375 | ;; return current dc
376 | (define (read-block bit-port block prev-dc-q q-table dc-table ac-table)
377 |   (define (record! index quantized-coefficient)
378 |     (let* ((index (bytes-ref normal-order index))
379 |            (q (vector-ref q-table index)))
380 |       (vector-set! block index (* quantized-coefficient q))))
381 |   ;; First, read DC coefficient.
382 |   (let* ((dc-diff-bits (read-huffman-coded-value bit-port dc-table))
383 |          (dc-qdiff (read-signed-bits bit-port dc-diff-bits))
384 |          (dc-q (+ prev-dc-q dc-qdiff)))
385 |     (record! 0 dc-q)
386 |     ;; Now read AC coefficients.
387 |     (let lp ((k 1))
388 |       (let* ((code (read-huffman-coded-value bit-port ac-table)))
389 |         (let ((r (arithmetic-shift code -4))
390 |               (s (bitwise-and code #xf)))
391 |           (cond
392 |            ((zero? s)
393 |             ;; #xf0 indicates 16 zeroes.  Otherwise stop.
394 |             (when (eqv? r #xf)
395 |               (lp (+ k 16))))
396 |            (else
397 |             (let* ((bits (read-signed-bits bit-port s))
398 |                    (k (+ k r)))
399 |               (record! k bits)
400 |               ;; Loop if there are more coefficients.
401 |               (when (< k 63)
402 |                 (lp (add1 k)))))))))
403 |     ;; Return DC coefficient.
404 |     dc-q))
405 | 
406 | (define (read-mcu bit-port scan-components mcu)
407 |   (for ((scan-component scan-components))
408 |     (match scan-component
409 |       ((vector component prev-dc q-table dc-table ac-table)
410 |        (vector-set! scan-component 1
411 |                     (for/fold ((dc prev-dc))
412 |                         ((block (in-array (vector-ref mcu (component-index component)))))
413 |                       (read-block bit-port block
414 |                                   dc q-table dc-table ac-table)))))))
415 | 
416 | (define (read-dct-scan bit-port scan-components dest Ss Se Ah Al)
417 |   (unless (and (= Ss 0) (= Se 63) (= Ah 0) (= Al 0))
418 |     (error "progressive frame reading not yet supported"))
419 |   (for ((mcu (in-array dest)))
420 |     (read-mcu bit-port scan-components mcu)))
421 | 
422 | (define (read-scan port frame params dest)
423 |   (define (find-component id)
424 |     (or (for/or ((component (frame-components frame)))
425 |           (and (= (component-id component) id)
426 |                component))
427 |         (error "No component found with id" id)))
428 |   (unless (frame-dct? frame) (error "DCT frame expected" frame))
429 |   (unless (frame-huffman-coded? frame) (error "Huffman coding expected" frame))
430 |   (let ((len (read-u16 port)))
431 |     (unless (>= len 6)
432 |       (error "Unexpected scan segment length" len))
433 |     (let ((scan-component-count (read-u8 port)))
434 |       (unless (= len (+ 6 (* scan-component-count 2)))
435 |         (error "Unexpected scan segment length" len))
436 |       (let ((scan-components (make-vector scan-component-count)))
437 |         (for/fold ((next-component-index 0))
438 |             ((i (in-range scan-component-count)))
439 |           (let* ((id (read-u8 port))
440 |                  (T (read-u8 port))
441 |                  (Td (arithmetic-shift T -4))
442 |                  (Ta (bitwise-and T #xf))
443 |                  (component (find-component id)))
444 |             (unless (< Td 4) (error "Bad Td" Td))
445 |             (unless (< Ta 4) (error "Bad Ta" Ta))
446 |             (unless (<= (component-index component) next-component-index)
447 |               (error "Bad component ordering in scan" component))
448 |             (vector-set! scan-components i
449 |                          (vector
450 |                           component
451 |                           0 ;; Previous DC coefficient.
452 |                           (let ((q (component-q-table component)))
453 |                             (or (vector-ref (params-q-tables params) q)
454 |                                 (error "Missing Q table" q)))
455 |                           (or (vector-ref (params-dc-tables params) Td)
456 |                               (error "Missing DC table" Td))
457 |                           (or (vector-ref (params-ac-tables params) Ta)
458 |                               (error "Missing AC table" Ta))))
459 |             (add1 (component-index component))))
460 |         (let* ((Ss (read-u8 port))
461 |                (Se (read-u8 port))
462 |                (A (read-u8 port))
463 |                (Ah (arithmetic-shift A -4))
464 |                (Al (bitwise-and A #xf))
465 |                (bit-port (make-bit-port port)))
466 |           (cond
467 |            ((frame-sequential? frame)
468 |             (unless (zero? Ss) (error "Bad Ss for sequential frame" Ss))
469 |             (unless (= Se 63) (error "Bad Se for sequential frame" Se))
470 |             (unless (zero? Ah) (error "Bad Ah for sequential frame" Ah))
471 |             (unless (zero? Al) (error "Bad Al for sequential frame" Al))
472 |             (read-dct-scan bit-port scan-components dest 0 63 0 0))
473 |            ((frame-progressive? frame)
474 |             (unless (<= Ss Se 63) (error "Bad Ss / Se" Ss Se))
475 |             (unless (< Ah 14) (error "Bad Ah" Ah))
476 |             (unless (< Al 14) (error "Bad Ah" Al))
477 |             (read-dct-scan bit-port scan-components dest Ss Se Ah Al))
478 |            (else (error "Unsupported frame type" frame))))))))
479 | 
480 | (define (read-jfif port #:with-body? (with-body? #t)
481 |                    #:with-misc-sections? (with-misc-sections? #t))
482 |   (cond
483 |    ((string? port)
484 |     (call-with-input-file port
485 |       (lambda (port)
486 |         (read-jfif port
487 |                    #:with-body? with-body?
488 |                    #:with-misc-sections? with-misc-sections?))))
489 |    ((bytes? port)
490 |     (read-jfif (open-input-bytes port)
491 |                #:with-body? with-body?
492 |                #:with-misc-sections? with-misc-sections?))
493 |    (else
494 |     (read-soi port)
495 |     (call-with-values (lambda ()
496 |                         (read-params port *initial-params* with-misc-sections?))
497 |       (lambda (image-params sof)
498 |         (let* ((frame (read-frame-header port sof))
499 |                (dest (allocate-dct-matrix frame)))
500 |           (let lp ((params image-params) (misc (params-misc-segments image-params)))
501 |             (call-with-values (lambda ()
502 |                                 (read-params port params with-misc-sections?))
503 |               (lambda (scan-params marker)
504 |                 (case marker
505 |                   ((#xffd9)             ; EOI
506 |                    (jfif frame misc dest))
507 |                   ((#xffda)             ; SOS
508 |                    (cond
509 |                     (with-body?
510 |                      (read-scan port frame scan-params dest)
511 |                      (lp scan-params (append misc (params-misc-segments scan-params))))
512 |                     (else
513 |                      (jfif frame misc dest))))
514 |                   (else
515 |                    (error "Unexpected marker" marker))))))))))))
516 | 
517 | (define (q-tables-for-mcu-array mcu-array #:max-value (max-value 255))
518 |   (define (gcd* coeff q) (gcd (abs coeff) q))
519 |   (define (meet-tables coeffs q)
520 |     (if q
521 |         (vector-map gcd* coeffs q)
522 |         (vector-map abs coeffs)))
523 |   (define (meet-mcu-blocks sequence q)
524 |     (for/fold ((q q)) ((coeffs sequence))
525 |       (meet-tables coeffs q)))
526 |   (call-with-values
527 |       (lambda ()
528 |         (for/fold ((luma-q #f) (chroma-q #f)) ((mcu (in-array mcu-array)))
529 |           (match mcu
530 |             ((vector y)
531 |              (values (meet-mcu-blocks (in-array y) luma-q)
532 |                      chroma-q))
533 |             ((vector y u v)
534 |              (values (meet-mcu-blocks (in-array y) luma-q)
535 |                      (meet-mcu-blocks (sequence-append (in-array u)
536 |                                                        (in-array v))
537 |                                       chroma-q))))))
538 |     (lambda (luma-q chroma-q)
539 |       (define (fixup q)
540 |         (cond
541 |          ((zero? q) 255)
542 |          ((<= q max-value) q)
543 |          ((zero? (remainder q 2)) (fixup (/ q 2)))
544 |          (else (error "q out of range" q))))
545 |       (vector (vector-map fixup luma-q) (vector-map fixup chroma-q)
546 |               #f #f))))
547 | 
548 | (define (compute-block-codes block q-table prev-dc)
549 |   (let ((zzq (for/vector ((i (in-range 64)))
550 |                (let ((i (bytes-ref normal-order i)))
551 |                  (/ (vector-ref block i) (vector-ref q-table i))))))
552 |     (define (bit-count x)
553 |       (cond
554 |        ((negative? x) (let lp ((n 1)) (if (< (arithmetic-shift -1 n) x) n (lp (add1 n)))))
555 |        ((zero? x) 0)
556 |        (else  (let lp ((n 1)) (if (< x (arithmetic-shift 1 n)) n (lp (add1 n)))))))
557 |     (define (code-and-bits code bits) (bitwise-ior code (arithmetic-shift bits 8)))
558 |     (define (encode-dc dc) (code-and-bits (bit-count dc) dc))
559 |     (define (encode-ac ac zero-count)
560 |       (code-and-bits (bitwise-ior (arithmetic-shift zero-count 4) (bit-count ac)) ac))
561 |     (define (skip-zeroes i zero-count codes)
562 |       (let ((ac (vector-ref zzq i)))
563 |         (if (zero? ac)
564 |             (if (= i 63)
565 |                 (cons 0 codes) ;; EOB.
566 |                 (skip-zeroes (add1 i) (add1 zero-count) codes))
567 |             (let lp ((zero-count zero-count) (codes codes))
568 |               (if (< zero-count 16)
569 |                   (encode-next (add1 i)
570 |                                (cons (encode-ac ac zero-count) codes))
571 |                   (lp (- zero-count 16) (cons #xf0 codes))))))) ; ZRL.
572 |     (define (encode-next i codes)
573 |       (if (= i 64)
574 |           codes
575 |           (skip-zeroes i 0 codes)))
576 |     (let ((dc (vector-ref zzq 0)))
577 |       (values dc
578 |               (cons (encode-dc (- dc prev-dc))
579 |                     (reverse (encode-next 1 '())))))))
580 | 
581 | (define (compute-code-sequences jpeg)
582 |   (define (compute-scan-components frame q-tables)
583 |     (vector-map
584 |      (lambda (component)
585 |        (let ((q-table (vector-ref q-tables (component-q-table component))))
586 |          ;; We don't know the dc and ac huffman tables yet.
587 |          (vector component 0 q-table #f #f)))
588 |      (frame-components frame)))
589 |   (match jpeg
590 |     ((jfif frame misc mcu-array)
591 |      (let* ((q-tables (q-tables-for-mcu-array mcu-array))
592 |             (scan-components (compute-scan-components frame q-tables)))
593 |        (values
594 |         q-tables
595 |         (for/array #:shape (array-shape mcu-array)
596 |                    ((mcu (in-array mcu-array)))
597 |           (vector-map
598 |            (lambda (blocks scan-component)
599 |              (match scan-component
600 |                ((vector component prev-dc q-table dc-table ac-table)
601 |                 (call-with-values
602 |                     (lambda ()
603 |                       (for/fold ((dc prev-dc) (out '()))
604 |                           ((block (in-array blocks)))
605 |                         (call-with-values
606 |                             (lambda ()
607 |                               (compute-block-codes block q-table dc))
608 |                           (lambda (dc codes)
609 |                             (values dc (cons codes out))))))
610 |                   (lambda (dc out)
611 |                     ;; good up to here.
612 |                     (vector-set! scan-component 1 dc)
613 |                     (reverse out))))))
614 |            mcu
615 |            scan-components)))))))
616 | 
617 | (define (compute-code-frequencies codes)
618 |   (let ((dc-freqs (vector (make-vector 256 0) (make-vector 256 0) #f #f))
619 |         (ac-freqs (vector (make-vector 256 0) (make-vector 256 0) #f #f)))
620 |     (define (count! table code)
621 |       (let ((idx (bitwise-and code #xff)))
622 |         (vector-set! table idx (add1 (vector-ref table idx)))))
623 |     (define (accumulate-frequencies codes idx)
624 |       (let ((dc-freqs (vector-ref dc-freqs idx))
625 |             (ac-freqs (vector-ref ac-freqs idx)))
626 |         (match codes
627 |           ((cons dc ac)
628 |            (count! dc-freqs dc)
629 |            (for-each (lambda (ac) (count! ac-freqs ac)) ac)))))
630 |     (for ((mcu (in-array codes)))
631 |       (for ((k (in-naturals))
632 |             (blocks (in-vector mcu)))
633 |         (for ((codes (in-list blocks)))
634 |           (let ((idx (if (zero? k) 0 1)))
635 |             (accumulate-frequencies codes idx)))))
636 |     (vector dc-freqs ac-freqs)))
637 | 
638 | (define (compute-huffman-code-tables dc-and-ac-freqs)
639 |   (vector-map
640 |    (lambda (freqs-v)
641 |      (vector-map
642 |       (lambda (freqs)
643 |         (and freqs (compute-huffman-table-for-freqs freqs)))
644 |       freqs-v))
645 |    dc-and-ac-freqs))
646 | 
647 | (define (write-short u16 port)
648 |   (write-byte (arithmetic-shift u16 -8) port)
649 |   (write-byte (bitwise-and u16 #xff) port))
650 | 
651 | (define (write-soi port)
652 |   (write-short #xffd8 port)) ; SOI.
653 | 
654 | (define (write-misc-segment port misc)
655 |   (write-short (misc-marker misc) port)
656 |   (write-short (+ 2 (bytes-length (misc-bytes misc))) port)
657 |   (write-bytes (misc-bytes misc) port))
658 | 
659 | (define (write-baseline-frame port frame)
660 |   (write-short #xffc0 port) ; SOF0.
661 |   (let ((len (+ 8 (* (frame-component-count frame) 3))))
662 |     (write-short len port))
663 |   (write-byte (frame-precision frame) port)
664 |   (write-short (frame-y frame) port)
665 |   (write-short (frame-x frame) port)
666 |   (write-byte (frame-component-count frame) port)
667 |   (for ((component (in-vector (frame-components frame))))
668 |     (write-byte (component-id component) port)
669 |     (write-byte (bitwise-ior (arithmetic-shift (component-samp-x component) 4)
670 |                              (component-samp-y component)) port)
671 |     (write-byte (component-q-table component) port)))
672 | 
673 | (define (write-q-tables port q-tables)
674 |   (for ((i (in-naturals))
675 |         (table (in-vector q-tables)))
676 |     (when table
677 |       (write-short #xffdb port) ; DQT.
678 |       (let ((len (+ 3 64)))
679 |         (write-short len port))
680 |       (let ((P 0)
681 |             (T i))
682 |         (write-byte (bitwise-ior (arithmetic-shift P 4) T) port))
683 |       (let lp ((i 0))
684 |         (when (< i 64)
685 |           (let ((i (bytes-ref normal-order i)))
686 |             (write-byte (vector-ref table i) port))
687 |           (lp (add1 i)))))))
688 | 
689 | (define (write-huffman-tables port huffman-tables)
690 |   (define (write-table k table Tc)
691 |     (match table
692 |       (#f #f)
693 |       ((vector size-counts size-offsets
694 |          values value-indexes sizes codes max-codes)
695 |        (write-short #xffc4 port)            ; DHT.
696 |        (let ((len (+ 19 (bytes-length values))))
697 |          (write-short len port))
698 |        (write-byte (bitwise-ior (arithmetic-shift Tc 4) k) port)
699 |        (write-bytes size-counts port)
700 |        (write-bytes values port))))
701 |   (match huffman-tables
702 |     ((vector dc-tables ac-tables)
703 |      (for ((k (in-naturals)) (table (in-vector dc-tables)))
704 |        (write-table k table 0))
705 |      (for ((k (in-naturals)) (table (in-vector ac-tables)))
706 |        (write-table k table 1)))))
707 | 
708 | (define (write-baseline-scan-header port frame)
709 |   (write-short #xffda port) ; SOS.
710 |   (let ((len (+ 6 (* (frame-component-count frame) 2))))
711 |     (write-short len port))
712 |   (write-byte (frame-component-count frame) port)
713 |   (for ((k (in-naturals)) (component (in-vector (frame-components frame))))
714 |     (let ((Td (if (zero? k) 0 1))
715 |           (Ta (if (zero? k) 0 1)))
716 |       (write-byte (component-id component) port)
717 |       (write-byte (bitwise-ior (arithmetic-shift Td 4) Ta) port)))
718 |   (let ((Ss 0)
719 |         (Se 63)
720 |         (Ah 0)
721 |         (Al 0))
722 |     (write-byte Ss port)
723 |     (write-byte Se port)
724 |     (write-byte (bitwise-ior (arithmetic-shift Ah 4) Al) port)))
725 | 
726 | (define (write-baseline-entropy-coded-data port codes huffman-tables)
727 |   (let ((port (make-bit-port port)))
728 |     (match huffman-tables
729 |       ((vector dc-tables ac-tables)
730 |        (define (write-code code table)
731 |          (match table
732 |            ((vector size-counts size-offsets
733 |                     values value-indexes sizes codes max-codes)
734 |             (let* ((u8 (bitwise-and code #xff))
735 |                    (diff (arithmetic-shift code -8))
736 |                    (ssss (bitwise-and code #xf))
737 |                    (code-index (vector-ref value-indexes u8))
738 |                    (code (vector-ref codes code-index))
739 |                    (size (bytes-ref sizes code-index)))
740 |               (write-bits port code size)
741 |               (unless (zero? ssss)
742 |                 (write-bits port diff ssss))))))
743 |        (define (write-codes codes idx)
744 |          (let ((dc-table (vector-ref dc-tables idx))
745 |                (ac-table (vector-ref ac-tables idx)))
746 |            (match codes
747 |              ((cons dc ac)
748 |               (write-code dc dc-table)
749 |               (for-each (lambda (ac) (write-code ac ac-table)) ac)))))
750 |        (for ((mcu (in-array codes)))
751 |          (for ((k (in-naturals)) (blocks (in-vector mcu)))
752 |            (for ((codes (in-list blocks)))
753 |              (let ((idx (if (zero? k) 0 1)))
754 |                (write-codes codes idx)))))
755 |        (flush-bits port)))))
756 | 
757 | (define (write-eoi port)
758 |   (write-short #xffd9 port)) ; EOI.
759 | 
760 | (define (write-jfif port jpeg)
761 |   (cond
762 |    ((string? port)
763 |     (call-with-output-file port
764 |       (lambda (port) (write-jfif port jpeg))))
765 |    (else
766 |     (match jpeg
767 |       ((jfif frame misc mcu-array)
768 |        (call-with-values (lambda () (compute-code-sequences jpeg))
769 |          (lambda (q-tables codes)
770 |            (let* ((frequencies (compute-code-frequencies codes))
771 |                   (huffman-tables (compute-huffman-code-tables frequencies)))
772 |              (write-soi port)
773 |              (for-each (lambda (misc) (write-misc-segment port misc)) misc)
774 |              (write-baseline-frame port frame)
775 |              (write-q-tables port q-tables)
776 |              (write-huffman-tables port huffman-tables)
777 |              (write-baseline-scan-header port frame)
778 |              (write-baseline-entropy-coded-data port codes huffman-tables)
779 |              (write-eoi port)))))))))
780 | 
781 | (module+ test
782 |   (require rackunit)
783 |   (define test-file-name "./test.jpg")
784 |   (define expected-width 500)
785 |   (define expected-height 375)
786 |   (define test-jfif (read-jfif test-file-name #:with-body? #f))
787 |   (check-eqv? (frame-x (jfif-frame test-jfif)) expected-width)
788 |   (check-eqv? (frame-y (jfif-frame test-jfif)) expected-height))
789 | 


--------------------------------------------------------------------------------