diff --git a/scsh/tiff/AUTHORS b/scsh/tiff/AUTHORS new file mode 100644 index 0000000..d5c860d --- /dev/null +++ b/scsh/tiff/AUTHORS @@ -0,0 +1 @@ +Oleg Kiselyov, RT Happe (porter) diff --git a/scsh/tiff/BLURB b/scsh/tiff/BLURB new file mode 100644 index 0000000..6883be1 --- /dev/null +++ b/scsh/tiff/BLURB @@ -0,0 +1 @@ +Read entries from the (first) image directory of tiff files. diff --git a/scsh/tiff/README b/scsh/tiff/README new file mode 100644 index 0000000..6bd2646 --- /dev/null +++ b/scsh/tiff/README @@ -0,0 +1,325 @@ +* Tiff -- A port of Oleg Kiselyov's tiff code + +Both the code and this documentation is derived from Oleg's files, cf. +http://okmij.org/ftp/Scheme/binary-io.html#tiff + +This distribution comes with two family-friendly tiff files in sunterlib/ +scsh/tiff/. + +** Reading TIFF files + +[ Oleg's announcement. Main changes to the announced library: modularisation + and fake srfi-4 uniform vectors. (The source files list the changes.) ] + +From posting-system@google.com Wed Oct 8 01:24:13 2003 +Date: Tue, 7 Oct 2003 18:24:12 -0700 +From: oleg@pobox.com (oleg@pobox.com) +Newsgroups: comp.lang.scheme +Subject: [ANN] Reading TIFF files +Message-ID: <7eb8ac3e.0310071724.59bffe62@posting.google.com> +Status: OR + +This is to announce a Scheme library to read and analyze TIFF image +files. We can use the library to obtain the dimensions of a TIFF +image; the image name and description; the resolution and other +meta-data. We can then load a pixel matrix or a colormap table. An +accompanying tiff-prober program prints out the TIFF dictionary in a +raw and polished formats. + + http://pobox.com/~oleg/ftp/Scheme/lib/tiff.scm + dependencies: util.scm, char-encoding.scm, myenv.scm + http://pobox.com/~oleg/ftp/Scheme/tests/vtiff.scm + see also: gnu-head-sm.tif in the same directory + http://pobox.com/~oleg/ftp/Scheme/tiff-prober.scm + +Features: + - The library handles TIFF files written in both endian formats + - A TIFF directory is treated somewhat as a SRFI-44 immutable + dictionary collection. Only the most basic SRFI-44 methods are + implemented, including the left fold iterator and the get method. + - An extensible tag dictionary translates between symbolic tag + names and numeric ones. Ditto for tag values. + - A tag dictionary for all TIFF 6 standard tags and values comes + with the library. A user can add the definitions of + his private tags. + - The library handles TIFF directory values of types: + (signed/unsigned) byte, short, long, rational; ASCII strings. + - A particular care is taken to properly handle values whose + total size is no more than 4 bytes. + - Array values (including the image matrix) are returned as + uniform vectors (SRFI-4) + - Values are read lazily. If you are only interested in the + dimensions of an image, the image matrix itself will not be loaded. + + +Here's the result of running tiff-prober on the image of the GNU head +(converted from JPEG to TIFF by xv). I hope I won't have any copyright +problems with using and distributing that image. + +Analyzing TIFF file tests/gnu-head-sm.tif... +There are 15 entries in the TIFF directory +they are +TIFFTAG:IMAGEWIDTH, count 1, type short, value-offset 129 (0x81) +TIFFTAG:IMAGELENGTH, count 1, type short, value-offset 122 (0x7A) +TIFFTAG:BITSPERSAMPLE, count 1, type short, value-offset 8 (0x8) +TIFFTAG:COMPRESSION, count 1, type short, value-offset 1 (0x1) +TIFFTAG:PHOTOMETRIC, count 1, type short, value-offset 1 (0x1) +TIFFTAG:IMAGEDESCRIPTION, count 29, type ascii str, value-offset 15932 (0x3E3C) +TIFFTAG:STRIPOFFSETS, count 1, type long, value-offset 8 (0x8) +TIFFTAG:ORIENTATION, count 1, type short, value-offset 1 (0x1) +TIFFTAG:SAMPLESPERPIXEL, count 1, type short, value-offset 1 (0x1) +TIFFTAG:ROWSPERSTRIP, count 1, type short, value-offset 122 (0x7A) +TIFFTAG:STRIPBYTECOUNTS, count 1, type long, value-offset 15738 (0x3D7A) +TIFFTAG:XRESOLUTION, count 1, type rational, value-offset 15962 (0x3E5A) +TIFFTAG:YRESOLUTION, count 1, type rational, value-offset 15970 (0x3E62) +TIFFTAG:PLANARCONFIG, count 1, type short, value-offset 1 (0x1) +TIFFTAG:RESOLUTIONUNIT, count 1, type short, value-offset 2 (0x2) + +image width: 129 +image height: 122 +image depth: 8 +document name: *NOT SPECIFIED* +image description: + JPEG:gnu-head-sm.jpg 129x122 +time stamp: *NOT SPECIFIED* +compression: NONE + +In particular, the dump of the tiff directory is produced by the +following line of code + (print-tiff-directory tiff-dict (current-output-port)) +To determine the width of the image, we do + (tiff-directory-get tiff-dict 'TIFFTAG:IMAGEWIDTH not-spec) +To determine the compression (as a symbol) we evaluate + (tiff-directory-get-as-symbol tiff-dict 'TIFFTAG:COMPRESSION not-spec) + +If an image directory contains private tags, they will be printed like +the following: + +private tag 33009, count 1, type signed long, value-offset 16500000 (0xFBC520) +private tag 33010, count 1, type signed long, value-offset 4294467296 + (0xFFF85EE0) + +A user may supply a dictionary of his private tags and enjoy +the automatic translation from symbolic to numerical tag names. + +The validation code vtiff.scm includes a function +test-reading-pixel-matrix that demonstrates loading a pixel matrix of +an image in an u8vector. The code can handle a single or multiple +strips. + +Portability: the library itself, tiff.scm, relies on the following +extensions to R5RS: uniform vectors (SRFI-4); ascii->char function +(which is on many systems just integer->char); trivial define-macro +(which can be easily re-written into syntax-rules); let*-values +(SRFI-11); records (SRFI-9). Actually, the code uses Gambit's native +define-structures, which can be easily re-written into SRFI-9 +records. The Scheme system should be able to represent the full range +of 32-bit integers and should support rationals. + +The most problematic extension is an endian port. The TIFF library +assumes the existence of a data structure with the following +operations + endian-port-set-bigendian!:: EPORT -> UNSPECIFIED + endian-port-set-littlendian!:: EPORT -> UNSPECIFIED + endian-port-read-int1:: EPORT -> UINTEGER (byte) + endian-port-read-int2:: EPORT -> UINTEGER + endian-port-read-int4:: EPORT -> UINTEGER + endian-port-setpos:: EPORT INTEGER -> UNSPECIFIED + +The library uses solely these methods to access the input port. The +endian port can be implemented in a R5RS Scheme system if we assume +that the composition of char->integer and read-char yields a byte and +if we read the whole file into a string or a u8vector +(SRFI-4). Obviously, there are times when such a solution is not +satisfactory. Therefore, tiff-prober and the validation code +vtiff.scm rely on a Gambit-specific code. All major Scheme systems can +implement endian ports in a similar vein -- alas, each in its own +particular way. + + + +** Endian ports +from structure endian. + +We rely on an ENDIAN-PORT +A port with the following operations + endian-port-set-bigendian!:: EPORT -> UNSPECIFIED + endian-port-set-littlendian!:: EPORT -> UNSPECIFIED + endian-port-read-int1:: EPORT -> UINTEGER (byte) + endian-port-read-int2:: EPORT -> UINTEGER + endian-port-read-int4:: EPORT -> UINTEGER + endian-port-setpos EPORT INTEGER -> UNSPECIFIED + + close-endian-port:: EPORT -> UNSPECIFIED + make-endian-port:: INPORT BOOLEAN -> EPORT + The boolean argument sets the endianness of the resulting endian-port, + boolean(most sigificant bit first). After having wrapped the INPORT + in the EPORT, you should no longer manipulate the INPORT directly. + + + +** Tiff +in structures TIFF and TIFFLET. TIFFLET exports a survival package of +bindings: + read-tiff-file, print-tiff-directory, tiff-directory-get(-as-symbol). +Refined needs will require TIFF. + +*** TIFF tags: codes and values + +A tag dictionary, tagdict, record helps translate between +tag-symbols and their numerical values. + +tagdict-get-by-name TAGDICT TAG-NAME => INT + where TAG-NAME is a symbol. +Translate a symbolic representation of a TIFF tag into a numeric +representation. +An error is raised if the lookup fails. + +tagdict-get-by-num TAGDICT INT => TAG-NAME or #f + Translate from a numeric tag value to a symbolic representation, +if it exists. Return #f otherwise. + +tagdict-tagval-get-by-name TAGDICT TAG-NAME VAL-NAME => INT + where VAL-NAME is a symbol. +Translate from the symbolic representation of a value associated +with TAG-NAME in the TIFF directory, into the numeric representation. +An error is raised if the lookup fails. + +tagdict-tagval-get-by-num TAGDICT TAG-NAME INT => VAL-NAME or #f + Translate from a numeric value associated with TAG-NAME in the TIFF +directory to a symbolic representation, if it exists. Return #f +otherwise. + +make-tagdict ((TAG-NAME INT (VAL-NAME . INT) ...) ...) + Build a tag dictionary + +tagdict? TAGDICT -> BOOL + +tagdict-add-all DEST-DICT SRC-DICT -> DEST-DICT + Join two dictionaries + +tiff-standard-tagdict : TAGDICT + The variable tiff-standard-tagdict is initialized to the dictionary +of standard TIFF tags (which you may look up in the first section above +or in the source, tiff.scm). + +Usage scenario: + (tagdict-get-by-name tiff-standard-tagdict 'TIFFTAG:IMAGEWIDTH) => 256 + (tagdict-get-by-num tiff-standard-tagdict 256) => 'TIFFTAG:IMAGEWIDTH + (tagdict-tagval-get-by-name tiff-standard-tagdict + 'TIFFTAG:COMPRESSION 'LZW) => 5 + (tagdict-tagval-get-by-num tiff-standard-tagdict + 'TIFFTAG:COMPRESSION 5) => 'LZW + + (define extended-tagdict + (tagdict-add-all tiff-standard-tagdict + (make-tagdict + '((WAupper_left_lat 33004) + (WAhemisphere 33003 (North . 1) (South . 2)))))) + + +*** TIFF directory entry + +a descriptor of a TIFF "item", which can be image data, document description, +time stamp, etc, depending on the tag. Thus an entry has the following +structure: + unsigned short tag; + unsigned short type; // data type: byte, short word, etc. + unsigned long count; // number of items; length in spec + unsigned long val_offset; // byte offset to field data + +The values associated with each entry are disjoint and may appear anywhere +in the file (so long as they are placed on a word boundary). + +Note, If the value takes 4 bytes or less, then it is placed in the offset +field to save space. If the value takes less than 4 bytes, it is +*left*-justified in the offset field. +Note, that it's always *left* justified (stored in the lower bytes) +no matter what the byte order (big- or little- endian) is! +Here's the precise quote from the TIFF 6.0 specification: +"To save time and space the Value Offset contains the Value instead of +pointing to the Value if and only if the Value fits into 4 bytes. If +the Value is shorter than 4 bytes, it is left-justified within the +4-byte Value Offset, i.e., stored in the lower- numbered +bytes. Whether the Value fits within 4 bytes is determined by the Type +and Count of the field." + +tiff-dir-entry? TIFF-DIR-ENTRY => BOOLEAN +tiff-dir-entry-tag TIFF-DIR-ENTRY => INTEGER +tiff-dir-entry-type TIFF-DIR-ENTRY => INTEGER +tiff-dir-entry-count TIFF-DIR-ENTRY => INTEGER +tiff-dir-entry-val-offset TIFF-DIR-ENTRY => INTEGER +tiff-dir-entry-value TIFF-DIR-ENTRY => VALUE + +print-tiff-dir-entry TIFF-DIR-ENTRY TAGDICT OPORT -> UNSPECIFIED + Print the contents of TIFF-DIR-ENTRY onto the output port OPORT +using TAGDICT to convert tag identifiers to symbolic names + + +*** TIFF Image File Directory + +TIFF directory is a collection of TIFF directory entries. The entries +are sorted in an ascending order by tag. +Note, a TIFF file can contain more than one directory (chained together). +We handle only the first one. + +We treat a TIFF image directory somewhat as an ordered, immutable, +dictionary collection, see SRFI-44. + +tiff-directory? VALUE => BOOLEAN +tiff-directory-size TIFF-DIRECTORY => INTEGER +tiff-directory-empty? TIFF-DIRECTORY => BOOLEAN + +tiff-directory-get TIFF-DIRECTORY KEY [ABSENCE-THUNK] => VALUE + KEY can be either a symbol or an integer. +If the lookup fails, ABSENCE-THUNK, if given, is evaluated and its value +is returned. If ABSENCE-THUNK is omitted, the return value on failure +is #f. + +tiff-directory-get-as-symbol TIFF-DIRECTORY KEY [ABSENCE-THUNK] => VALUE + KEY must be a symbol. +If it is possible, the VALUE is returned as a symbol, as translated +by the tagdict. + +tiff-directory-fold-left TIFF-DIRECTORY FOLD-FUNCTION SEED-VALUE + ... => seed-value ... + The fold function receives a tiff-directory-entry as a value + +read-tiff-file:: EPORT [PRIVATE-TAGDICT] -> TIFF-DIRECTORY +print-tiff-directory:: TIFF-DIRECTORY OPORT -> UNSPECIFIED + + + +** Usage example: tiff prober + +The scripts probe-tiff and equivalently tiff-prober.scm read a TIFF file +and print out its directory (as well as values of a few "important" tags). +The scripts (or script headers) assume that the executable scsh resides +in /usr/local/bin, and that the environment variable SCSH_LIB_DIRS lists +the sunterlib directory with the config file sunterlib.scm; cf. the reference +manual about "Running Scsh\Scsh command-line switches\Switches". + +Usage + probe-tiff tiff-file1 ... +or + tiff-prober.scm tiff-file1 ... + +Structure tiff-prober exports the entry point for the scripts: + +tiff-prober ARGV => UNSPECIFIED +Call, for instance, (tiff-prober '("foo" "bsp.tiff")). + + +** Validating the library + +The valdidating code is in sunterlib/scsh/tiff/vtiff.scm and assumes that +the tiffed GNU logo sunterlib/tiff/gnu-head-sm.tif resides in the working +directory. In that situation you may go + ,in tiff-testbed ; and + ,load vtiff.scm +Alternatively make sure that the env variable SCSH_LIB_DIRS lists the +directory with sunterlib.scm (just as for the tiff prober, see above) +and run vtiff.scm as script. + + oOo + diff --git a/scsh/tiff/aux.scm b/scsh/tiff/aux.scm new file mode 100644 index 0000000..d84acb7 --- /dev/null +++ b/scsh/tiff/aux.scm @@ -0,0 +1,51 @@ +; +; COUT, CERR, NL, ++ from Oleg Kiselyov's myenv.scm +; changes: +; ##stderr --> (error-output-port) +; ++ via define-syntax and + + +(define-syntax define-structure + (lambda (form rename name=) + (let ((name (cadr form)) ; Symbol | Generated-Name + (fields (cddr form)) ; Proper-List(S. | G.N.) + (concat (lambda (symbols) ; Proper-List(S.) -> S. + (string->symbol + (apply string-append + (map symbol->string symbols)))))) + + `(,(rename 'define-record-type) + ,name + (,(concat `(make- ,name)) ,@fields) + ,(concat `(,name ?)) + ,@(map (lambda (field) + `(,field + ,(concat `(,name - ,field)) + ,(concat `(,name - ,field -set!)))) + fields)) + ))) + + +; like cout << arguments << args +; where argument can be any Scheme object. If it's a procedure +; (without args) it's executed rather than printed (like newline) + +(define (cout . args) + (for-each (lambda (x) + (if (procedure? x) (x) (display x))) + args)) + +(define (cerr . args) + (for-each (lambda (x) + (if (procedure? x) + (x (error-output-port)) + (display x (error-output-port)))) + args)) + +(define nl (string #\newline)) + + +;; read-only increment +(define-syntax ++ + (syntax-rules () + ((++ x) + (+ 1 x)))) diff --git a/scsh/tiff/bsp.tiff b/scsh/tiff/bsp.tiff new file mode 100644 index 0000000..37b6d10 Binary files /dev/null and b/scsh/tiff/bsp.tiff differ diff --git a/scsh/tiff/endian.scm b/scsh/tiff/endian.scm new file mode 100644 index 0000000..c431391 --- /dev/null +++ b/scsh/tiff/endian.scm @@ -0,0 +1,79 @@ +; taken and adapted from Oleg Kiselyov's tiff-prober.scm +; Changes +; ##fixnumm.logior --> bitwise-ior +; ##fixnum.shl --> arithmetic-shift +; make-endian-port : switches off buffering +; To be evaluated in an environment binding +; DEFINE-STRUCTURE to the required syntax (like CL's DEFSTRUCT) +; CHAR->INTEGER to CHAR->ASCII + +(define-structure endian-port port msb-first?) +(set! make-endian-port + (let ((really-make-endian-port make-endian-port)) + (lambda (port msb-first?) + (set-port-buffering port bufpol/none) ; work around SEEK bug + (really-make-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 + ; sunterlib: c->i bound to char->ascii + +; 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) + (bitwise-ior (arithmetic-shift c1 8) c2) ;(+ (* c1 256) c2) + (bitwise-ior (arithmetic-shift 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) + ;; (+ c4 (* 256 (+ c3 (* 256 (+ c2 (* 256 c1)))))) + (if (< c1 64) ; The int4 will fit into a fixnum + (bitwise-ior + (arithmetic-shift + (bitwise-ior + (arithmetic-shift + (bitwise-ior (arithmetic-shift c1 8) c2) 8) c3) 8) c4) + (+ (* 256 ; The multiplication will make a bignum + (bitwise-ior + (arithmetic-shift + (bitwise-ior (arithmetic-shift c1 8) c2) 8) c3)) + c4)) + ;; (+ c1 (* 256 (+ c2 (* 256 (+ c3 (* 256 c4)))))) + ; c4 is the most-significant byte + (if (< c4 64) + (bitwise-ior + (arithmetic-shift + (bitwise-ior + (arithmetic-shift + (bitwise-ior (arithmetic-shift c4 8) c3) 8) c2) 8) c1) + (+ (* 256 + (bitwise-ior + (arithmetic-shift + (bitwise-ior (arithmetic-shift 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)) diff --git a/scsh/tiff/gnu-head-sm.tif b/scsh/tiff/gnu-head-sm.tif new file mode 100644 index 0000000..7ce0faf Binary files /dev/null and b/scsh/tiff/gnu-head-sm.tif differ diff --git a/scsh/tiff/interfaces.scm b/scsh/tiff/interfaces.scm new file mode 100644 index 0000000..7d63bbf --- /dev/null +++ b/scsh/tiff/interfaces.scm @@ -0,0 +1,78 @@ +(define tifflet-face + (export read-tiff-file + print-tiff-directory + tiff-directory-get + tiff-directory-get-as-symbol + )) + +(define tifftag-face + (export tagdict-get-by-name + tagdict-get-by-num + tagdict-tagval-get-by-name + tagdict-tagval-get-by-num + make-tagdict + tagdict? + tagdict-add-all + tiff-standard-tagdict + )) + +(define tiffdir-face + (export tiff-directory? + tiff-directory-size + tiff-directory-empty? + tiff-directory-get + tiff-directory-get-as-symbol + read-tiff-file + print-tiff-directory + tiff-directory-fold-left + tiff-dir-entry? + tiff-dir-entry-tag + tiff-dir-entry-type + tiff-dir-entry-count + tiff-dir-entry-val-offset + tiff-dir-entry-value + print-tiff-dir-entry + )) + +(define tiff-prober-face + (export tiff-prober)) + +(define-interface endian-face + (export make-endian-port + close-endian-port + endian-port-set-bigendian! + endian-port-set-littlendian! + endian-port-read-int1 + endian-port-read-int2 + endian-port-read-int4 + endian-port-setpos)) + +;;; + +(define-interface ersatz-srfi-4-face + (export u8vector? + u8vector make-u8vector + u8vector-length + u8vector-ref u8vector-set! + u8vector->list list->u8vector + + u16vector? + u16vector make-u16vector + u16vector-length + u16vector-ref u16vector-set! + u16vector->list list->u16vector + + u32vector? + u32vector make-u32vector + u32vector-length + u32vector-ref u32vector-set! + u32vector->list list->u32vector + )) + + +(define-interface tiff-helpers-face + (export (define-structure :syntax) + (++ :syntax) + cerr cout nl)) + + diff --git a/scsh/tiff/packages.scm b/scsh/tiff/packages.scm new file mode 100644 index 0000000..06ad730 --- /dev/null +++ b/scsh/tiff/packages.scm @@ -0,0 +1,79 @@ +(define-structures + ((tifflet tifflet-face) + (tiff (compound-interface tifftag-face tiffdir-face))) + (open tiff-helpers endian + krims ; assert + (modify sequence-lib (rename (sequence-any any?))) ; any? + ascii ; ascii->char + srfi-11 ; let*-values + srfi-23 ; error + ersatz-srfi-4 + scheme) + (files tiff)) + +(define-structure endian endian-face + (open tiff-helpers ; define-structure + ascii ; char->ascii + srfi-23 ; error + (modify scheme-with-scsh (rename (seek OS:fseek-abs)))) + ; seek, bit-ops, buffer policy + (begin (define char->integer char->ascii)) + (files endian)) + +(define-structure tiff-helpers tiff-helpers-face + (open srfi-9 + srfi-23 ; error + scheme-with-scsh ; error-output-port + ) + (for-syntax (open scheme)) + (files aux)) + +(define-structure ersatz-srfi-4 ersatz-srfi-4-face + (open (modify scheme (alias (vector? u8vector?) + (vector u8vector) + (make-vector make-u8vector) + (vector-length u8vector-length) + (vector-ref u8vector-ref) + (vector-set! u8vector-set!) + (vector->list u8vector->list) + (list->vector list->u8vector) + + (vector? u16vector?) + (vector u16vector) + (make-vector make-u16vector) + (vector-length u16vector-length) + (vector-ref u16vector-ref) + (vector-set! u16vector-set!) + (vector->list u16vector->list) + (list->vector list->u16vector) + + (vector? u32vector?) + (vector u32vector) + (make-vector make-u32vector) + (vector-length u32vector-length) + (vector-ref u32vector-ref) + (vector-set! u32vector-set!) + (vector->list u32vector->list) + (list->vector list->u32vector) + )))) + +(define-structure tiff-prober tiff-prober-face + (open tifflet + endian ; make-endian-port + tiff-helpers ; cout cerr nl + scheme-with-scsh ; scsh for open-input-file + ) + (begin (define (exit) #f)) ; good enough + (files tiff-prober)) + +(define-structure tiff-testbed (export ) + (open tiff + endian ; endian ports + tiff-helpers ; cerr nl ++ + krims ; assert + ersatz-srfi-4 ; fake uniform vectors + srfi-11 ; let-values* + scheme-with-scsh + ) + (begin )) + diff --git a/scsh/tiff/probe-tiff b/scsh/tiff/probe-tiff new file mode 100755 index 0000000..9f88b55 --- /dev/null +++ b/scsh/tiff/probe-tiff @@ -0,0 +1,3 @@ +#! /usr/local/bin/scsh \ +-e tiff-prober -ll sunterlib.scm -o tiff-prober -s +!# diff --git a/scsh/tiff/tiff-prober.scm b/scsh/tiff/tiff-prober.scm new file mode 100755 index 0000000..1ebee34 --- /dev/null +++ b/scsh/tiff/tiff-prober.scm @@ -0,0 +1,55 @@ +#! /usr/local/bin/scsh \ +-e tiff-prober -ll sunterlib.scm -o tiff -o tiff-helpers -o endian -s +!# + +;**************************************************************************** +; TIFF prober +; +; This code reads a TIFF file and prints out its directory (as well as values +; of a few "important" tags) +; Usage +; tiff-prober tiff-file1... +; Derived from Oleg Kiselyov's tiff-prober.scm 2.0 2003/10/04 02:35:30 +; Changes for the sunterlib +; procedural wrapper TIFF-PROBER as entry point +; argv as parameter +; endian ports moved to endian.scm + +(define (tiff-prober argv-s) + (let + ((help + (lambda () + (cerr nl nl "print information about TIFF file(s)" nl) + (cerr nl "Usage") + (cerr nl " tiff-prober tiff-file1...") + (cerr nl nl "Example:") + (cerr nl " tiff-prober im1.tiff im2.tiff" nl nl) + (exit))) + ) + ; (car argv-s) is program's name, as usual + (if (or (null? argv-s) (null? (cdr argv-s))) + (help)) ; at least one argument, besides argv[0], is expected + (for-each + (lambda (file-name) + (cout nl nl "Analyzing TIFF file " file-name "..." nl) + (let* ((eport (make-endian-port (open-input-file file-name) #t)) + (tiff-dict (read-tiff-file eport)) + (not-spec (lambda () "*NOT SPECIFIED*"))) + (print-tiff-directory tiff-dict (current-output-port)) + (cout nl "image width: " + (tiff-directory-get tiff-dict 'TIFFTAG:IMAGEWIDTH not-spec)) + (cout nl "image height: " + (tiff-directory-get tiff-dict 'TIFFTAG:IMAGELENGTH not-spec)) + (cout nl "image depth: " + (tiff-directory-get tiff-dict 'TIFFTAG:BITSPERSAMPLE not-spec)) + (cout nl "document name: " + (tiff-directory-get tiff-dict 'TIFFTAG:DOCUMENTNAME not-spec)) + (cout nl "image description: " nl " " + (tiff-directory-get tiff-dict 'TIFFTAG:IMAGEDESCRIPTION not-spec)) + (cout nl "time stamp: " + (tiff-directory-get tiff-dict 'TIFFTAG:DATETIME not-spec)) + (cout nl "compression: " + (tiff-directory-get-as-symbol tiff-dict + 'TIFFTAG:COMPRESSION not-spec)) + (cout nl nl))) + (cdr argv-s))) ) diff --git a/scsh/tiff/tiff.scm b/scsh/tiff/tiff.scm new file mode 100644 index 0000000..ce081c5 --- /dev/null +++ b/scsh/tiff/tiff.scm @@ -0,0 +1,774 @@ +;**************************************************************************** +; +; Tag Image File Format (TIFF) +; +; +; Tiff tag definitions were borrowed from: +; > Copyright (c) 1988, 1990 by Sam Leffler. +; > All rights reserved. +; > +; > This file is provided for unrestricted use provided that this +; > legend is included on all tape media and as a part of the +; > software program in whole or part. Users may copy, modify or +; > distribute this file at will. +; > +; > Based on Rev 5.0 from: +; > Developer's Desk Window Marketing Group +; > Aldus Corporation Microsoft Corporation +; > 411 First Ave. South 16011 NE 36th Way +; > Suite 200 Box 97017 +; > Seattle, WA 98104 Redmond, WA 98073-9717 +; > 206-622-5500 206-882-8080 +; +; Now updated for TIFF 6 +; http://www.wotsit.org/download.asp?f=tiff6 +; +; We rely on an ENDIAN-PORT +; A port with the following operations +; endian-port-set-bigendian!:: PORT -> UNSPECIFIED +; endian-port-set-littlendian!:: PORT -> UNSPECIFIED +; endian-port-read-int1:: PORT -> UINTEGER (byte) +; endian-port-read-int2:: PORT -> UINTEGER +; endian-port-read-int4:: PORT -> UINTEGER +; endian-port-setpos PORT INTEGER -> UNSPECIFIED +; +; Also needed SRFIs: SRFI-4 (uniform vectors), SRFI-9 (records) +; Actually, we're using structures, which can be translated to SRFI-9 +; records. +; +; Derived from Oleg Kiselyov's tiff.scm 2.0 2003/09/29 20:05:12 +; Changes: +; make-define-env, define-macro --> explicit-renaming + + +;------------------------------------------------------------------------ +; TIFF file header +; It is always written at the very beginning of the TIFF file + +; unsigned short magic; // magic number (defines byte order) +; unsigned short version; // TIFF version number +; unsigned long diroffset; // byte offset to the first directory + +(define TIFF:BIGENDIAN-magic #x4d4d) ; 'MM' +(define TIFF:LITTLEENDIAN-magic #x4949) ; 'II' +(define TIFF:VERSION 42) + +; procedure: TIFF:read-header ENDIAN-PORT -> OFFSET +; +; Reads and checks the TIFF header, sets the reader to +; the appropriate little/big endian mode and returns the byte +; offset to the first TIFF directory +(define (TIFF:read-header eport) + (let ((magic-word (endian-port-read-int2 eport))) + (cond + ((= magic-word TIFF:BIGENDIAN-magic) + (endian-port-set-bigendian! eport)) + ((= magic-word TIFF:LITTLEENDIAN-magic) + (endian-port-set-littlendian! eport)) + (else (error "invalid magic word 0x" (number->string magic-word 16) + "of the TIFF file")))) + (let ((version (endian-port-read-int2 eport))) + (if (not (= version TIFF:VERSION)) + (error "TIFF file version " version "differs from the standard " + TIFF:VERSION))) + (endian-port-read-int4 eport)) + +;------------------------------------------------------------------------ +; TIFF tags: codes and values +; +; A tag dictionary, tagdict, structure helps translate between +; tag-symbols and their numerical values. +; +; procedure: tagdict-get-by-name TAGDICT TAG-NAME -> INT +; where TAG-NAME is a symbol. +; Translate a symbolic representation of a TIFF tag into a numeric +; representation. +; An error is raised if the lookup fails. +; +; procedure: tagdict-get-by-num TAGDICT INT -> TAG-NAME or #f +; Translate from a numeric tag value to a symbolic representation, +; if it exists. Return #f otherwise. +; +; procedure: tagdict-tagval-get-by-name TAGDICT TAG-NAME VAL-NAME -> INT +; where VAL-NAME is a symbol. +; Translate from the symbolic representation of a value associated +; with TAG-NAME in the TIFF directory, into the numeric representation. +; An error is raised if the lookup fails. +; +; procedure: tagdict-tagval-get-by-num TAGDICT TAG-NAME INT -> VAL-NAME or #f +; Translate from a numeric value associated with TAG-NAME in the TIFF +; directory to a symbolic representation, if it exists. Return #f +; otherwise. +; +; procedure: make-tagdict ((TAG-NAME INT (VAL-NAME . INT) ...) ...) +; Build a tag dictionary +; +; procedure: tagdict? TAGDICT -> BOOL +; +; procedure: tagdict-add-all DEST-DICT SRC-DICT -> DEST-DICT +; Join two dictionaries +; +; The variable tiff-standard-tagdict is initialized to the dictionary +; of standard TIFF tags. + +; Usage scenario: +; (tagdict-get-by-name tiff-standard-tagdict 'TIFFTAG:IMAGEWIDTH) => 256 +; (tagdict-get-by-num tiff-standard-tagdict 256) => 'TIFFTAG:IMAGEWIDTH +; (tagdict-tagval-get-by-name tiff-standard-tagdict +; 'TIFFTAG:COMPRESSION 'LZW) => 5 +; (tagdict-tagval-get-by-num tiff-standard-tagdict +; 'TIFFTAG:COMPRESSION 5) => 'LZW +; +; (define extended-tagdict +; (tagdict-add-all tiff-standard-tagdict +; (make-tagdict +; '((WAupper_left_lat 33004) +; (WAhemisphere 33003 (North . 1) (South . 2)))))) + +(define-structure p-tiff-tag-dict table) + + +(define tagdict? p-tiff-tag-dict?) + +(define (make-tagdict args) + (for-each ; error-check each dict association + (lambda (arg) + (or + (and + (pair? arg) + (list? arg) + (symbol? (car arg)) + (integer? (cadr arg))) + (error "make-tagdict: bad association to add: " arg)) + (for-each + (lambda (val-assoc) + (or + (and + (pair? val-assoc) + (symbol? (car val-assoc)) + (integer? (cdr val-assoc))) + (error "make-tagdict: bad tag value association: " val-assoc))) + (cddr arg))) + args) + (make-p-tiff-tag-dict args)) + + +; procedure: tagdict-add-all DEST-DICT SRC-DICT -> DEST-DICT +; Join two dictionaries +(define (tagdict-add-all dest-dict src-dict) + (assert (tagdict? dest-dict) (tagdict? src-dict)) + (make-p-tiff-tag-dict + (append (p-tiff-tag-dict-table dest-dict) + (p-tiff-tag-dict-table src-dict)))) + +; procedure: tagdict-get-by-name TAGDICT TAG-NAME -> INT +; An error is raised if the lookup fails. + +(define (tagdict-get-by-name dict tag-name) + (assert (tagdict? dict)) + (cond + ((assq tag-name (p-tiff-tag-dict-table dict)) + => cadr) + (else + (error "tagdict-get-by-name: can't translate: " tag-name)))) + + +; procedure: tagdict-get-by-num TAGDICT INT -> TAG-NAME or #f +(define (tagdict-get-by-num dict tag-int) + (assert (tagdict? dict)) + (any? + (lambda (table-row) + (and (= (cadr table-row) tag-int) (car table-row))) + (p-tiff-tag-dict-table dict))) + + +; procedure: tagdict-tagval-get-by-name TAGDICT TAG-NAME VAL-NAME -> INT +; An error is raised if the lookup fails. +(define (tagdict-tagval-get-by-name dict tag-name val-name) + (assert (tagdict? dict)) + (cond + ((assq tag-name (p-tiff-tag-dict-table dict)) + => (lambda (table-row) + (cond + ((assq val-name (cddr table-row)) => cdr) + (else + (error "tagdict-tagval-get-by-name: can't translate " + tag-name val-name))))) + (else + (error "tagdict-tagval-get-by-name: unknown tag: " tag-name)))) + + +; procedure: tagdict-tagval-get-by-num TAGDICT TAG-NAME INT -> VAL-NAME or #f +; Translate from a numeric value associated with TAG-NAME in the +; TIFF directory. +(define (tagdict-tagval-get-by-num dict tag-name val-int) + (assert (tagdict? dict)) + (cond + ((assq tag-name (p-tiff-tag-dict-table dict)) + => (lambda (table-row) + (any? + (lambda (assc) + (and (= val-int (cdr assc)) (car assc))) + (cddr table-row)))) + (else + (error "tagdict-tagval-get-by-num: unknown tag: " tag-name)))) + +(define tiff-standard-tagdict + (make-tagdict + '( + (TIFFTAG:SUBFILETYPE 254 ; subfile data descriptor + (TIFFTAG:REDUCEDIMAGE . #x1) ; reduced resolution version + (TIFFTAG:PAGE . #x2) ; one page of many + (TIFFTAG:MASK . #x4)) + (TIFFTAG:OSUBFILETYPE 255 ; +kind of data in subfile + (TIFFTAG:IMAGE . 1) ; full resolution image data + (TIFFTAG:REDUCEDIMAGE . 2) ; reduced size image data + (TIFFTAG:PAGE . 3)) ; one page of many + (TIFFTAG:IMAGEWIDTH 256) ; image width in pixels + (TIFFTAG:IMAGELENGTH 257) ; image height in pixels + (TIFFTAG:BITSPERSAMPLE 258) ; bits per channel (sample) + + (TIFFTAG:COMPRESSION 259 ; data compression technique + (NONE . 1) ; dump mode + (CCITTRLE . 2) ; CCITT modified Huffman RLE + (CCITTFAX3 . 3) ; CCITT Group 3 fax encoding + (CCITTFAX4 . 4) ; CCITT Group 4 fax encoding + (LZW . 5) ; Lempel-Ziv & Welch + (NEXT . 32766) ; NeXT 2-bit RLE + (CCITTRLEW . 32771) ; #1 w/ word alignment + (PACKBITS . 32773) ; Macintosh RLE + (THUNDERSCAN . 32809) ; ThunderScan RLE + (PICIO . 32900) ; old Pixar picio RLE + (SGIRLE . 32901)) ; Silicon Graphics RLE + + (TIFFTAG:PHOTOMETRIC 262 ; photometric interpretation + (MINISWHITE . 0) ; min value is white + (MINISBLACK . 1) ; min value is black + (RGB . 2) ; RGB color model + (PALETTE . 3) ; color map indexed + (MASK . 4) ; holdout mask + (DEPTH . 32768)) ; z-depth data + + (TIFFTAG:THRESHOLDING 263 ; +thresholding used on data + (BILEVEL . 1) ; b&w art scan + (HALFTONE . 2) ; or dithered scan + (ERRORDIFFUSE . 3)) ; usually floyd-steinberg + + (TIFFTAG:CELLWIDTH 264) ; +dithering matrix width + (TIFFTAG:CELLLENGTH 265) ; +dithering matrix height + (TIFFTAG:FILLORDER 266 ; +data order within a byte + (MSB2LSB . 1) ; most significant -> least + (LSB2MSB . 2)) ; least significant -> most + + (TIFFTAG:DOCUMENTNAME 269) ; name of doc. image is from + (TIFFTAG:IMAGEDESCRIPTION 270) ; info about image + (TIFFTAG:MAKE 271) ; scanner manufacturer name + (TIFFTAG:MODEL 272) ; scanner model name/number + (TIFFTAG:STRIPOFFSETS 273) ; offsets to data strips + + (TIFFTAG:ORIENTATION 274 ; +image orientation + (TOPLEFT . 1) ; row 0 top, col 0 lhs + (TOPRIGHT . 2) ; row 0 top, col 0 rhs + (BOTRIGHT . 3) ; row 0 bottom, col 0 rhs + (BOTLEFT . 4) ; row 0 bottom, col 0 lhs + (LEFTTOP . 5) ; row 0 lhs, col 0 top + (RIGHTTOP . 6) ; row 0 rhs, col 0 top + (RIGHTBOT . 7) ; row 0 rhs, col 0 bottom + (LEFTBOT . 8)) ; row 0 lhs, col 0 bottom + + (TIFFTAG:SAMPLESPERPIXEL 277) ; samples per pixel + (TIFFTAG:ROWSPERSTRIP 278) ; rows per strip of data + (TIFFTAG:STRIPBYTECOUNTS 279) ; bytes counts for strips + (TIFFTAG:MINSAMPLEVALUE 280) ; +minimum sample value + (TIFFTAG:MAXSAMPLEVALUE 281) ; maximum sample value + (TIFFTAG:XRESOLUTION 282) ; pixels/resolution in x + (TIFFTAG:YRESOLUTION 283) ; pixels/resolution in y + + (TIFFTAG:PLANARCONFIG 284 ; storage organization + (CONTIG . 1) ; single image plane + (SEPARATE . 2)) ; separate planes of data + + (TIFFTAG:PAGENAME 285) ; page name image is from + (TIFFTAG:XPOSITION 286) ; x page offset of image lhs + (TIFFTAG:YPOSITION 287) ; y page offset of image lhs + (TIFFTAG:FREEOFFSETS 288) ; +byte offset to free block + (TIFFTAG:FREEBYTECOUNTS 289) ; +sizes of free blocks + + (TIFFTAG:GRAYRESPONSEUNIT 290 ; gray scale curve accuracy + (S10 . 1) ; tenths of a unit + (S100 . 2) ; hundredths of a unit + (S1000 . 3) ; thousandths of a unit + (S10000 . 4) ; ten-thousandths of a unit + (S100000 . 5)) ; hundred-thousandths + (TIFFTAG:GRAYRESPONSECURVE 291) ; gray scale response curve + + (TIFFTAG:GROUP3OPTIONS 292 ; 32 flag bits + (ENCODING2D . #x1) ; 2-dimensional coding + (UNCOMPRESSED . #x2) ; data not compressed + (FILLBITS . #x4)) ; fill to byte boundary + (TIFFTAG:GROUP4OPTIONS 293 ; 32 flag bits + (UNCOMPRESSED . #x2)) ; data not compressed + + (TIFFTAG:RESOLUTIONUNIT 296 ; units of resolutions + (NONE . 1) ; no meaningful units + (INCH . 2) ; english + (CENTIMETER . 3)) ; metric + + (TIFFTAG:PAGENUMBER 297) ; page numbers of multi-page + + (TIFFTAG:COLORRESPONSEUNIT 300 ; color scale curve accuracy + (S10 . 1) ; tenths of a unit + (S100 . 2) ; hundredths of a unit + (S1000 . 3) ; thousandths of a unit + (S10000 . 4) ; ten-thousandths of a unit + (S100000 . 5)) ; hundred-thousandths + + (TIFFTAG:COLORRESPONSECURVE 301); RGB response curve + (TIFFTAG:SOFTWARE 305) ; name & release + (TIFFTAG:DATETIME 306) ; creation date and time + (TIFFTAG:ARTIST 315) ; creator of image + (TIFFTAG:HOSTCOMPUTER 316) ; machine where created + (TIFFTAG:PREDICTOR 317) ; prediction scheme w/ LZW + (TIFFTAG:WHITEPOINT 318) ; image white point + (TIFFTAG:PRIMARYCHROMATICITIES 319) ; primary chromaticities + (TIFFTAG:COLORMAP 320) ; RGB map for pallette image + (TIFFTAG:BADFAXLINES 326) ; lines w/ wrong pixel count + + (TIFFTAG:CLEANFAXDATA 327 ; regenerated line info + (CLEAN . 0) ; no errors detected + (REGENERATED . 1) ; receiver regenerated lines + (UNCLEAN . 2)) ; uncorrected errors exist + + (TIFFTAG:CONSECUTIVEBADFAXLINES 328); max consecutive bad lines + + (TIFFTAG:MATTEING 32995) ; alpha channel is present +))) + +;------------------------------------------------------------------------ +; TIFF directory entry +; a descriptor of a TIFF "item", which can be image data, document description, +; time stamp, etc, depending on the tag. Thus an entry has the following +; structure: +; unsigned short tag; +; unsigned short type; // data type: byte, short word, etc. +; unsigned long count; // number of items; length in spec +; unsigned long val_offset; // byte offset to field data +; +; The values associated with each entry are disjoint and may appear anywhere +; in the file (so long as they are placed on a word boundary). +; +; Note, If the value takes 4 bytes or less, then it is placed in the offset +; field to save space. If the value takes less than 4 bytes, it is +; *left*-justified in the offset field. +; Note, that it's always *left* justified (stored in the lower bytes) +; no matter what the byte order (big- or little- endian) is! +; Here's the precise quote from the TIFF 6.0 specification: +; "To save time and space the Value Offset contains the Value instead of +; pointing to the Value if and only if the Value fits into 4 bytes. If +; the Value is shorter than 4 bytes, it is left-justified within the +; 4-byte Value Offset, i.e., stored in the lower- numbered +; bytes. Whether the Value fits within 4 bytes is determined by the Type +; and Count of the field." + + +; Could be easily implemented as a syntax-rule +(define-syntax make-define-env + (lambda (form rename name=) + (let ((env-name (cadr form)) + (associations (cddr form)) + (%begin (rename 'begin)) + (%define (rename 'define))) + `(,%begin + (,%define ,env-name ',associations) + ,@(map + (lambda (assc) ; (name val . other fields) + `(,%define ,(car assc) ,(cadr assc))) + associations))))) + + ; values of the 'data type' field +(make-define-env + TIFF:types + (TIFF:type-byte 1 "byte") ; 8-bit unsigned integer + (TIFF:type-ascii 2 "ascii str") ; 8-bit bytes w/ last byte null + (TIFF:type-short 3 "short") ; 16-bit unsigned integer + (TIFF:type-long 4 "long") ; 32-bit unsigned integer + (TIFF:type-rational 5 "rational") ; 64-bit fractional (numer+denominator) + ; The following was added in TIFF 6.0 + (TIFF:type-sbyte 6 "signed byte") ; 8-bit signed (2s-complement) integer + (TIFF:type-undefined 7 "8-bit chunk") ; An 8-bit byte + (TIFF:type-sshort 8 "signed short"); 16-bit signed (2s-complement) integer + (TIFF:type-slong 9 "signed long") ; 32-bit signed (2s-complement) integer + (TIFF:type-srational 10 "signed rational") ; two SLONGs (num+denominator) + (TIFF:type-float 11 "IEEE 32-bit float") ; single precision (4-byte) + (TIFF:type-double 12 "IEEE 64-bit double") ; double precision (8-byte) +) + +(define-structure tiff-dir-entry tag type count val-offset value) + +; procedure: TIFF:read-dir-entry EPORT -> TIFF-DIR-ENTRY +; +; This procedure parses the current directory entry and +; returns a tiff-dir-entry structure. EPORT must point to the beginning +; of the entry in the TIFF directory. On exit, EPORT points to the +; next entry or the end of the directory. +; TIFF-DIR-ENTRY contains all the data of the entry, plus a promise +; of entry's value. +; The promise is forced only when the value is specifically requested +; by an object's user. That is, we won't rush to read and make the +; value (which may be pretty big: say the pixel matrix, etc). +; +; The promise closes over the EPORT! +; +; The value of an entry corresponds to its type: character, string, +; exact integer, floating-point number, or a uniform +; (u8, u16, or u32) vector. SRFI-4 is implied. + +(define (TIFF:read-dir-entry eport) + (let* + ((tag (endian-port-read-int2 eport)) + (type (endian-port-read-int2 eport)) + (count (endian-port-read-int4 eport)) + ; we read the val-offset later. We need to check the size and the type + ; of the datum, because val-offset may contain the value itself, + ; in its lower-numbered bytes, regardless of the big/little endian + ; order! + ) + ; Some conversion procedures + (define (u32->float x) ; unsigned 32-bit int -> IEEE float + (error "u32->float is not yet implemented")) + (define (u32->s32 x) ; unsigned 32-bit int -> signed 32 bit + (if (>= x #x80000000) + (- x #x100000000) + x)) + ; (= (u32->s32 #x7fffffff) #x7fffffff) + ; (= (u32->s32 #xffffffff) -1) + + (define (u16->s16 x) ; unsigned 16-bit int -> signed 16 bit + (if (>= x #x8000) + (- x #x10000) x)) + ; (= (u16->s16 32767) 32767) + ; (= (u16->s16 32768) -32768) + ; (= (u16->s16 65535) -1) + + (define (u8->s8 x) ; unsigned 8-bit int -> signed 8-bit + (if (>= x #x80) + (- x #x100) x)) + ; (= (u8->s8 127) 127) + ; (= (u8->s8 128) -128) + ; (= (u8->s8 255) -1) + + (define (read-double val-offset) + (error "read-double: not yet implemented")) + + ; read an ascii string. Note, the last byte of + ; an ascii string is always zero, which is + ; included in 'count' + ; but we don't need to read it + (define (read-string val-offset) + (assert (= TIFF:type-ascii type) (positive? count)) + (let ((str (make-string (- count 1)))) + (endian-port-setpos eport val-offset) + (do ((i 0 (+ 1 i))) ((>= i (- count 1)) str) + (string-set! str i + (ascii->char (endian-port-read-int1 eport)))))) + + + ; read an array of 'count' items + ; return a *uniform* vector of read data: + ; u8vector, u16vector or u32vector + ; We roll-out the code for efficiency + (define (read-array val-offset) + (endian-port-setpos eport val-offset) + (cond + ((or (= type TIFF:type-byte) (= type TIFF:type-undefined)) + (let ((array (make-u8vector count))) + (do ((i 0 (+ 1 i))) ((>= i count) array) + (u8vector-set! array i (endian-port-read-int1 eport))))) + ((= type TIFF:type-short) + (let ((array (make-u16vector count))) + (do ((i 0 (+ 1 i))) ((>= i count) array) + (u16vector-set! array i (endian-port-read-int2 eport))))) + ((= type TIFF:type-long) + (let ((array (make-u32vector count))) + (do ((i 0 (+ 1 i))) ((>= i count) array) + (u32vector-set! array i (endian-port-read-int4 eport))))) + (else (error "don't know how to read an array " + "of type " type)))) + + ; Now we need to figure out if val-offset contains the offset + ; or the value (or a part of the value). If val-offset contains the + ; value, we read it in val-offset and make the value a trivial promise + ; (delay val-offset). + ; If val-offset is an offset, then value is a non-trivial promise + ; (which closes over EPORT). + (assert (positive? count)) + (let*-values + (((val-offset value) + (cond + ((> count 4) ; for sure, val-offset is an offset + (let ((offset (endian-port-read-int4 eport))) + (if (= type TIFF:type-ascii) + (values offset (delay (read-string offset))) + (values offset (delay (read-array offset)))))) + ((> count 1) ; the iffy case + (cond + ((and (= count 2) (= type TIFF:type-short)) + (let* ((v1 (endian-port-read-int2 eport)) + (v2 (endian-port-read-int2 eport)) + (v (u16vector v1 v2))) + (values v (delay v)))) + ((and (= count 2) (= type TIFF:type-ascii)) ; 1-char string + (let ((v + (string (ascii->char (endian-port-read-int1 eport))))) + (endian-port-read-int1 eport) ; don't read '\0' + (endian-port-read-int1 eport) ; skip two more zeros: + (endian-port-read-int1 eport) ; padding + (values v (delay v)))) + ((and (= count 2) (or (= type TIFF:type-byte) + (= type TIFF:type-undefined))) + (let* ((v1 (endian-port-read-int1 eport)) + (v2 (endian-port-read-int1 eport)) + (v (u8vector v1 v2))) + (endian-port-read-int1 eport) ; skip two more zeros: + (endian-port-read-int1 eport) ; padding + (values v (delay v)))) + ((and (= count 3) (= type TIFF:type-ascii)) ; 2-char string + (let* ((v1 (endian-port-read-int1 eport)) + (v2 (endian-port-read-int1 eport)) + (v (string (ascii->char v1) (ascii->char v2)))) + (endian-port-read-int1 eport) ; skip two more zeros: + (endian-port-read-int1 eport) ; padding + (values v (delay v)))) + ((and (= count 3) (or (= type TIFF:type-byte) + (= type TIFF:type-undefined))) + (let* ((v1 (endian-port-read-int1 eport)) + (v2 (endian-port-read-int1 eport)) + (v3 (endian-port-read-int1 eport)) + (v (u8vector v1 v2 v3))) + (endian-port-read-int1 eport) ; skip padding + (values v (delay v)))) + ((and (= count 4) (= type TIFF:type-ascii)) ; 3-char string + (let* ((v1 (endian-port-read-int1 eport)) + (v2 (endian-port-read-int1 eport)) + (v3 (endian-port-read-int1 eport)) + (v (string (ascii->char v1) (ascii->char v2) + (ascii->char v3)))) + (endian-port-read-int1 eport) ; skip padding + (values v (delay v)))) + ((and (= count 4) (or (= type TIFF:type-byte) + (= type TIFF:type-undefined))) + (let* ((v1 (endian-port-read-int1 eport)) + (v2 (endian-port-read-int1 eport)) + (v3 (endian-port-read-int1 eport)) + (v4 (endian-port-read-int1 eport)) + (v (u8vector v1 v2 v3 v4))) + (values v (delay v)))) + (else + (let ((offset (endian-port-read-int4 eport))) + (if (= type TIFF:type-ascii) + (values offset (delay (read-string offset))) + (values offset (delay (read-array offset)))))))) + ; Now count is 1 + ((or (= type TIFF:type-byte) (= type TIFF:type-undefined) + (= type TIFF:type-sbyte)) + (let ((v1 (endian-port-read-int1 eport))) + (endian-port-read-int1 eport) ; skip the padding + (endian-port-read-int1 eport) + (endian-port-read-int1 eport) + (values v1 (delay + (if (= type TIFF:type-sbyte) (u8->s8 v1) v1))))) + ((= type TIFF:type-ascii) ; 0-byte string: count=1 for terminator + (endian-port-read-int1 eport) ; skip the padding + (endian-port-read-int1 eport) + (endian-port-read-int1 eport) + (endian-port-read-int1 eport) + (values "" (delay ""))) + ((or (= type TIFF:type-short) (= type TIFF:type-sshort)) + (let ((v1 (endian-port-read-int2 eport))) + (endian-port-read-int1 eport) ; skip the padding + (endian-port-read-int1 eport) + (values v1 (delay + (if (= type TIFF:type-sshort) (u16->s16 v1) v1))))) + ((= type TIFF:type-long) + (let ((v1 (endian-port-read-int4 eport))) + (values v1 (delay v1)))) + ((= type TIFF:type-slong) + (let ((v1 (endian-port-read-int4 eport))) + (values v1 (delay (u32->s32 v1))))) + ((= type TIFF:type-float) + (let ((v1 (endian-port-read-int4 eport))) + (values v1 (delay (u32->float v1))))) + ((= type TIFF:type-double) + (let ((offset (endian-port-read-int4 eport))) + (values offset (delay (read-double offset))))) + ((or (= type TIFF:type-rational) (= type TIFF:type-srational)) + (let ((offset (endian-port-read-int4 eport))) + (values offset + (delay + (let* ((_ (endian-port-setpos eport offset)) + (v1 (endian-port-read-int4 eport)) + (v2 (endian-port-read-int4 eport))) + (if (= type TIFF:type-srational) + (/ (u32->s32 v1) (u32->s32 v2)) + (/ v1 v2))))))) + (else (delay (error "unknown data type: " type)))))) + (make-tiff-dir-entry tag type count val-offset value) + ))) + +; procedure: print-tiff-dir-entry TIFF-DIR-ENTRY TAGDICT OPORT -> UNSPECIFIED +; +; Print the contents of TIFF-DIR-ENTRY onto the output port OPORT +; using TAGDICT to convert tag identifiers to symbolic names +(define (print-tiff-dir-entry tiff-dir-entry tagdict oport) + (define (dspl . args) (for-each (lambda (item) (display item oport)) args)) + (let* ((tag-num (tiff-dir-entry-tag tiff-dir-entry)) + (tag-symbol (tagdict-get-by-num tagdict tag-num))) + (dspl + (or tag-symbol + (string-append "private tag " (number->string tag-num)))) + (dspl ", count " (tiff-dir-entry-count tiff-dir-entry) + ", type ") + (let ((type-str + (any? + (lambda (elem) + (and (= (cadr elem) (tiff-dir-entry-type tiff-dir-entry)) + (caddr elem))) + TIFF:types))) + (if type-str + (dspl type-str) + (dspl "unknown (" (tiff-dir-entry-type tiff-dir-entry) ")"))) + (let ((val-offset (tiff-dir-entry-val-offset tiff-dir-entry))) + (dspl ", value-offset " val-offset) + (if (integer? val-offset) + (dspl " (0x" (number->string val-offset 16) ")"))) + (dspl nl))) + + +;------------------------------------------------------------------------ +; TIFF Image File Directory +; TIFF directory is a collection of TIFF directory entries. The entries +; are sorted in an ascending order by tag. +; Note, a TIFF file can contain more than one directory (chained together). +; We handle only the first one. +; +; We treat a TIFF image directory somewhat as an ordered, immutable, +; dictionary collection, see SRFI-44. + +; http://srfi.schemers.org/srfi-44/srfi-44.html + +(define-structure tiff-directory entries tagdict) + +; ; procedure: collection-name collection => symbol ('%) +; (define (collection-name coll) +; (and (tiff-directory? coll) 'tiff-directory)) + +; ; collection? value => value +; (define collection? tiff-directory?) + +; ; procedure: tiff-directory? value => bool +; ; implied by the define-structure + +; ; *-size collection => integer +(define (tiff-directory-size coll) + (vector-length (tiff-directory-entries coll))) + +; (define (mutable-collection? coll) #f) +; (define (dictionary? coll) #t) + +(define (tiff-directory-empty? coll) + (zero? (vector-length (tiff-directory-entries coll)))) + + +; tiff-directory-fold-left tiff-directory fold-function seed-value +; ... => seed-value ... +; The fold function receives a tiff-directory-entry as a value + +(define (tiff-directory-fold-left coll fn . seeds) + (let ((entries (tiff-directory-entries coll))) + (let loop ((i 0) (seeds seeds)) + (if (>= i (vector-length entries)) + (apply values seeds) + (let*-values + (((proceed? . seeds) (apply fn (vector-ref entries i) seeds))) + (loop (if proceed? (+ 1 i) (vector-length entries)) + seeds)))))) + +; procedure: collection-fold-keys-left collection fold-function +; seed-value ... => seed-value ... +; *-keys->list dictionary => list + + +; read-tiff-file EPORT [PRIVATE-TAGDICT] => TIFF-DIRECTORY +(define (read-tiff-file eport . tag-dict-opt) + (endian-port-setpos eport (TIFF:read-header eport)) + (let ((entries (make-vector (endian-port-read-int2 eport))) + (tagdict (if (null? tag-dict-opt) + tiff-standard-tagdict + (tagdict-add-all tiff-standard-tagdict + (car tag-dict-opt))))) + (do ((i 0 (+ 1 i))) ((>= i (vector-length entries))) + (vector-set! entries i (TIFF:read-dir-entry eport))) + (if (not (zero? (endian-port-read-int4 eport))) + (cerr "The TIFF file contains several images, only the first one " + "will be considered" nl)) + (make-tiff-directory entries tagdict))) + + +; print-tiff-directory TIFF-DIRECTORY OPORT -> UNSPECIFIED +(define (print-tiff-directory tiff-directory oport) + (let* + ((entries (tiff-directory-entries tiff-directory)) + (nentries (vector-length entries)) + (tagdict (tiff-directory-tagdict tiff-directory))) + (for-each (lambda (item) (display item oport)) + (list + "There are " nentries " entries in the TIFF directory" nl + "they are" nl)) + (do ((i 0 (+ 1 i))) ((>= i nentries)) + (print-tiff-dir-entry (vector-ref entries i) tagdict oport)))) + + +; *-get dictionary key [absence-thunk] => value +; key can be either a symbol or an integer +; tiff-directory-get TIFF-DIRECTORY KEY [ABSENCE-THUNK] -> VALUE +; If the lookup fails, ABSENCE-THUNK, if given, is evaluated and its value +; is returned. If ABSENCE-THUNK is omitted, the return value on failure +; is #f. +(define (tiff-directory-get coll key . default-val) + (let* + ((key + (cond + ((symbol? key) + (tagdict-get-by-name (tiff-directory-tagdict coll) key)) + ((integer? key) key) + (else (error "tiff-directory-get: bad type of key: " key)))) + (entry + ; look up the entry in the directory of entries + ; We could have used a binary search... On the other hand, + ; the directory is usually not that big, so that binary + ; search is kind of overkill + (any? + (lambda (curr-elem) + (and (= (tiff-dir-entry-tag curr-elem) key) curr-elem)) + (tiff-directory-entries coll))) + ) + (if entry + (force (tiff-dir-entry-value entry)) + (and (not (null? default-val)) ((car default-val)))))) + + +; tiff-directory-get-as-symbol TIFF-DIRECTORY KEY [ABSENCE-THUNK] -> VALUE +; KEY must be a symbol +; If it is possible, the VALUE is returned as a symbol, as translated +; by the tagdict. +(define (tiff-directory-get-as-symbol coll key . default-val) + (let ((val (tiff-directory-get coll key))) + (if val + (if (integer? val) + (let ((val-symbol + (tagdict-tagval-get-by-num + (tiff-directory-tagdict coll) key val))) + (or val-symbol val)) + val) ; val is not an integer: don't translate + (and (not (null? default-val)) ((car default-val))) + ))) diff --git a/scsh/tiff/vtiff.scm b/scsh/tiff/vtiff.scm new file mode 100755 index 0000000..acd9d8e --- /dev/null +++ b/scsh/tiff/vtiff.scm @@ -0,0 +1,176 @@ +#! /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)