-
Notifications
You must be signed in to change notification settings - Fork 35
/
jpeg.lisp
150 lines (139 loc) · 6.22 KB
/
jpeg.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
;;; Copyright (c) 2011 Cyrus Harmon, All rights reserved.
;;; See COPYRIGHT file for details.
(in-package :opticl)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +ncomp-gray+ 1)
(defconstant +ncomp-rgb+ 3)
(defconstant +ncomp-cmyk+ 4))
(defparameter *rgb-sampling* '((1 1)(1 1)(1 1)))
(defparameter *rgb-q-tabs* (vector jpeg::+q-luminance-hi+
jpeg::+q-chrominance-hi+))
(defparameter *gray-q-tabs* (vector jpeg::+q-luminance+))
;;;
;;; Reading JPEG files
(defun read-jpeg-stream (stream &key (colorspace-conversion t))
(multiple-value-bind (buffer height width ncomp)
(jpeg:decode-stream stream :colorspace-conversion colorspace-conversion)
(flet ((read-rgb-buffer (buffer)
(let ((image (make-8-bit-rgb-image height width)))
(declare (type 8-bit-rgb-image image))
(loop for i below height
do
(loop for j below width
do
(let ((pixoff (* +ncomp-rgb+ (+ (* i width) j))))
(setf (pixel image i j)
(values (aref buffer (+ 2 pixoff))
(aref buffer (+ 1 pixoff))
(aref buffer pixoff))))))
image)))
(ecase ncomp
(#.+ncomp-rgb+
(read-rgb-buffer buffer))
(#.+ncomp-cmyk+
(read-rgb-buffer (jpeg:convert-cmyk-to-rgb buffer height width)))
(#.+ncomp-gray+
(let ((image (make-8-bit-gray-image height width))
(pixoff 0))
(declare (type 8-bit-gray-image image))
(loop for i below height
do
(loop for j below width
do
(setf (pixel image i j)
(aref buffer pixoff))
(incf pixoff)))
image))))))
(defun read-jpeg-file (pathname &key (colorspace-conversion t))
(with-open-file (stream pathname :direction :input :element-type '(unsigned-byte 8))
(read-jpeg-stream stream :colorspace-conversion colorspace-conversion)))
(defun write-jpeg-stream (stream image)
(typecase image
(8-bit-gray-image
(locally
(declare (type 8-bit-gray-image image))
(destructuring-bind (height width)
(array-dimensions image)
(let ((jpeg-array (make-array (* height width) :element-type '(unsigned-byte 8)))
(pixoff 0))
(loop for i below height
do
(loop for j below width
do
(setf (aref jpeg-array pixoff)
(pixel image i j))
(incf pixoff)))
(jpeg::encode-image-stream stream jpeg-array +ncomp-gray+ height width
:q-tabs *gray-q-tabs*)))))
;; as with the RGBA images down below, just ignore the alpha channel for now
(8-bit-gray-alpha-image
(locally
(declare (type 8-bit-gray-alpha-image image))
(destructuring-bind (height width channels)
(array-dimensions image)
(declare (ignore channels))
(let ((jpeg-array (make-array (* height width) :element-type '(unsigned-byte 8)))
(pixoff 0))
(loop for i below height
do
(loop for j below width
do
(setf (aref jpeg-array pixoff)
(pixel image i j))
(incf pixoff)))
(jpeg::encode-image-stream stream jpeg-array +ncomp-gray+ height width
:q-tabs *gray-q-tabs*)))))
(8-bit-rgb-image
(locally
(declare (type 8-bit-rgb-image image))
(destructuring-bind (height width channels)
(array-dimensions image)
(declare (ignore channels))
(let ((jpeg-array (make-array (* height width +ncomp-rgb+) :element-type '(unsigned-byte 8))))
(loop for i below height
do
(loop for j below width
do
(let ((pixoff (* +ncomp-rgb+ (+ (* i width) j))))
(multiple-value-bind
(r g b)
(pixel image i j)
(setf (aref jpeg-array pixoff) b
(aref jpeg-array (incf pixoff)) g
(aref jpeg-array (incf pixoff)) r)))))
(jpeg::encode-image-stream stream jpeg-array +ncomp-rgb+ height width
:sampling *rgb-sampling*
:q-tabs *rgb-q-tabs*)))))
;; NB: The JPEG format doesn't, AAICT, have a well-specified way
;; of writing an RGBA image. So, for now at least, we'll punt and
;; write it as an RGB image.
(8-bit-rgba-image
(locally
(declare (type 8-bit-rgba-image image))
(destructuring-bind (height width channels)
(array-dimensions image)
(declare (ignore channels))
(let ((jpeg-array (make-array (* height width +ncomp-rgb+) :element-type '(unsigned-byte 8))))
(loop for i below height
do
(loop for j below width
do
(let ((pixoff (* +ncomp-rgb+ (+ (* i width) j))))
(multiple-value-bind
(r g b a)
(pixel image i j)
(declare (ignore a))
(setf (aref jpeg-array pixoff) b
(aref jpeg-array (incf pixoff)) g
(aref jpeg-array (incf pixoff)) r)))))
(jpeg::encode-image-stream stream jpeg-array +ncomp-rgb+ height width
:sampling *rgb-sampling*
:q-tabs *rgb-q-tabs*)))))
(t (error "Cannot write a JPEG image from ~A" (type-of image)))))
(defun write-jpeg-file (pathname image)
(with-open-file (stream pathname
:direction :output
:element-type '(unsigned-byte 8)
:if-exists :supersede)
(write-jpeg-stream stream image)
pathname))