;**************************************************************************** ; 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. ; ; IMPORT ; appropriate prelude: myenv.scm, myenv-bigloo.scm, myenv-scm.scm ; depending on your system ; catch-error.scm -- for procedure, for-syntax ; util.scm ; char-encoding.scm (for ascii->char) ; tiff.scm - the library itself ; ; $Id: vtiff.scm,v 1.1 2003/09/29 20:41:51 oleg Exp 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") ;---- Endian port ; We need an endian port. The following is Gambit-specific ; Everything that starts with two hashes is Gambit-specific (define-structure endian-port port msb-first?) (define (close-endian-port eport) (close-input-port (endian-port-port eport))) ; endian-port-set-bigendian! EPORT -> UNSPECIFIED (define (endian-port-set-bigendian! eport) (endian-port-msb-first?-set! eport #t)) ; endian-port-set-littlendian! EPORT -> UNSPECIFIED (define (endian-port-set-littlendian! eport) (endian-port-msb-first?-set! eport #f)) ; endian-port-read-int1:: PORT -> UINTEGER (byte) (define (endian-port-read-int1 eport) (let ((c (read-char (endian-port-port eport)))) (if (eof-object? c) (error "unexpected EOF") (char->integer c)))) ; Gambit-specific. Need read-byte ; endian-port-read-int2:: PORT -> UINTEGER (define (endian-port-read-int2 eport) (let* ((c1 (endian-port-read-int1 eport)) (c2 (endian-port-read-int1 eport))) (if (endian-port-msb-first? eport) (##fixnum.logior (##fixnum.shl c1 8) c2) ;(+ (* c1 256) c2) (##fixnum.logior (##fixnum.shl c2 8) c1) ;(+ (* c2 256) c1) ))) ; endian-port-read-int4:: PORT -> UINTEGER (define (endian-port-read-int4 eport) (let* ((c1 (endian-port-read-int1 eport)) (c2 (endian-port-read-int1 eport)) (c3 (endian-port-read-int1 eport)) (c4 (endian-port-read-int1 eport))) (if (endian-port-msb-first? eport) (if (< c1 64) ; The int4 will fit into a fixnum (##fixnum.logior (##fixnum.shl (##fixnum.logior (##fixnum.shl (##fixnum.logior (##fixnum.shl c1 8) c2) 8) c3) 8) c4) (+ (* 256 ; The multiplication will make a bignum (##fixnum.logior (##fixnum.shl (##fixnum.logior (##fixnum.shl c1 8) c2) 8) c3)) c4)) ; c4 is the most-significant byte (if (< c4 64) (##fixnum.logior (##fixnum.shl (##fixnum.logior (##fixnum.shl (##fixnum.logior (##fixnum.shl c4 8) c3) 8) c2) 8) c1) (+ (* 256 (##fixnum.logior (##fixnum.shl (##fixnum.logior (##fixnum.shl c4 8) c3) 8) c2)) c1))))) ; endian-port-setpos PORT INTEGER -> UNSPECIFIED (define (endian-port-setpos eport pos) (OS:fseek-abs (endian-port-port eport) pos)) ;^^^^^^^^^^^^^ (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)