1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*-
2 ;;; ---------------------------------------------------------------------------
3 ;;; Title: General image routines
4 ;;; Created: 1998-11-11
5 ;;; Author: Gilbert Baumann <gilbert@base-engineering.com>
6 ;;; License: MIT style (see below)
7 ;;; ---------------------------------------------------------------------------
8 ;;; (c) copyright 1998 by Gilbert Baumann
10 ;;; Permission is hereby granted, free of charge, to any person obtaining
11 ;;; a copy of this software and associated documentation files (the
12 ;;; "Software"), to deal in the Software without restriction, including
13 ;;; without limitation the rights to use, copy, modify, merge, publish,
14 ;;; distribute, sublicense, and/or sell copies of the Software, and to
15 ;;; permit persons to whom the Software is furnished to do so, subject to
16 ;;; the following conditions:
18 ;;; The above copyright notice and this permission notice shall be
19 ;;; included in all copies or substantial portions of the Software.
21 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
22 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
23 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
24 ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
25 ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
26 ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
27 ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
32 ;; ----------------------------------------------------------------------------
33 ;; 1999-08-18 GB - Spend a printer for AIMAGE
34 ;; - fixed URL->AIMAGE-REAL,
35 ;; - it now returns the condition
36 ;; - obeys to `deliver-broken-image-p'
39 (in-package :imagelib
)
41 ;;; AIMAGE has been moved into McCLIM under the name RGB-IMAGE, but
42 ;;; without a plist and with different slot accessors. Here's a wrapper
45 ((rgb-image :initarg
:rgb-image
:accessor aimage-rgb-image
)
46 (plist :initarg
:plist
:accessor aimage-plist
)))
48 (defun aimage-width (ai) (climi::image-width
(aimage-rgb-image ai
)))
49 (defun aimage-height (ai) (climi::image-height
(aimage-rgb-image ai
)))
50 (defun aimage-data (ai) (climi::image-data
(aimage-rgb-image ai
)))
51 (defun aimage-alpha-p (ai) (climi::image-alpha-p
(aimage-rgb-image ai
)))
53 (defun make-aimage/low
(&key width height data alphap plist
)
54 (make-instance 'aimage
55 :rgb-image
(make-instance 'climi
::rgb-image
62 (defmethod print-object ((self aimage
) sink
)
63 (format sink
"<~S ~D x ~D from ~S>" 'aimage
64 (aimage-width self
) (aimage-height self
)
65 (getf (aimage-plist self
) :url
)))
67 (defun make-aimage (width height
&key
(alpha-p nil
))
68 (make-aimage/low
:width width
70 :data
(make-array (list height width
)
71 :element-type
'(unsigned-byte 32))
74 (defun scale-aimage (source new-width new-height
)
75 (when (or (zerop new-width
) (zerop new-height
))
76 (warn "You can't scale an image to zero width or height"))
77 (setf new-height
(max 1 new-height
))
78 (setf new-width
(max 1 new-width
))
79 (cond ((and (= new-width
(aimage-width source
))
80 (= new-height
(aimage-height source
)))
83 (let ((res (make-aimage new-width new-height
84 :alpha-p
(aimage-alpha-p source
)))
85 (w (aimage-width source
))
86 (h (aimage-height source
)))
87 (dotimes (x new-width
)
88 (dotimes (y new-height
)
89 (let ((x2 (floor (* x w
) new-width
))
90 (y2 (floor (* y h
) new-height
)))
91 (setf (aref (aimage-data res
) y x
)
92 (aref (aimage-data source
) y2 x2
)))))
95 ;;;; --------------------------------------------------------------------------
97 (deftype octet
() '(unsigned-byte 8))
99 (defconstant c
/raute
#o43
)
101 (defconstant c
/lf
#o12
)
102 (defconstant c
/cr
#o15
)
104 (defconstant c
/0 #o60
)
105 (defconstant c
/9 #o71
)
107 (defconstant c
/P
#o120
)
109 (defun full-read-byte-sequence (sequence input
110 &key
(start 0) (end (length sequence
)))
111 (unless (<= end start
)
113 (n (g/read-byte-sequence sequence input
:start
0)
114 (g/read-byte-sequence sequence input
:start n
)))
118 (error "EOF during ~S." 'full-read-byte-sequence
))))))
120 ;; BUG in P4,5,6 nach maxval genau ein _white-space_
122 (defun read-pnm-file (input)
126 (setf lookahead
(g/read-byte input nil
:eof
)))
129 (or (eql lookahead
8)
137 (do () ((not (white-p)))
139 (when (eql lookahead c
/raute
)
141 ((eql lookahead c
/raute
)
144 (error "[~D] White space expected. -- got `~A'"
145 (file-position input
)
146 (code-char lookahead
)))) )
150 (do () ((or (eql lookahead c
/lf
)
151 (eql lookahead c
/cr
)))
157 (cond ((<= c
/0 lookahead c
/9)
158 (do () ((not (<= c
/0 lookahead c
/9)))
159 (setf r
(+ (* r
10) (- lookahead c
/0)))
163 (error "Integer expected.")) )))
166 (values (progn (wsp) (int))
170 (let ((maxval (int)))
171 (cond ((zerop maxval
)
172 (warn "Bogus maxval ~D, resetting to 255." maxval
)
177 (error "Sorry, P1 pnm format not understood."))
179 (error "Sorry, P4 pnm format not understood."))
182 (multiple-value-bind (width height maxval
) (dimensions)
184 (setf res
(make-array (list height width
)
185 :element-type
'(unsigned-byte 32)))
186 (setf dis
(make-array (* width height
)
188 :element-type
'(unsigned-byte 32)))
189 (dotimes (i (* width height
))
194 (setq v
(ldb (byte 8 0) (floor (* v
255) maxval
)))
195 (logior v
(ash v
8) (ash v
16))))))
199 (multiple-value-bind (width height maxval
) (dimensions)
201 (setf res
(make-array (list height width
)
202 :element-type
'(unsigned-byte 32)))
203 (setf dis
(make-array (* width height
)
205 :element-type
'(unsigned-byte 32)))
206 (dotimes (i (* width height
))
209 (let ((r (progn (wsp) (int)))
210 (g (progn (wsp) (int)))
211 (b (progn (wsp) (int))))
212 (setq r
(ldb (byte 8 0) (floor (* r
255) maxval
)))
213 (setq g
(ldb (byte 8 0) (floor (* g
255) maxval
)))
214 (setq b
(ldb (byte 8 0) (floor (* b
255) maxval
)))
215 (logior r
(ash g
8) (ash b
16))))))
219 (multiple-value-bind (width height maxval
) (dimensions)
221 (setf res
(make-array (list height width
)
222 :element-type
'(unsigned-byte 32)))
223 (setf dis
(make-array (* width height
)
225 :element-type
'(unsigned-byte 32)))
226 (unless (or (eql lookahead c
/cr
)
227 (eql lookahead c
/lf
))
228 (error "Expected exactly one Linefeed."))
229 (let ((buffer (make-array 4096 :element-type
'octet
))
234 (cond ((= i m
) (return)))
235 (setf n
(g/read-byte-sequence buffer input
236 :end
(min (length buffer
)
239 (error "Unexpected EOF.")))
240 (cond ((= maxval
255)
243 (let ((v (aref buffer j
)))
244 (logior v
(ash v
8) (ash v
16))))
249 (let ((v (aref buffer j
)))
250 (setq v
(ldb (byte 8 0) (floor (* v
255) maxval
)))
251 (logior v
(ash v
8) (ash v
16))))
256 (multiple-value-bind (width height maxval
) (dimensions)
258 (setf res
(make-array (list height width
)
259 :element-type
'(unsigned-byte 32)))
260 (setf dis
(make-array (* width height
)
262 :element-type
'(unsigned-byte 32)))
263 (unless (or (eql lookahead c
/cr
)
264 (eql lookahead c
/lf
))
265 (error "Expected exactly one Linefeed."))
266 (let ((buffer (make-array (* 3 1024) :element-type
'octet
))
271 (cond ((= i m
) (return)))
272 (setq n
(min (/ (length buffer
) 3) (- m i
)))
273 (full-read-byte-sequence buffer input
:end
(* 3 n
))
276 (let ((r (aref buffer
(* j
3)))
277 (g (aref buffer
(+ 1 (* j
3))))
278 (b (aref buffer
(+ 2 (* j
3)))))
279 (setq r
(ldb (byte 8 0) (floor (* r
255) maxval
)))
280 (setq g
(ldb (byte 8 0) (floor (* g
255) maxval
)))
281 (setq b
(ldb (byte 8 0) (floor (* b
255) maxval
)))
282 (logior r
(ash g
8) (ash b
16))))
287 (unless (eql (consume) c
/P
)
288 (error "pnm magic number expected."))
290 (cond ((eql lookahead
(+ c
/0 1)) (consume) (p1))
291 ((eql lookahead
(+ c
/0 2)) (consume) (p2))
292 ((eql lookahead
(+ c
/0 3)) (consume) (p3))
293 ((eql lookahead
(+ c
/0 4)) (consume) (p4))
294 ((eql lookahead
(+ c
/0 5)) (consume) (p5))
295 ((eql lookahead
(+ c
/0 6)) (consume) (p6))
298 (error "pnm magic number expected. -- '~A'"
299 (code-char c
/0)))) ) )
302 (defun pnm-stream->aimage
(input)
303 (let ((arr (read-pnm-file input
)))
304 (make-aimage/low
:width
(array-dimension arr
1)
305 :height
(array-dimension arr
0)
310 (defun any->aimage-by-filter
(filter-name input
)
311 (with-temporary-file (temp-filename)
312 (with-temporary-file (pnm-filename)
313 (with-open-file (sink temp-filename
315 :if-exists
:overwrite
316 :element-type
'(unsigned-byte 8))
317 (let ((sink (make-instance 'glisp
:cl-byte-stream
:cl-stream sink
)))
318 (let ((tmp (make-array 4096 :element-type
'(unsigned-byte 8))))
319 (do ((n (g/read-byte-sequence tmp input
)
320 (g/read-byte-sequence tmp input
)))
322 (g/write-byte-sequence tmp sink
:end n
)))))
323 (let ((cmd (format nil
"~A <~A >~A" filter-name
324 (namestring (truename temp-filename
))
325 (namestring pnm-filename
))))
326 (format *debug-io
* "~%;; running: ~A" cmd
)
327 (run-unix-shell-command cmd
))
328 (progn ;ignore-errors
329 (with-open-file (input pnm-filename
331 :element-type
'(unsigned-byte 8))
333 (make-instance 'cl-byte-stream
:cl-stream input
)))) )))
338 (defun write-ppm-image (aimage sink
)
339 ;; We write P3/P6 images
340 (let ((binary-p (subtypep (stream-element-type sink
) '(unsigned-byte 8))))
342 (with-output-to-string (bag)
343 (format bag
"~A~%" (if binary-p
"P6" "P3"))
344 (format bag
"~D ~D ~D" (aimage-width aimage
) (aimage-height aimage
) 255))))
346 (write-sequence (map '(array (unsigned-byte 8) (*)) #'char-code header
) sink
)
347 (write-string header sink
))
350 (let ((buffer (make-array (* 3 (aimage-width aimage
)) :element-type
'(unsigned-byte 8)))
351 (width (aimage-width aimage
))
352 (data (aimage-data aimage
))
354 (declare (type (simple-array (unsigned-byte 8) (*)) buffer
)
355 (type (array (unsigned-byte 32) (* *)) data
)
358 (dotimes (y (aimage-height aimage
))
360 (do ((x 0 (the fixnum
(+ x
1))))
362 (declare (type fixnum x
))
363 (let ((byte (aref data y x
)))
364 (declare (type (unsigned-byte 8) byte
))
365 (setf (aref buffer i
) (ldb (byte 8 0) byte
))
366 (setf i
(the fixnum
(+ i
1)))
367 (setf (aref buffer i
) (ldb (byte 8 8) byte
))
368 (setf i
(the fixnum
(+ i
1)))
369 (setf (aref buffer i
) (ldb (byte 8 16) byte
))
370 (setf i
(the fixnum
(+ i
1)))))
371 (write-sequence buffer sink
))))
373 (dotimes (y (aimage-height aimage
))
374 (dotimes (x (aimage-width aimage
))
375 (when (= (mod x
4) 0)
377 (let ((byte (aref (aimage-data aimage
) y x
)))
378 (format sink
" ~D ~D ~D"
379 (ldb (byte 8 0) byte
)
380 (ldb (byte 8 8) byte
)
381 (ldb (byte 8 16) byte
)) )))
385 (with-open-file (sink "/tmp/a.ppm"
387 :if-exists
:new-version
388 :element-type
'(unsigned-byte 8))
389 (write-ppm-image aimage sink
)))