1
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
3
;;; CLX Image functions
6
;;; TEXAS INSTRUMENTS INCORPORATED
8
;;; AUSTIN, TEXAS 78769
10
;;; Copyright (C) 1987 Texas Instruments Incorporated.
12
;;; Permission is granted to any individual or institution to use, copy, modify,
13
;;; and distribute this software, provided that this complete copyright and
14
;;; permission notice is maintained, intact, in all copies and supporting
17
;;; Texas Instruments Incorporated provides this software "as is" without
18
;;; express or implied warranty.
23
(defmacro with-image-data-buffer ((buffer size) &body body)
24
(declare (indentation 0 4 1 1))
25
`(let ((.reply-buffer. (allocate-reply-buffer ,size)))
26
(declare (type reply-buffer .reply-buffer.))
28
(let ((,buffer (reply-ibuf8 .reply-buffer.)))
29
(declare (type buffer-bytes ,buffer))
30
(with-vector (,buffer buffer-bytes)
32
(deallocate-reply-buffer .reply-buffer.))))
34
(def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil))
36
(width 0 :type card16 :read-only t)
37
(height 0 :type card16 :read-only t)
38
(depth 1 :type card8 :read-only t)
39
(plist nil :type list))
41
;; Image-Plist accessors:
42
(defmacro image-name (image) `(getf (image-plist ,image) :name))
43
(defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot))
44
(defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot))
45
(defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask))
46
(defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask))
47
(defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask))
49
(defun print-image (image stream depth)
50
(declare (type image image)
52
(print-unreadable-object (image stream :type t)
53
(when (image-name image)
54
(write-string (string (image-name image)) stream)
55
(write-string " " stream))
56
(prin1 (image-width image) stream)
57
(write-string "x" stream)
58
(prin1 (image-height image) stream)
59
(write-string "x" stream)
60
(prin1 (image-depth image) stream)))
62
(defconstant +empty-data-x+ '#.(make-sequence '(array card8 (*)) 0))
64
(defconstant +empty-data-z+
65
'#.(make-array '(0 0) :element-type 'pixarray-1-element-type))
67
(def-clx-class (image-x (:include image) (:copier nil)
68
(:print-function print-image))
69
;; Use this format for shoveling image data
70
;; Private structure. Accessors for these NOT exported.
71
(format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap))
72
(bytes-per-line 0 :type card16)
73
(bits-per-pixel 1 :type (member 1 4 8 16 24 32))
74
(bit-lsb-first-p +image-bit-lsb-first-p+ :type generalized-boolean) ; Bit order
75
(byte-lsb-first-p +image-byte-lsb-first-p+ :type generalized-boolean) ; Byte order
76
(data +empty-data-x+ :type (array card8 (*))) ; row-major
77
(unit +image-unit+ :type (member 8 16 32)) ; Bitmap unit
78
(pad +image-pad+ :type (member 8 16 32)) ; Scanline pad
79
(left-pad 0 :type card8)) ; Left pad
81
(def-clx-class (image-xy (:include image) (:copier nil)
82
(:print-function print-image))
84
;; Use this format for image processing
85
(bitmap-list nil :type list)) ;; list of bitmaps
87
(def-clx-class (image-z (:include image) (:copier nil)
88
(:print-function print-image))
90
;; Use this format for image processing
91
(bits-per-pixel 1 :type (member 1 4 8 16 24 32))
92
(pixarray +empty-data-z+ :type pixarray))
94
(defun create-image (&key width height depth
95
(data (required-arg data))
96
plist name x-hot y-hot
97
red-mask blue-mask green-mask
98
bits-per-pixel format bytes-per-line
100
#+clx-little-endian t
101
#-clx-little-endian nil)
103
#+clx-little-endian t
104
#-clx-little-endian nil)
106
;; Returns an image-x image-xy or image-z structure, depending on the
107
;; type of the :DATA parameter.
109
(type (or null card16) width height) ; Required
110
(type (or null card8) depth) ; Defualts to 1
111
(type (or buffer-bytes ; Returns image-x
112
list ; Returns image-xy
113
pixarray) data) ; Returns image-z
115
(type (or null stringable) name)
116
(type (or null card16) x-hot y-hot)
117
(type (or null pixel) red-mask blue-mask green-mask)
118
(type (or null (member 1 4 8 16 24 32)) bits-per-pixel)
120
;; The following parameters are ignored for image-xy and image-z:
121
(type (or null (member :bitmap :xy-pixmap :z-pixmap))
122
format) ; defaults to :z-pixmap
123
(type (or null card16) bytes-per-line)
124
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p)
125
(type (or null (member 8 16 32)) unit pad)
126
(type (or null card8) left-pad))
127
(declare (clx-values image))
130
(buffer-bytes ; image-x
132
(declare (type buffer-bytes data))
133
(unless depth (setq depth (or bits-per-pixel 1)))
135
(setq format (if (= depth 1) :xy-pixmap :z-pixmap)))
136
(unless bits-per-pixel
138
(cond ((eq format :xy-pixmap) 1)
139
((index> depth 24) 32)
140
((index> depth 16) 24)
141
((index> depth 8) 16)
145
(unless width (required-arg width))
146
(unless height (required-arg height))
147
(unless bytes-per-line
148
(let* ((pad (or pad 8))
149
(bits-per-line (index* width bits-per-pixel))
150
(padded-bits-per-line
151
(index* (index-ceiling bits-per-line pad) pad)))
152
(declare (type array-index pad bits-per-line
153
padded-bits-per-line))
154
(setq bytes-per-line (index-ceiling padded-bits-per-line 8))))
155
(unless unit (setq unit +image-unit+))
158
(dolist (pad '(32 16 8))
159
(when (and (index<= pad +image-pad+)
162
(index* bytes-per-line 8) pad)))
164
(unless left-pad (setq left-pad 0))
166
:width width :height height :depth depth :plist plist
167
:format format :data data
168
:bits-per-pixel bits-per-pixel
169
:bytes-per-line bytes-per-line
170
:byte-lsb-first-p byte-lsb-first-p
171
:bit-lsb-first-p bit-lsb-first-p
172
:unit unit :pad pad :left-pad left-pad)))
175
(declare (type list data))
176
(unless depth (setq depth (length data)))
178
(unless width (setq width (array-dimension (car data) 1)))
179
(unless height (setq height (array-dimension (car data) 0))))
181
:width width :height height :plist plist :depth depth
185
(declare (type pixarray data))
186
(unless width (setq width (array-dimension data 1)))
187
(unless height (setq height (array-dimension data 0)))
188
(unless bits-per-pixel
197
(unless depth (setq depth bits-per-pixel))
199
:width width :height height :depth depth :plist plist
200
:bits-per-pixel bits-per-pixel :pixarray data)))))
201
(declare (type image image))
202
(when name (setf (image-name image) name))
203
(when x-hot (setf (image-x-hot image) x-hot))
204
(when y-hot (setf (image-y-hot image) y-hot))
205
(when red-mask (setf (image-red-mask image) red-mask))
206
(when blue-mask (setf (image-blue-mask image) blue-mask))
207
(when green-mask (setf (image-green-mask image) green-mask))
210
;;;-----------------------------------------------------------------------------
214
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
215
(declare (type buffer-bytes src dest)
216
(type array-index srcoff destoff srclen srcinc destinc)
218
(type generalized-boolean lsb-first-p)
219
(ignore lsb-first-p))
221
(if (index= srcinc destinc)
224
(index+ destoff (index* srcinc (index1- height)) srclen)
226
(do* ((h height (index1- h))
227
(srcstart srcoff (index+ srcstart srcinc))
228
(deststart destoff (index+ deststart destinc))
229
(destend (index+ deststart srclen) (index+ deststart srclen)))
231
(declare (type array-index srcstart deststart destend)
233
(buffer-replace dest src deststart destend srcstart))))
235
(defun image-swap-two-bytes
236
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
237
(declare (type buffer-bytes src dest)
238
(type array-index srcoff destoff srclen srcinc destinc)
240
(type generalized-boolean lsb-first-p))
242
(with-vector (src buffer-bytes)
243
(with-vector (dest buffer-bytes)
244
(do ((length (index* (index-ceiling srclen 2) 2))
245
(h height (index1- h))
246
(srcstart srcoff (index+ srcstart srcinc))
247
(deststart destoff (index+ deststart destinc)))
249
(declare (type array-index length srcstart deststart)
251
(when (and (index= h 1) (not (index= srclen length)))
252
(index-decf length 2)
254
(setf (aref dest (index1+ (index+ deststart length)))
255
(the card8 (aref src (index+ srcstart length))))
256
(setf (aref dest (index+ deststart length))
257
(the card8 (aref src (index1+ (index+ srcstart length)))))))
258
(do ((i length (index- i 2))
259
(srcidx srcstart (index+ srcidx 2))
260
(destidx deststart (index+ destidx 2)))
262
(declare (type array-index i srcidx destidx))
263
(setf (aref dest destidx)
264
(the card8 (aref src (index1+ srcidx))))
265
(setf (aref dest (index1+ destidx))
266
(the card8 (aref src srcidx))))))))
268
(defun image-swap-three-bytes
269
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
270
(declare (type buffer-bytes src dest)
271
(type array-index srcoff destoff srclen srcinc destinc)
273
(type generalized-boolean lsb-first-p))
275
(with-vector (src buffer-bytes)
276
(with-vector (dest buffer-bytes)
277
(do ((length (index* (index-ceiling srclen 3) 3))
278
(h height (index1- h))
279
(srcstart srcoff (index+ srcstart srcinc))
280
(deststart destoff (index+ deststart destinc)))
282
(declare (type array-index length srcstart deststart)
284
(when (and (index= h 1) (not (index= srclen length)))
285
(index-decf length 3)
286
(when (index= (index- srclen length) 2)
287
(setf (aref dest (index+ deststart length 1))
288
(the card8 (aref src (index+ srcstart length 1)))))
290
(setf (aref dest (index+ deststart length 2))
291
(the card8 (aref src (index+ srcstart length))))
292
(setf (aref dest (index+ deststart length))
293
(the card8 (aref src (index+ srcstart length 2))))))
294
(do ((i length (index- i 3))
295
(srcidx srcstart (index+ srcidx 3))
296
(destidx deststart (index+ destidx 3)))
298
(declare (type array-index i srcidx destidx))
299
(setf (aref dest destidx)
300
(the card8 (aref src (index+ srcidx 2))))
301
(setf (aref dest (index1+ destidx))
302
(the card8 (aref src (index1+ srcidx))))
303
(setf (aref dest (index+ destidx 2))
304
(the card8 (aref src srcidx))))))))
306
(defun image-swap-four-bytes
307
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
308
(declare (type buffer-bytes src dest)
309
(type array-index srcoff destoff srclen srcinc destinc)
311
(type generalized-boolean lsb-first-p))
313
(with-vector (src buffer-bytes)
314
(with-vector (dest buffer-bytes)
315
(do ((length (index* (index-ceiling srclen 4) 4))
316
(h height (index1- h))
317
(srcstart srcoff (index+ srcstart srcinc))
318
(deststart destoff (index+ deststart destinc)))
320
(declare (type array-index length srcstart deststart)
322
(when (and (index= h 1) (not (index= srclen length)))
323
(index-decf length 4)
325
(setf (aref dest (index+ deststart length))
326
(the card8 (aref src (index+ srcstart length 3)))))
327
(when (if lsb-first-p
328
(index= (index- srclen length) 3)
329
(not (index-zerop (index-logand srclen 2))))
330
(setf (aref dest (index+ deststart length 1))
331
(the card8 (aref src (index+ srcstart length 2)))))
332
(when (if (null lsb-first-p)
333
(index= (index- srclen length) 3)
334
(not (index-zerop (index-logand srclen 2))))
335
(setf (aref dest (index+ deststart length 2))
336
(the card8 (aref src (index+ srcstart length 1)))))
338
(setf (aref dest (index+ deststart length 3))
339
(the card8 (aref src (index+ srcstart length))))))
340
(do ((i length (index- i 4))
341
(srcidx srcstart (index+ srcidx 4))
342
(destidx deststart (index+ destidx 4)))
344
(declare (type array-index i srcidx destidx))
345
(setf (aref dest destidx)
346
(the card8 (aref src (index+ srcidx 3))))
347
(setf (aref dest (index1+ destidx))
348
(the card8 (aref src (index+ srcidx 2))))
349
(setf (aref dest (index+ destidx 2))
350
(the card8 (aref src (index1+ srcidx))))
351
(setf (aref dest (index+ destidx 3))
352
(the card8 (aref src srcidx))))))))
354
(defun image-swap-words
355
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
356
(declare (type buffer-bytes src dest)
357
(type array-index srcoff destoff srclen srcinc destinc)
359
(type generalized-boolean lsb-first-p))
361
(with-vector (src buffer-bytes)
362
(with-vector (dest buffer-bytes)
363
(do ((length (index* (index-ceiling srclen 4) 4))
364
(h height (index1- h))
365
(srcstart srcoff (index+ srcstart srcinc))
366
(deststart destoff (index+ deststart destinc)))
368
(declare (type array-index length srcstart deststart)
370
(when (and (index= h 1) (not (index= srclen length)))
371
(index-decf length 4)
373
(setf (aref dest (index+ deststart length 1))
374
(the card8 (aref src (index+ srcstart length 3)))))
375
(when (if lsb-first-p
376
(index= (index- srclen length) 3)
377
(not (index-zerop (index-logand srclen 2))))
378
(setf (aref dest (index+ deststart length))
379
(the card8 (aref src (index+ srcstart length 2)))))
380
(when (if (null lsb-first-p)
381
(index= (index- srclen length) 3)
382
(not (index-zerop (index-logand srclen 2))))
383
(setf (aref dest (index+ deststart length 3))
384
(the card8 (aref src (index+ srcstart length 1)))))
386
(setf (aref dest (index+ deststart length 2))
387
(the card8 (aref src (index+ srcstart length))))))
388
(do ((i length (index- i 4))
389
(srcidx srcstart (index+ srcidx 4))
390
(destidx deststart (index+ destidx 4)))
392
(declare (type array-index i srcidx destidx))
393
(setf (aref dest destidx)
394
(the card8 (aref src (index+ srcidx 2))))
395
(setf (aref dest (index1+ destidx))
396
(the card8 (aref src (index+ srcidx 3))))
397
(setf (aref dest (index+ destidx 2))
398
(the card8 (aref src srcidx)))
399
(setf (aref dest (index+ destidx 3))
400
(the card8 (aref src (index1+ srcidx)))))))))
402
(defun image-swap-nibbles
403
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
404
(declare (type buffer-bytes src dest)
405
(type array-index srcoff destoff srclen srcinc destinc)
407
(type generalized-boolean lsb-first-p)
408
(ignore lsb-first-p))
410
(with-vector (src buffer-bytes)
411
(with-vector (dest buffer-bytes)
412
(do ((h height (index1- h))
413
(srcstart srcoff (index+ srcstart srcinc))
414
(deststart destoff (index+ deststart destinc)))
416
(declare (type array-index srcstart deststart)
418
(do ((i srclen (index1- i))
419
(srcidx srcstart (index1+ srcidx))
420
(destidx deststart (index1+ destidx)))
422
(declare (type array-index i srcidx destidx))
423
(setf (aref dest destidx)
425
(let ((byte (aref src srcidx)))
426
(declare (type card8 byte))
427
(dpb (the card4 (ldb (byte 4 0) byte))
429
(the card4 (ldb (byte 4 4) byte)))))))))))
431
(defun image-swap-nibbles-left
432
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
433
(declare (type buffer-bytes src dest)
434
(type array-index srcoff destoff srclen srcinc destinc)
436
(type generalized-boolean lsb-first-p)
437
(ignore lsb-first-p))
439
(with-vector (src buffer-bytes)
440
(with-vector (dest buffer-bytes)
441
(do ((h height (index1- h))
442
(srcstart srcoff (index+ srcstart srcinc))
443
(deststart destoff (index+ deststart destinc)))
445
(declare (type array-index srcstart deststart)
447
(do ((i srclen (index1- i))
448
(srcidx srcstart (index1+ srcidx))
449
(destidx deststart (index1+ destidx)))
451
(setf (aref dest destidx)
453
(let ((byte1 (aref src srcidx)))
454
(declare (type card8 byte1))
455
(dpb (the card4 (ldb (byte 4 0) byte1))
458
(declare (type array-index i srcidx destidx))
459
(setf (aref dest destidx)
461
(let ((byte1 (aref src srcidx))
462
(byte2 (aref src (index1+ srcidx))))
463
(declare (type card8 byte1 byte2))
464
(dpb (the card4 (ldb (byte 4 0) byte1))
466
(the card4 (ldb (byte 4 4) byte2)))))))))))
468
(defconstant +image-byte-reverse+
471
0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240
472
8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248
473
4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244
474
12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252
475
2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242
476
10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250
477
6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246
478
14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254
479
1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241
480
9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249
481
5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245
482
13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253
483
3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243
484
11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251
485
7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247
486
15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255)
489
(defun image-swap-bits
490
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
491
(declare (type buffer-bytes src dest)
492
(type array-index srcoff destoff srclen srcinc destinc)
494
(type generalized-boolean lsb-first-p)
495
(ignore lsb-first-p))
497
(with-vector (src buffer-bytes)
498
(with-vector (dest buffer-bytes)
499
(let ((byte-reverse +image-byte-reverse+))
500
(with-vector (byte-reverse (simple-array card8 (256)))
501
(macrolet ((br (byte)
502
`(the card8 (aref byte-reverse (the card8 ,byte)))))
503
(do ((h height (index1- h))
504
(srcstart srcoff (index+ srcstart srcinc))
505
(deststart destoff (index+ deststart destinc)))
507
(declare (type array-index srcstart deststart)
509
(do ((i srclen (index1- i))
510
(srcidx srcstart (index1+ srcidx))
511
(destidx deststart (index1+ destidx)))
513
(declare (type array-index i srcidx destidx))
514
(setf (aref dest destidx) (br (aref src srcidx)))))))))))
516
(defun image-swap-bits-and-two-bytes
517
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
518
(declare (type buffer-bytes src dest)
519
(type array-index srcoff destoff srclen srcinc destinc)
521
(type generalized-boolean lsb-first-p))
523
(with-vector (src buffer-bytes)
524
(with-vector (dest buffer-bytes)
525
(let ((byte-reverse +image-byte-reverse+))
526
(with-vector (byte-reverse (simple-array card8 (256)))
527
(macrolet ((br (byte)
528
`(the card8 (aref byte-reverse (the card8 ,byte)))))
529
(do ((length (index* (index-ceiling srclen 2) 2))
530
(h height (index1- h))
531
(srcstart srcoff (index+ srcstart srcinc))
532
(deststart destoff (index+ deststart destinc)))
534
(declare (type array-index length srcstart deststart)
536
(when (and (index= h 1) (not (index= srclen length)))
537
(index-decf length 2)
539
(setf (aref dest (index1+ (index+ deststart length)))
540
(br (aref src (index+ srcstart length))))
541
(setf (aref dest (index+ deststart length))
542
(br (aref src (index1+ (index+ srcstart length)))))))
543
(do ((i length (index- i 2))
544
(srcidx srcstart (index+ srcidx 2))
545
(destidx deststart (index+ destidx 2)))
547
(declare (type array-index i srcidx destidx))
548
(setf (aref dest destidx)
549
(br (aref src (index1+ srcidx))))
550
(setf (aref dest (index1+ destidx))
551
(br (aref src srcidx)))))))))))
553
(defun image-swap-bits-and-four-bytes
554
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
555
(declare (type buffer-bytes src dest)
556
(type array-index srcoff destoff srclen srcinc destinc)
558
(type generalized-boolean lsb-first-p))
560
(with-vector (src buffer-bytes)
561
(with-vector (dest buffer-bytes)
562
(let ((byte-reverse +image-byte-reverse+))
563
(with-vector (byte-reverse (simple-array card8 (256)))
564
(macrolet ((br (byte)
565
`(the card8 (aref byte-reverse (the card8 ,byte)))))
566
(do ((length (index* (index-ceiling srclen 4) 4))
567
(h height (index1- h))
568
(srcstart srcoff (index+ srcstart srcinc))
569
(deststart destoff (index+ deststart destinc)))
571
(declare (type array-index length srcstart deststart)
573
(when (and (index= h 1) (not (index= srclen length)))
574
(index-decf length 4)
576
(setf (aref dest (index+ deststart length))
577
(br (aref src (index+ srcstart length 3)))))
578
(when (if lsb-first-p
579
(index= (index- srclen length) 3)
580
(not (index-zerop (index-logand srclen 2))))
581
(setf (aref dest (index+ deststart length 1))
582
(br (aref src (index+ srcstart length 2)))))
583
(when (if (null lsb-first-p)
584
(index= (index- srclen length) 3)
585
(not (index-zerop (index-logand srclen 2))))
586
(setf (aref dest (index+ deststart length 2))
587
(br (aref src (index+ srcstart length 1)))))
589
(setf (aref dest (index+ deststart length 3))
590
(br (aref src (index+ srcstart length))))))
591
(do ((i length (index- i 4))
592
(srcidx srcstart (index+ srcidx 4))
593
(destidx deststart (index+ destidx 4)))
595
(declare (type array-index i srcidx destidx))
596
(setf (aref dest destidx)
597
(br (aref src (index+ srcidx 3))))
598
(setf (aref dest (index1+ destidx))
599
(br (aref src (index+ srcidx 2))))
600
(setf (aref dest (index+ destidx 2))
601
(br (aref src (index1+ srcidx))))
602
(setf (aref dest (index+ destidx 3))
603
(br (aref src srcidx)))))))))))
605
(defun image-swap-bits-and-words
606
(src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
607
(declare (type buffer-bytes src dest)
608
(type array-index srcoff destoff srclen srcinc destinc)
610
(type generalized-boolean lsb-first-p))
612
(with-vector (src buffer-bytes)
613
(with-vector (dest buffer-bytes)
614
(let ((byte-reverse +image-byte-reverse+))
615
(with-vector (byte-reverse (simple-array card8 (256)))
616
(macrolet ((br (byte)
617
`(the card8 (aref byte-reverse (the card8 ,byte)))))
618
(do ((length (index* (index-ceiling srclen 4) 4))
619
(h height (index1- h))
620
(srcstart srcoff (index+ srcstart srcinc))
621
(deststart destoff (index+ deststart destinc)))
623
(declare (type array-index length srcstart deststart)
625
(when (and (index= h 1) (not (index= srclen length)))
626
(index-decf length 4)
628
(setf (aref dest (index+ deststart length 1))
629
(br (aref src (index+ srcstart length 3)))))
630
(when (if lsb-first-p
631
(index= (index- srclen length) 3)
632
(not (index-zerop (index-logand srclen 2))))
633
(setf (aref dest (index+ deststart length))
634
(br (aref src (index+ srcstart length 2)))))
635
(when (if (null lsb-first-p)
636
(index= (index- srclen length) 3)
637
(not (index-zerop (index-logand srclen 2))))
638
(setf (aref dest (index+ deststart length 3))
639
(br (aref src (index+ srcstart length 1)))))
641
(setf (aref dest (index+ deststart length 2))
642
(br (aref src (index+ srcstart length))))))
643
(do ((i length (index- i 4))
644
(srcidx srcstart (index+ srcidx 4))
645
(destidx deststart (index+ destidx 4)))
647
(declare (type array-index i srcidx destidx))
648
(setf (aref dest destidx)
649
(br (aref src (index+ srcidx 2))))
650
(setf (aref dest (index1+ destidx))
651
(br (aref src (index+ srcidx 3))))
652
(setf (aref dest (index+ destidx 2))
653
(br (aref src srcidx)))
654
(setf (aref dest (index+ destidx 3))
655
(br (aref src (index1+ srcidx))))))))))))
657
;;; The following table gives the bit ordering within bytes (when accessed
658
;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to
659
;;; 31, where bit 0 should be leftmost on the display. For a given byte
660
;;; labelled A-B, A is for the most significant bit of the byte, and B is
661
;;; for the least significant bit.
664
;;; 1 scanline-unit = 8
665
;;; 2 scanline-unit = 16
666
;;; 4 scanline-unit = 32
667
;;; M byte-order = MostSignificant
668
;;; L byte-order = LeastSignificant
669
;;; m bit-order = MostSignificant
670
;;; l bit-order = LeastSignificant
675
;;; 1Mm 00-07 08-15 16-23 24-31
676
;;; 2Mm 00-07 08-15 16-23 24-31
677
;;; 4Mm 00-07 08-15 16-23 24-31
678
;;; 1Ml 07-00 15-08 23-16 31-24
679
;;; 2Ml 15-08 07-00 31-24 23-16
680
;;; 4Ml 31-24 23-16 15-08 07-00
681
;;; 1Lm 00-07 08-15 16-23 24-31
682
;;; 2Lm 08-15 00-07 24-31 16-23
683
;;; 4Lm 24-31 16-23 08-15 00-07
684
;;; 1Ll 07-00 15-08 23-16 31-24
685
;;; 2Ll 07-00 15-08 23-16 31-24
686
;;; 4Ll 07-00 15-08 23-16 31-24
689
;;; The following table gives the required conversion between any two
690
;;; formats. It is based strictly on the table above. If you believe one,
691
;;; you should believe the other.
695
;;; s reverse 8-bit units within 16-bit units
696
;;; l reverse 8-bit units within 32-bit units
697
;;; w reverse 16-bit units within 32-bit units
698
;;; r reverse bits within 8-bit units
703
(defconstant +image-swap-function+
705
'(12 12) :initial-contents
706
(let ((n 'image-noswap)
707
(s 'image-swap-two-bytes)
708
(l 'image-swap-four-bytes)
709
(w 'image-swap-words)
711
(sr 'image-swap-bits-and-two-bytes)
712
(lr 'image-swap-bits-and-four-bytes)
713
(wr 'image-swap-bits-and-words))
714
(list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |#
715
(list #| 1Mm |# n n n r sr lr n s l r r r )
716
(list #| 2Mm |# n n n r sr lr n s l r r r )
717
(list #| 4Mm |# n n n r sr lr n s l r r r )
718
(list #| 1Ml |# r r r n s l r sr lr n n n )
719
(list #| 2Ml |# sr sr sr s n w sr r wr s s s )
720
(list #| 4Ml |# lr lr lr l w n lr wr r l l l )
721
(list #| 1Lm |# n n n r sr lr n s l r r r )
722
(list #| 2Lm |# s s s sr r wr s n w sr sr sr)
723
(list #| 4Lm |# l l l lr wr r l w n lr lr lr)
724
(list #| 1Ll |# r r r n s l r sr lr n n n )
725
(list #| 2Ll |# r r r n s l r sr lr n n n )
726
(list #| 4Ll |# r r r n s l r sr lr n n n )))))
728
;;; Of course, the table above is a lie. We also need to factor in the
729
;;; order of the source data to cope with swapping half of a unit at the
730
;;; end of a scanline, since we are trying to avoid de-ref'ing off the
731
;;; end of the source.
733
;;; Defines whether the first half of a unit has the first half of the data
735
(defconstant +image-swap-lsb-first-p+
752
(defun image-swap-function
754
from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
755
to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
756
(declare (type (member 1 4 8 16 24 32) bits-per-pixel)
757
(type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
758
(type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p
759
to-byte-lsb-first-p to-bit-lsb-first-p)
760
(clx-values function lsb-first-p))
761
(cond ((index= bits-per-pixel 1)
764
(ecase from-bitmap-unit (32 2) (16 1) (8 0))
765
(if from-bit-lsb-first-p 3 0)
766
(if from-byte-lsb-first-p 6 0))))
768
(aref +image-swap-function+ from-index
770
(ecase to-bitmap-unit (32 2) (16 1) (8 0))
771
(if to-bit-lsb-first-p 3 0)
772
(if to-byte-lsb-first-p 6 0)))
773
(aref +image-swap-lsb-first-p+ from-index))))
776
(if (if (index= bits-per-pixel 4)
777
(eq from-bit-lsb-first-p to-bit-lsb-first-p)
778
(eq from-byte-lsb-first-p to-byte-lsb-first-p))
780
(ecase bits-per-pixel
781
(4 'image-swap-nibbles)
783
(16 'image-swap-two-bytes)
784
(24 'image-swap-three-bytes)
785
(32 'image-swap-four-bytes)))
786
from-byte-lsb-first-p))))
789
;;;-----------------------------------------------------------------------------
792
(defun read-pixarray-1 (buffer-bbuf index array x y width height
793
padded-bytes-per-line bits-per-pixel)
794
(declare (type buffer-bytes buffer-bbuf)
795
(type pixarray-1 array)
796
(type card16 x y width height)
797
(type array-index index padded-bytes-per-line)
798
(type (member 1 4 8 16 24 32) bits-per-pixel)
799
(ignore bits-per-pixel))
801
(with-vector (buffer-bbuf buffer-bytes)
802
(do* ((start (index+ index
803
(index* y padded-bytes-per-line)
805
(index+ start padded-bytes-per-line))
807
(left-bits (the array-index
808
(mod (the (integer #x-FFFF 0) (- x))
810
(right-bits (index-mod (index- width left-bits) 8))
811
(middle-bits (- width left-bits right-bits))
812
(middle-bytes (floor middle-bits 8)))
814
(declare (type array-index start y left-bits right-bits))
815
(declare (fixnum middle-bits middle-bytes))
816
(cond ((< middle-bits 0)
817
(let ((byte (aref buffer-bbuf (index1- start)))
819
(declare (type card8 byte)
820
(type array-index x))
821
(when (index> right-bits 6)
822
(setf (aref array y (index- x 1))
823
(read-image-load-byte 1 7 byte)))
824
(when (and (index> left-bits 1)
825
(index> right-bits 5))
826
(setf (aref array y (index- x 2))
827
(read-image-load-byte 1 6 byte)))
828
(when (and (index> left-bits 2)
829
(index> right-bits 4))
830
(setf (aref array y (index- x 3))
831
(read-image-load-byte 1 5 byte)))
832
(when (and (index> left-bits 3)
833
(index> right-bits 3))
834
(setf (aref array y (index- x 4))
835
(read-image-load-byte 1 4 byte)))
836
(when (and (index> left-bits 4)
837
(index> right-bits 2))
838
(setf (aref array y (index- x 5))
839
(read-image-load-byte 1 3 byte)))
840
(when (and (index> left-bits 5)
841
(index> right-bits 1))
842
(setf (aref array y (index- x 6))
843
(read-image-load-byte 1 2 byte)))
844
(when (index> left-bits 6)
845
(setf (aref array y (index- x 7))
846
(read-image-load-byte 1 1 byte)))))
848
(unless (index-zerop left-bits)
849
(let ((byte (aref buffer-bbuf (index1- start)))
851
(declare (type card8 byte)
852
(type array-index x))
853
(setf (aref array y (index- x 1))
854
(read-image-load-byte 1 7 byte))
855
(when (index> left-bits 1)
856
(setf (aref array y (index- x 2))
857
(read-image-load-byte 1 6 byte))
858
(when (index> left-bits 2)
859
(setf (aref array y (index- x 3))
860
(read-image-load-byte 1 5 byte))
861
(when (index> left-bits 3)
862
(setf (aref array y (index- x 4))
863
(read-image-load-byte 1 4 byte))
864
(when (index> left-bits 4)
865
(setf (aref array y (index- x 5))
866
(read-image-load-byte 1 3 byte))
867
(when (index> left-bits 5)
868
(setf (aref array y (index- x 6))
869
(read-image-load-byte 1 2 byte))
870
(when (index> left-bits 6)
871
(setf (aref array y (index- x 7))
872
(read-image-load-byte 1 1 byte))
874
(do* ((end (index+ start middle-bytes))
875
(i start (index1+ i))
876
(x left-bits (index+ x 8)))
878
(unless (index-zerop right-bits)
879
(let ((byte (aref buffer-bbuf end))
880
(x (index+ left-bits middle-bits)))
881
(declare (type card8 byte)
882
(type array-index x))
883
(setf (aref array y (index+ x 0))
884
(read-image-load-byte 1 0 byte))
885
(when (index> right-bits 1)
886
(setf (aref array y (index+ x 1))
887
(read-image-load-byte 1 1 byte))
888
(when (index> right-bits 2)
889
(setf (aref array y (index+ x 2))
890
(read-image-load-byte 1 2 byte))
891
(when (index> right-bits 3)
892
(setf (aref array y (index+ x 3))
893
(read-image-load-byte 1 3 byte))
894
(when (index> right-bits 4)
895
(setf (aref array y (index+ x 4))
896
(read-image-load-byte 1 4 byte))
897
(when (index> right-bits 5)
898
(setf (aref array y (index+ x 5))
899
(read-image-load-byte 1 5 byte))
900
(when (index> right-bits 6)
901
(setf (aref array y (index+ x 6))
902
(read-image-load-byte 1 6 byte))
904
(declare (type array-index end i x))
905
(let ((byte (aref buffer-bbuf i)))
906
(declare (type card8 byte))
907
(setf (aref array y (index+ x 0))
908
(read-image-load-byte 1 0 byte))
909
(setf (aref array y (index+ x 1))
910
(read-image-load-byte 1 1 byte))
911
(setf (aref array y (index+ x 2))
912
(read-image-load-byte 1 2 byte))
913
(setf (aref array y (index+ x 3))
914
(read-image-load-byte 1 3 byte))
915
(setf (aref array y (index+ x 4))
916
(read-image-load-byte 1 4 byte))
917
(setf (aref array y (index+ x 5))
918
(read-image-load-byte 1 5 byte))
919
(setf (aref array y (index+ x 6))
920
(read-image-load-byte 1 6 byte))
921
(setf (aref array y (index+ x 7))
922
(read-image-load-byte 1 7 byte))))
925
(defun read-pixarray-4 (buffer-bbuf index array x y width height
926
padded-bytes-per-line bits-per-pixel)
927
(declare (type buffer-bytes buffer-bbuf)
928
(type pixarray-4 array)
929
(type card16 x y width height)
930
(type array-index index padded-bytes-per-line)
931
(type (member 1 4 8 16 24 32) bits-per-pixel)
932
(ignore bits-per-pixel))
934
(with-vector (buffer-bbuf buffer-bytes)
935
(do* ((start (index+ index
936
(index* y padded-bytes-per-line)
938
(index+ start padded-bytes-per-line))
940
(left-nibbles (mod (the fixnum (- x)) 2))
941
(right-nibbles (index-mod (index- width left-nibbles) 2))
942
(middle-nibbles (index- width left-nibbles right-nibbles))
943
(middle-bytes (index-floor middle-nibbles 2)))
945
(declare (type array-index start y
946
left-nibbles right-nibbles middle-nibbles middle-bytes))
947
(unless (index-zerop left-nibbles)
948
(setf (aref array y 0)
949
(read-image-load-byte
950
4 4 (aref buffer-bbuf (index1- start)))))
951
(do* ((end (index+ start middle-bytes))
952
(i start (index1+ i))
953
(x left-nibbles (index+ x 2)))
955
(unless (index-zerop right-nibbles)
956
(setf (aref array y (index+ left-nibbles middle-nibbles))
957
(read-image-load-byte 4 0 (aref buffer-bbuf end)))))
958
(declare (type array-index end i x))
959
(let ((byte (aref buffer-bbuf i)))
960
(declare (type card8 byte))
961
(setf (aref array y (index+ x 0))
962
(read-image-load-byte 4 0 byte))
963
(setf (aref array y (index+ x 1))
964
(read-image-load-byte 4 4 byte))))
967
(defun read-pixarray-8 (buffer-bbuf index array x y width height
968
padded-bytes-per-line bits-per-pixel)
969
(declare (type buffer-bytes buffer-bbuf)
970
(type pixarray-8 array)
971
(type card16 x y width height)
972
(type array-index index padded-bytes-per-line)
973
(type (member 1 4 8 16 24 32) bits-per-pixel)
974
(ignore bits-per-pixel))
976
(with-vector (buffer-bbuf buffer-bytes)
977
(do* ((start (index+ index
978
(index* y padded-bytes-per-line)
980
(index+ start padded-bytes-per-line))
983
(declare (type array-index start y))
984
(do* ((end (index+ start width))
985
(i start (index1+ i))
988
(declare (type array-index end i x))
989
(setf (aref array y x)
990
(the card8 (aref buffer-bbuf i)))))))
992
(defun read-pixarray-16 (buffer-bbuf index array x y width height
993
padded-bytes-per-line bits-per-pixel)
994
(declare (type buffer-bytes buffer-bbuf)
995
(type pixarray-16 array)
996
(type card16 width height)
997
(type array-index index padded-bytes-per-line)
998
(type (member 1 4 8 16 24 32) bits-per-pixel)
999
(ignore bits-per-pixel))
1001
(with-vector (buffer-bbuf buffer-bytes)
1002
(do* ((start (index+ index
1003
(index* y padded-bytes-per-line)
1005
(index+ start padded-bytes-per-line))
1007
((index>= y height))
1008
(declare (type array-index start y))
1009
(do* ((end (index+ start (index* width 2)))
1010
(i start (index+ i 2))
1013
(declare (type array-index end i x))
1014
(setf (aref array y x)
1015
(read-image-assemble-bytes
1016
(aref buffer-bbuf (index+ i 0))
1017
(aref buffer-bbuf (index+ i 1))))))))
1019
(defun read-pixarray-24 (buffer-bbuf index array x y width height
1020
padded-bytes-per-line bits-per-pixel)
1021
(declare (type buffer-bytes buffer-bbuf)
1022
(type pixarray-24 array)
1023
(type card16 width height)
1024
(type array-index index padded-bytes-per-line)
1025
(type (member 1 4 8 16 24 32) bits-per-pixel)
1026
(ignore bits-per-pixel))
1028
(with-vector (buffer-bbuf buffer-bytes)
1029
(do* ((start (index+ index
1030
(index* y padded-bytes-per-line)
1032
(index+ start padded-bytes-per-line))
1034
((index>= y height))
1035
(declare (type array-index start y))
1036
(do* ((end (index+ start (index* width 3)))
1037
(i start (index+ i 3))
1040
(declare (type array-index end i x))
1041
(setf (aref array y x)
1042
(read-image-assemble-bytes
1043
(aref buffer-bbuf (index+ i 0))
1044
(aref buffer-bbuf (index+ i 1))
1045
(aref buffer-bbuf (index+ i 2))))))))
1047
(defun read-pixarray-32 (buffer-bbuf index array x y width height
1048
padded-bytes-per-line bits-per-pixel)
1049
(declare (type buffer-bytes buffer-bbuf)
1050
(type pixarray-32 array)
1051
(type card16 width height)
1052
(type array-index index padded-bytes-per-line)
1053
(type (member 1 4 8 16 24 32) bits-per-pixel)
1054
(ignore bits-per-pixel))
1056
(with-vector (buffer-bbuf buffer-bytes)
1057
(do* ((start (index+ index
1058
(index* y padded-bytes-per-line)
1060
(index+ start padded-bytes-per-line))
1062
((index>= y height))
1063
(declare (type array-index start y))
1064
(do* ((end (index+ start (index* width 4)))
1065
(i start (index+ i 4))
1068
(declare (type array-index end i x))
1069
(setf (aref array y x)
1070
(read-image-assemble-bytes
1071
(aref buffer-bbuf (index+ i 0))
1072
(aref buffer-bbuf (index+ i 1))
1073
(aref buffer-bbuf (index+ i 2))
1074
(aref buffer-bbuf (index+ i 3))))))))
1076
(defun read-pixarray-internal
1077
(bbuf boffset pixarray x y width height padded-bytes-per-line
1078
bits-per-pixel read-pixarray-function
1079
from-unit from-byte-lsb-first-p from-bit-lsb-first-p
1080
to-unit to-byte-lsb-first-p to-bit-lsb-first-p)
1081
(declare (type buffer-bytes bbuf)
1082
(type array-index boffset padded-bytes-per-line)
1083
(type pixarray pixarray)
1084
(type card16 x y width height)
1085
(type (member 1 4 8 16 24 32) bits-per-pixel)
1086
(type function read-pixarray-function)
1087
(type (member 8 16 32) from-unit to-unit)
1088
(type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p
1089
to-byte-lsb-first-p to-bit-lsb-first-p))
1090
(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
1091
(image-swap-function
1093
from-unit from-byte-lsb-first-p from-bit-lsb-first-p
1094
to-unit to-byte-lsb-first-p to-bit-lsb-first-p)
1095
(if (eq image-swap-function 'image-noswap)
1097
read-pixarray-function
1098
bbuf boffset pixarray x y width height padded-bytes-per-line
1100
(with-image-data-buffer (buf (index* height padded-bytes-per-line))
1102
(symbol-function image-swap-function) bbuf buf
1103
(index+ boffset (index* y padded-bytes-per-line)) 0
1104
(index-ceiling (index* (index+ x width) bits-per-pixel) 8)
1105
padded-bytes-per-line padded-bytes-per-line height
1106
image-swap-lsb-first-p)
1108
read-pixarray-function
1109
buf 0 pixarray x 0 width height padded-bytes-per-line
1112
(defun read-pixarray
1113
(bbuf boffset pixarray x y width height padded-bytes-per-line
1114
bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1115
(declare (type buffer-bytes bbuf)
1116
(type array-index boffset padded-bytes-per-line)
1117
(type pixarray pixarray)
1118
(type card16 x y width height)
1119
(type (member 1 4 8 16 24 32) bits-per-pixel)
1120
(type (member 8 16 32) unit)
1121
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1122
(unless (fast-read-pixarray
1123
bbuf boffset pixarray x y width height padded-bytes-per-line
1124
bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1125
(read-pixarray-internal
1126
bbuf boffset pixarray x y width height padded-bytes-per-line
1128
(ecase bits-per-pixel
1129
( 1 #'read-pixarray-1 )
1130
( 4 #'read-pixarray-4 )
1131
( 8 #'read-pixarray-8 )
1132
(16 #'read-pixarray-16)
1133
(24 #'read-pixarray-24)
1134
(32 #'read-pixarray-32))
1135
unit byte-lsb-first-p bit-lsb-first-p
1136
+image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)))
1138
(defun read-xy-format-image-x
1139
(buffer-bbuf index length data width height depth
1140
padded-bytes-per-line padded-bytes-per-plane
1141
unit byte-lsb-first-p bit-lsb-first-p pad)
1142
(declare (type buffer-bytes buffer-bbuf)
1143
(type card16 width height)
1144
(type array-index index length padded-bytes-per-line
1145
padded-bytes-per-plane)
1146
(type image-depth depth)
1147
(type (member 8 16 32) unit pad)
1148
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p)
1149
(clx-values image-x))
1150
(assert (index<= (index* depth padded-bytes-per-plane) length))
1151
(let* ((bytes-per-line (index-ceiling width 8))
1152
(data-length (index* padded-bytes-per-plane depth)))
1153
(declare (type array-index bytes-per-line data-length))
1155
(check-type data buffer-bytes)
1156
(assert (index>= (length data) data-length)))
1158
(setq data (make-array data-length :element-type 'card8))))
1159
(do ((plane 0 (index1+ plane)))
1160
((index>= plane depth))
1161
(declare (type image-depth plane))
1164
(index+ index (index* plane padded-bytes-per-plane))
1165
(index* plane padded-bytes-per-plane)
1166
bytes-per-line padded-bytes-per-line padded-bytes-per-line
1167
height byte-lsb-first-p))
1169
:width width :height height :depth depth :data data
1170
:bits-per-pixel 1 :format :xy-pixmap
1171
:bytes-per-line padded-bytes-per-line
1173
:byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p)))
1175
(defun read-z-format-image-x
1176
(buffer-bbuf index length data width height depth
1177
padded-bytes-per-line
1178
unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel)
1179
(declare (type buffer-bytes buffer-bbuf)
1180
(type card16 width height)
1181
(type array-index index length padded-bytes-per-line)
1182
(type image-depth depth)
1183
(type (member 8 16 32) unit pad)
1184
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p)
1185
(type (member 1 4 8 16 24 32) bits-per-pixel)
1186
(clx-values image-x))
1187
(assert (index<= (index* height padded-bytes-per-line) length))
1188
(let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8))
1189
(data-length (index* padded-bytes-per-line height)))
1190
(declare (type array-index bytes-per-line data-length))
1192
(check-type data buffer-bytes)
1193
(assert (index>= (length data) data-length)))
1195
(setq data (make-array data-length :element-type 'card8))))
1197
buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line
1198
padded-bytes-per-line height byte-lsb-first-p)
1200
:width width :height height :depth depth :data data
1201
:bits-per-pixel bits-per-pixel :format :z-pixmap
1202
:bytes-per-line padded-bytes-per-line
1204
:byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p)))
1206
(defun read-image-xy (bbuf index length data x y width height depth
1207
padded-bytes-per-line padded-bytes-per-plane
1208
unit byte-lsb-first-p bit-lsb-first-p)
1209
(declare (type buffer-bytes bbuf)
1210
(type card16 x y width height)
1211
(type array-index index length padded-bytes-per-line
1212
padded-bytes-per-plane)
1213
(type image-depth depth)
1214
(type (member 8 16 32) unit)
1215
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p)
1216
(clx-values image-xy))
1217
(check-type data list)
1218
(multiple-value-bind (dimensions element-type)
1220
(values (array-dimensions (first data))
1221
(array-element-type (first data)))
1222
(values (list height
1223
(index* (index-ceiling width +image-pad+) +image-pad+))
1224
'pixarray-1-element-type))
1227
(limit (index+ length index))
1228
(plane 0 (1+ plane))
1229
(index index (index+ index padded-bytes-per-plane)))
1230
((or (>= plane depth)
1231
(index> (index+ index padded-bytes-per-plane) limit))
1232
(setq data (nreverse result) depth (length data)))
1233
(declare (type array-index limit index)
1234
(type image-depth plane)
1235
(type list arrays result))
1236
(let ((array (or (pop arrays)
1237
(make-array dimensions :element-type element-type))))
1238
(declare (type pixarray-1 array))
1241
bbuf index array x y width height padded-bytes-per-line 1
1242
unit byte-lsb-first-p bit-lsb-first-p)))
1244
:width width :height height :depth depth :data data)))
1246
(defun read-image-z (bbuf index length data x y width height depth
1247
padded-bytes-per-line bits-per-pixel
1248
unit byte-lsb-first-p bit-lsb-first-p)
1249
(declare (type buffer-bytes bbuf)
1250
(type card16 x y width height)
1251
(type array-index index length padded-bytes-per-line)
1252
(type image-depth depth)
1253
(type (member 1 4 8 16 24 32) bits-per-pixel)
1254
(type (member 8 16 32) unit)
1255
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p)
1256
(clx-values image-z))
1257
(assert (index<= (index* (index+ y height) padded-bytes-per-line) length))
1258
(let* ((image-bits-per-line (index* width bits-per-pixel))
1259
(image-pixels-per-line
1261
(index* (index-ceiling image-bits-per-line +image-pad+)
1264
(declare (type array-index image-bits-per-line image-pixels-per-line))
1268
(list height image-pixels-per-line)
1269
:element-type (ecase bits-per-pixel
1270
(1 'pixarray-1-element-type)
1271
(4 'pixarray-4-element-type)
1272
(8 'pixarray-8-element-type)
1273
(16 'pixarray-16-element-type)
1274
(24 'pixarray-24-element-type)
1275
(32 'pixarray-32-element-type)))))
1277
bbuf index data x y width height padded-bytes-per-line bits-per-pixel
1278
unit byte-lsb-first-p bit-lsb-first-p)
1280
:width width :height height :depth depth :data data
1281
:bits-per-pixel bits-per-pixel)))
1283
(defun get-image (drawable &key
1285
(x (required-arg x))
1286
(y (required-arg y))
1287
(width (required-arg width))
1288
(height (required-arg height))
1289
plane-mask format result-type)
1290
(declare (type drawable drawable)
1291
(type (or buffer-bytes list pixarray) data)
1292
(type int16 x y) ;; required
1293
(type card16 width height) ;; required
1294
(type (or null pixel) plane-mask)
1295
(type (or null (member :xy-pixmap :z-pixmap)) format)
1296
(type (or null (member image-xy image-x image-z)) result-type)
1297
(clx-values image visual-info))
1299
(setq result-type (ecase format
1300
(:xy-pixmap 'image-xy)
1301
(:z-pixmap 'image-z)
1304
(setq format (case result-type
1305
(image-xy :xy-pixmap)
1306
((image-z image-x) :z-pixmap))))
1307
(unless (ecase result-type
1308
(image-xy (eq format :xy-pixmap))
1309
(image-z (eq format :z-pixmap))
1311
(error "Result-type ~s is incompatable with format ~s"
1312
result-type format))
1313
(unless plane-mask (setq plane-mask #xffffffff))
1314
(let ((display (drawable-display drawable)))
1315
(with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32))
1316
(((data (member error :xy-pixmap :z-pixmap)) format)
1319
(card16 width height)
1320
(card32 plane-mask))
1321
(let* ((depth (card8-get 1))
1322
(length (index* 4 (card32-get 4)))
1323
(visual-info (visual-info display (resource-id-get 8)))
1324
(bitmap-format (display-bitmap-format display))
1325
(unit (bitmap-format-unit bitmap-format))
1326
(byte-lsb-first-p (display-image-lsb-first-p display))
1327
(bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format)))
1328
(declare (type image-depth depth)
1329
(type array-index length)
1330
(type (or null visual-info) visual-info)
1331
(type bitmap-format bitmap-format)
1332
(type (member 8 16 32) unit)
1333
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1334
(multiple-value-bind (pad bits-per-pixel)
1337
(values (bitmap-format-pad bitmap-format) 1))
1340
(values (bitmap-format-pad bitmap-format) 1)
1341
(let ((pixmap-format
1342
(find depth (display-pixmap-formats display)
1343
:key #'pixmap-format-depth)))
1344
(declare (type pixmap-format pixmap-format))
1345
(values (pixmap-format-scanline-pad pixmap-format)
1346
(pixmap-format-bits-per-pixel pixmap-format))))))
1347
(declare (type (member 8 16 32) pad)
1348
(type (member 1 4 8 16 24 32) bits-per-pixel))
1349
(let* ((bits-per-line (index* bits-per-pixel width))
1350
(padded-bits-per-line
1351
(index* (index-ceiling bits-per-line pad) pad))
1352
(padded-bytes-per-line
1353
(index-ceiling padded-bits-per-line 8))
1354
(padded-bytes-per-plane
1355
(index* padded-bytes-per-line height))
1361
(read-xy-format-image-x
1362
buffer-bbuf +replysize+ length data
1364
padded-bytes-per-line padded-bytes-per-plane
1365
unit byte-lsb-first-p bit-lsb-first-p
1368
(read-z-format-image-x
1369
buffer-bbuf +replysize+ length data
1371
padded-bytes-per-line
1372
unit byte-lsb-first-p bit-lsb-first-p
1373
pad bits-per-pixel))))
1376
buffer-bbuf +replysize+ length data
1377
0 0 width height depth
1378
padded-bytes-per-line padded-bytes-per-plane
1379
unit byte-lsb-first-p bit-lsb-first-p))
1382
buffer-bbuf +replysize+ length data
1383
0 0 width height depth padded-bytes-per-line
1385
unit byte-lsb-first-p bit-lsb-first-p)))))
1386
(declare (type image image)
1387
(type array-index bits-per-line
1388
padded-bits-per-line padded-bytes-per-line))
1390
(unless (zerop (visual-info-red-mask visual-info))
1391
(setf (image-red-mask image)
1392
(visual-info-red-mask visual-info)))
1393
(unless (zerop (visual-info-green-mask visual-info))
1394
(setf (image-green-mask image)
1395
(visual-info-green-mask visual-info)))
1396
(unless (zerop (visual-info-blue-mask visual-info))
1397
(setf (image-blue-mask image)
1398
(visual-info-blue-mask visual-info))))
1399
(values image visual-info)))))))
1402
;;;-----------------------------------------------------------------------------
1405
(defun write-pixarray-1 (buffer-bbuf index array x y width height
1406
padded-bytes-per-line bits-per-pixel)
1407
(declare (type buffer-bytes buffer-bbuf)
1408
(type pixarray-1 array)
1409
(type card16 x y width height)
1410
(type array-index index padded-bytes-per-line)
1411
(type (member 1 4 8 16 24 32) bits-per-pixel)
1412
(ignore bits-per-pixel))
1414
(with-vector (buffer-bbuf buffer-bytes)
1415
(do* ((h 0 (index1+ h))
1417
(right-bits (index-mod width 8))
1418
(middle-bits (index- width right-bits))
1419
(middle-bytes (index-ceiling middle-bits 8))
1420
(start index (index+ start padded-bytes-per-line)))
1421
((index>= h height))
1422
(declare (type array-index h y right-bits middle-bits
1423
middle-bytes start))
1424
(do* ((end (index+ start middle-bytes))
1425
(i start (index1+ i))
1427
(x start-x (index+ x 8)))
1429
(unless (index-zerop right-bits)
1430
(let ((x (index+ start-x middle-bits)))
1431
(declare (type array-index x))
1432
(setf (aref buffer-bbuf end)
1433
(write-image-assemble-bytes
1434
(aref array y (index+ x 0))
1435
(if (index> right-bits 1)
1436
(aref array y (index+ x 1))
1438
(if (index> right-bits 2)
1439
(aref array y (index+ x 2))
1441
(if (index> right-bits 3)
1442
(aref array y (index+ x 3))
1444
(if (index> right-bits 4)
1445
(aref array y (index+ x 4))
1447
(if (index> right-bits 5)
1448
(aref array y (index+ x 5))
1450
(if (index> right-bits 6)
1451
(aref array y (index+ x 6))
1454
(declare (type array-index end i start-x x))
1455
(setf (aref buffer-bbuf i)
1456
(write-image-assemble-bytes
1457
(aref array y (index+ x 0))
1458
(aref array y (index+ x 1))
1459
(aref array y (index+ x 2))
1460
(aref array y (index+ x 3))
1461
(aref array y (index+ x 4))
1462
(aref array y (index+ x 5))
1463
(aref array y (index+ x 6))
1464
(aref array y (index+ x 7))))))))
1466
(defun write-pixarray-4 (buffer-bbuf index array x y width height
1467
padded-bytes-per-line bits-per-pixel)
1468
(declare (type buffer-bytes buffer-bbuf)
1469
(type pixarray-4 array)
1471
(type card16 width height)
1472
(type array-index index padded-bytes-per-line)
1473
(type (member 1 4 8 16 24 32) bits-per-pixel)
1474
(ignore bits-per-pixel))
1476
(with-vector (buffer-bbuf buffer-bytes)
1477
(do* ((h 0 (index1+ h))
1479
(right-nibbles (index-mod width 2))
1480
(middle-nibbles (index- width right-nibbles))
1481
(middle-bytes (index-ceiling middle-nibbles 2))
1482
(start index (index+ start padded-bytes-per-line)))
1483
((index>= h height))
1484
(declare (type array-index h y right-nibbles middle-nibbles
1485
middle-bytes start))
1486
(do* ((end (index+ start middle-bytes))
1487
(i start (index1+ i))
1489
(x start-x (index+ x 2)))
1491
(unless (index-zerop right-nibbles)
1492
(setf (aref buffer-bbuf end)
1493
(write-image-assemble-bytes
1494
(aref array y (index+ start-x middle-nibbles))
1496
(declare (type array-index end i start-x x))
1497
(setf (aref buffer-bbuf i)
1498
(write-image-assemble-bytes
1499
(aref array y (index+ x 0))
1500
(aref array y (index+ x 1))))))))
1502
(defun write-pixarray-8 (buffer-bbuf index array x y width height
1503
padded-bytes-per-line bits-per-pixel)
1504
(declare (type buffer-bytes buffer-bbuf)
1505
(type pixarray-8 array)
1507
(type card16 width height)
1508
(type array-index index padded-bytes-per-line)
1509
(type (member 1 4 8 16 24 32) bits-per-pixel)
1510
(ignore bits-per-pixel))
1512
(with-vector (buffer-bbuf buffer-bytes)
1513
(do* ((h 0 (index1+ h))
1515
(start index (index+ start padded-bytes-per-line)))
1516
((index>= h height))
1517
(declare (type array-index h y start))
1518
(do* ((end (index+ start width))
1519
(i start (index1+ i))
1522
(declare (type array-index end i x))
1523
(setf (aref buffer-bbuf i) (the card8 (aref array y x)))))))
1525
(defun write-pixarray-16 (buffer-bbuf index array x y width height
1526
padded-bytes-per-line bits-per-pixel)
1527
(declare (type buffer-bytes buffer-bbuf)
1528
(type pixarray-16 array)
1530
(type card16 width height)
1531
(type array-index index padded-bytes-per-line)
1532
(type (member 1 4 8 16 24 32) bits-per-pixel)
1533
(ignore bits-per-pixel))
1535
(with-vector (buffer-bbuf buffer-bytes)
1536
(do* ((h 0 (index1+ h))
1538
(start index (index+ start padded-bytes-per-line)))
1539
((index>= h height))
1540
(declare (type array-index h y start))
1541
(do* ((end (index+ start (index* width 2)))
1542
(i start (index+ i 2))
1545
(declare (type array-index end i x))
1546
(let ((pixel (aref array y x)))
1547
(declare (type pixarray-16-element-type pixel))
1548
(setf (aref buffer-bbuf (index+ i 0))
1549
(write-image-load-byte 0 pixel 16))
1550
(setf (aref buffer-bbuf (index+ i 1))
1551
(write-image-load-byte 8 pixel 16)))))))
1553
(defun write-pixarray-24 (buffer-bbuf index array x y width height
1554
padded-bytes-per-line bits-per-pixel)
1555
(declare (type buffer-bytes buffer-bbuf)
1556
(type pixarray-24 array)
1558
(type card16 width height)
1559
(type array-index index padded-bytes-per-line)
1560
(type (member 1 4 8 16 24 32) bits-per-pixel)
1561
(ignore bits-per-pixel))
1563
(with-vector (buffer-bbuf buffer-bytes)
1564
(do* ((h 0 (index1+ h))
1566
(start index (index+ start padded-bytes-per-line)))
1567
((index>= h height))
1568
(declare (type array-index y start))
1569
(do* ((end (index+ start (index* width 3)))
1570
(i start (index+ i 3))
1573
(declare (type array-index end i x))
1574
(let ((pixel (aref array y x)))
1575
(declare (type pixarray-24-element-type pixel))
1576
(setf (aref buffer-bbuf (index+ i 0))
1577
(write-image-load-byte 0 pixel 24))
1578
(setf (aref buffer-bbuf (index+ i 1))
1579
(write-image-load-byte 8 pixel 24))
1580
(setf (aref buffer-bbuf (index+ i 2))
1581
(write-image-load-byte 16 pixel 24)))))))
1583
(defun write-pixarray-32 (buffer-bbuf index array x y width height
1584
padded-bytes-per-line bits-per-pixel)
1585
(declare (type buffer-bytes buffer-bbuf)
1586
(type pixarray-32 array)
1588
(type card16 width height)
1589
(type array-index index padded-bytes-per-line)
1590
(type (member 1 4 8 16 24 32) bits-per-pixel)
1591
(ignore bits-per-pixel))
1593
(with-vector (buffer-bbuf buffer-bytes)
1594
(do* ((h 0 (index1+ h))
1596
(start index (index+ start padded-bytes-per-line)))
1597
((index>= h height))
1598
(declare (type array-index h y start))
1599
(do* ((end (index+ start (index* width 4)))
1600
(i start (index+ i 4))
1603
(declare (type array-index end i x))
1604
(let ((pixel (aref array y x)))
1605
(declare (type pixarray-32-element-type pixel))
1606
(setf (aref buffer-bbuf (index+ i 0))
1607
(write-image-load-byte 0 pixel 32))
1608
(setf (aref buffer-bbuf (index+ i 1))
1609
(write-image-load-byte 8 pixel 32))
1610
(setf (aref buffer-bbuf (index+ i 2))
1611
(write-image-load-byte 16 pixel 32))
1612
(setf (aref buffer-bbuf (index+ i 3))
1613
(write-image-load-byte 24 pixel 32)))))))
1615
(defun write-pixarray-internal
1616
(bbuf boffset pixarray x y width height padded-bytes-per-line
1617
bits-per-pixel write-pixarray-function
1618
from-unit from-byte-lsb-first-p from-bit-lsb-first-p
1619
to-unit to-byte-lsb-first-p to-bit-lsb-first-p)
1620
(declare (type buffer-bytes bbuf)
1621
(type pixarray pixarray)
1622
(type card16 x y width height)
1623
(type array-index boffset padded-bytes-per-line)
1624
(type (member 1 4 8 16 24 32) bits-per-pixel)
1625
(type function write-pixarray-function)
1626
(type (member 8 16 32) from-unit to-unit)
1627
(type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p
1628
to-byte-lsb-first-p to-bit-lsb-first-p))
1629
(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
1630
(image-swap-function
1632
from-unit from-byte-lsb-first-p from-bit-lsb-first-p
1633
to-unit to-byte-lsb-first-p to-bit-lsb-first-p)
1634
(declare (type symbol image-swap-function)
1635
(type generalized-boolean image-swap-lsb-first-p))
1636
(if (eq image-swap-function 'image-noswap)
1638
write-pixarray-function
1639
bbuf boffset pixarray x y width height padded-bytes-per-line
1641
(with-image-data-buffer (buf (index* height padded-bytes-per-line))
1643
write-pixarray-function
1644
buf 0 pixarray x y width height padded-bytes-per-line
1647
(symbol-function image-swap-function) buf bbuf 0 boffset
1648
(index-ceiling (index* width bits-per-pixel) 8)
1649
padded-bytes-per-line padded-bytes-per-line height
1650
image-swap-lsb-first-p)))))
1652
(defun write-pixarray
1653
(bbuf boffset pixarray x y width height padded-bytes-per-line
1654
bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1655
(declare (type buffer-bytes bbuf)
1656
(type pixarray pixarray)
1657
(type card16 x y width height)
1658
(type array-index boffset padded-bytes-per-line)
1659
(type (member 1 4 8 16 24 32) bits-per-pixel)
1660
(type (member 8 16 32) unit)
1661
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1662
(unless (fast-write-pixarray
1663
bbuf boffset pixarray x y width height padded-bytes-per-line
1664
bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1665
(write-pixarray-internal
1666
bbuf boffset pixarray x y width height padded-bytes-per-line
1668
(ecase bits-per-pixel
1669
( 1 #'write-pixarray-1 )
1670
( 4 #'write-pixarray-4 )
1671
( 8 #'write-pixarray-8 )
1672
(16 #'write-pixarray-16)
1673
(24 #'write-pixarray-24)
1674
(32 #'write-pixarray-32))
1675
+image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+
1676
unit byte-lsb-first-p bit-lsb-first-p)))
1678
(defun write-xy-format-image-x-data
1679
(data obuf data-start obuf-start x y width height
1680
from-padded-bytes-per-line to-padded-bytes-per-line
1681
from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
1682
to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
1683
(declare (type buffer-bytes data obuf)
1684
(type array-index data-start obuf-start
1685
from-padded-bytes-per-line to-padded-bytes-per-line)
1686
(type card16 x y width height)
1687
(type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
1688
(type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p
1689
to-byte-lsb-first-p to-bit-lsb-first-p))
1690
(assert (index-zerop (index-mod x 8)))
1691
(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
1692
(image-swap-function
1694
from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
1695
to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
1696
(declare (type symbol image-swap-function)
1697
(type generalized-boolean image-swap-lsb-first-p))
1698
(let ((x-mod-unit (index-mod x from-bitmap-unit)))
1699
(declare (type card16 x-mod-unit))
1700
(if (and (index-plusp x-mod-unit)
1701
(not (eq from-byte-lsb-first-p from-bit-lsb-first-p)))
1702
(let* ((temp-width (index+ width x-mod-unit))
1703
(temp-bytes-per-line (index-ceiling temp-width 8))
1704
(temp-padded-bits-per-line
1705
(index* (index-ceiling temp-width from-bitmap-unit)
1707
(temp-padded-bytes-per-line
1708
(index-ceiling temp-padded-bits-per-line 8)))
1709
(declare (type card16 temp-width temp-bytes-per-line
1710
temp-padded-bits-per-line temp-padded-bytes-per-line))
1711
(with-image-data-buffer
1712
(buf (index* height temp-padded-bytes-per-line))
1714
(symbol-function image-swap-function) data buf
1716
(index* y from-padded-bytes-per-line)
1717
(index-floor (index- x x-mod-unit) 8))
1718
0 temp-bytes-per-line from-padded-bytes-per-line
1719
temp-padded-bytes-per-line height image-swap-lsb-first-p)
1720
(write-xy-format-image-x-data
1721
buf obuf 0 obuf-start x-mod-unit 0 width height
1722
temp-padded-bytes-per-line to-padded-bytes-per-line
1723
from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p
1724
to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)))
1726
(symbol-function image-swap-function) data obuf
1728
(index* y from-padded-bytes-per-line)
1730
obuf-start (index-ceiling width 8) from-padded-bytes-per-line
1731
to-padded-bytes-per-line height image-swap-lsb-first-p)))))
1733
(defun write-xy-format-image-x
1734
(display image src-x src-y width height
1735
padded-bytes-per-line
1736
unit byte-lsb-first-p bit-lsb-first-p)
1737
(declare (type display display)
1738
(type image-x image)
1739
(type int16 src-x src-y)
1740
(type card16 width height)
1741
(type array-index padded-bytes-per-line)
1742
(type (member 8 16 32) unit)
1743
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1744
(dotimes (plane (image-depth image))
1746
(index* (index* plane (image-height image))
1747
(image-x-bytes-per-line image)))
1750
(declare (type int16 src-y)
1751
(type card16 height))
1753
(when (index-zerop height) (return))
1755
(index-min (index-floor (index- (buffer-size display)
1756
(buffer-boffset display))
1757
padded-bytes-per-line)
1759
(declare (type array-index nlines))
1760
(when (index-plusp nlines)
1761
(write-xy-format-image-x-data
1762
(image-x-data image) (buffer-obuf8 display)
1763
data-start (buffer-boffset display)
1764
src-x src-y width nlines
1765
(image-x-bytes-per-line image) padded-bytes-per-line
1766
(image-x-unit image) (image-x-byte-lsb-first-p image)
1767
(image-x-bit-lsb-first-p image)
1768
unit byte-lsb-first-p bit-lsb-first-p)
1769
(index-incf (buffer-boffset display)
1770
(index* nlines padded-bytes-per-line))
1771
(index-incf src-y nlines)
1772
(when (index-zerop (index-decf height nlines)) (return))))
1773
(buffer-flush display)))))
1775
(defun write-z-format-image-x-data
1776
(data obuf data-start obuf-start x y width height
1777
from-padded-bytes-per-line to-padded-bytes-per-line
1779
from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
1780
to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
1781
(declare (type buffer-bytes data obuf)
1782
(type array-index data-start obuf-start
1783
from-padded-bytes-per-line to-padded-bytes-per-line)
1784
(type card16 x y width height)
1785
(type (member 1 4 8 16 24 32) bits-per-pixel)
1786
(type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
1787
(type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p
1788
to-byte-lsb-first-p to-bit-lsb-first-p))
1789
(if (index= bits-per-pixel 1)
1790
(write-xy-format-image-x-data
1791
data obuf data-start obuf-start x y width height
1792
from-padded-bytes-per-line to-padded-bytes-per-line
1793
from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
1794
to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
1797
(index* y from-padded-bytes-per-line)
1798
(index-floor (index* x bits-per-pixel) 8)))
1799
(srclen (index-ceiling (index* width bits-per-pixel) 8)))
1800
(declare (type array-index srcoff srclen))
1801
(if (and (index= bits-per-pixel 4) (index-oddp x))
1802
(with-image-data-buffer (buf (index* height to-padded-bytes-per-line))
1803
(image-swap-nibbles-left
1804
data buf srcoff 0 srclen
1805
from-padded-bytes-per-line to-padded-bytes-per-line height nil)
1806
(write-z-format-image-x-data
1807
buf obuf 0 obuf-start 0 0 width height
1808
to-padded-bytes-per-line to-padded-bytes-per-line
1810
from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
1811
to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))
1812
(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
1813
(image-swap-function
1815
from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
1816
to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
1817
(declare (type symbol image-swap-function)
1818
(type generalized-boolean image-swap-lsb-first-p))
1820
(symbol-function image-swap-function) data obuf srcoff obuf-start
1821
srclen from-padded-bytes-per-line to-padded-bytes-per-line height
1822
image-swap-lsb-first-p))))))
1824
(defun write-z-format-image-x (display image src-x src-y width height
1825
padded-bytes-per-line
1826
unit byte-lsb-first-p bit-lsb-first-p)
1827
(declare (type display display)
1828
(type image-x image)
1829
(type int16 src-x src-y)
1830
(type card16 width height)
1831
(type array-index padded-bytes-per-line)
1832
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1834
(when (index-zerop height) (return))
1836
(index-min (index-floor (index- (buffer-size display)
1837
(buffer-boffset display))
1838
padded-bytes-per-line)
1840
(declare (type array-index nlines))
1841
(when (index-plusp nlines)
1842
(write-z-format-image-x-data
1843
(image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display)
1844
src-x src-y width nlines
1845
(image-x-bytes-per-line image) padded-bytes-per-line
1846
(image-x-bits-per-pixel image)
1847
(image-x-unit image) (image-x-byte-lsb-first-p image)
1848
(image-x-bit-lsb-first-p image)
1849
unit byte-lsb-first-p bit-lsb-first-p)
1850
(index-incf (buffer-boffset display)
1851
(index* nlines padded-bytes-per-line))
1852
(index-incf src-y nlines)
1853
(when (index-zerop (index-decf height nlines)) (return))))
1854
(buffer-flush display)))
1856
(defun write-image-xy (display image src-x src-y width height
1857
padded-bytes-per-line
1858
unit byte-lsb-first-p bit-lsb-first-p)
1859
(declare (type display display)
1860
(type image-xy image)
1861
(type array-index padded-bytes-per-line)
1862
(type int16 src-x src-y)
1863
(type card16 width height)
1864
(type (member 8 16 32) unit)
1865
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1866
(dolist (bitmap (image-xy-bitmap-list image))
1867
(declare (type pixarray-1 bitmap))
1870
(declare (type int16 src-y)
1871
(type card16 height))
1874
(index-min (index-floor (index- (buffer-size display)
1875
(buffer-boffset display))
1876
padded-bytes-per-line)
1878
(declare (type array-index nlines))
1879
(when (index-plusp nlines)
1881
(buffer-obuf8 display) (buffer-boffset display)
1882
bitmap src-x src-y width nlines
1883
padded-bytes-per-line 1
1884
unit byte-lsb-first-p bit-lsb-first-p)
1885
(index-incf (buffer-boffset display)
1886
(index* nlines padded-bytes-per-line))
1887
(index-incf src-y nlines)
1888
(when (index-zerop (index-decf height nlines)) (return))))
1889
(buffer-flush display)))))
1891
(defun write-image-z (display image src-x src-y width height
1892
padded-bytes-per-line
1893
unit byte-lsb-first-p bit-lsb-first-p)
1894
(declare (type display display)
1895
(type image-z image)
1896
(type array-index padded-bytes-per-line)
1897
(type int16 src-x src-y)
1898
(type card16 width height)
1899
(type (member 8 16 32) unit)
1900
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1902
(let ((bits-per-pixel (image-z-bits-per-pixel image))
1904
(index-min (index-floor (index- (buffer-size display)
1905
(buffer-boffset display))
1906
padded-bytes-per-line)
1908
(declare (type (member 1 4 8 16 24 32) bits-per-pixel)
1909
(type array-index nlines))
1910
(when (index-plusp nlines)
1912
(buffer-obuf8 display) (buffer-boffset display)
1913
(image-z-pixarray image) src-x src-y width nlines
1914
padded-bytes-per-line bits-per-pixel
1915
unit byte-lsb-first-p bit-lsb-first-p)
1916
(index-incf (buffer-boffset display)
1917
(index* nlines padded-bytes-per-line))
1918
(index-incf src-y nlines)
1919
(when (index-zerop (index-decf height nlines)) (return))))
1920
(buffer-flush display)))
1922
;;; Note: The only difference between a format of :bitmap and :xy-pixmap
1923
;;; of depth 1 is that when sending a :bitmap format the foreground
1924
;;; and background in the gcontext are used.
1926
(defun put-image (drawable gcontext image &key
1927
(src-x 0) (src-y 0) ;Position within image
1928
(x (required-arg x)) ;Position within drawable
1929
(y (required-arg y))
1932
;; Copy an image into a drawable.
1933
;; WIDTH and HEIGHT default from IMAGE.
1934
;; When BITMAP-P, force format to be :bitmap when depth=1.
1935
;; This causes gcontext to supply foreground & background pixels.
1936
(declare (type drawable drawable)
1937
(type gcontext gcontext)
1939
(type int16 x y) ;; required
1940
(type int16 src-x src-y)
1941
(type (or null card16) width height)
1942
(type generalized-boolean bitmap-p))
1945
(image-x (image-x-format (the image-x image)))
1946
(image-xy :xy-pixmap)
1947
(image-z :z-pixmap)))
1949
(if (image-x-p image)
1950
(index+ src-x (image-x-left-pad (the image-x image)))
1952
(image-width (image-width image))
1953
(image-height (image-height image))
1954
(width (min (or width image-width) (index- image-width src-x)))
1955
(height (min (or height image-height) (index- image-height src-y)))
1956
(depth (image-depth image))
1957
(display (drawable-display drawable))
1958
(bitmap-format (display-bitmap-format display))
1959
(unit (bitmap-format-unit bitmap-format))
1960
(byte-lsb-first-p (display-image-lsb-first-p display))
1961
(bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format)))
1962
(declare (type (member :bitmap :xy-pixmap :z-pixmap) format)
1963
(type fixnum src-x image-width image-height width height)
1964
(type image-depth depth)
1965
(type display display)
1966
(type bitmap-format bitmap-format)
1967
(type (member 8 16 32) unit)
1968
(type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1969
(when (and bitmap-p (not (index= depth 1)))
1970
(error "Bitmaps must have depth 1"))
1971
(unless (<= 0 src-x (index1- (image-width image)))
1972
(error "src-x not inside image"))
1973
(unless (<= 0 src-y (index1- (image-height image)))
1974
(error "src-y not inside image"))
1975
(when (and (index> width 0) (index> height 0))
1976
(multiple-value-bind (pad bits-per-pixel)
1978
((:bitmap :xy-pixmap)
1979
(values (bitmap-format-pad bitmap-format) 1))
1982
(values (bitmap-format-pad bitmap-format) 1)
1983
(let ((pixmap-format
1984
(find depth (display-pixmap-formats display)
1985
:key #'pixmap-format-depth)))
1986
(declare (type (or null pixmap-format) pixmap-format))
1987
(if (null pixmap-format)
1988
(error "The depth of the image ~s does not match any server pixmap format." image))
1989
(if (not (= (etypecase image
1990
(image-z (image-z-bits-per-pixel image))
1991
(image-x (image-x-bits-per-pixel image)))
1992
(pixmap-format-bits-per-pixel pixmap-format)))
1993
;; We could try to use the "/* XXX slow, but works */"
1994
;; code in XPutImage from X11R4 here. However, that
1995
;; would require considerable support code
1996
;; (see XImUtil.c, etc).
1997
(error "The bits-per-pixel of the image ~s does not match any server pixmap format." image))
1998
(values (pixmap-format-scanline-pad pixmap-format)
1999
(pixmap-format-bits-per-pixel pixmap-format))))))
2000
(declare (type (member 8 16 32) pad)
2001
(type (member 1 4 8 16 24 32) bits-per-pixel))
2003
(if (or (eq format :xy-pixmap) (= depth 1))
2004
(index-mod src-x (index-min pad +image-pad+))
2006
(left-padded-src-x (index- src-x left-pad))
2007
(left-padded-width (index+ width left-pad))
2008
(bits-per-line (index* left-padded-width bits-per-pixel))
2009
(padded-bits-per-line
2010
(index* (index-ceiling bits-per-line pad) pad))
2011
(padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
2012
(request-bytes-per-line
2014
((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth))
2015
(:z-pixmap padded-bytes-per-line)))
2016
(max-bytes-per-request
2017
(index* (index- (display-max-request-length display) 6) 4))
2019
(floor max-bytes-per-request request-bytes-per-line)))
2020
(declare (type card8 left-pad)
2021
(type int16 left-padded-src-x)
2022
(type card16 left-padded-width)
2023
(type array-index bits-per-line padded-bits-per-line
2024
padded-bytes-per-line request-bytes-per-line
2025
max-bytes-per-request max-request-height))
2026
;; Be sure that a scanline can fit in a request
2027
(when (index-zerop max-request-height)
2028
(error "Can't even fit one image scanline in a request"))
2029
;; Be sure a scanline can fit in a buffer
2030
(buffer-ensure-size display padded-bytes-per-line)
2031
;; Send the image in multiple requests to avoid exceeding the
2033
(do* ((request-src-y src-y (index+ request-src-y request-height))
2034
(request-y y (index+ request-y request-height))
2036
height (the fixnum (- height-remaining request-height)))
2038
(index-min height-remaining max-request-height)
2039
(index-min height-remaining max-request-height)))
2040
((<= height-remaining 0))
2041
(declare (type array-index request-src-y request-height)
2042
(fixnum height-remaining))
2043
(let* ((request-bytes (index* request-bytes-per-line request-height))
2044
(request-words (index-ceiling request-bytes 4))
2045
(request-length (index+ request-words 6)))
2046
(declare (type array-index request-bytes)
2047
(type card16 request-words request-length))
2048
(with-buffer-request (display +x-putimage+ :gc-force gcontext)
2049
((data (member :bitmap :xy-pixmap :z-pixmap))
2050
(cond ((or (eq format :bitmap) bitmap-p) :bitmap)
2051
((plusp left-pad) :xy-pixmap)
2055
(card16 width request-height)
2057
(card8 left-pad depth)
2060
(length-put 2 request-length)
2061
(setf (buffer-boffset display) (advance-buffer-offset 24))
2064
(ecase (image-x-format (the image-x image))
2065
((:bitmap :xy-pixmap)
2066
(write-xy-format-image-x
2067
display image left-padded-src-x request-src-y
2068
left-padded-width request-height
2069
padded-bytes-per-line
2070
unit byte-lsb-first-p bit-lsb-first-p))
2072
(write-z-format-image-x
2073
display image left-padded-src-x request-src-y
2074
left-padded-width request-height
2075
padded-bytes-per-line
2076
unit byte-lsb-first-p bit-lsb-first-p))))
2079
display image left-padded-src-x request-src-y
2080
left-padded-width request-height
2081
padded-bytes-per-line
2082
unit byte-lsb-first-p bit-lsb-first-p))
2085
display image left-padded-src-x request-src-y
2086
left-padded-width request-height
2087
padded-bytes-per-line
2088
unit byte-lsb-first-p bit-lsb-first-p)))
2089
;; Be sure the request is padded to a multiple of 4 bytes
2090
(buffer-pad-request display (index- (index* request-words 4) request-bytes))
2093
;;;-----------------------------------------------------------------------------
2096
(defun xy-format-image-x->image-x (image x y width height)
2097
(declare (type image-x image)
2098
(type card16 x y width height)
2099
(clx-values image-x))
2100
(let* ((padded-x (index+ x (image-x-left-pad image)))
2101
(left-pad (index-mod padded-x 8))
2102
(x (index- padded-x left-pad))
2103
(unit (image-x-unit image))
2104
(byte-lsb-first-p (image-x-byte-lsb-first-p image))
2105
(bit-lsb-first-p (image-x-bit-lsb-first-p image))
2106
(pad (image-x-pad image))
2108
(index* (index-ceiling (index+ width left-pad) pad) pad))
2109
(padded-bytes-per-line (index-ceiling padded-width 8))
2110
(padded-bytes-per-plane (index* padded-bytes-per-line height))
2111
(length (index* padded-bytes-per-plane (image-depth image)))
2112
(obuf (make-array length :element-type 'card8)))
2113
(declare (type card16 x)
2114
(type card8 left-pad)
2115
(type (member 8 16 32) unit pad)
2116
(type array-index padded-width padded-bytes-per-line
2117
padded-bytes-per-plane length)
2118
(type buffer-bytes obuf))
2119
(dotimes (plane (image-depth image))
2121
(index* (image-x-bytes-per-line image)
2122
(image-height image)
2125
(index* padded-bytes-per-plane
2127
(declare (type array-index data-start obuf-start))
2128
(write-xy-format-image-x-data
2129
(image-x-data image) obuf data-start obuf-start
2131
(image-x-bytes-per-line image) padded-bytes-per-line
2132
unit byte-lsb-first-p bit-lsb-first-p
2133
unit byte-lsb-first-p bit-lsb-first-p)))
2135
:width width :height height :depth (image-depth image)
2136
:data obuf :format (image-x-format image) :bits-per-pixel 1
2137
:bytes-per-line padded-bytes-per-line
2138
:unit unit :pad pad :left-pad left-pad
2139
:byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p)))
2141
(defun z-format-image-x->image-x (image x y width height)
2142
(declare (type image-x image)
2143
(type card16 x y width height)
2144
(clx-values image-x))
2145
(let* ((padded-x (index+ x (image-x-left-pad image)))
2147
(if (index= (image-depth image) 1)
2148
(index-mod padded-x 8)
2150
(x (index- padded-x left-pad))
2151
(bits-per-pixel (image-x-bits-per-pixel image))
2152
(unit (image-x-unit image))
2153
(byte-lsb-first-p (image-x-byte-lsb-first-p image))
2154
(bit-lsb-first-p (image-x-bit-lsb-first-p image))
2155
(pad (image-x-pad image))
2156
(bits-per-line (index* (index+ width left-pad) bits-per-pixel))
2157
(padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad))
2158
(padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
2159
(padded-bytes-per-plane (index* padded-bytes-per-line height))
2160
(length (index* padded-bytes-per-plane (image-depth image)))
2161
(obuf (make-array length :element-type 'card8)))
2162
(declare (type card16 x)
2163
(type card8 left-pad)
2164
(type (member 8 16 32) unit pad)
2165
(type array-index bits-per-pixel padded-bytes-per-line
2166
padded-bytes-per-plane length)
2167
(type buffer-bytes obuf))
2168
(write-z-format-image-x-data
2169
(image-x-data image) obuf 0 0
2171
(image-x-bytes-per-line image) padded-bytes-per-line
2173
unit byte-lsb-first-p bit-lsb-first-p
2174
unit byte-lsb-first-p bit-lsb-first-p)
2176
:width width :height height :depth (image-depth image)
2177
:data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel
2178
:bytes-per-line padded-bytes-per-line
2179
:unit unit :pad pad :left-pad left-pad
2180
:byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p)))
2182
(defun image-x->image-x (image x y width height)
2183
(declare (type image-x image)
2184
(type card16 x y width height)
2185
(clx-values image-x))
2186
(ecase (image-x-format image)
2187
((:bitmap :xy-pixmap)
2188
(xy-format-image-x->image-x image x y width height))
2190
(z-format-image-x->image-x image x y width height))))
2192
(defun image-x->image-xy (image x y width height)
2193
(declare (type image-x image)
2194
(type card16 x y width height)
2195
(clx-values image-xy))
2196
(unless (or (eq (image-x-format image) :bitmap)
2197
(eq (image-x-format image) :xy-pixmap)
2198
(and (eq (image-x-format image) :z-pixmap)
2199
(index= (image-depth image) 1)))
2200
(error "Format conversion from ~S to ~S not supported"
2201
(image-x-format image) :xy-pixmap))
2203
(image-x-data image) 0 (length (image-x-data image)) nil
2204
(index+ x (image-x-left-pad image)) y width height
2205
(image-depth image) (image-x-bytes-per-line image)
2206
(index* (image-x-bytes-per-line image) (image-height image))
2207
(image-x-unit image) (image-x-byte-lsb-first-p image)
2208
(image-x-bit-lsb-first-p image)))
2210
(defun image-x->image-z (image x y width height)
2211
(declare (type image-x image)
2212
(type card16 x y width height)
2213
(clx-values image-z))
2214
(unless (or (eq (image-x-format image) :z-pixmap)
2215
(eq (image-x-format image) :bitmap)
2216
(and (eq (image-x-format image) :xy-pixmap)
2217
(index= (image-depth image) 1)))
2218
(error "Format conversion from ~S to ~S not supported"
2219
(image-x-format image) :z-pixmap))
2221
(image-x-data image) 0 (length (image-x-data image)) nil
2222
(index+ x (image-x-left-pad image)) y width height
2223
(image-depth image) (image-x-bytes-per-line image)
2224
(image-x-bits-per-pixel image)
2225
(image-x-unit image) (image-x-byte-lsb-first-p image)
2226
(image-x-bit-lsb-first-p image)))
2228
(defun copy-pixarray (array x y width height bits-per-pixel)
2229
(declare (type pixarray array)
2230
(type card16 x y width height)
2231
(type (member 1 4 8 16 24 32) bits-per-pixel))
2232
(let* ((bits-per-line (index* bits-per-pixel width))
2233
(padded-bits-per-line
2234
(index* (index-ceiling bits-per-line +image-pad+) +image-pad+))
2235
(padded-width (index-ceiling padded-bits-per-line bits-per-pixel))
2236
(copy (make-array (list height padded-width)
2237
:element-type (array-element-type array))))
2238
(declare (type array-index bits-per-line padded-bits-per-line padded-width)
2239
(type pixarray copy))
2241
(unless (fast-copy-pixarray array copy x y width height bits-per-pixel)
2243
((copy (array-type element-type)
2244
`(let ((array array)
2246
(declare (type ,array-type array copy))
2247
(do* ((dst-y 0 (index1+ dst-y))
2248
(src-y y (index1+ src-y)))
2249
((index>= dst-y height))
2250
(declare (type card16 dst-y src-y))
2251
(do* ((dst-x 0 (index1+ dst-x))
2252
(src-x x (index1+ src-x)))
2253
((index>= dst-x width))
2254
(declare (type card16 dst-x src-x))
2255
(setf (aref copy dst-y dst-x)
2257
(aref array src-y src-x))))))))
2258
(ecase bits-per-pixel
2259
(1 (copy pixarray-1 pixarray-1-element-type))
2260
(4 (copy pixarray-4 pixarray-4-element-type))
2261
(8 (copy pixarray-8 pixarray-8-element-type))
2262
(16 (copy pixarray-16 pixarray-16-element-type))
2263
(24 (copy pixarray-24 pixarray-24-element-type))
2264
(32 (copy pixarray-32 pixarray-32-element-type)))))
2267
(defun image-xy->image-x (image x y width height)
2268
(declare (type image-xy image)
2269
(type card16 x y width height)
2270
(clx-values image-x))
2271
(let* ((padded-bits-per-line
2272
(index* (index-ceiling width +image-pad+) +image-pad+))
2273
(padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
2274
(padded-bytes-per-plane (index* padded-bytes-per-line height))
2275
(bytes-total (index* padded-bytes-per-plane (image-depth image)))
2276
(data (make-array bytes-total :element-type 'card8)))
2277
(declare (type array-index padded-bits-per-line padded-bytes-per-line
2278
padded-bytes-per-plane bytes-total)
2279
(type buffer-bytes data))
2281
(declare (type array-index index))
2282
(dolist (bitmap (image-xy-bitmap-list image))
2283
(declare (type pixarray-1 bitmap))
2285
data index bitmap x y width height padded-bytes-per-line 1
2286
+image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)
2287
(index-incf index padded-bytes-per-plane)))
2289
:width width :height height :depth (image-depth image)
2290
:data data :format :xy-pixmap :bits-per-pixel 1
2291
:bytes-per-line padded-bytes-per-line
2292
:unit +image-unit+ :pad +image-pad+
2293
:byte-lsb-first-p +image-byte-lsb-first-p+
2294
:bit-lsb-first-p +image-bit-lsb-first-p+)))
2296
(defun image-xy->image-xy (image x y width height)
2297
(declare (type image-xy image)
2298
(type card16 x y width height)
2299
(clx-values image-xy))
2301
:width width :height height :depth (image-depth image)
2304
(declare (type pixarray-1 array))
2305
(copy-pixarray array x y width height 1))
2306
(image-xy-bitmap-list image))))
2308
(defun image-xy->image-z (image x y width height)
2309
(declare (type image-xy image)
2310
(type card16 x y width height)
2311
(ignore image x y width height))
2312
(error "Format conversion from ~S to ~S not supported"
2313
:xy-pixmap :z-pixmap))
2315
(defun image-z->image-x (image x y width height)
2316
(declare (type image-z image)
2317
(type card16 x y width height)
2318
(clx-values image-x))
2319
(let* ((bits-per-line (index* width (image-z-bits-per-pixel image)))
2320
(padded-bits-per-line
2321
(index* (index-ceiling bits-per-line +image-pad+) +image-pad+))
2322
(padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
2324
(index* padded-bytes-per-line height (image-depth image)))
2325
(data (make-array bytes-total :element-type 'card8))
2326
(bits-per-pixel (image-z-bits-per-pixel image)))
2327
(declare (type array-index bits-per-line padded-bits-per-line
2328
padded-bytes-per-line bytes-total)
2329
(type buffer-bytes data)
2330
(type (member 1 4 8 16 24 32) bits-per-pixel))
2332
data 0 (image-z-pixarray image) x y width height padded-bytes-per-line
2333
(image-z-bits-per-pixel image)
2334
+image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)
2336
:width width :height height :depth (image-depth image)
2337
:data data :format :z-pixmap
2338
:bits-per-pixel bits-per-pixel
2339
:bytes-per-line padded-bytes-per-line
2340
:unit +image-unit+ :pad +image-pad+
2341
:byte-lsb-first-p +image-byte-lsb-first-p+
2342
:bit-lsb-first-p +image-bit-lsb-first-p+)))
2344
(defun image-z->image-xy (image x y width height)
2345
(declare (type image-z image)
2346
(type card16 x y width height)
2347
(ignore image x y width height))
2348
(error "Format conversion from ~S to ~S not supported"
2349
:z-pixmap :xy-pixmap))
2351
(defun image-z->image-z (image x y width height)
2352
(declare (type image-z image)
2353
(type card16 x y width height)
2354
(clx-values image-z))
2356
:width width :height height :depth (image-depth image)
2357
:data (copy-pixarray
2358
(image-z-pixarray image) x y width height
2359
(image-z-bits-per-pixel image))))
2361
(defun copy-image (image &key (x 0) (y 0) width height result-type)
2362
;; Copy with optional sub-imaging and format conversion.
2363
;; result-type defaults to (type-of image)
2364
(declare (type image image)
2366
(type (or null card16) width height) ;; Default from image
2367
(type (or null (member image-x image-xy image-z)) result-type))
2368
(declare (clx-values image))
2369
(let* ((image-width (image-width image))
2370
(image-height (image-height image))
2371
(width (or width image-width))
2372
(height (or height image-height)))
2373
(declare (type card16 image-width image-height width height))
2374
(unless (<= 0 x (the fixnum (1- image-width)))
2375
(error "x not inside image"))
2376
(unless (<= 0 y (the fixnum (1- image-height)))
2377
(error "y not inside image"))
2378
(setq width (index-min width (max (the fixnum (- image-width x)) 0)))
2379
(setq height (index-min height (max (the fixnum (- image-height y)) 0)))
2384
((nil image-x) (image-x->image-x image x y width height))
2385
(image-xy (image-x->image-xy image x y width height))
2386
(image-z (image-x->image-z image x y width height))))
2389
(image-x (image-xy->image-x image x y width height))
2390
((nil image-xy) (image-xy->image-xy image x y width height))
2391
(image-z (image-xy->image-z image x y width height))))
2394
(image-x (image-z->image-x image x y width height))
2395
(image-xy (image-z->image-xy image x y width height))
2396
((nil image-z) (image-z->image-z image x y width height)))))))
2397
(declare (type image copy))
2398
(setf (image-plist copy) (copy-list (image-plist image)))
2399
(when (and (image-x-hot image) (not (index-zerop x)))
2400
(setf (image-x-hot copy) (index- (image-x-hot image) x)))
2401
(when (and (image-y-hot image) (not (index-zerop y)))
2402
(setf (image-y-hot copy) (index- (image-y-hot image) y)))
2406
;;;-----------------------------------------------------------------------------
2407
;;; Image I/O functions
2410
(defun read-bitmap-file (pathname)
2411
;; Creates an image from a C include file in standard X11 format
2412
(declare (type (or pathname string stream) pathname))
2413
(declare (clx-values image))
2414
(with-open-file (fstream pathname :direction :input)
2419
(declare (type string line)
2420
(type stringable name)
2421
(type list properties))
2424
(setq line (read-line fstream))
2425
(unless (char= (aref line 0) #\#) (return))
2426
(flet ((read-keyword (line start end)
2430
(#-excl string-upcase
2432
(subseq line start end))
2435
(setq name-end (position #\_ line :test #'char= :from-end t)
2436
name (read-keyword line 8 name-end))
2437
(unless (eq name :image)
2438
(setf (getf properties :name) name)))
2439
(let* ((ind-start (index1+ name-end))
2440
(ind-end (position #\Space line :test #'char=
2442
(ind (read-keyword line ind-start ind-end))
2443
(val-start (index1+ ind-end))
2444
(val (parse-integer line :start val-start)))
2445
(setf (getf properties ind) val))))
2447
(multiple-value-bind (width height depth left-pad)
2448
(flet ((extract-property (ind &rest default)
2449
(prog1 (apply #'getf properties ind default)
2450
(remf properties ind))))
2451
(values (extract-property :width)
2452
(extract-property :height)
2453
(extract-property :depth 1)
2454
(extract-property :left-pad 0)))
2455
(declare (type (or null card16) width height)
2456
(type image-depth depth)
2457
(type card8 left-pad))
2458
(unless (and width height) (error "Not a BITMAP file"))
2459
(let* ((bits-per-pixel
2460
(cond ((index> depth 24) 32)
2461
((index> depth 16) 24)
2462
((index> depth 8) 16)
2463
((index> depth 4) 8)
2464
((index> depth 1) 4)
2466
(bits-per-line (index* width bits-per-pixel))
2467
(bytes-per-line (index-ceiling bits-per-line 8))
2468
(padded-bits-per-line
2469
(index* (index-ceiling bits-per-line 32) 32))
2470
(padded-bytes-per-line
2471
(index-ceiling padded-bits-per-line 8))
2472
(data (make-array (* padded-bytes-per-line height)
2473
:element-type 'card8))
2476
(declare (type array-index bits-per-line bytes-per-line
2477
padded-bits-per-line padded-bytes-per-line
2479
(type buffer-bytes data))
2480
(with-vector (data buffer-bytes)
2481
(flet ((parse-hex (char)
2484
'((#\0 0) (#\1 1) (#\2 2) (#\3 3)
2485
(#\4 4) (#\5 5) (#\6 6) (#\7 7)
2486
(#\8 8) (#\9 9) (#\a 10) (#\b 11)
2487
(#\c 12) (#\d 13) (#\e 14) (#\f 15))
2488
:test #'char-equal))))
2489
(declare (inline parse-hex))
2491
;; Note: using read-line instead of read-char would be 20% faster,
2492
;; but would cons a lot of garbage...
2494
(dotimes (j bytes-per-line)
2495
(loop (when (eql (read-char fstream) #\x) (return)))
2496
(setf (aref data (index+ line-base byte))
2497
(index+ (index-ash (parse-hex (read-char fstream)) 4)
2498
(parse-hex (read-char fstream))))
2501
line-base (index+ line-base padded-bytes-per-line)))))
2502
;; Compensate for left-pad in width and x-hot
2503
(index-decf width left-pad)
2504
(when (and (getf properties :x-hot) (plusp (getf properties :x-hot)))
2505
(index-decf (getf properties :x-hot) left-pad))
2507
:width width :height height
2508
:depth depth :bits-per-pixel bits-per-pixel
2509
:data data :plist properties :format :z-pixmap
2510
:bytes-per-line padded-bytes-per-line
2511
:unit 32 :pad 32 :left-pad left-pad
2512
:byte-lsb-first-p t :bit-lsb-first-p t))))))
2514
(defun write-bitmap-file (pathname image &optional name)
2515
;; Writes an image to a C include file in standard X11 format
2516
;; NAME argument used for variable prefixes. Defaults to "image"
2517
(declare (type (or pathname string stream) pathname)
2519
(type (or null stringable) name))
2520
(unless (typep image 'image-x)
2521
(setq image (copy-image image :result-type 'image-x)))
2522
(let* ((plist (image-plist image))
2523
(name (or name (image-name image) 'image))
2524
(left-pad (image-x-left-pad image))
2525
(width (index+ (image-width image) left-pad))
2526
(height (image-height image))
2528
(if (eq (image-x-format image) :z-pixmap)
2531
(bits-per-pixel (image-x-bits-per-pixel image))
2532
(bits-per-line (index* width bits-per-pixel))
2533
(bytes-per-line (index-ceiling bits-per-line 8))
2534
(last (index* bytes-per-line height))
2536
(declare (type list plist)
2537
(type stringable name)
2538
(type card8 left-pad)
2539
(type card16 width height)
2540
(type (member 1 4 8 16 24 32) bits-per-pixel)
2541
(type image-depth depth)
2542
(type array-index bits-per-line bytes-per-line count last))
2543
;; Move x-hot by left-pad, if there is an x-hot, so image readers that
2544
;; don't know about left pad get the hot spot in the right place. We have
2545
;; already increased width by left-pad.
2546
(when (getf plist :x-hot)
2547
(setq plist (copy-list plist))
2548
(index-incf (getf plist :x-hot) left-pad))
2549
(with-image-data-buffer (data last)
2550
(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
2551
(image-swap-function
2553
(image-x-unit image) (image-x-byte-lsb-first-p image)
2554
(image-x-bit-lsb-first-p image) 32 t t)
2555
(declare (type symbol image-swap-function)
2556
(type generalized-boolean image-swap-lsb-first-p))
2558
(symbol-function image-swap-function) (image-x-data image)
2559
data 0 0 bytes-per-line (image-x-bytes-per-line image)
2560
bytes-per-line height image-swap-lsb-first-p))
2561
(with-vector (data buffer-bytes)
2562
(setq name (string-downcase (string name)))
2563
(with-open-file (fstream pathname :direction :output)
2564
(format fstream "#define ~a_width ~d~%" name width)
2565
(format fstream "#define ~a_height ~d~%" name height)
2567
(format fstream "#define ~a_depth ~d~%" name depth))
2568
(unless (zerop left-pad)
2569
(format fstream "#define ~a_left_pad ~d~%" name left-pad))
2570
(do ((prop plist (cddr prop)))
2572
(when (and (not (member (car prop) '(:width :height)))
2573
(numberp (cadr prop)))
2574
(format fstream "#define ~a_~a ~d~%"
2577
#\_ #\- (string-downcase (string (car prop)))
2580
(format fstream "static char ~a_bits[] = {" name)
2582
(dotimes (j bytes-per-line)
2583
(when (zerop (index-mod count 15))
2585
(write-char #\space fstream))
2586
(write-string "0x" fstream)
2587
;; Faster than (format fstream "0x~2,'0x," byte)
2588
(let ((byte (aref data count))
2589
(translate "0123456789abcdef"))
2590
(declare (type card8 byte))
2591
(write-char (char translate (ldb (byte 4 4) byte)) fstream)
2592
(write-char (char translate (ldb (byte 4 0) byte)) fstream))
2594
(unless (index= count last)
2595
(write-char #\, fstream))))
2596
(format fstream "};~%"))))))
2598
(defun bitmap-image (&optional plist &rest patterns)
2599
;; Create an image containg pattern
2600
;; PATTERNS are bit-vector constants (e.g. #*10101)
2601
;; If the first parameter is a list, its used as the image property-list.
2602
(declare (type (or list bit-vector) plist)
2603
(type list patterns)) ;; list of bitvector
2604
(declare (clx-values image))
2605
(unless (listp plist)
2606
(push plist patterns)
2608
(let* ((width (length (first patterns)))
2609
(height (length patterns))
2610
(bitarray (make-array (list height width) :element-type 'bit))
2612
(declare (type card16 width height row)
2613
(type pixarray-1 bitarray))
2614
(dolist (pattern patterns)
2615
(declare (type simple-bit-vector pattern))
2616
(dotimes (col width)
2617
(declare (type card16 col))
2618
(setf (aref bitarray row col) (the bit (aref pattern col))))
2620
(create-image :width width :height height :plist plist :data bitarray)))
2622
(defun image-pixmap (drawable image &key gcontext width height depth)
2623
;; Create a pixmap containing IMAGE. Size defaults from the image.
2624
;; DEPTH is the pixmap depth.
2625
;; GCONTEXT is used for putting the image into the pixmap.
2626
;; If none is supplied, then one is created, used then freed.
2627
(declare (type drawable drawable)
2629
(type (or null gcontext) gcontext)
2630
(type (or null card16) width height)
2631
(type (or null card8) depth))
2632
(declare (clx-values pixmap))
2633
(let* ((image-width (image-width image))
2634
(image-height (image-height image))
2635
(image-depth (image-depth image))
2636
(width (or width image-width))
2637
(height (or height image-height))
2638
(depth (or depth image-depth))
2639
(pixmap (create-pixmap :drawable drawable
2643
(gc (or gcontext (create-gcontext
2647
(unless (= depth image-depth)
2648
(if (= image-depth 1)
2649
(unless gcontext (xlib::required-arg gcontext))
2650
(error "Pixmap depth ~d incompatable with image depth ~d"
2651
depth image-depth)))
2652
(put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1)
2654
;; Tile when image-width is less than the pixmap width, or
2655
;; the image-height is less than the pixmap height.
2656
;; ??? Would it be better to create a temporary pixmap and
2657
;; ??? let the server do the tileing?
2658
(do ((x image-width (+ x image-width)))
2660
(copy-area pixmap gc 0 0 image-width image-height pixmap x 0)
2661
(incf image-width image-width))
2662
(do ((y image-height (+ y image-height)))
2664
(copy-area pixmap gc 0 0 image-width image-height pixmap 0 y)
2665
(incf image-height image-height))
2666
(unless gcontext (free-gcontext gc))
added
removed
src/clx/image.lisp
