sunterlib/scsh/tiff/vtiff.scm

#! /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)