/[eclipse]/eclipse/lib/image-reader.lisp
ViewVC logotype

Contents of /eclipse/lib/image-reader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (show annotations)
Tue Nov 17 09:30:28 2009 UTC (4 years, 4 months ago) by ihatchondo
Branch: MAIN
CVS Tags: HEAD
Changes since 1.14: +2 -4 lines
Fix: improper and useless slot unset.
1 ;;; -*- Mode: Lisp; Package: PPM -*-
2 ;;; $Id: image-reader.lisp,v 1.15 2009/11/17 09:30:28 ihatchondo Exp $
3 ;;;
4 ;;; This a ppm image reader for CLX
5 ;;; This file is part of Eclipse
6 ;;; Copyright (C) 2000, 2001 Iban HATCHONDO
7 ;;; Copyright (C) 2000 Frederic BRUNEL
8 ;;; contact : hatchond@yahoo.fr
9 ;;; brunel@mail.dotcom.fr
10 ;;;
11 ;;; This program is free software; you can redistribute it and/or
12 ;;; modify it under the terms of the GNU General Public License
13 ;;; as published by the Free Software Foundation.
14 ;;;
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23
24 (common-lisp:in-package :common-lisp-user)
25
26 (defpackage ppm
27 (:use common-lisp)
28 (:size 50)
29 (:export
30 #:initialize
31 #:image #:gray-scale-image #:colored-24-image #:p5 #:p6
32 #:image-width #:image-height #:image-pixels #:image-max-level #:image-pixel
33 #:make-image-from-stream #:make-p5-image #:make-p6-image
34 #:with-pnm-header
35 #:load-ppm #:load-ppm-into-clx-image #:image->clx-image
36 ))
37
38 (in-package :PPM)
39
40 (declaim (optimize (speed 3) (safety 1) (debug 0) (compilation-speed 0)))
41
42 ;;;; some internal types.
43
44 (deftype card-32 () `(unsigned-byte 32))
45 (deftype card-29 () `(unsigned-byte 29))
46 (deftype card-24 () `(unsigned-byte 24))
47 (deftype card-16 () `(unsigned-byte 16))
48 (deftype card-8 () `(unsigned-byte 8))
49 (deftype card-6 () `(unsigned-byte 6))
50 (deftype card-4 () `(unsigned-byte 4))
51
52 (deftype pixarray-1 () '(simple-array bit (* *)))
53 (deftype pixarray-4 () '(simple-array card-4 (* *)))
54 (deftype pixarray-8 () '(simple-array card-8 (* *)))
55 (deftype pixarray-16 () '(simple-array card-16 (* *)))
56 (deftype pixarray-24 () '(simple-array card-24 (* *)))
57 (deftype pixarray-32 () '(simple-array card-32 (* *)))
58 (deftype pixarray ()
59 '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
60
61 (deftype clx-array () 'pixarray)
62
63 (deftype color-table () '(simple-array fixnum (256)))
64
65 ;;;; x color utilities.
66
67 (defvar *gray-table* (make-array 256 :element-type 'fixnum))
68 (defvar *red-table* (make-array 256 :element-type 'fixnum))
69 (defvar *green-table* (make-array 256 :element-type 'fixnum))
70 (defvar *blue-table* (make-array 256 :element-type 'fixnum))
71
72 (declaim (type color-table *gray-table* *red-table* *green-table* *blue-table*))
73
74 (defun initialize-color-tables (colormap r-table g-table b-table)
75 (declare (type color-table r-table g-table b-table))
76 (loop for i of-type card-16 from 0 to 255
77 for r = (xlib:make-color :red (/ i 255) :green 0 :blue 0)
78 for g = (xlib:make-color :red 0 :green (/ i 255) :blue 0)
79 for b = (xlib:make-color :red 0 :green 0 :blue (/ i 255))
80 do (setf (aref r-table i) (xlib:alloc-color colormap r)
81 (aref g-table i) (xlib:alloc-color colormap g)
82 (aref b-table i) (xlib:alloc-color colormap b))))
83
84 (defun initialize-gray-table (colormap gray-table)
85 (declare (type color-table gray-table))
86 (loop with m of-type card-8 = 255
87 for i of-type card-16 from 0 to m
88 for rgb = (xlib:make-color :red (/ i m) :green (/ i m) :blue (/ i m))
89 do (setf (aref gray-table i) (xlib:alloc-color colormap rgb))))
90
91 ;; Public color utilities.
92
93 (defun initialize (colormap)
94 (initialize-gray-table colormap *gray-table*)
95 (initialize-color-tables colormap *red-table* *green-table* *blue-table*))
96
97 (defun get-gray (index)
98 (declare (type card-8 index))
99 (aref *gray-table* index))
100
101 (defun get-color (r-index g-index b-index)
102 (declare (type card-8 r-index g-index b-index))
103 (logior (the fixnum (aref *red-table* r-index))
104 (the fixnum (aref *green-table* g-index))
105 (the fixnum (aref *blue-table* b-index))))
106
107 ;;;; Images
108 ;; Protocol class
109
110 (defclass image ()
111 ((max-level :initarg :max-level :type card-8 :reader image-max-level)
112 (pixels :initarg :pixels :type pixarray :reader image-pixels)))
113
114 (defgeneric image-width (image))
115 (defgeneric image-height (image))
116 (defgeneric image-pixel (image x y))
117 (defgeneric image-pixels (image))
118 (defgeneric (setf image-pixel) (x y pixel image))
119 (defgeneric make-image-from-stream (type stream width height mlevel))
120
121 (defmethod image-width ((image image))
122 (cadr (array-dimensions (image-pixels image))))
123
124 (defmethod image-height ((image image))
125 (car (array-dimensions (image-pixels image))))
126
127 ;; Gray scale image
128
129 (eval-when (:compile-toplevel :load-toplevel :execute)
130 (defclass gray-scale-image (image)
131 ((pixels :type pixarray-8))))
132
133 (defmethod image-pixel ((image gray-scale-image) x y)
134 (aref (the pixarray-8 (image-pixels image)) y x))
135
136 (defmethod (setf image-pixel) (x y pixel (image gray-scale-image))
137 (setf (aref (the pixarray-8 (image-pixels image)) y x) pixel))
138
139 (defun gray->x-gray (pixel)
140 (declare (type card-8 pixel))
141 (get-gray pixel))
142
143 ;; Colored image
144
145 (eval-when (:compile-toplevel :load-toplevel :execute)
146 (defclass colored-24-image (image)
147 ((pixels :type pixarray-24))))
148
149 (defmethod image-pixel ((image colored-24-image) x y)
150 (aref (the pixarray-24 (image-pixels image)) y x))
151
152 (defmethod (setf image-pixel) (x y pixel (image colored-24-image))
153 (setf (aref (the pixarray-24 (image-pixels image)) y x) pixel))
154
155 (defmacro red-component (pixel)
156 `(the (unsigned-byte 8) (logand (ash ,pixel -16) 255)))
157
158 (defmacro green-component (pixel)
159 `(the (unsigned-byte 8) (logand (ash ,pixel -8) 255)))
160
161 (defmacro blue-component (pixel)
162 `(the (unsigned-byte 8) (logand ,pixel 255)))
163
164 (defun color->x-color (pix)
165 (declare (type card-24 pix))
166 (get-color (red-component pix) (green-component pix) (blue-component pix)))
167
168 ;; PNM supported formats
169
170 (defclass p5 (gray-scale-image) ())
171
172 (defun make-p5-image (pixels &optional (max-level 255))
173 (make-instance 'p5 :pixels pixels :max-level max-level))
174
175 (defmethod make-image-from-stream ((type (eql :P5)) stream width height mlevel)
176 (declare (type card-16 width height))
177 (declare (type card-8 mlevel))
178 (loop with size of-type card-32 = (* width height)
179 with pixels = (make-array (list height width) :element-type 'card-8)
180 with vec = (make-array size :element-type 'card-8 :displaced-to pixels)
181 with offset of-type card-32 = 0
182 while (< offset size)
183 do (setf offset (read-sequence vec stream :start offset))
184 finally (return (make-p5-image pixels mlevel))))
185
186 (defclass p6 (colored-24-image) ())
187
188 (defun make-p6-image (pixels &optional (max-level 255))
189 (make-instance 'p6 :pixels pixels :max-level max-level))
190
191 (defmethod make-image-from-stream ((type (eql :P6)) stream width height mlevel)
192 (declare (type card-16 width height))
193 (declare (type card-8 mlevel))
194 (loop with size of-type card-32 = (* width height)
195 with cache-size of-type card-32 = (the card-32 (min size 21000))
196 with aux = (make-array (* 3 cache-size) :element-type 'card-8)
197 for start of-type card-32 from 0 by cache-size below size
198 for end of-type card-32 = (min (+ start cache-size) size)
199 with data = (make-array (list height width) :element-type 'card-24)
200 with vec = (make-array size :element-type 'card-24 :displaced-to data)
201 do (loop with offset of-type card-32 = 0
202 while (< offset (* 3 (the card-32 (- end start))))
203 do (setf offset (read-sequence aux stream :start offset)))
204 (loop for i of-type card-32 from start below end
205 for j of-type card-32 from 0 by 3
206 do (setf (aref vec i)
207 (the card-24
208 (+ (ash (the card-8 (aref aux j)) 16)
209 (ash (the card-8 (aref aux (1+ j))) 8)
210 (the card-8 (aref aux (+ 2 j)))))))
211 finally (return (make-p6-image data mlevel))))
212
213 ;;;; Macros.
214
215 (defvar *ppm-readtable* (copy-readtable))
216
217 (defmacro with-pnm-header
218 ((stream pnm-type &key width height max-level) &body body)
219 "The macro with-pnm-header establishes a lexical environment for referring to
220 the pnm image attirbutes: pnm-type, width, height, max-level."
221 (let ((var1 (gensym)) (var2 (gensym)) (var3 (gensym)))
222 `(progn
223 (set-syntax-from-char #\# #\; *ppm-readtable*)
224 (flet ((parse (stream)
225 (let ((*readtable* *ppm-readtable*))
226 (read stream))))
227 (let ((,pnm-type (intern (format nil "~a" (parse ,stream)) :keyword))
228 (,(or width var1) (parse ,stream))
229 (,(or height var2) (parse ,stream))
230 (,(or max-level var3) (parse ,stream)))
231 ,@(unless width `((declare (ignore ,var1))))
232 ,@(unless height `((declare (ignore ,var2))))
233 ,@(unless max-level `((declare (ignore ,var3))))
234 ,@body)))))
235
236 ;;;; Load functions.
237
238 (defun load-ppm (filename)
239 "Returns an image instance that contains a representation of a pnm image."
240 (with-open-file (stream filename
241 #+SB-UNICODE :external-format
242 #+SB-UNICODE :latin-1)
243 (with-pnm-header (stream type :width width :height height :max-level max)
244 (declare (type card-16 width height))
245 (declare (type card-8 max))
246 (with-open-file (byte-stream filename :element-type 'card-8
247 #+SB-UNICODE :external-format
248 #+SB-UNICODE :latin-1)
249 (unless (file-position byte-stream (file-position stream))
250 (error "could not reposition image data stream"))
251 (make-image-from-stream type byte-stream width height max)))))
252
253 (defun image->clx-image (image drawable)
254 "Returns a clx image representation of an image."
255 (loop with getter = (typecase image
256 (gray-scale-image #'gray->x-gray)
257 (colored-24-image #'color->x-color)
258 (t (error "unknow image type ~a" (type-of image))))
259 with depth of-type card-8 = (xlib:drawable-depth drawable)
260 with bits-per-pixel = (find-bits-per-pixel depth)
261 with w = (image-width image)
262 with h = (image-height image)
263 with type = `(unsigned-byte ,bits-per-pixel)
264 with res of-type clx-array = (make-array (list h w) :element-type type)
265 for y of-type card-16 from 0 below h
266 do (loop for x of-type card-16 from 0 below w
267 for pixel = (image-pixel image x y)
268 do (setf (aref res y x)
269 (funcall (the function getter) pixel)))
270 finally (return (xlib:create-image
271 :width w :height h :depth depth :data res
272 :bits-per-pixel bits-per-pixel))))
273
274 (defun load-ppm-into-clx-image (filename drawable)
275 "Returns a clx image representation of a pnm image readed in a pnm file."
276 (image->clx-image (load-ppm filename) drawable))
277
278 ;;;; private routines.
279
280 (defun find-bits-per-pixel (depth)
281 (declare (type card-8 depth))
282 (cond ((>= depth 24) 32)
283 ((> depth 16) 24)
284 ((> depth 8) 16)
285 ((> depth 4) 8)
286 ((> depth 1) 4)
287 (t depth 1)))

  ViewVC Help
Powered by ViewVC 1.1.5