1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011 Bert Burgemeister
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.
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.
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.
21 (defparameter *picture-header-length-tolerance
* 20
22 "Amount of leeway for the length of a picture header in a .pictures
25 (defun find-keyword-in-stream (stream keyword
&optional start-position search-range
)
26 "Return file-position in binary stream after first occurence of
28 (unless start-position
(setf start-position
0))
29 (let ((end-position (if search-range
30 (+ start-position search-range
)
31 most-positive-fixnum
)))
34 (file-position stream start-position
)
35 (let ((chunk-size (length keyword
)))
37 for next-chunk
= (let ((result
38 (make-array (list chunk-size
)
41 (i chunk-size
(coerce result
'string
))
43 (code-char (read-byte stream
)) result
))) ; TODO: try read-sequence
44 if
(string/= next-chunk keyword
) do
45 (let ((next-position (- (file-position stream
) chunk-size -
1)))
46 (if (< next-position end-position
)
47 (file-position stream next-position
)
48 (return-from find-keyword-in-stream
)))
49 else return
(file-position stream
))))
50 (end-of-file () nil
))))
52 (defun find-keyword-value (path keyword
&optional start-position search-range
)
53 "Return value associated with keyword."
55 (find-keyword path keyword start-position search-range
)))
57 (with-open-file (stream path
)
58 (file-position stream start-of-value
)
59 (car (read-delimited-list #\
; stream))))))
61 (defun find-keyword (path keyword
&optional start-position search-range
)
62 "Return file-position after keyword."
63 (with-open-file (stream path
:element-type
'unsigned-byte
)
64 (find-keyword-in-stream stream keyword start-position search-range
)))
66 (defun read-huffman-table (stream &optional start-position
)
67 "Return in a hash table a huffman table read from stream. Start
68 either at stream's file position or at start-position."
69 (let* ((huffman-codes-start
72 (file-position stream
))))
73 (file-position stream
(+ (* 511 4) huffman-codes-start
)) ; start of lengths
76 for length
= (read-byte stream
) ; TODO: try read-sequence
78 (huffman-table (make-hash-table :size
1000 :test
#'equal
)))
79 (file-position stream huffman-codes-start
)
81 for i from -
255 to
255
83 for key
= (make-array (list length
) :element-type
'bit
)
84 for code
= (let ((code-part 0))
85 (setf code-part
(dpb (read-byte stream
)
86 (byte 8 24) code-part
))
87 (setf code-part
(dpb (read-byte stream
)
88 (byte 8 16) code-part
))
89 (setf code-part
(dpb (read-byte stream
)
90 (byte 8 8) code-part
))
91 (dpb (read-byte stream
)
92 (byte 8 0) code-part
)) ; TODO: try read-sequence
95 for key-index from
0 below length
96 for code-index downfrom
(1- length
)
97 do
(setf (sbit key key-index
)
98 (ldb (byte 1 code-index
) code
)))
100 do
(setf (gethash key huffman-table
) i
))
103 (defun read-compressed-picture (stream start-position length
)
104 "Return a compressed picture in a bit array. Start either at
105 start-position or, if that is nil, at stream's file position."
106 (when start-position
(file-position stream start-position
))
107 (let ((compressed-picture
108 (make-array (list (* 8 length
)) :element-type
'bit
)))
110 for byte-position from
0 below length
111 for byte
= (read-byte stream
) ; TODO: try read-sequence
113 for source-bit from
7 downto
0
114 for destination-bit from
0 to
7
115 do
(setf (sbit compressed-picture
116 (+ destination-bit
(* 8 byte-position
)))
117 (ldb (byte 1 source-bit
) byte
))))
120 (defun get-leading-byte (bit-array &optional
(start 0) &aux
(result 0))
121 "Return integer made of eight bits from bit-array."
123 for bit-array-index from start
124 for result-index from
7 downto
0
125 for result
= (dpb (sbit bit-array bit-array-index
)
126 (byte 1 result-index
) 0)
127 then
(dpb (sbit bit-array bit-array-index
) (byte 1 result-index
) result
)
128 finally
(return result
)))
130 (defun uncompress-picture (huffman-table compressed-picture
131 height width color-type
&key reversep
)
132 "Return the Bayer pattern extracted from compressed-picture, turned
133 upside-down if reversep is t, in a zpng:png image, everything in color
135 (let* ((samples-per-pixel
136 (zpng:samples-per-pixel
(make-instance 'zpng
:png
137 :color-type color-type
138 :width
1 :height
1)))
140 (make-array (list (* height width samples-per-pixel
))
141 :element-type
'(unsigned-byte 8)))
143 (make-array (list height width samples-per-pixel
)
144 :element-type
'(unsigned-byte 8)
145 :displaced-to image-data
))
146 (channel (if reversep
147 (1- samples-per-pixel
) ;becomes 0 by reversal
149 (compressed-picture-index 0)
152 for code being the hash-key in huffman-table
153 minimize
(length code
)))
156 for code being the hash-key in huffman-table
157 maximize
(length code
))))
159 for row from
0 below height
161 (setf (aref uncompressed-image row
0 channel
)
162 (get-leading-byte compressed-picture
163 (prog1 compressed-picture-index
164 (incf compressed-picture-index
8))))
165 (setf (aref uncompressed-image row
1 channel
)
166 (get-leading-byte compressed-picture
167 (prog1 compressed-picture-index
168 (incf compressed-picture-index
8))))
170 for column from
2 below width
171 for try-start from compressed-picture-index
174 for key-length from min-key-length to max-key-length
175 for huffman-code
= (subseq compressed-picture
176 try-start
(+ try-start key-length
))
177 for pixel-delta-maybe
= (gethash huffman-code huffman-table
)
178 when pixel-delta-maybe
180 (setf (aref uncompressed-image row column channel
)
181 (- (aref uncompressed-image row
(- column
2) channel
)
183 and do
(incf try-start
(1- key-length
))
186 "Decoder out of step at row ~S, column ~S. Giving up."
189 (setf compressed-picture-index
(1+ try-start
))))
190 (make-instance 'zpng
:png
191 :color-type color-type
192 :width width
:height height
193 :image-data
(if reversep
197 (defun fetch-picture (stream start-position length height width color-type
199 "Return the Bayer pattern taken from stream in a zpng:png image,
200 everything in color channel 0. Start at start-position or, if that is
201 nil, at stream's file position."
202 (when start-position
(file-position stream start-position
))
203 (let* ((samples-per-pixel
204 (zpng:samples-per-pixel
(make-instance 'zpng
:png
205 :color-type color-type
206 :width
1 :height
1)))
208 (make-array (list (* height width samples-per-pixel
))
209 :element-type
'(unsigned-byte 8)))
211 (make-array (list length
) :element-type
'unsigned-byte
)))
214 (read-sequence image-data stream
))
216 (error "Not implemented: fetch-picture for (uncompressed) truecolor images")
217 ;; (read-sequence raw-image stream)
219 ;; for pixel across raw-image and red from 0 by 3 do
220 ;; (setf (svref png-image-data red) pixel))
222 (make-instance 'zpng
:png
223 :color-type color-type
224 :width width
:height height
225 :image-data
(if reversep
229 (defun complete-horizontally (png row column color
)
230 "Fake a color component of a pixel based its neighbors."
231 (let ((data-array (zpng:data-array png
)))
232 (setf (aref data-array row column color
)
233 (round (+ (aref data-array row
(1- column
) color
)
234 (aref data-array row
(1+ column
) color
))
237 (defun complete-vertically (png row column color
)
238 "Fake a color component of a pixel based its neighbors."
239 (let ((data-array (zpng:data-array png
)))
240 (setf (aref data-array row column color
)
241 (round (+ (aref data-array
(1- row
) column color
)
242 (aref data-array
(1+ row
) column color
))
245 (defun complete-squarely (png row column color
)
246 "Fake a color component of a pixel based its neighbors."
247 (let ((data-array (zpng:data-array png
)))
248 (setf (aref data-array row column color
)
249 (round (+ (aref data-array row
(1- column
) color
)
250 (aref data-array row
(1+ column
) color
)
251 (aref data-array
(1- row
) column color
)
252 (aref data-array
(1+ row
) column color
))
255 (defun complete-diagonally (png row column color
)
256 "Fake a color component of a pixel based its neighbors."
257 (let ((data-array (zpng:data-array png
)))
258 (setf (aref data-array row column color
)
259 (round (+ (aref data-array
(1- row
) (1- column
) color
)
260 (aref data-array
(1- row
) (1+ column
) color
)
261 (aref data-array
(1+ row
) (1- column
) color
)
262 (aref data-array
(1+ row
) (1+ column
) color
))
265 (defun demosaic-png (png bayer-pattern color-raiser
)
266 "Demosaic color png in-place whose color channel 0 is supposed to be
267 filled with a Bayer color pattern. Return demosaiced png.
268 bayer-pattern is an array of 24-bit RGB values (red occupying the
269 least significant byte), describing the upper left corner of the
270 image. Currently, only pixels 0, 1 on row 0 are taken into account.
271 And, it's currently not even an array but a vector due to limitations
272 in postmodern. For a grayscale image do nothing."
273 (when (eq (zpng:color-type png
) :truecolor
)
274 (let ((lowest-row (- (zpng:height png
) 2))
275 (rightmost-column (- (zpng:width png
) 2))
276 (bayer-pattern-red #x0000ff
)
277 (bayer-pattern-green #x00ff00
)
278 (bayer-pattern-blue #xff0000
)
279 (red 0) (green 1) (blue 2) ;color coordinate in PNG array
280 (color-raiser-red (elt color-raiser
0))
281 (color-raiser-green (elt color-raiser
1))
282 (color-raiser-blue (elt color-raiser
2))
283 (pix-depth 255) ;may some day become a function argument
284 complete-even-row-even-column
285 complete-even-row-odd-column
286 complete-odd-row-even-column
287 complete-odd-row-odd-column
288 colorize-even-row-even-column
289 colorize-even-row-odd-column
290 colorize-odd-row-even-column
291 colorize-odd-row-odd-column
)
292 (flet ((complete-green-on-red-row (row column
)
293 (complete-horizontally png row column red
)
294 (complete-vertically png row column blue
))
295 (complete-green-on-blue-row (row column
)
296 (complete-horizontally png row column blue
)
297 (complete-vertically png row column red
))
298 (complete-red (row column
)
299 (complete-squarely png row column green
)
300 (complete-diagonally png row column blue
))
301 (complete-blue (row column
)
302 (complete-squarely png row column green
)
303 (complete-diagonally png row column red
))
304 (colorize-red (row column
)
305 (setf (aref (zpng:data-array png
) row column red
)
307 (round (* color-raiser-red
308 (aref (zpng:data-array png
)
310 (colorize-green (row column
)
311 (setf (aref (zpng:data-array png
) row column green
)
313 (round (* color-raiser-green
314 (aref (zpng:data-array png
)
316 (colorize-blue (row column
)
317 (setf (aref (zpng:data-array png
) row column blue
)
319 (round (* color-raiser-blue
320 (aref (zpng:data-array png
)
321 row column red
)))))))
323 ((= (aref bayer-pattern
0) bayer-pattern-red
)
324 (setf colorize-even-row-even-column
#'colorize-red
)
325 (setf colorize-even-row-odd-column
#'colorize-green
)
326 (setf colorize-odd-row-even-column
#'colorize-green
)
327 (setf colorize-odd-row-odd-column
#'colorize-blue
)
328 (setf complete-even-row-even-column
#'complete-red
)
329 (setf complete-even-row-odd-column
#'complete-green-on-red-row
)
330 (setf complete-odd-row-even-column
#'complete-green-on-blue-row
)
331 (setf complete-odd-row-odd-column
#'complete-blue
))
332 ((= (aref bayer-pattern
0) bayer-pattern-blue
)
333 (setf colorize-even-row-even-column
#'colorize-blue
)
334 (setf colorize-even-row-odd-column
#'colorize-green
)
335 (setf colorize-odd-row-even-column
#'colorize-green
)
336 (setf colorize-odd-row-odd-column
#'colorize-red
)
337 (setf complete-even-row-even-column
#'complete-blue
)
338 (setf complete-even-row-odd-column
#'complete-green-on-blue-row
)
339 (setf complete-odd-row-even-column
#'complete-green-on-red-row
)
340 (setf complete-odd-row-odd-column
#'complete-red
))
341 ((= (aref bayer-pattern
0) bayer-pattern-green
)
343 ((=(aref bayer-pattern
1) bayer-pattern-red
)
344 (setf colorize-even-row-even-column
#'colorize-green
)
345 (setf colorize-even-row-odd-column
#'colorize-red
)
346 (setf colorize-odd-row-even-column
#'colorize-blue
)
347 (setf colorize-odd-row-odd-column
#'colorize-green
)
348 (setf complete-even-row-even-column
#'complete-green-on-red-row
)
349 (setf complete-even-row-odd-column
#'complete-red
)
350 (setf complete-odd-row-even-column
#'complete-blue
)
351 (setf complete-odd-row-odd-column
#'complete-green-on-blue-row
))
352 ((=(aref bayer-pattern
1) bayer-pattern-blue
)
353 (setf colorize-even-row-even-column
#'colorize-green
)
354 (setf colorize-even-row-odd-column
#'colorize-blue
)
355 (setf colorize-odd-row-even-column
#'colorize-red
)
356 (setf colorize-odd-row-odd-column
#'colorize-green
)
357 (setf complete-even-row-even-column
#'complete-green-on-blue-row
)
358 (setf complete-even-row-odd-column
#'complete-blue
)
359 (setf complete-odd-row-even-column
#'complete-red
)
360 (setf complete-odd-row-odd-column
#'complete-green-on-red-row
))
361 (t (error "Don't know how to deal with a bayer-pattern of ~A"
363 (t (error "Don't know how to deal with a bayer-pattern of ~A"
365 ;; Recover colors (so far everything is in channel 0)
366 (loop for row from
0 below
(zpng:height png
) by
2
367 do
(loop for column from
0 below
(zpng:width png
) by
2
368 do
(funcall colorize-even-row-even-column row column
))
369 (loop for column from
1 below
(zpng:width png
) by
2
370 do
(funcall colorize-even-row-odd-column row column
)))
371 (loop for row from
1 below
(zpng:height png
) by
2
372 do
(loop for column from
0 below
(zpng:width png
) by
2
373 do
(funcall colorize-odd-row-even-column row column
))
374 (loop for column from
1 below
(zpng:width png
) by
2
375 do
(funcall colorize-odd-row-odd-column row column
)))
378 for row from
2 to lowest-row by
2 do
380 for column from
2 to rightmost-column by
2 do
381 (funcall complete-even-row-even-column row column
))
383 for column from
1 to rightmost-column by
2 do
384 (funcall complete-even-row-odd-column row column
)))
386 for row from
1 to lowest-row by
2 do
388 for column from
2 to rightmost-column by
2 do
389 (funcall complete-odd-row-even-column row column
))
391 for column from
1 to rightmost-column by
2 do
392 (funcall complete-odd-row-odd-column row column
))))))
395 (defun* send-png
(output-stream path start
396 &key
(color-raiser #(1 1 1)) reversep
397 &mandatory-key bayer-pattern
)
398 "Read an image at position start in .pictures file at path and send
399 it to the binary output-stream. Return UNIX trigger-time of image.
400 If reversep is t, turn it upside-down. Bayer-pattern is applied after
401 turning, which is a wart."
402 ;; TODO: bayer-pattern should be applied to the unturned image
403 (let ((blob-start (find-keyword path
"PICTUREDATA_BEGIN" start
))
404 (blob-size (find-keyword-value path
"dataSize=" start
))
405 (huffman-table-size (* 511 (+ 1 4)))
406 (image-height (find-keyword-value path
"height=" start
))
407 (image-width (find-keyword-value path
"width=" start
))
408 (compression-mode (find-keyword-value path
"compressed=" start
))
409 (color-type (ecase (find-keyword-value path
"channels=" start
)
412 (trigger-time (find-keyword-value path
"timeTrigger=" start
)))
413 (with-open-file (input-stream path
:element-type
'unsigned-byte
)
414 (zpng:write-png-stream
416 (ecase compression-mode
417 ((2 1) ;compressed with individual/pre-built huffman table
418 (uncompress-picture (read-huffman-table input-stream blob-start
)
419 (read-compressed-picture
421 (+ blob-start huffman-table-size
)
422 (- blob-size huffman-table-size
))
423 image-height image-width color-type
426 (fetch-picture input-stream blob-start blob-size
427 image-height image-width color-type
428 :reversep reversep
)))
434 (defun find-nth-picture (n path
)
435 "Find file-position of zero-indexed nth picture in in .pictures file
437 (let ((estimated-header-length
438 (- (find-keyword path
"PICTUREHEADER_END")
439 (find-keyword path
"PICTUREHEADER_BEGIN")
440 *picture-header-length-tolerance
*))) ; allow for variation in dataSize and a few other parameters
444 (find-keyword path
"PICTUREHEADER_BEGIN" 0) then
445 (find-keyword path
"PICTUREHEADER_BEGIN"
446 (+ picture-start picture-length estimated-header-length
))
447 for picture-length
= (find-keyword-value path
448 "dataSize=" picture-start
)
449 finally
(return (- picture-start
(length "PICTUREHEADER_BEGIN"))))))
451 (defun* send-nth-png
(n output-stream path
453 &mandatory-key bayer-pattern
)
454 "Read image number n (zero-indexed) in .pictures file at path and
455 send it to the binary output-stream. Return UNIX trigger-time of
457 (send-png output-stream path
(find-nth-picture n path
)
458 :bayer-pattern bayer-pattern
:color-raiser color-raiser
))
462 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
463 ;; collect 4 single color pixels into a three-color one
464 ;; enhance contrast of grayscale images