scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Sunday sore-throat edition

This commit is contained in:
Rolf-Thomas Happe 2003-11-09 17:04:04 +00:00
parent 9f6397806f
commit d292dc423f
13 changed files with 1622 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scsh/tiff/AUTHORS Normal file
View File

@ -0,0 +1 @@
Oleg Kiselyov, RT Happe (porter)

1
scsh/tiff/BLURB Normal file
View File

@ -0,0 +1 @@
Read entries from the (first) image directory of tiff files.

325
scsh/tiff/README Normal file
View File

@ -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

51
scsh/tiff/aux.scm Normal file
View File

@ -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))))

BIN
scsh/tiff/bsp.tiff Normal file
View File

Binary file not shown.

79
scsh/tiff/endian.scm Normal file
View File

@ -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))

BIN
scsh/tiff/gnu-head-sm.tif Normal file
View File

Binary file not shown.

78
scsh/tiff/interfaces.scm Normal file
View File

@ -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))

79
scsh/tiff/packages.scm Normal file
View File

@ -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 ))

3
scsh/tiff/probe-tiff Executable file
View File

@ -0,0 +1,3 @@
#! /usr/local/bin/scsh \
-e tiff-prober -ll sunterlib.scm -o tiff-prober -s
!#

55
scsh/tiff/tiff-prober.scm Executable file
View File

@ -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))) )

774
scsh/tiff/tiff.scm Normal file
View File

@ -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)))
)))

176
scsh/tiff/vtiff.scm Executable file
View File

@ -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)