image-reader.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011, 2012, 2016, 2017 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 (defparameter *picture-header-length-tolerance* 20
  22   "Amount of leeway for the length of a picture header in a .pictures
  23   file.")
  24
  25 (defun find-keyword-in-stream (stream keyword &optional
  26                                (start-position 0 start-position-p)
  27                                search-range)
  28   "Return file-position in binary stream after first occurence of
  29 keyword, or nil if the search is unsuccessful.  Return nil if
  30 start-position is explicitly nil."
  31   (unless (and start-position-p
  32                (null start-position))
  33     (unless start-position-p (setf start-position 0))
  34     (let* ((keyword-size (length keyword))
  35            (keyword-bytes (map 'vector #'char-code keyword))
  36            (chunk-max-size 300)
  37            (chunk (make-array (list (+ chunk-max-size (1- keyword-size)))
  38                               :element-type '(unsigned-byte 8)))
  39            (end-position-in-stream (if search-range
  40                                        (+ start-position search-range)
  41                                        most-positive-fixnum)))
  42       (loop
  43          for chunk-start-in-stream from start-position to end-position-in-stream by chunk-max-size
  44          for chunk-size = (let ((*readtable* (copy-readtable)))
  45                             (setf (readtable-case *readtable*) :preserve)
  46                             (file-position stream chunk-start-in-stream)
  47                             (read-sequence chunk stream))
  48          for end-in-chunk = (min chunk-size (- end-position-in-stream
  49                                                chunk-start-in-stream))
  50          while (plusp chunk-size)
  51          do (loop
  52                for i from 0 to end-in-chunk
  53                for correct-characters = (mismatch keyword-bytes chunk
  54                                                   :start2 i
  55                                                   :end2 end-in-chunk)
  56                do (when (or (null correct-characters)
  57                             (= correct-characters keyword-size))
  58                     (return-from find-keyword-in-stream
  59                       (+ chunk-start-in-stream i keyword-size))))))))
  60
  61 (defun find-keyword-value (path keyword &optional start-position search-range)
  62   "Return value associated with keyword."
  63   (let ((start-of-value
  64          (find-keyword path keyword start-position search-range)))
  65     (when start-of-value
  66       (with-open-file (stream path)
  67         (let ((*readtable* (copy-readtable)))
  68           (setf (readtable-case *readtable*) :preserve)
  69           (file-position stream start-of-value)
  70           (car (read-delimited-list #\; stream)))))))
  71
  72 (defun find-keyword (path keyword &optional (start-position 0) search-range)
  73   "Return file-position after keyword."
  74   (with-open-file (stream path :element-type 'unsigned-byte)
  75     (find-keyword-in-stream stream keyword start-position search-range)))
  76
  77 (cffi:defcstruct mem-encode
  78     (buffer :pointer)
  79   (size :int))
  80
  81 (defun* send-png (output-stream path start
  82                                 &key (color-raiser #(1 1 1))
  83                                 reversep brightenp
  84                                 &mandatory-key bayer-pattern)
  85   "Read an image at position start in .pictures file at path and send
  86 it to the binary output-stream.  Return UNIX trigger-time of image.
  87 If brightenp is t, have it brightened up if necessary.  If reversep is
  88 t, turn it upside-down.  Bayer-pattern is applied after turning, which
  89 is a wart."
  90   ;; TODO: bayer-pattern should be applied to the unturned image
  91   (let ((blob-start (find-keyword path "PICTUREDATA_BEGIN" start))
  92         (blob-size (find-keyword-value path "dataSize=" start))
  93         (image-height (find-keyword-value path "height=" start))
  94         (image-width (find-keyword-value path "width=" start))
  95         (compression-mode (find-keyword-value path "compressed=" start))
  96         (channels (find-keyword-value path "channels=" start))
  97         (trigger-time (find-keyword-value path "timeTrigger=" start))
  98         (demosaic-fast t))
  99     (cffi:with-foreign-objects ((baypat :int 3)
 100                                 (colr-raisr :double 3)
 101                                 (mem-png 'mem-encode))
 102       (loop
 103          for i from 0 below (min 4 (first (array-dimensions bayer-pattern))) do
 104            (setf (cffi:mem-aref baypat :int i) (aref bayer-pattern i)))
 105       (loop
 106          for i from 0 to 2 do
 107            (setf (cffi:mem-aref colr-raisr :double i)
 108                  (coerce (aref color-raiser i) 'double-float)))
 109       (let ((png2mem-exit
 110              (imread:png2mem (namestring path) blob-start blob-size
 111                              image-width image-height channels
 112                              baypat demosaic-fast compression-mode
 113                              mem-png reversep brightenp colr-raisr)))
 114         (cond ((zerop png2mem-exit)
 115                (cffi:with-foreign-slots ((buffer size) mem-png mem-encode)
 116                  (loop
 117                     for i from 0 below size do
 118                       (write-byte (cffi:mem-aref buffer :unsigned-char i) output-stream))
 119                  (unless (cffi:null-pointer-p buffer) (cffi:foreign-free buffer))))
 120               ((= 1 png2mem-exit)
 121                (error "Input file ~A not found." path))
 122               ((or (= 2 png2mem-exit) (= 3 png2mem-exit))
 123                (error "Don't know how to deal with a bayer-pattern of ~A."
 124                       bayer-pattern))
 125               ((= 5 png2mem-exit)
 126                (error "Unknown compression mode ~A in ~A."
 127                       compression-mode path))
 128               ((= 6 png2mem-exit)
 129                (error "Don't know how to deal with ~D-channel pixels." channels))
 130               ((= 71 png2mem-exit)
 131                (error "JPEG decompression error."))
 132               ((= 72 png2mem-exit)
 133                (error "JPEG discarded.  It was bigger than expected."))
 134               ((= 73 png2mem-exit)
 135                (error "JPEG reversing not implemented."))
 136               ((= 74 png2mem-exit)
 137                (error "JPEG brightening not implemented."))
 138               ((= 75 png2mem-exit)
 139                (error "Couldn't allocate memory for uncompressed image."))
 140               ((= 76 png2mem-exit)
 141                (error "Couldn't allocate buffer for image data input."))
 142               ((= 11 png2mem-exit)
 143                (error "PNG error: create_write_struct()."))
 144               ((= 12 png2mem-exit)
 145                (error "PNG error: create_info_struct()"))
 146               ((= 13 png2mem-exit)
 147                (error "Error during PNG setup."))
 148               ((= 21 png2mem-exit)
 149                (error "Error while writing PNG row."))
 150               ((= 31 png2mem-exit)
 151                (error "Couldn't allocate memory for huffman table."))
 152               ((= 32 png2mem-exit)
 153                (error "Huffman decoder out of step."))
 154               (t
 155                (error "Can't unpack image.")))))
 156     trigger-time))
 157
 158 (defun find-nth-picture (n path)
 159   "Find file-position of zero-indexed nth picture in in .pictures file
 160 at path."
 161   (let ((estimated-header-length
 162          (- (find-keyword path "PICTUREHEADER_END")
 163             (find-keyword path "PICTUREHEADER_BEGIN")
 164             *picture-header-length-tolerance*))) ; allow for variation in dataSize and a few other parameters
 165     (loop
 166        for i from 0 to n
 167        for picture-start =
 168        (find-keyword path "PICTUREHEADER_BEGIN" 0) then
 169        (find-keyword path "PICTUREHEADER_BEGIN"
 170                      (+ picture-start picture-length estimated-header-length))
 171        for picture-length = (find-keyword-value path
 172                                                 "dataSize=" picture-start)
 173        finally (return (- picture-start (length "PICTUREHEADER_BEGIN"))))))
 174
 175 (defun* send-nth-png (n output-stream path
 176                      &key (color-raiser #(1 1 1))
 177                      reversep brightenp
 178                      &mandatory-key bayer-pattern)
 179   "Read image number n (zero-indexed) in .pictures file at path and
 180 send it to the binary output-stream.  Return UNIX trigger-time of
 181 image."
 182   (send-png output-stream path (find-nth-picture n path)
 183             :bayer-pattern bayer-pattern
 184             :reversep reversep
 185             :brightenp brightenp
 186             :color-raiser color-raiser))
 187
 188
 189 ;; TODO: (perhaps)
 190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 191 ;; collect 4 single color pixels into a three-color one
 192 ;; enhance contrast of grayscale images