Skip to content
Snippets Groups Projects
image.lisp 101 KiB
Newer Older
dan's avatar
dan committed
2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685
			(find depth (display-pixmap-formats display)
			      :key #'pixmap-format-depth)))
		  (declare (type (or null pixmap-format) pixmap-format))
		  (if (null pixmap-format)
		      (error "The depth of the image ~s does not match any server pixmap format." image))
		  (if (not (= (etypecase image
				(image-z (image-z-bits-per-pixel image))
				(image-x (image-x-bits-per-pixel image)))
			      (pixmap-format-bits-per-pixel pixmap-format)))
		      ;; We could try to use the "/* XXX slow, but works */"
		      ;; code in XPutImage from X11R4 here.  However, that
		      ;; would require considerable support code
		      ;; (see XImUtil.c, etc).
		      (error "The bits-per-pixel of the image ~s does not match any server pixmap format." image))
		  (values (pixmap-format-scanline-pad pixmap-format)
			  (pixmap-format-bits-per-pixel pixmap-format))))))
	(declare (type (member 8 16 32) pad)
		 (type (member 1 4 8 16 24 32) bits-per-pixel))
	(let* ((left-pad
		 (if (or (eq format :xy-pixmap) (= depth 1))
		     (index-mod src-x (index-min pad *image-pad*))
		   0))
	       (left-padded-src-x (index- src-x left-pad))
	       (left-padded-width (index+ width left-pad))
	       (bits-per-line (index* left-padded-width bits-per-pixel))
	       (padded-bits-per-line
		 (index* (index-ceiling bits-per-line pad) pad))
	       (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
	       (request-bytes-per-line
		 (ecase format
		   ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth))
		   (:z-pixmap padded-bytes-per-line)))
	       (max-bytes-per-request
		 (index* (index- (display-max-request-length display) 6) 4))
	       (max-request-height
		 (floor max-bytes-per-request request-bytes-per-line)))
	  (declare (type card8 left-pad)
		   (type int16 left-padded-src-x)
		   (type card16 left-padded-width)
		   (type array-index bits-per-line padded-bits-per-line
			 padded-bytes-per-line request-bytes-per-line
			 max-bytes-per-request max-request-height))
	  ;; Be sure that a scanline can fit in a request
	  (when (index-zerop max-request-height)
	    (error "Can't even fit one image scanline in a request"))
	  ;; Be sure a scanline can fit in a buffer
	  (buffer-ensure-size display padded-bytes-per-line)
	  ;; Send the image in multiple requests to avoid exceeding the
	  ;; request limit
	  (do* ((request-src-y src-y (index+ request-src-y request-height))
		(request-y y (index+ request-y request-height))
		(height-remaining
 		  height (the fixnum (- height-remaining request-height)))
		(request-height
		  (index-min height-remaining max-request-height)
		  (index-min height-remaining max-request-height)))
	       ((<= height-remaining 0))
	    (declare (type array-index request-src-y request-height)
		     (fixnum height-remaining))
	    (let* ((request-bytes (index* request-bytes-per-line request-height))
		   (request-words (index-ceiling request-bytes 4))
		   (request-length (index+ request-words 6)))
	      (declare (type array-index request-bytes)
		       (type card16 request-words request-length))
	      (with-buffer-request (display *x-putimage* :gc-force gcontext)
		((data (member :bitmap :xy-pixmap :z-pixmap))
		 (cond ((or (eq format :bitmap) bitmap-p) :bitmap)
		       ((plusp left-pad) :xy-pixmap)
		       (t format)))
		(drawable drawable)
		(gcontext gcontext)
		(card16 width request-height)
		(int16 x request-y)
		(card8 left-pad depth)
		(pad16 nil)
		(progn 
		  (length-put 2 request-length)
		  (setf (buffer-boffset display) (advance-buffer-offset 24))
		  (etypecase image
		    (image-x
		      (ecase (image-x-format (the image-x image))
			((:bitmap :xy-pixmap)
			  (write-xy-format-image-x
			    display image left-padded-src-x request-src-y
			    left-padded-width request-height
			    padded-bytes-per-line
			    unit byte-lsb-first-p bit-lsb-first-p))
			(:z-pixmap
			  (write-z-format-image-x
			    display image left-padded-src-x request-src-y
			    left-padded-width request-height
			    padded-bytes-per-line
			    unit byte-lsb-first-p bit-lsb-first-p))))
		    (image-xy
		      (write-image-xy
			display image left-padded-src-x request-src-y
			left-padded-width request-height
			padded-bytes-per-line
			unit byte-lsb-first-p bit-lsb-first-p))
		    (image-z
		      (write-image-z
			display image left-padded-src-x request-src-y
			left-padded-width request-height
			padded-bytes-per-line
			unit byte-lsb-first-p bit-lsb-first-p)))
		  ;; Be sure the request is padded to a multiple of 4 bytes
		  (buffer-pad-request display (index- (index* request-words 4) request-bytes))
		  )))))))))

;;;-----------------------------------------------------------------------------
;;; COPY-IMAGE

(defun xy-format-image-x->image-x (image x y width height)
  (declare (type image-x image)
	   (type card16 x y width height)
	   (clx-values image-x))
  (let* ((padded-x (index+ x (image-x-left-pad image)))
	 (left-pad (index-mod padded-x 8))
	 (x (index- padded-x left-pad))
	 (unit (image-x-unit image))
	 (byte-lsb-first-p (image-x-byte-lsb-first-p image))
	 (bit-lsb-first-p (image-x-bit-lsb-first-p image))
	 (pad (image-x-pad image))
	 (padded-width
	   (index* (index-ceiling (index+ width left-pad) pad) pad))
	 (padded-bytes-per-line (index-ceiling padded-width 8))
	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
	 (length (index* padded-bytes-per-plane (image-depth image)))
	 (obuf (make-array length :element-type 'card8)))
    (declare (type card16 x)
	     (type card8 left-pad)
	     (type (member 8 16 32) unit pad)
	     (type array-index padded-width padded-bytes-per-line
		   padded-bytes-per-plane length)
	     (type buffer-bytes obuf))
    (dotimes (plane (image-depth image))
      (let ((data-start
	      (index* (image-x-bytes-per-line image)
		      (image-height image)
		      plane))
	    (obuf-start
	      (index* padded-bytes-per-plane
		      plane)))
	(declare (type array-index data-start obuf-start))
	(write-xy-format-image-x-data
	  (image-x-data image) obuf data-start obuf-start
	  x y width height 
	  (image-x-bytes-per-line image) padded-bytes-per-line
	  unit byte-lsb-first-p bit-lsb-first-p
	  unit byte-lsb-first-p bit-lsb-first-p)))
    (create-image
      :width width :height height :depth (image-depth image)
      :data obuf :format (image-x-format image) :bits-per-pixel 1
      :bytes-per-line padded-bytes-per-line
      :unit unit :pad pad :left-pad left-pad
      :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p)))

(defun z-format-image-x->image-x (image x y width height)
  (declare (type image-x image)
	   (type card16 x y width height)
	   (clx-values image-x))
  (let* ((padded-x (index+ x (image-x-left-pad image)))
	 (left-pad
	   (if (index= (image-depth image) 1)
	       (index-mod padded-x 8)
	     0))
	 (x (index- padded-x left-pad))
	 (bits-per-pixel (image-x-bits-per-pixel image))
	 (unit (image-x-unit image))
	 (byte-lsb-first-p (image-x-byte-lsb-first-p image))
	 (bit-lsb-first-p (image-x-bit-lsb-first-p image))
	 (pad (image-x-pad image))
	 (bits-per-line (index* (index+ width left-pad) bits-per-pixel))
	 (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad))
	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
	 (length (index* padded-bytes-per-plane (image-depth image)))
	 (obuf (make-array length :element-type 'card8)))
    (declare (type card16 x)
	     (type card8 left-pad)
	     (type (member 8 16 32) unit pad)
	     (type array-index bits-per-pixel padded-bytes-per-line
		   padded-bytes-per-plane length)
	     (type buffer-bytes obuf))
    (write-z-format-image-x-data
      (image-x-data image) obuf 0 0
      x y width height 
      (image-x-bytes-per-line image) padded-bytes-per-line
      bits-per-pixel
      unit byte-lsb-first-p bit-lsb-first-p
      unit byte-lsb-first-p bit-lsb-first-p)
    (create-image
      :width width :height height :depth (image-depth image)
      :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel
      :bytes-per-line padded-bytes-per-line
      :unit unit :pad pad :left-pad left-pad
      :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p)))

(defun image-x->image-x  (image x y width height)
  (declare (type image-x image)
	   (type card16 x y width height)
	   (clx-values image-x))
  (ecase (image-x-format image)
    ((:bitmap :xy-pixmap)
      (xy-format-image-x->image-x image x y width height))
    (:z-pixmap
      (z-format-image-x->image-x image x y width height))))

(defun image-x->image-xy (image x y width height)
  (declare (type image-x image)
	   (type card16 x y width height)
	   (clx-values image-xy))
  (unless (or (eq (image-x-format image) :bitmap)
	      (eq (image-x-format image) :xy-pixmap)
	      (and (eq (image-x-format image) :z-pixmap)
		   (index= (image-depth image) 1)))
    (error "Format conversion from ~S to ~S not supported"
	   (image-x-format image) :xy-pixmap))
  (read-image-xy
    (image-x-data image) 0 (length (image-x-data image)) nil
    (index+ x (image-x-left-pad image)) y width height
    (image-depth image) (image-x-bytes-per-line image)
    (index* (image-x-bytes-per-line image) (image-height image))
    (image-x-unit image) (image-x-byte-lsb-first-p image)
    (image-x-bit-lsb-first-p image)))

(defun image-x->image-z  (image x y width height)
  (declare (type image-x image)
	   (type card16 x y width height)
	   (clx-values image-z))
  (unless (or (eq (image-x-format image) :z-pixmap)
	      (eq (image-x-format image) :bitmap)
	      (and (eq (image-x-format image) :xy-pixmap)
		   (index= (image-depth image) 1)))
    (error "Format conversion from ~S to ~S not supported"
	   (image-x-format image) :z-pixmap))
  (read-image-z
    (image-x-data image) 0 (length (image-x-data image)) nil
    (index+ x (image-x-left-pad image)) y width height
    (image-depth image) (image-x-bytes-per-line image)
    (image-x-bits-per-pixel image)
    (image-x-unit image) (image-x-byte-lsb-first-p image)
    (image-x-bit-lsb-first-p image)))

(defun copy-pixarray (array x y width height bits-per-pixel)
  (declare (type pixarray array)
	   (type card16 x y width height)
	   (type (member 1 4 8 16 24 32) bits-per-pixel))
  (let* ((bits-per-line (index* bits-per-pixel width))
	 (padded-bits-per-line
	   (index* (index-ceiling bits-per-line *image-pad*) *image-pad*))
	 (padded-width (index-ceiling padded-bits-per-line bits-per-pixel))
	 (copy (make-array (list height padded-width)
			   :element-type (array-element-type array))))
    (declare (type array-index bits-per-line padded-bits-per-line padded-width)
	     (type pixarray copy))
    #.(declare-buffun)
    (unless (fast-copy-pixarray array copy x y width height bits-per-pixel)
      (macrolet
	((copy (array-type element-type)
	   `(let ((array array)
		  (copy copy))
	      (declare (type ,array-type array copy))
	      (do* ((dst-y 0 (index1+ dst-y))
		    (src-y y (index1+ src-y)))
		   ((index>= dst-y height))
		(declare (type card16 dst-y src-y))
		(do* ((dst-x 0 (index1+ dst-x))
		      (src-x x (index1+ src-x)))
		     ((index>= dst-x width))
		  (declare (type card16 dst-x src-x))
		  (setf (aref copy dst-y dst-x)
			(the ,element-type
			     (aref array src-y src-x))))))))
	(ecase bits-per-pixel
	  (1  (copy pixarray-1  pixarray-1-element-type))
	  (4  (copy pixarray-4  pixarray-4-element-type))
	  (8  (copy pixarray-8  pixarray-8-element-type))
	  (16 (copy pixarray-16 pixarray-16-element-type))
	  (24 (copy pixarray-24 pixarray-24-element-type))
	  (32 (copy pixarray-32 pixarray-32-element-type)))))
    copy))

(defun image-xy->image-x (image x y width height)
  (declare (type image-xy image)
	   (type card16 x y width height)
	   (clx-values image-x))
  (let* ((padded-bits-per-line
	   (index* (index-ceiling width *image-pad*) *image-pad*))
	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
	 (bytes-total (index* padded-bytes-per-plane (image-depth image)))
	 (data (make-array bytes-total :element-type 'card8)))
    (declare (type array-index padded-bits-per-line padded-bytes-per-line
		   padded-bytes-per-plane bytes-total)
	     (type buffer-bytes data))
    (let ((index 0))
      (declare (type array-index index))
      (dolist (bitmap (image-xy-bitmap-list image))
	(declare (type pixarray-1 bitmap))
	(write-pixarray
	  data index bitmap x y width height padded-bytes-per-line 1
	  *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)
	(index-incf index padded-bytes-per-plane)))
    (create-image
      :width width :height height :depth (image-depth image)
      :data data :format :xy-pixmap :bits-per-pixel 1
      :bytes-per-line padded-bytes-per-line
      :unit *image-unit* :pad *image-pad*
      :byte-lsb-first-p *image-byte-lsb-first-p*
      :bit-lsb-first-p *image-bit-lsb-first-p*)))

(defun image-xy->image-xy (image x y width height)
  (declare (type image-xy image)
	   (type card16 x y width height)
	   (clx-values image-xy))
  (create-image
    :width width :height height :depth (image-depth image)
    :data (mapcar
	    #'(lambda (array)
		(declare (type pixarray-1 array))
		(copy-pixarray array x y width height 1))
	    (image-xy-bitmap-list image))))

(defun image-xy->image-z (image x y width height)
  (declare (type image-z image)
	   (type card16 x y width height)
	   (ignore image x y width height))
  (error "Format conversion from ~S to ~S not supported"
	 :xy-pixmap :z-pixmap))

(defun image-z->image-x (image x y width height)
  (declare (type image-z image)
	   (type card16 x y width height)
	   (clx-values image-x))
  (let* ((bits-per-line (index* width (image-z-bits-per-pixel image)))
	 (padded-bits-per-line
	   (index* (index-ceiling bits-per-line *image-pad*) *image-pad*))
	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
	 (bytes-total
	   (index* padded-bytes-per-line height (image-depth image)))
	 (data (make-array bytes-total :element-type 'card8))
	 (bits-per-pixel (image-z-bits-per-pixel image)))
    (declare (type array-index bits-per-line padded-bits-per-line
		   padded-bytes-per-line bytes-total)
	     (type buffer-bytes data)
	     (type (member 1 4 8 16 24 32) bits-per-pixel))
    (write-pixarray
      data 0 (image-z-pixarray image) x y width height padded-bytes-per-line 
      (image-z-bits-per-pixel image)
      *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)
    (create-image
      :width width :height height :depth (image-depth image)
      :data data :format :z-pixmap
      :bits-per-pixel bits-per-pixel
      :bytes-per-line padded-bytes-per-line
      :unit *image-unit* :pad *image-pad*
      :byte-lsb-first-p *image-byte-lsb-first-p*
      :bit-lsb-first-p *image-bit-lsb-first-p*)))

(defun image-z->image-xy (image x y width height)
  (declare (type image-z image)
	   (type card16 x y width height)
	   (ignore image x y width height))
  (error "Format conversion from ~S to ~S not supported"
	 :z-pixmap :xy-pixmap))

(defun image-z->image-z (image x y width height)
  (declare (type image-z image)
	   (type card16 x y width height)
	   (clx-values image-z))
  (create-image
    :width width :height height :depth (image-depth image)
    :data (copy-pixarray
	    (image-z-pixarray image) x y width height
	    (image-z-bits-per-pixel image))))

(defun copy-image (image &key (x 0) (y 0) width height result-type)
  ;; Copy with optional sub-imaging and format conversion.
  ;; result-type defaults to (type-of image)
  (declare (type image image)
	   (type card16 x y)
	   (type (or null card16) width height) ;; Default from image
	   (type (or null (member image-x image-xy image-z)) result-type))
  (declare (clx-values image))
  (let* ((image-width (image-width image))
	 (image-height (image-height image))
	 (width (or width image-width))
	 (height (or height image-height)))
    (declare (type card16 image-width image-height width height))
    (unless (<= 0 x (the fixnum (1- image-width)))
      (error "x not inside image"))
    (unless (<= 0 y (the fixnum (1- image-height)))
      (error "y not inside image"))
    (setq width (index-min width (max (the fixnum (- image-width x)) 0)))
    (setq height (index-min height (max (the fixnum (- image-height y)) 0)))
    (let ((copy
	    (etypecase image
	      (image-x
		(ecase result-type
		  ((nil image-x) (image-x->image-x image x y width height))
		  (image-xy (image-x->image-xy image x y width height))
		  (image-z  (image-x->image-z  image x y width height))))
	      (image-xy
		(ecase result-type
		  (image-x (image-xy->image-x image x y width height))
		  ((nil image-xy) (image-xy->image-xy image x y width height))
		  (image-z  (image-xy->image-z image x y width height))))
	      (image-z 
		(ecase result-type
		  (image-x (image-z->image-x image x y width height))
		  (image-xy  (image-z->image-xy image x y width height))
		  ((nil image-z) (image-z->image-z image x y width height)))))))
      (declare (type image copy))
      (setf (image-plist copy) (copy-list (image-plist image)))
      (when (and (image-x-hot image) (not (index-zerop x)))
	(setf (image-x-hot copy) (index- (image-x-hot image) x)))
      (when (and (image-y-hot image) (not (index-zerop y)))
	(setf (image-y-hot copy) (index- (image-y-hot image) y)))
      copy)))


;;;-----------------------------------------------------------------------------
;;; Image I/O functions


(defun read-bitmap-file (pathname)
  ;; Creates an image from a C include file in standard X11 format
  (declare (type (or pathname string stream) pathname))
  (declare (clx-values image))
  (with-open-file (fstream pathname :direction :input)
    (let ((line "")
	  (properties nil)
	  (name nil)
	  (name-end nil))
      (declare (type string line)
	       (type stringable name)
	       (type list properties))
      ;; Get properties
      (loop
	(setq line (read-line fstream))
	(unless (char= (aref line 0) #\#) (return))
	(flet ((read-keyword (line start end)
		 (kintern
		   (substitute
		     #\- #\_
		     (#-excl string-upcase
		      #+excl correct-case
		      (subseq line start end))
		     :test #'char=))))
	  (when (null name)
	    (setq name-end (position #\_ line :test #'char= :from-end t)
		  name (read-keyword line 8 name-end))
	    (unless (eq name :image)
	      (setf (getf properties :name) name)))
	  (let* ((ind-start (index1+ name-end))
		 (ind-end (position #\Space line :test #'char=
				    :start ind-start))
		 (ind (read-keyword line ind-start ind-end))
		 (val-start (index1+ ind-end))
		 (val (parse-integer line :start val-start)))
	    (setf (getf properties ind) val))))
      ;; Calculate sizes
      (multiple-value-bind (width height depth left-pad)
	  (flet ((extract-property (ind &rest default)
		   (prog1 (apply #'getf properties ind default)
			  (remf properties ind))))
	    (values (extract-property :width)
		    (extract-property :height)
		    (extract-property :depth 1)
		    (extract-property :left-pad 0)))
	(declare (type (or null card16) width height)
		 (type image-depth depth)
		 (type card8 left-pad))
	(unless (and width height) (error "Not a BITMAP file"))
	(let* ((bits-per-pixel
		 (cond ((index> depth 24) 32)
		       ((index> depth 16) 24)
		       ((index> depth 8)  16)
		       ((index> depth 4)   8)
		       ((index> depth 1)   4)
		       (t                  1)))
	       (bits-per-line (index* width bits-per-pixel))
	       (bytes-per-line (index-ceiling bits-per-line 8))
	       (padded-bits-per-line
		 (index* (index-ceiling bits-per-line 32) 32))
	       (padded-bytes-per-line
		 (index-ceiling padded-bits-per-line 8))
	       (data (make-array (* padded-bytes-per-line height)
				 :element-type 'card8))
	       (line-base 0)
	       (byte 0))
	  (declare (type array-index bits-per-line bytes-per-line
			 padded-bits-per-line padded-bytes-per-line
			 line-base byte)
		   (type buffer-bytes data))
	  (with-vector (data buffer-bytes)
	    (flet ((parse-hex (char)
		     (second
		       (assoc char
			      '((#\0  0) (#\1  1) (#\2  2) (#\3  3)
				(#\4  4) (#\5  5) (#\6  6) (#\7  7)
				(#\8  8) (#\9  9) (#\a 10) (#\b 11)
				(#\c 12) (#\d 13) (#\e 14) (#\f 15))
			      :test #'char-equal))))
	      (declare (inline parse-hex))
	      ;; Read data
	      ;; Note: using read-line instead of read-char would be 20% faster,
	      ;;       but would cons a lot of garbage...
	      (dotimes (i height)
		(dotimes (j bytes-per-line)
		  (loop (when (eql (read-char fstream) #\x) (return)))
		  (setf (aref data (index+ line-base byte))
			(index+ (index-ash (parse-hex (read-char fstream)) 4)
				(parse-hex (read-char fstream))))
		  (incf byte))
		(setq byte 0
		      line-base (index+ line-base padded-bytes-per-line)))))
	  ;; Compensate for left-pad in width and x-hot
	  (index-decf width left-pad)
	  (when (and (getf properties :x-hot) (plusp (getf properties :x-hot)))
	    (index-decf (getf properties :x-hot) left-pad))
	  (create-image
	    :width width :height height
	    :depth depth :bits-per-pixel bits-per-pixel
	    :data data :plist properties :format :z-pixmap
	    :bytes-per-line padded-bytes-per-line
	    :unit 32 :pad 32 :left-pad left-pad
	    :byte-lsb-first-p t :bit-lsb-first-p t))))))

(defun write-bitmap-file (pathname image &optional name)
  ;; Writes an image to a C include file in standard X11 format
  ;; NAME argument used for variable prefixes.  Defaults to "image"
  (declare (type (or pathname string stream) pathname)
	   (type image image)
	   (type (or null stringable) name))
  (unless (typep image 'image-x)
    (setq image (copy-image image :result-type 'image-x)))
  (let* ((plist (image-plist image))
	 (name (or name (image-name image) 'image))
	 (left-pad (image-x-left-pad image))
	 (width (index+ (image-width image) left-pad))
	 (height (image-height image))
	 (depth
	   (if (eq (image-x-format image) :z-pixmap)
	       (image-depth image)
	     1))
	 (bits-per-pixel (image-x-bits-per-pixel image))
	 (bits-per-line (index* width bits-per-pixel))
	 (bytes-per-line (index-ceiling bits-per-line 8))
	 (last (index* bytes-per-line height))
	 (count 0))
    (declare (type list plist)
	     (type stringable name)
	     (type card8 left-pad)
	     (type card16 width height)
	     (type (member 1 4 8 16 24 32) bits-per-pixel)
	     (type image-depth depth)
	     (type array-index bits-per-line bytes-per-line count last))
    ;; Move x-hot by left-pad, if there is an x-hot, so image readers that
    ;; don't know about left pad get the hot spot in the right place.  We have
    ;; already increased width by left-pad.
    (when (getf plist :x-hot)
      (setq plist (copy-list plist))
      (index-incf (getf plist :x-hot) left-pad))
    (with-image-data-buffer (data last)
      (multiple-value-bind (image-swap-function image-swap-lsb-first-p)
	  (image-swap-function
	    bits-per-pixel
	    (image-x-unit image) (image-x-byte-lsb-first-p image)
	    (image-x-bit-lsb-first-p image) 32 t t)
	(declare (type symbol image-swap-function)
		 (type generalized-boolean image-swap-lsb-first-p))
	(funcall
	  (symbol-function image-swap-function) (image-x-data image)
	  data 0 0 bytes-per-line (image-x-bytes-per-line image)
	  bytes-per-line height image-swap-lsb-first-p))
      (with-vector (data buffer-bytes)
	(setq name (string-downcase (string name)))
	(with-open-file (fstream pathname :direction :output)
	  (format fstream "#define ~a_width ~d~%" name width)
	  (format fstream "#define ~a_height ~d~%" name height)
	  (unless (= depth 1)
	    (format fstream "#define ~a_depth ~d~%" name depth))
	  (unless (zerop left-pad)
	    (format fstream "#define ~a_left_pad ~d~%" name left-pad))
	  (do ((prop plist (cddr prop)))
	      ((endp prop))
	    (when (and (not (member (car prop) '(:width :height)))
		       (numberp (cadr prop)))
	      (format fstream "#define ~a_~a ~d~%"
		      name
		      (substitute
			#\_ #\- (string-downcase (string (car prop)))
			:test #'char=)
		      (cadr prop))))
	  (format fstream "static char ~a_bits[] = {" name)
	  (dotimes (i height)
	    (dotimes (j bytes-per-line)
	      (when (zerop (index-mod count 15))
		(terpri fstream)
		(write-char #\space fstream))
	      (write-string "0x" fstream)
	      ;; Faster than (format fstream "0x~2,'0x," byte)
	      (let ((byte (aref data count))
		    (translate "0123456789abcdef"))
		(declare (type card8 byte))
		(write-char (char translate (ldb (byte 4 4) byte)) fstream)
		(write-char (char translate (ldb (byte 4 0) byte)) fstream))
	      (index-incf count)
	      (unless (index= count last)
		(write-char #\, fstream))))
	  (format fstream "};~%" fstream))))))

(defun bitmap-image (&optional plist &rest patterns)
  ;; Create an image containg pattern
  ;; PATTERNS are bit-vector constants (e.g. #*10101)
  ;; If the first parameter is a list, its used as the image property-list.
  (declare (type (or list bit-vector) plist)
	   (type list patterns)) ;; list of bitvector
  (declare (clx-values image))
  (unless (listp plist)
    (push plist patterns)
    (setq plist nil))
  (let* ((width (length (first patterns)))
	 (height (length patterns))
	 (bitarray (make-array (list height width) :element-type 'bit))
	 (row 0))
    (declare (type card16 width height row)
	     (type pixarray-1 bitarray))
    (dolist (pattern patterns)
      (declare (type simple-bit-vector pattern))
      (dotimes (col width)
	(declare (type card16 col))
	(setf (aref bitarray row col) (the bit (aref pattern col))))
      (incf row))
    (create-image :width width :height height :plist plist :data bitarray)))

(defun image-pixmap (drawable image &key gcontext width height depth)
  ;; Create a pixmap containing IMAGE. Size defaults from the image.
  ;; DEPTH is the pixmap depth.
  ;; GCONTEXT is used for putting the image into the pixmap.
  ;; If none is supplied, then one is created, used then freed.
  (declare (type drawable drawable)
	   (type image image)
	   (type (or null gcontext) gcontext)
	   (type (or null card16) width height)
	   (type (or null card8) depth))
  (declare (clx-values pixmap))
  (let* ((image-width (image-width image))
	 (image-height (image-height image))
	 (image-depth (image-depth image))
	 (width (or width image-width))
	 (height (or height image-height))
	 (depth (or depth image-depth))
	 (pixmap (create-pixmap :drawable drawable
			       :width width
			       :height height
			       :depth depth))
	 (gc (or gcontext (create-gcontext
			    :drawable pixmap
			    :foreground 1
			    :background 0))))
    (unless (= depth image-depth)
      (if (= image-depth 1)
	  (unless gcontext (xlib::required-arg gcontext))
	(error "Pixmap depth ~d incompatable with image depth ~d"
	       depth image-depth)))	       
    (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1)
							gcontext))
    ;; Tile when image-width is less than the pixmap width, or
    ;; the image-height is less than the pixmap height.
    ;; ??? Would it be better to create a temporary pixmap and 
    ;; ??? let the server do the tileing?
    (do ((x image-width (+ x image-width)))
	((>= x width))
      (copy-area pixmap gc 0 0 image-width image-height pixmap x 0)
      (incf image-width image-width))
    (do ((y image-height (+ y image-height)))
	((>= y height))
      (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y)
      (incf image-height image-height))
    (unless gcontext (free-gcontext gc))
    pixmap))