image-reader.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011, 2012 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18
  19 (in-package :img)
  20
  21 ;;; See file phoros.asd for how to choose between two alternative
  22 ;;; image creation libraries, zpng and cl-png.
  23
  24 (deftype image-dimension () '(unsigned-byte 16))
  25
  26 (deftype color () '(unsigned-byte 8))
  27
  28 (deftype channels () '(unsigned-byte 8))
  29
  30 #-png
  31 (deftype image ()
  32   "We are using zpng."
  33   '(simple-array color 3))
  34
  35 (defparameter *picture-header-length-tolerance* 20
  36   "Amount of leeway for the length of a picture header in a .pictures
  37   file.")
  38
  39 (defun find-keyword-in-stream (stream keyword &optional
  40                                (start-position 0 start-position-p)
  41                                search-range)
  42   "Return file-position in binary stream after first occurence of
  43 keyword, or nil if the search is unsuccessful.  Return nil if
  44 start-position is explicitly nil."
  45   (unless (and start-position-p
  46                (null start-position))
  47     (unless start-position-p (setf start-position 0))
  48     (let* ((keyword-size (length keyword))
  49            (keyword-bytes (map 'vector #'char-code keyword))
  50            (chunk-max-size 300)
  51            (chunk (make-array (list (+ chunk-max-size (1- keyword-size)))
  52                               :element-type '(unsigned-byte 8)))
  53            (end-position-in-stream (if search-range
  54                                        (+ start-position search-range)
  55                                        most-positive-fixnum)))
  56       (loop
  57          for chunk-start-in-stream from start-position to end-position-in-stream by chunk-max-size
  58          for chunk-size = (progn (file-position stream chunk-start-in-stream)
  59                                  (read-sequence chunk stream))
  60          for end-in-chunk = (min chunk-size (- end-position-in-stream
  61                                                chunk-start-in-stream))
  62          while (plusp chunk-size)
  63          do (loop
  64                for i from 0 to end-in-chunk
  65                for correct-characters = (mismatch keyword-bytes chunk
  66                                                   :start2 i
  67                                                   :end2 end-in-chunk)
  68                do (when (= correct-characters keyword-size)
  69                     (return-from find-keyword-in-stream
  70                       (+ chunk-start-in-stream i keyword-size))))))))
  71
  72 (defun find-keyword-value (path keyword &optional start-position search-range)
  73   "Return value associated with keyword."
  74   (let ((start-of-value
  75          (find-keyword path keyword start-position search-range)))
  76     (when start-of-value
  77       (with-open-file (stream path)
  78         (file-position stream start-of-value)
  79         (car (read-delimited-list #\; stream))))))
  80
  81 (defun find-keyword (path keyword &optional (start-position 0) search-range)
  82   "Return file-position after keyword."
  83   (with-open-file (stream path :element-type 'unsigned-byte)
  84     (find-keyword-in-stream stream keyword start-position search-range)))
  85
  86 (defun read-huffman-table (stream &optional start-position)
  87   "Return in a hash table a huffman table read from stream.  Start
  88 either at stream's file position or at start-position."
  89   (let ((huffman-codes-start (if start-position
  90                                  start-position
  91                                  (file-position stream))))
  92     (file-position stream (+ (* 511 4) huffman-codes-start)) ; start of lengths
  93     (let* ((lengths (make-list 511))
  94            (huffman-table (make-hash-table :size 1000 :test #'equal)))
  95       (read-sequence lengths stream)
  96       (file-position stream huffman-codes-start)
  97       (loop
  98          for i from -255 to 255
  99          for length in lengths
 100          for key = (make-array (list length) :element-type 'bit)
 101          for code = (let ((raw (make-array '(4) :element-type 'unsigned-byte))
 102                           (code-part 0))
 103                       (read-sequence raw stream)
 104                       (loop
 105                          for raw-byte across raw
 106                          for code-position from 24 downto 0 by 8
 107                          do (setf code-part (dpb raw-byte
 108                                                  (byte 8 code-position)
 109                                                  code-part))
 110                          finally (return code-part)))
 111          unless (zerop length)
 112          do (loop
 113                for key-index from 0 below length
 114                for code-index downfrom (1- length)
 115                do (setf (sbit key key-index)
 116                         (ldb (byte 1 code-index) code)))
 117          and
 118          do (setf (gethash key huffman-table) i))
 119       huffman-table)))
 120
 121 (defun read-compressed-picture (stream start-position length)
 122   "Return a compressed picture in a bit array.  Start either at
 123 start-position or, if that is nil, at stream's file position."
 124   (when start-position (file-position stream start-position))
 125   (let ((raw (make-array (list length) :element-type 'unsigned-byte))
 126         (compressed-picture
 127          (make-array (list (* 8 length)) :element-type 'bit)))
 128     (read-sequence raw stream)
 129     (loop
 130        for byte across raw
 131        for byte-position from 0
 132        do (loop
 133              for source-bit from 7 downto 0
 134              for destination-bit from 0 to 7
 135              do (setf (sbit compressed-picture
 136                             (+ destination-bit
 137                                (* 8 byte-position)))
 138                       (ldb (byte 1 source-bit) byte)))
 139        finally (return compressed-picture))))
 140
 141 (defun get-leading-byte (bit-array &optional (start 0) &aux (result 0))
 142   "Return integer made of eight bits from bit-array."
 143   (loop
 144      for bit-array-index from start
 145      for result-index from 7 downto 0
 146      for result = (dpb (sbit bit-array bit-array-index)
 147                        (byte 1 result-index) 0)
 148      then (dpb (sbit bit-array bit-array-index) (byte 1 result-index) result)
 149      finally (return result)))
 150
 151 #+png
 152 (defun uncompress-picture (huffman-table compressed-picture
 153                            height width channels &key reversep)
 154   "Return the Bayer pattern extracted from compressed-picture, turned
 155 upside-down if reversep is t, in an (array color (height
 156 width channels)), everything in channel 0."
 157   (declare (optimize speed)
 158            (optimize (safety 0))
 159            (type (unsigned-byte 16) height width)
 160            (type vector compressed-picture))
 161   (let* ((uncompressed-image
 162           (png:make-image height width channels 8))
 163          (uncompressed-image-vector
 164           (make-array (list (* height width channels))
 165                       :element-type 'color
 166                       :displaced-to uncompressed-image))
 167          (channel (if reversep
 168                       (1- channels)     ;becomes 0 by reversal
 169                       0))
 170          (compressed-picture-index 0)
 171          (min-key-length
 172           (loop
 173              for code of-type simple-bit-vector being the hash-key in huffman-table
 174              minimize (length code)))
 175          (max-key-length
 176           (loop
 177              for code of-type simple-bit-vector being the hash-key in huffman-table
 178              maximize (length code))))
 179     (declare (type (signed-byte 48) compressed-picture-index)
 180              (type channels channels))
 181     (loop
 182        for row from 0 below height
 183        do
 184        (setf (aref uncompressed-image row 0 channel)
 185              (get-leading-byte compressed-picture
 186                                (prog1 compressed-picture-index
 187                                  (incf compressed-picture-index 8))))
 188        (setf (aref uncompressed-image row 1 channel)
 189              (get-leading-byte compressed-picture
 190                                (prog1 compressed-picture-index
 191                                  (incf compressed-picture-index 8))))
 192        (loop
 193           for column from 2 below width
 194           for try-start of-type (unsigned-byte 48) from compressed-picture-index
 195           do
 196           (loop
 197              for key-length from min-key-length to max-key-length
 198              for huffman-code = (subseq compressed-picture
 199                                         try-start (+ try-start key-length))
 200              for pixel-delta-maybe = (gethash huffman-code huffman-table)
 201              when pixel-delta-maybe
 202              do
 203              (setf (aref uncompressed-image row column channel)
 204                    (- (aref uncompressed-image row (- column 2) channel)
 205                       (the fixnum pixel-delta-maybe)))
 206              and do (incf try-start (1- key-length))
 207              and return nil
 208              finally (error
 209                       "Decoder out of step at row ~S, column ~S.  Giving up."
 210                       row column))
 211           finally
 212           (setf compressed-picture-index (1+ try-start))))
 213     (when reversep (setf uncompressed-image-vector
 214                          (reverse uncompressed-image-vector)))
 215     uncompressed-image))
 216
 217 #-png
 218 (defun uncompress-picture (huffman-table compressed-picture
 219                            height width channels &key reversep)
 220   "Return the Bayer pattern extracted from compressed-picture, turned
 221 upside-down if reversep is t, in an (array color (height
 222 width channels)), everything in channel 0."
 223   (declare (optimize (safety 0))
 224            (type (unsigned-byte 16) height width)
 225            (type vector compressed-picture))
 226   (let* ((uncompressed-image
 227           (make-array (list height width channels)
 228                       :element-type 'color))
 229          (uncompressed-image-vector
 230           (make-array (list (* height width channels))
 231                       :element-type 'color
 232                       :displaced-to uncompressed-image))
 233
 234          (channel (if reversep
 235                       (1- channels)     ;becomes 0 by reversal
 236                       0))
 237          (compressed-picture-index 0)
 238          (min-key-length
 239           (loop
 240              for code of-type simple-bit-vector
 241              being the hash-key in huffman-table
 242              minimize (length code)))
 243          (max-key-length
 244           (loop
 245              for code of-type simple-bit-vector
 246              being the hash-key in huffman-table
 247              maximize (length code))))
 248     (declare (type (signed-byte 48) compressed-picture-index)
 249              (type channels channels))
 250     (loop
 251        for row from 0 below height
 252        do
 253        (setf (aref uncompressed-image row 0 channel)
 254              (get-leading-byte compressed-picture
 255                                (prog1 compressed-picture-index
 256                                  (incf compressed-picture-index 8))))
 257        (setf (aref uncompressed-image row 1 channel)
 258              (get-leading-byte compressed-picture
 259                                (prog1 compressed-picture-index
 260                                  (incf compressed-picture-index 8))))
 261        (loop
 262           for column from 2 below width
 263           for try-start of-type (unsigned-byte 48) from compressed-picture-index
 264           do
 265           (loop
 266              for key-length from min-key-length to max-key-length
 267              for huffman-code = (subseq compressed-picture
 268                                         try-start (+ try-start key-length))
 269              for pixel-delta-maybe = (gethash huffman-code huffman-table)
 270              when pixel-delta-maybe
 271              do
 272              (setf (aref uncompressed-image row column channel)
 273                    (- (aref uncompressed-image row (- column 2) channel)
 274                       (the fixnum pixel-delta-maybe)))
 275              and do (incf try-start (1- key-length))
 276              and return nil
 277              finally (error
 278                       "Decoder out of step at row ~S, column ~S.  Giving up."
 279                       row column))
 280           finally
 281           (setf compressed-picture-index (1+ try-start))))
 282     (when reversep (setf uncompressed-image-vector
 283                          (reverse uncompressed-image-vector)))
 284     uncompressed-image))
 285
 286 (defun fetch-picture (stream start-position length height width channels
 287                       &key reversep)
 288   "Return the Bayer pattern taken from stream in an (array
 289 \(unsigned-byte l8) (height width channels)), everything in color
 290 channel 0.  Start at start-position or, if that is nil, at stream's
 291 file position."
 292   (when start-position (file-position stream start-position))
 293   (let* ((image
 294           (make-array (list height width channels)
 295                       :element-type 'color))
 296          (image-vector
 297           (make-array (list (* height width channels))
 298                       :element-type 'color
 299                       :displaced-to image))
 300          (raw-image
 301           (make-array (list length) :element-type 'unsigned-byte)))
 302     (ecase channels
 303       (1
 304        (read-sequence image-vector stream))
 305       (3
 306        (error "Not implemented: ~
 307               fetch-picture for (uncompressed) truecolor images")
 308        ;; (read-sequence raw-image stream)
 309        ;; (loop
 310        ;;    for pixel across raw-image and red from 0 by 3 do
 311        ;;      (setf (svref png-image-data red) pixel))
 312        ))
 313     (when reversep (setf image-vector (reverse image-vector)))
 314     image))
 315
 316 (defun complete-horizontally (image row column color)
 317   "Fake a color component of a pixel based its neighbors."
 318   (declare (optimize (safety 0))
 319            (optimize speed)
 320            #-png(type image image)
 321            (type image-dimension row column))
 322   (setf (aref image row column color)
 323         (round (+ (the color (aref image row (1- column) color))
 324                   (the color (aref image row (1+ column) color)))
 325                2)))
 326
 327 (defun complete-vertically (image row column color)
 328   "Fake a color component of a pixel based its neighbors."
 329   (declare (optimize (safety 0))
 330            (optimize speed)
 331            #-png(type image image)
 332            (type image-dimension row column))
 333   (setf (aref image row column color)
 334         (round (+ (the color (aref image (1- row) column color))
 335                   (the color (aref image (1+ row) column color)))
 336                2)))
 337
 338 (defun complete-squarely (image row column color)
 339   "Fake a color component of a pixel based its neighbors."
 340   (declare (optimize (safety 0))
 341            (optimize speed)
 342            #-png(type image image)
 343            (type image-dimension row column))
 344   (setf (aref image row column color)
 345         (round (+ (the color (aref image row (1- column) color))
 346                   (the color (aref image row (1+ column) color))
 347                   (the color (aref image (1- row) column color))
 348                   (the color (aref image (1+ row) column color)))
 349                4)))
 350
 351 (defun complete-diagonally (image row column color)
 352   "Fake a color component of a pixel based its neighbors."
 353   (declare (optimize (safety 0))
 354            (optimize speed)
 355            #-png(type image image)
 356            (type image-dimension row column))
 357   (setf (aref image row column color)
 358         (round (+ (the color (aref image (1- row) (1- column) color))
 359                   (the color (aref image (1- row) (1+ column) color))
 360                   (the color (aref image (1+ row) (1- column) color))
 361                   (the color (aref image (1+ row) (1+ column) color)))
 362                4)))
 363
 364 (defun height (image) (array-dimension image 0))
 365 (defun width (image) (array-dimension image 1))
 366 (defun channels (image) (array-dimension image 2))
 367
 368 #-png
 369 (defun demosaic-image (image bayer-pattern color-raiser brightenp)
 370   "Demosaic color image whose color channel 0 is supposed to be
 371 filled with a Bayer color pattern.  Return demosaiced image.
 372 bayer-pattern is an array of 24-bit RGB values (red occupying the
 373 least significant byte), describing the upper left corner of the
 374 image.  Currently, only pixels 0, 1 on row 0 are taken into account.
 375 And, it's currently not even an array but a vector due to limitations
 376 in postmodern.  For a grayscale image do nothing.  Then, if brightenp
 377 is t and the image is too dark, make it brighter.
 378 We are using zpng."
 379   (declare (optimize (safety 0))
 380            (optimize speed)
 381            (type image image))
 382   (when (= 3 (channels image))
 383     (let ((lowest-row (- (height image) 2))
 384           (rightmost-column (- (width image) 2))
 385           (bayer-pattern-red #x0000ff)
 386           (bayer-pattern-green #x00ff00)
 387           (bayer-pattern-blue #xff0000)
 388           (red 0) (green 1) (blue 2)  ;color coordinate in IMAGE array
 389           (color-raiser-red (coerce (elt color-raiser 0)
 390                                     '(single-float -10.0s0 10.0s0)))
 391           (color-raiser-green (coerce (elt color-raiser 1)
 392                                       '(single-float -10.0s0 10.0s0)))
 393           (color-raiser-blue (coerce (elt color-raiser 2)
 394                                      '(single-float -10.0s0 10.0s0)))
 395           (pix-depth 255)     ;may some day become a function argument
 396           complete-even-row-even-column
 397           complete-even-row-odd-column
 398           complete-odd-row-even-column
 399           complete-odd-row-odd-column
 400           colorize-even-row-even-column
 401           colorize-even-row-odd-column
 402           colorize-odd-row-even-column
 403           colorize-odd-row-odd-column)
 404       (declare (type image-dimension lowest-row rightmost-column)
 405                )
 406       (flet ((complete-green-on-red-row (row column)
 407                (complete-horizontally image row column red)
 408                (complete-vertically image row column blue))
 409              (complete-green-on-blue-row (row column)
 410                (complete-horizontally image row column blue)
 411                (complete-vertically image row column red))
 412              (complete-red (row column)
 413                (complete-squarely image row column green)
 414                (complete-diagonally image row column blue))
 415              (complete-blue (row column)
 416                (complete-squarely image row column green)
 417                (complete-diagonally image row column red))
 418              (colorize-red (row column)
 419                (setf (aref image row column red)
 420                      (min pix-depth
 421                           (round (* color-raiser-red
 422                                     (aref image
 423                                           row column red))))))
 424              (colorize-green (row column)
 425                (setf (aref image row column green)
 426                      (min pix-depth
 427                           (round (* color-raiser-green
 428                                     (aref image
 429                                           row column red))))))
 430              (colorize-blue (row column)
 431                (setf (aref image row column blue)
 432                      (min pix-depth
 433                           (round (* color-raiser-blue
 434                                     (aref image
 435                                           row column red)))))))
 436         (cond
 437           ((= (aref bayer-pattern 0) bayer-pattern-red)
 438            (setf colorize-even-row-even-column #'colorize-red)
 439            (setf colorize-even-row-odd-column #'colorize-green)
 440            (setf colorize-odd-row-even-column #'colorize-green)
 441            (setf colorize-odd-row-odd-column #'colorize-blue)
 442            (setf complete-even-row-even-column #'complete-red)
 443            (setf complete-even-row-odd-column #'complete-green-on-red-row)
 444            (setf complete-odd-row-even-column #'complete-green-on-blue-row)
 445            (setf complete-odd-row-odd-column #'complete-blue))
 446           ((= (aref bayer-pattern 0) bayer-pattern-blue)
 447            (setf colorize-even-row-even-column #'colorize-blue)
 448            (setf colorize-even-row-odd-column #'colorize-green)
 449            (setf colorize-odd-row-even-column #'colorize-green)
 450            (setf colorize-odd-row-odd-column #'colorize-red)
 451            (setf complete-even-row-even-column #'complete-blue)
 452            (setf complete-even-row-odd-column #'complete-green-on-blue-row)
 453            (setf complete-odd-row-even-column #'complete-green-on-red-row)
 454            (setf complete-odd-row-odd-column #'complete-red))
 455           ((= (aref bayer-pattern 0) bayer-pattern-green)
 456            (cond
 457              ((= (aref bayer-pattern 1) bayer-pattern-red)
 458               (setf colorize-even-row-even-column #'colorize-green)
 459               (setf colorize-even-row-odd-column #'colorize-red)
 460               (setf colorize-odd-row-even-column #'colorize-blue)
 461               (setf colorize-odd-row-odd-column #'colorize-green)
 462               (setf complete-even-row-even-column #'complete-green-on-red-row)
 463               (setf complete-even-row-odd-column #'complete-red)
 464               (setf complete-odd-row-even-column #'complete-blue)
 465               (setf complete-odd-row-odd-column #'complete-green-on-blue-row))
 466              ((= (aref bayer-pattern 1) bayer-pattern-blue)
 467               (setf colorize-even-row-even-column #'colorize-green)
 468               (setf colorize-even-row-odd-column #'colorize-blue)
 469               (setf colorize-odd-row-even-column #'colorize-red)
 470               (setf colorize-odd-row-odd-column #'colorize-green)
 471               (setf complete-even-row-even-column #'complete-green-on-blue-row)
 472               (setf complete-even-row-odd-column #'complete-blue)
 473               (setf complete-odd-row-even-column #'complete-red)
 474               (setf complete-odd-row-odd-column #'complete-green-on-red-row))
 475              (t (error "Don't know how to deal with a bayer-pattern of ~A"
 476                        bayer-pattern))))
 477           (t (error "Don't know how to deal with a bayer-pattern of ~A"
 478                     bayer-pattern)))
 479         ;; Recover colors (so far everything is in channel 0)
 480         (loop
 481            for row from 0 below (the image-dimension (height image)) by 2
 482            do (loop
 483                  for column
 484                  from 0 below (the image-dimension (width image)) by 2
 485                  do (funcall colorize-even-row-even-column row column))
 486            (loop
 487               for column
 488               from 1 below (the image-dimension (width image)) by 2
 489               do (funcall colorize-even-row-odd-column row column)))
 490         (loop
 491            for row from 1 below (the image-dimension (height image)) by 2
 492            do (loop
 493                  for column
 494                  from 0 below (the image-dimension (width image)) by 2
 495                  do (funcall colorize-odd-row-even-column row column))
 496            (loop
 497               for column
 498               from 1 below (the image-dimension (width image)) by 2
 499               do (funcall colorize-odd-row-odd-column row column)))
 500         ;; Demosaic
 501         (loop
 502            for row from 2 to lowest-row by 2 do
 503            (loop
 504               for column from 2 to rightmost-column by 2 do
 505               (funcall complete-even-row-even-column row column))
 506            (loop
 507               for column from 1 to rightmost-column by 2 do
 508               (funcall complete-even-row-odd-column row column)))
 509         (loop
 510            for row from 1 to lowest-row by 2 do
 511            (loop
 512               for column from 2 to rightmost-column by 2 do
 513               (funcall complete-odd-row-even-column row column))
 514            (loop
 515               for column from 1 to rightmost-column by 2 do
 516               (funcall complete-odd-row-odd-column row column))))))
 517   (when brightenp (brighten-maybe image))
 518   image)
 519
 520 #+png
 521 (defun demosaic-image (image bayer-pattern color-raiser brightenp)
 522   "Demosaic color image whose color channel 0 is supposed to be
 523 filled with a Bayer color pattern.  Return demosaiced image.
 524 bayer-pattern is an array of 24-bit RGB values (red occupying the
 525 least significant byte), describing the upper left corner of the
 526 image.  Currently, only pixels 0, 1 on row 0 are taken into account.
 527 And, it's currently not even an array but a vector due to limitations
 528 in postmodern.  For a grayscale image do nothing.  Then, if brightenp
 529 is t and the image is too dark, make it brighter.
 530 We are using cl-png."
 531   (declare (optimize speed)
 532            (optimize (safety 0))
 533            (optimize speed))
 534   (when (= 3 (png:image-channels image))
 535     (let ((lowest-row (- (png:image-height image) 2))
 536           (rightmost-column (- (png:image-width image) 2))
 537           (bayer-pattern-red #x0000ff)
 538           (bayer-pattern-green #x00ff00)
 539           (bayer-pattern-blue #xff0000)
 540           (red 0) (green 1) (blue 2)    ;color coordinate in IMAGE array
 541           (color-raiser-red (coerce (elt color-raiser 0) '(single-float -10.0s0 10.0s0)))
 542           (color-raiser-green (coerce (elt color-raiser 1) '(single-float -10.0s0 10.0s0)))
 543           (color-raiser-blue (coerce (elt color-raiser 2) '(single-float -10.0s0 10.0s0)))
 544           (pix-depth 255)     ;may some day become a function argument
 545           complete-even-row-even-column
 546           complete-even-row-odd-column
 547           complete-odd-row-even-column
 548           complete-odd-row-odd-column
 549           colorize-even-row-even-column
 550           colorize-even-row-odd-column
 551           colorize-odd-row-even-column
 552           colorize-odd-row-odd-column)
 553       (declare (type image-dimension lowest-row rightmost-column))
 554       (flet ((complete-green-on-red-row (row column)
 555                (complete-horizontally image row column red)
 556                (complete-vertically image row column blue))
 557              (complete-green-on-blue-row (row column)
 558                (complete-horizontally image row column blue)
 559                (complete-vertically image row column red))
 560              (complete-red (row column)
 561                (complete-squarely image row column green)
 562                (complete-diagonally image row column blue))
 563              (complete-blue (row column)
 564                (complete-squarely image row column green)
 565                (complete-diagonally image row column red))
 566              (colorize-red (row column)
 567                (setf (aref image row column red)
 568                      (min pix-depth
 569                           (round (* color-raiser-red
 570                                     (the color (aref image
 571                                                       row column red)))))))
 572              (colorize-green (row column)
 573                (setf (aref image row column green)
 574                      (min pix-depth
 575                           (round (* color-raiser-green
 576                                     (the color (aref image
 577                                                       row column red)))))))
 578              (colorize-blue (row column)
 579                (setf (aref image row column blue)
 580                      (min pix-depth
 581                           (round (* color-raiser-blue
 582                                     (the color (aref image
 583                                                       row column red))))))))
 584         (cond
 585           ((= (aref bayer-pattern 0) bayer-pattern-red)
 586            (setf colorize-even-row-even-column #'colorize-red)
 587            (setf colorize-even-row-odd-column #'colorize-green)
 588            (setf colorize-odd-row-even-column #'colorize-green)
 589            (setf colorize-odd-row-odd-column #'colorize-blue)
 590            (setf complete-even-row-even-column #'complete-red)
 591            (setf complete-even-row-odd-column #'complete-green-on-red-row)
 592            (setf complete-odd-row-even-column #'complete-green-on-blue-row)
 593            (setf complete-odd-row-odd-column #'complete-blue))
 594           ((= (aref bayer-pattern 0) bayer-pattern-blue)
 595            (setf colorize-even-row-even-column #'colorize-blue)
 596            (setf colorize-even-row-odd-column #'colorize-green)
 597            (setf colorize-odd-row-even-column #'colorize-green)
 598            (setf colorize-odd-row-odd-column #'colorize-red)
 599            (setf complete-even-row-even-column #'complete-blue)
 600            (setf complete-even-row-odd-column #'complete-green-on-blue-row)
 601            (setf complete-odd-row-even-column #'complete-green-on-red-row)
 602            (setf complete-odd-row-odd-column #'complete-red))
 603           ((= (aref bayer-pattern 0) bayer-pattern-green)
 604            (cond
 605              ((=(aref bayer-pattern 1) bayer-pattern-red)
 606               (setf colorize-even-row-even-column #'colorize-green)
 607               (setf colorize-even-row-odd-column #'colorize-red)
 608               (setf colorize-odd-row-even-column #'colorize-blue)
 609               (setf colorize-odd-row-odd-column #'colorize-green)
 610               (setf complete-even-row-even-column #'complete-green-on-red-row)
 611               (setf complete-even-row-odd-column #'complete-red)
 612               (setf complete-odd-row-even-column #'complete-blue)
 613               (setf complete-odd-row-odd-column #'complete-green-on-blue-row))
 614              ((=(aref bayer-pattern 1) bayer-pattern-blue)
 615               (setf colorize-even-row-even-column #'colorize-green)
 616               (setf colorize-even-row-odd-column #'colorize-blue)
 617               (setf colorize-odd-row-even-column #'colorize-red)
 618               (setf colorize-odd-row-odd-column #'colorize-green)
 619               (setf complete-even-row-even-column #'complete-green-on-blue-row)
 620               (setf complete-even-row-odd-column #'complete-blue)
 621               (setf complete-odd-row-even-column #'complete-red)
 622               (setf complete-odd-row-odd-column #'complete-green-on-red-row))
 623              (t (error "Don't know how to deal with a bayer-pattern of ~A"
 624                        bayer-pattern))))
 625           (t (error "Don't know how to deal with a bayer-pattern of ~A"
 626                     bayer-pattern)))
 627         ;; Recover colors (so far everything is in channel 0)
 628         (loop for row from 0 below (the image-dimension (height image)) by 2
 629            do (loop for column from 0 below (the image-dimension (width image)) by 2
 630                  do (funcall colorize-even-row-even-column row column))
 631            (loop for column from 1 below (the image-dimension (width image)) by 2
 632               do (funcall colorize-even-row-odd-column row column)))
 633         (loop for row from 1 below (the image-dimension (height image)) by 2
 634            do (loop for column from 0 below (the image-dimension (width image)) by 2
 635                  do (funcall colorize-odd-row-even-column row column))
 636              (loop for column from 1 below (the image-dimension (width image)) by 2
 637                 do (funcall colorize-odd-row-odd-column row column)))
 638         ;; Demosaic
 639         (loop
 640            for row from 2 to lowest-row by 2 do
 641            (loop
 642               for column from 2 to rightmost-column by 2 do
 643               (funcall complete-even-row-even-column row column))
 644            (loop
 645               for column from 1 to rightmost-column by 2 do
 646               (funcall complete-even-row-odd-column row column)))
 647         (loop
 648            for row from 1 to lowest-row by 2 do
 649            (loop
 650               for column from 2 to rightmost-column by 2 do
 651               (funcall complete-odd-row-even-column row column))
 652            (loop
 653               for column from 1 to rightmost-column by 2 do
 654               (funcall complete-odd-row-odd-column row column))))))
 655   (when brightenp (brighten-maybe image))
 656   image)
 657
 658 #-png
 659 (defun brighten-maybe (image)
 660   "Make image brighter if it is too dark.
 661 We are using zpng."
 662   (declare (optimize speed)
 663            (optimize (safety 0))
 664            (type image image))
 665   (multiple-value-bind (brightest-value darkest-value)
 666       (brightness image)
 667     (declare (type color brightest-value darkest-value))
 668     (when (< (the color brightest-value) 200)
 669       (dotimes (y (the image-dimension (height image)))
 670         (dotimes (x (the image-dimension (width image)))
 671           (dotimes (c (the channels (channels image)))
 672             (setf (aref image y x c)
 673                   (floor (* (the color (- (aref image y x c)
 674                                           darkest-value))
 675                             255)
 676                          (- brightest-value darkest-value)))))))))
 677
 678 #+png
 679 (defun brighten-maybe (image)
 680   "Make image brighter if it is too dark.
 681 We are using cl-png."
 682   (declare (optimize speed)
 683            (optimize (safety 0)))
 684   (multiple-value-bind (brightest-value darkest-value)
 685       (brightness image)
 686     (declare (type color brightest-value darkest-value))
 687     (when (< (the color brightest-value) 200)
 688       (let ((image-vector (make-array (list (* (height image)
 689                                                (width image)
 690                                                (channels image)))
 691                                       :element-type 'color
 692                                       :displaced-to image)))
 693         (loop
 694            for i from 0 below (length image-vector)
 695            do (setf (aref image-vector i)
 696                     (floor (* (the color (- (aref image-vector i)
 697                                             darkest-value))
 698                               255)
 699                            (- brightest-value darkest-value))))))))
 700
 701 #-png
 702 (defun brightness (image)
 703   "Return brightest value and darkest value of image.
 704 We are using zpng."
 705   (declare (optimize speed)
 706            (optimize (safety 0))
 707            (type image image))
 708   (let ((brightest-value 0)
 709         (darkest-value 0))
 710     (declare (type color brightest-value darkest-value))
 711     (dotimes (y (the image-dimension (height image)))
 712       (dotimes (x (the image-dimension (width image)))
 713         (dotimes (c (the channels (channels image)))
 714           (let ((intensity (aref image y x c)))
 715             (setf brightest-value (max intensity brightest-value))
 716             (setf darkest-value (min intensity darkest-value))))))
 717     (values brightest-value darkest-value)))
 718
 719 #+png
 720 (defun brightness (image)
 721   "Return brightest value and darkest value of image.  We are using
 722 cl-png."
 723   (declare (optimize speed))
 724   (let ((image-vector
 725          (make-array (list (* (height image) (width image) (channels image)))
 726                      :element-type 'color
 727                      :displaced-to image)))
 728     (loop
 729        for brightness across image-vector
 730        maximize brightness into brightest-value
 731        minimize brightness into darkest-value
 732        finally (return (values brightest-value
 733                                darkest-value)))))
 734
 735 (defun* send-png (output-stream path start
 736                                 &key (color-raiser #(1 1 1))
 737                                 reversep brightenp
 738                                 &mandatory-key bayer-pattern)
 739   "Read an image at position start in .pictures file at path and send
 740 it to the binary output-stream.  Return UNIX trigger-time of image.
 741 If brightenp is t, have it brightened up if necessary.  If reversep is
 742 t, turn it upside-down.  Bayer-pattern is applied after turning, which
 743 is a wart."
 744   ;; TODO: bayer-pattern should be applied to the unturned image
 745   (let ((blob-start (find-keyword path "PICTUREDATA_BEGIN" start))
 746         (blob-size (find-keyword-value path "dataSize=" start))
 747         (huffman-table-size (* 511 (+ 1 4)))
 748         (image-height (find-keyword-value path "height=" start))
 749         (image-width (find-keyword-value path "width=" start))
 750         (compression-mode (find-keyword-value path "compressed=" start))
 751         (channels (find-keyword-value path "channels=" start))
 752         (trigger-time (find-keyword-value path "timeTrigger=" start)))
 753     (assert (member channels '(1 3)) ()
 754             "Don't know how to deal with ~D-channel pixels." channels)
 755     (with-open-file (input-stream path :element-type 'unsigned-byte)
 756       (let ((image
 757              (demosaic-image
 758               (ecase compression-mode
 759                 ((2 1) ;compressed with individual/pre-built huffman table
 760                  (uncompress-picture (read-huffman-table input-stream
 761                                                          blob-start)
 762                                      (read-compressed-picture
 763                                       input-stream
 764                                       (+ blob-start huffman-table-size)
 765                                       (- blob-size huffman-table-size))
 766                                      image-height image-width channels
 767                                      :reversep reversep))
 768                 (0                      ;uncompressed
 769                  (fetch-picture input-stream blob-start blob-size
 770                                 image-height image-width channels
 771                                 :reversep reversep)))
 772               bayer-pattern
 773               color-raiser
 774               brightenp)))
 775         (write-image image output-stream)))
 776     trigger-time))
 777
 778 #-png
 779 (defun write-image (image stream)
 780   "Write image array (height, width, channel) to stream."
 781   (zpng:write-png-stream
 782    (zpng:copy-png
 783     (make-instance 'zpng:png
 784                    :height (height image)
 785                    :width (width image)
 786                    :color-type (getf '(1 :grayscale 3 :truecolor)
 787                                      (channels image))
 788                    :image-data (make-array
 789                                 (list (* (height image) (width image)
 790                                          (channels image)))
 791                                 :element-type 'color
 792                                 :displaced-to image)))
 793    stream))
 794
 795 #+png
 796 (defun write-image (image stream)
 797   "Write image array (height, width, channel) to stream."
 798   (png:encode image stream))
 799
 800 (defun find-nth-picture (n path)
 801   "Find file-position of zero-indexed nth picture in in .pictures file
 802 at path."
 803   (let ((estimated-header-length
 804          (- (find-keyword path "PICTUREHEADER_END")
 805             (find-keyword path "PICTUREHEADER_BEGIN")
 806             *picture-header-length-tolerance*))) ; allow for variation in dataSize and a few other parameters
 807     (loop
 808        for i from 0 to n
 809        for picture-start =
 810        (find-keyword path "PICTUREHEADER_BEGIN" 0) then
 811        (find-keyword path "PICTUREHEADER_BEGIN"
 812                      (+ picture-start picture-length estimated-header-length))
 813        for picture-length = (find-keyword-value path
 814                                                 "dataSize=" picture-start)
 815        finally (return (- picture-start (length "PICTUREHEADER_BEGIN"))))))
 816
 817 (defun* send-nth-png (n output-stream path
 818                      &key (color-raiser #(1 1 1))
 819                      reversep brightenp
 820                      &mandatory-key bayer-pattern)
 821   "Read image number n (zero-indexed) in .pictures file at path and
 822 send it to the binary output-stream.  Return UNIX trigger-time of
 823 image."
 824   (send-png output-stream path (find-nth-picture n path)
 825             :bayer-pattern bayer-pattern
 826             :reversep reversep
 827             :brightenp brightenp
 828             :color-raiser color-raiser))
 829
 830
 831 ;; TODO: (perhaps)
 832 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 833 ;; collect 4 single color pixels into a three-color one
 834 ;; enhance contrast of grayscale images