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