blob: aaef3a58d72b0d0364143e4ab86309dba3835c6b (
plain) (
blame)
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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
;;; Bitmap
;;; This could be extended to a general drawing interface, but for now it's probably better to use Tk's canvas.
(import "compat")
(defconstant +black+ 0)
(defconstant +white+ #xFFFFFF)
(defconstant +red+ #xFF0000)
(defconstant +green+ #x00FF00)
(defconstant +blue+ #x0000FF)
(defun make-rgb-pixel (r g b)
(logior (ash (assure <integer> r) 16) (ash (assure <integer> g) 8) (assure <integer> b)))
(defun rgb-pixel-red (rgb)
(logand (ash (assure <integer> rgb) -16) #xFF))
(defun rgb-pixel-green (rgb)
(logand (ash (assure <integer> rgb) -8) #xFF))
(defun rgb-pixel-blue (rgb)
(logand (assure <integer> rgb) #xFF))
(defun make-rgb-pixel-buffer (width height &rest args)
(let ((initial-element (if (null args)
+black+
(car args))))
(create-array (list (assure <integer> width) (assure <integer> height))
(assure <integer> initial-element))))
(defun rgb-pixel-buffer-width (buffer)
(elt (array-dimensions buffer) 0))
(defun rgb-pixel-buffer-height (buffer)
(elt (array-dimensions buffer) 1))
(defmacro rgb-pixel (buffer x y)
`(aref (assure <general-array*> ,buffer) (assure <integer> ,x) (assure <integer> ,y)))
(defun fill-rgb-pixel-buffer (buffer pixel)
(assure <general-array*> buffer)
(let* ((dimensions (array-dimensions buffer))
(width (elt dimensions 0))
(height (elt dimensions 1)))
(for ((y 0 (+ y 1)))
((>= y height) buffer)
(for ((x 0 (+ x 1)))
((>= x width) nil)
(setf (rgb-pixel buffer x y) (assure <integer> pixel))))))
;;; Write a PPM file
(defun write-rgb-buffer-to-ppm-file (filename buffer)
(with-open-output-file (outstream filename 8)
(let* ((dimensions (array-dimensions buffer))
(width (elt dimensions 0))
(height (elt dimensions 1))
(header (create-string-output-stream)))
(format header "P6~A~D ~D~A255~A"
#\newline
width height #\newline
#\newline)
(let ((s (get-output-stream-string header)))
(for ((i 0 (+ i 1)))
((>= i (length s)) nil)
(write-byte (convert (elt s i) <integer>) outstream)))
(for ((x 0 (+ x 1)))
((>= x width) filename)
(for ((y 0 (+ y 1)))
((>= y height) nil)
(let* ((pixel (rgb-pixel buffer x y))
(red (rgb-pixel-red pixel))
(green (rgb-pixel-green pixel))
(blue (rgb-pixel-blue pixel)))
(write-byte red outstream)
(write-byte green outstream)
(write-byte blue outstream)))))))
;;; Read a PPM file
(defconstant +whitespace-chars+ '(#\SPACE \#carriage-return #\TAB #\NEWLINE))
(defun read-header-chars (stream &rest args)
(let ((delimiter-list (if (null args)
+whitespace-chars+
(car args))))
(do ((c (read-char stream nil :eof)
(read-char stream nil :eof))
(vals nil (if (or (null c) (char= c #\#)) vals (cons c vals)))) ;;don't collect comment chars
((or (eql c :eof) (member c delimiter-list)) (map 'string #'identity (nreverse vals))) ;;return strings
(when (char= c #\#) ;;skip comments
(read-line stream)))))
(defun read-ppm-file-header (file)
(with-open-file (s file :direction :input)
(do ((failure-count 0 (1+ failure-count))
(tokens nil (let ((t1 (read-header-chars s)))
(if (> (length t1) 0)
(cons t1 tokens)
tokens))))
((>= (length tokens) 4) (values (nreverse tokens)
(file-position s)))
(when (>= failure-count 10)
(error (format nil "File ~a does not seem to be a proper ppm file - maybe too many comment lines" file)))
(when (= (length tokens) 1)
(when (not (or (string= (first tokens) "P6") (string= (first tokens) "P3")))
(error (format nil "File ~a is not a ppm file - wrong magic-number. Read ~a instead of P6 or P3 " file (first tokens))))))))
(defun read-ppm-image (file)
(flet ((image-data-reader (stream start-position width height image-build-function read-function)
(file-position stream start-position)
(dotimes (row height)
(dotimes (col width)
(funcall image-build-function row col (funcall read-function stream))))))
(multiple-value-bind (header file-pos) (read-ppm-file-header file)
(let* ((image-type (first header))
(width (parse-integer (second header) :junk-allowed t))
(height (parse-integer (third header) :junk-allowed t))
(max-value (parse-integer (fourth header) :junk-allowed t))
(image (make-rgb-pixel-buffer width height)))
(when (> max-value 255)
(error "unsupported depth - convert to 1byte depth with pamdepth"))
(cond ((string= "P6" image-type)
(with-open-file (stream file :direction :input :element-type '(unsigned-byte 8))
(image-data-reader stream
file-pos
width
height
#'(lambda (w h val)
(setf (rgb-pixel image w h) val))
#'(lambda (stream)
(make-rgb-pixel (read-byte stream)
(read-byte stream)
(read-byte stream))))
image))
((string= "P3" image-type)
(with-open-file (stream file :direction :input)
(image-data-reader stream
file-pos
width
height
#'(lambda (w h val)
(setf (rgb-pixel image w h) val))
#'(lambda (stream)
(make-rgb-pixel (read stream)
(read stream)
(read stream))))
image))
(t 'unsupported))
image))))
;;; Grayscale image
(defun rgb-to-gray-image (rgb-image)
(flet ((rgb-to-gray (rgb-value)
(round (+ (* 0.2126 (rgb-pixel-red rgb-value))
(* 0.7152 (rgb-pixel-green rgb-value))
(* 0.0722 (rgb-pixel-blue rgb-value))))))
(let ((gray-image (make-array (array-dimensions rgb-image) :element-type '(unsigned-byte 8))))
(dotimes (i (array-total-size rgb-image))
(setf (row-major-aref gray-image i) (rgb-to-gray (row-major-aref rgb-image i))))
gray-image)))
|