177 lines
6.1 KiB
Scheme
Executable File
177 lines
6.1 KiB
Scheme
Executable File
#! /usr/local/bin/scsh \
|
|
-ll sunterlib.scm -m tiff-testbed -s
|
|
!#
|
|
|
|
;****************************************************************************
|
|
; Validate the TIFF reading package
|
|
;
|
|
; We test reading of a known TIFF file, print out its directory.
|
|
; We also test an internal consistency of the package.
|
|
;
|
|
; Derived from vtiff.scm 1.1 2003/09/29 20:41:51 oleg
|
|
|
|
; Note: some tests below depend on the exact parameters
|
|
; of the following sample file
|
|
; The file is a GNU logo (from http://www.gnu.org)
|
|
; converted from JPG to TIFF
|
|
|
|
(define sample-tiff-file "gnu-head-sm.tif")
|
|
|
|
(cerr nl "Verifying the TIFF library" nl)
|
|
|
|
(cerr nl "Verifying tagdict operations..." nl)
|
|
(let ()
|
|
(assert
|
|
(= 256 (tagdict-get-by-name tiff-standard-tagdict 'TIFFTAG:IMAGEWIDTH)))
|
|
(assert (eq? 'TIFFTAG:IMAGEWIDTH
|
|
(tagdict-get-by-num tiff-standard-tagdict 256)))
|
|
(assert (eq? #f
|
|
(tagdict-get-by-num tiff-standard-tagdict 65500)))
|
|
(assert (= 5
|
|
(tagdict-tagval-get-by-name tiff-standard-tagdict
|
|
'TIFFTAG:COMPRESSION 'LZW)))
|
|
(assert (eq? 'LZW
|
|
(tagdict-tagval-get-by-num tiff-standard-tagdict
|
|
'TIFFTAG:COMPRESSION 5)))
|
|
(assert (eq? #f
|
|
(tagdict-tagval-get-by-num tiff-standard-tagdict
|
|
'TIFFTAG:COMPRESSION 65500)))
|
|
|
|
(let ((ext-dict
|
|
(tagdict-add-all tiff-standard-tagdict
|
|
(make-tagdict
|
|
'((WAupper_left_lat 33004)
|
|
(WAhemisphere 33003 (North . 1) (South . 2)))))))
|
|
(assert (= 33004 (tagdict-get-by-name ext-dict 'WAupper_left_lat)))
|
|
(assert (eq? 'WAupper_left_lat
|
|
(tagdict-get-by-num ext-dict 33004)))
|
|
(assert (eq? 'TIFFTAG:PHOTOMETRIC (tagdict-get-by-num ext-dict 262)))
|
|
(assert (eq? #f
|
|
(tagdict-tagval-get-by-num ext-dict 'WAupper_left_lat 0)))
|
|
(assert (= 1
|
|
(tagdict-tagval-get-by-name ext-dict 'WAhemisphere 'North)))
|
|
(assert (eq? 'South
|
|
(tagdict-tagval-get-by-num ext-dict 'WAhemisphere 2))))
|
|
)
|
|
|
|
(define (test-dictionary-consistency tiff-dict)
|
|
(cerr nl "Verifying the consistency of dictionary operations ..." nl)
|
|
(assert (tiff-directory? tiff-dict))
|
|
(assert (positive? (tiff-directory-size tiff-dict))
|
|
(not (tiff-directory-empty? tiff-dict)))
|
|
(assert (=
|
|
(tiff-directory-get tiff-dict 'TIFFTAG:IMAGEWIDTH)
|
|
(tiff-directory-get tiff-dict 256)))
|
|
(assert (eq? #f (tiff-directory-get tiff-dict 65500)))
|
|
(let ((not-given (list 'not-given)))
|
|
(assert (eq? not-given (tiff-directory-get tiff-dict 65500
|
|
(lambda () not-given)))))
|
|
(let ((size (tiff-directory-size tiff-dict)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(tiff-directory-fold-left tiff-dict
|
|
(lambda (el count) (values #t (+ 1 count))) 0))
|
|
(lambda (size-via-fold)
|
|
(assert (= size size-via-fold)))))
|
|
(let*-values
|
|
(((len) (tiff-directory-get tiff-dict 'TIFFTAG:IMAGELENGTH))
|
|
((len-via-fold prev-count)
|
|
(tiff-directory-fold-left tiff-dict
|
|
(lambda (dir-entry found prev-count)
|
|
(if (= (tiff-dir-entry-tag dir-entry) 257)
|
|
(values #f (force (tiff-dir-entry-value dir-entry))
|
|
prev-count) ; and terminate now
|
|
(values #t #f (+ 1 prev-count))))
|
|
#f 0)))
|
|
(assert (= len len-via-fold)
|
|
(< 0 prev-count (tiff-directory-size tiff-dict))))
|
|
)
|
|
|
|
(define (test-known-values-from-dict tiff-dict)
|
|
(cerr nl "Getting sample data from the dictionary ")
|
|
(let
|
|
((known-values
|
|
'((TIFFTAG:IMAGEWIDTH . 129)
|
|
(TIFFTAG:IMAGELENGTH . 122)
|
|
(TIFFTAG:BITSPERSAMPLE . 8)
|
|
(TIFFTAG:IMAGEDESCRIPTION . "JPEG:gnu-head-sm.jpg 129x122")
|
|
(TIFFTAG:COMPRESSION . 1)
|
|
(TIFFTAG:SAMPLESPERPIXEL . 1)
|
|
(TIFFTAG:STRIPBYTECOUNTS . 15738) ; the product of width and length
|
|
(TIFFTAG:XRESOLUTION . 72)
|
|
(TIFFTAG:CLEANFAXDATA . #f))))
|
|
(for-each
|
|
(lambda (tag-val)
|
|
(cerr "Tag " (car tag-val) "...")
|
|
(let ((real (tiff-directory-get tiff-dict (car tag-val))))
|
|
(cerr real nl)
|
|
(assert (equal? real (cdr tag-val)))))
|
|
known-values
|
|
))
|
|
(assert (eq? 'NONE
|
|
(tiff-directory-get-as-symbol tiff-dict
|
|
'TIFFTAG:COMPRESSION)))
|
|
)
|
|
|
|
|
|
(define (test-reading-pixel-matrix tiff-dict eport)
|
|
(cerr nl "Reading the pixel matrix and spot-checking it ...")
|
|
; Make sure we can handle this particular TIFF image
|
|
; No compression
|
|
(assert (eq? 'NONE
|
|
(tiff-directory-get-as-symbol tiff-dict
|
|
'TIFFTAG:COMPRESSION)))
|
|
(assert (= 1 (tiff-directory-get tiff-dict 'TIFFTAG:SAMPLESPERPIXEL)))
|
|
(assert (= 8 (tiff-directory-get tiff-dict 'TIFFTAG:BITSPERSAMPLE)))
|
|
|
|
(let*
|
|
((ncols (tiff-directory-get tiff-dict 'TIFFTAG:IMAGEWIDTH))
|
|
(_ (assert (number? ncols) (positive? ncols)))
|
|
(nrows (tiff-directory-get tiff-dict 'TIFFTAG:IMAGELENGTH))
|
|
(_ (assert (number? nrows) (positive? nrows)))
|
|
(rows-per-strip (tiff-directory-get tiff-dict 'TIFFTAG:ROWSPERSTRIP
|
|
(lambda () nrows)))
|
|
(_ (assert (positive? rows-per-strip)))
|
|
(strip-offsets (tiff-directory-get tiff-dict 'TIFFTAG:STRIPOFFSETS
|
|
(lambda () (error "STRIPOFFSETS must be present!"))))
|
|
; make it a u32vector
|
|
(strip-offsets
|
|
(cond
|
|
((u32vector? strip-offsets) strip-offsets)
|
|
((u16vector? strip-offsets)
|
|
(list->u32vector (u16vector->list strip-offsets)))
|
|
(else (u32vector strip-offsets))))
|
|
(image-size (* nrows ncols))
|
|
(strip-size (* rows-per-strip ncols))
|
|
(image (make-u8vector image-size 0))
|
|
)
|
|
(cerr nl "Loading the image matrix of the size " image-size
|
|
" bytes...")
|
|
(let outer ((strip 0) (i 0))
|
|
(if (>= strip (u32vector-length strip-offsets)) #f
|
|
(let ((i-end (min (+ i strip-size) image-size)))
|
|
(endian-port-setpos eport (u32vector-ref strip-offsets strip))
|
|
(let inner ((i i))
|
|
(if (>= i i-end) (outer (++ strip) i)
|
|
(begin
|
|
(u8vector-set! image i (endian-port-read-int1 eport))
|
|
(inner (++ i))))))))
|
|
(assert (= 255 (u8vector-ref image 0))
|
|
(= 248 (u8vector-ref image 17)))
|
|
;(display image)
|
|
))
|
|
|
|
|
|
|
|
(cerr nl "Reading the sample TIFF file " sample-tiff-file "..." nl)
|
|
(let* ((eport (make-endian-port (open-input-file sample-tiff-file) #t))
|
|
(tiff-dict (read-tiff-file eport)))
|
|
(print-tiff-directory tiff-dict (current-output-port))
|
|
(test-known-values-from-dict tiff-dict)
|
|
(test-dictionary-consistency tiff-dict)
|
|
(test-reading-pixel-matrix tiff-dict eport)
|
|
)
|
|
|
|
|
|
(cerr nl "All tests passed" nl)
|