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