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