forked from slyrus/opticl
-
Notifications
You must be signed in to change notification settings - Fork 0
/
png.lisp
148 lines (142 loc) · 5.16 KB
/
png.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
;;; Copyright (c) 2011 Cyrus Harmon, All rights reserved.
;;; See COPYRIGHT file for details.
(in-package :opticl)
(defun read-png-stream (stream)
(let* ((png (png-read:read-png-datastream stream))
(colour-type (png-read:colour-type png))
(bit-depth (png-read:bit-depth png))
(width (png-read:width png))
(height (png-read:height png))
(image-data (png-read:image-data png))
(transparency (png-read::transparency png)))
;; Temporary provision for buggy png-read where an internal
;; representation of transparency chunk were not turned into a
;; proper transparency map during postprocessing (see
;; <https://github.com/Ramarren/png-read/pull/3>.)
(unless (typep transparency '(array * 2))
(setf transparency nil))
(flet ((get-pixel-grey (i j)
(aref image-data j i))
(get-pixel-grey-alpha (i j)
(let ((brightness (aref image-data j i 0)))
(values brightness
brightness
brightness
(aref image-data j i 1))))
(get-pixel-grey-tmap (i j)
(let ((brightness (aref image-data j i)))
(values brightness
brightness
brightness
(aref transparency j i))))
(get-pixel-rgba (i j)
(values (aref image-data j i 0)
(aref image-data j i 1)
(aref image-data j i 2)
(aref image-data j i 3)))
(get-pixel-rgb-tmap (i j)
(values (aref image-data j i 0)
(aref image-data j i 1)
(aref image-data j i 2)
(aref transparency j i)))
(get-pixel-rgb (i j)
(values (aref image-data j i 0)
(aref image-data j i 1)
(aref image-data j i 2))))
(multiple-value-bind (constructor get-pixel-fn)
(case bit-depth
(8 (case transparency
((nil)
(case colour-type
((:truecolor :indexed-colour)
(values #'make-8-bit-rgb-image
#'get-pixel-rgb))
(:truecolor-alpha
(values #'make-8-bit-rgba-image
#'get-pixel-rgba))
(:greyscale-alpha
(values #'make-8-bit-rgba-image
#'get-pixel-grey-alpha))
(:greyscale
(values #'make-8-bit-gray-image
#'get-pixel-grey))))
(t
(values #'make-8-bit-rgba-image
(case colour-type
((:truecolor :indexed-colour)
#'get-pixel-rgb-tmap)
(:greyscale
#'get-pixel-grey-tmap)))))))
(unless get-pixel-fn
(error "unable to read PNG image -- fix read-png-stream!"))
(let ((img (funcall constructor height width)))
(dotimes (i height img)
(dotimes (j width)
(setf (pixel img i j)
(funcall get-pixel-fn i j)))))))))
(defun read-png-file (pathname)
(with-open-file (stream pathname :direction :input :element-type '(unsigned-byte 8))
(read-png-stream stream)))
(defun write-png-stream (stream image)
(typecase image
(8-bit-rgb-image
(with-image-bounds (ymax xmax)
image
(let ((displaced
(make-array (* ymax xmax 3)
:element-type '(unsigned-byte 8)
:initial-contents
(make-array (* ymax xmax 3)
:element-type '(unsigned-byte 8)
:displaced-to image))))
(zpng:write-png-stream
(make-instance 'zpng:png
:color-type :truecolor
:height ymax
:width xmax
:bpp 8
:image-data displaced)
stream))))
(8-bit-rgba-image
(with-image-bounds (ymax xmax)
image
(let ((displaced
(make-array (* ymax xmax 4)
:element-type '(unsigned-byte 8)
:initial-contents
(make-array (* ymax xmax 4)
:element-type '(unsigned-byte 8)
:displaced-to image))))
(zpng:write-png-stream
(make-instance 'zpng:png
:color-type :truecolor-alpha
:height ymax
:width xmax
:bpp 8
:image-data displaced)
stream))))
(8-bit-gray-image
(with-image-bounds (ymax xmax)
image
(let ((displaced
(make-array (* ymax xmax)
:element-type '(unsigned-byte 8)
:initial-contents
(make-array (* ymax xmax)
:element-type '(unsigned-byte 8)
:displaced-to image))))
(zpng:write-png-stream
(make-instance 'zpng:png
:color-type :grayscale
:height ymax
:width xmax
:bpp 8
:image-data displaced)
stream))))
(t (error "No PNG writing support for this image type."))))
(defun write-png-file (pathname image)
(with-open-file (stream pathname :direction :output
:if-exists :supersede
:element-type '(unsigned-byte 8))
(write-png-stream stream image)
(truename pathname)))