From d292dc423fe36a7cdf9815269bd0ffd7ffa86e8a Mon Sep 17 00:00:00 2001 From: Rolf-Thomas Happe Date: Sun, 9 Nov 2003 17:04:04 +0000 Subject: [PATCH] Sunday sore-throat edition --- scsh/tiff/AUTHORS | 1 + scsh/tiff/BLURB | 1 + scsh/tiff/README | 325 ++++++++++++++++ scsh/tiff/aux.scm | 51 +++ scsh/tiff/bsp.tiff | Bin 0 -> 4216 bytes scsh/tiff/endian.scm | 79 ++++ scsh/tiff/gnu-head-sm.tif | Bin 0 -> 15978 bytes scsh/tiff/interfaces.scm | 78 ++++ scsh/tiff/packages.scm | 79 ++++ scsh/tiff/probe-tiff | 3 + scsh/tiff/tiff-prober.scm | 55 +++ scsh/tiff/tiff.scm | 774 ++++++++++++++++++++++++++++++++++++++ scsh/tiff/vtiff.scm | 176 +++++++++ 13 files changed, 1622 insertions(+) create mode 100644 scsh/tiff/AUTHORS create mode 100644 scsh/tiff/BLURB create mode 100644 scsh/tiff/README create mode 100644 scsh/tiff/aux.scm create mode 100644 scsh/tiff/bsp.tiff create mode 100644 scsh/tiff/endian.scm create mode 100644 scsh/tiff/gnu-head-sm.tif create mode 100644 scsh/tiff/interfaces.scm create mode 100644 scsh/tiff/packages.scm create mode 100755 scsh/tiff/probe-tiff create mode 100755 scsh/tiff/tiff-prober.scm create mode 100644 scsh/tiff/tiff.scm create mode 100755 scsh/tiff/vtiff.scm 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 0000000000000000000000000000000000000000..37b6d10c1d15b986e776b442b9e664e708aebe50 GIT binary patch literal 4216 zcmYL|3sh5Qw#UyaCnw2CauQxKAe=zNhzJ2SJVZPR6e9&Dby17f+5;j+r5F(%Wh^}j zAv{D3Xesq-=YU=tUo=w2GLGY%K&tqt6Bw(sW!eysQpbAHT1&gEb6H)^z3W?Rf4}wL z-+%A5_P2I^J`e{0QjQ6|Q6|4;=3ZGCYV-!I#0Rfv!fs3k?d2vI>b=j<^MlVEx(KNw zD{1gjnJ!f9m@u^FJ*>|@)`|@zeFs$NyACu2r#THk2cWis$f0Y8dX^@XXQ>M`6P}^yKk8zFke;>FkvvV?wR;AY_JbAk4z1eMHDnL$ z(5vN|!b)S$o5@nXUDh#Jp;fjZwcs9CMM})OxfA`58a^ml8Ycd>q?7%6eM-a)$3OP2 zzrJbSyVv`ZESCy&k!?2|8!xJ&ncVqeSN0C)FO5l2t+Bz7w!hXm$NAmH) z9#GLjp{4DT>qDb@W^diAhjLF6$L`L=iUTI2fUx%kzrA>-|>@>BVJ<-v}zk*fb` z8qnN{$H&bdqs;^CgP5igc8wDC0Bgc{szKW#@p0GeXvP)OdeQMyz!K+)25!80LLZkz zcwN0KS_6-;TvX3lA{%U)Divn!v#Bsc!-;wOOQtTRwA4~hC?|4iiQy13b9zaOo^6_6 zXZ71dPIX!;=OUd9EkQiw8bw_|+c8fBP4#J-x?IlrO`xkXk_TGopv*DthVaG`*X5Lh zcFkbAw9Dz$HN))lIPpgA;<6zx7_qR$t38oU&@+WWe1pPH3Jj)_D768z#WV#59dY}! zih(Sm)MH3%Ep^?ao5r0pq|i1(lbC9uQo&boc_DScj6veCvK!{s7xxu~@>JC7V0$rD z7+lxcu=UeA(7ulpKwtTE2i5Xt8BGJJ6AQ#K?z1UU!>93@A)9$*ISc|Bp{TXPHcy}$ zX^weyY{sT(D$#Z)h_b4>GM&e*5+jj)&6pvZ7#Updgs>BFNFG}h{FP z*86~rXVs?4?4WC3q!997h*_oIQytaNu?&)yk?HG2uroKnwp zCluiStO=ZRHM4BTkg^3G=~vFWZb$UmRQo(+NguYq7{ z6vDJ8!O8b$H~4o#&pMo6GB}NN{9bOTO2-~8QA)^iS&4CR!;Z+Xanq(F9%mNjI~@tn z7_jNMFxYRGf_*C}4@TO27O}NRhYlNKVWure&*ciis#Lz^D`lh0Dh3}=Uib4zZ&9

7!}G(W%epZ0K8#js>gj>KX~q7YWm}90KAo4-vC~y0{Z=8zZvT{aI36m0EA{%}$e+ z=ttAABrMwA*C8$*S%zraf4Hlx;IT);YN^r=>y%LldcMKHc+CKJC>V5SHImnNW@)W5 zE3+K497G}PP5j~6vpL3;X*S^2LS6mh3u1l865c0RNUgR4w_0?(2WknZ zP3Hp^B}|hdE2H33GhsZSH%R8&migXHm3SAes~vrLvZZ!!^lPd3DY*N*dM2D{?*fyOd9NVWs$>HDu zO}P+sE}gTh2lvZHQM$k{TX;NzrXu&DRsLu&4+HX)Qu=5fIDBK(;`bKqby* zRCPHI!eC1^K&Ux;?D6=y$au zZ!%KeSPs9m8s&W9wTF5o)~mob>`lcNcAdyWYk8bI46+yn%uEFAH{;(-FX2<%oV(oC ze}mIn%t}V`*uK!(yWMS&Vgu<`UG46u{p8j(eaqLVc}+;IaVKu| zQx4NK2~q3ubH4aKb+*c0Im9O?ZhV}xz#k zA;@SE&ZmS%Uq5gC@rv->)_4^{EwlhNN9P-}o!a+SHcF~g_vS30dgRVt#{LqVrKu3Q zwJA~LgFyAkUz7d*f3NYE;?{RMc^^FpiuGlE@fVUrv^Qk~T0`HjnpkAHS7dc2qrgZ6 zT(FPW#L&TMRyl4pYU-G(m6e?C4f4B}>ferx8894(?ZOw=pU1*Cfd0JYfgWFrFs;8{!Osfc=~%R$9u0>Jb-b1YxWe~i-UZ&m zIDX5TRcA_YZe)gWC;O`>n61e`^)P#1(s;2F1a^~;mjd6z+;xfnxdcRI+bU$H3}J(= z_`~eU0t^+Kc>dDlgOu*SFBbqC{x$D*Qg=5WHLn6}->|z8AD;Pb&N3~Ha{Dl#L0I-I zn!dTo-}^aJl|`5Fxds8{lW@-@dPGLun!5K;$Xpk*XK`+Hga2YS*)1jmq8#_nAEkd@ zffc~+WeX;fsA|mLA|Pfku6m7N0_Cg(>l8@V378{%)`ry$qsM#s-`&I>DKO6VA#-FB zI4R^VBygut{K#dl?N6WnA{`he*dc`SO6aE|?LWozze2cxkm?u5RN+jon3@oI4Q8f_ zPt{;D1_LVi)Sj6BqQ%ri4L2f@l?mCi=Uj3l(~onvw0`eV>PXTRXE$|SO!>u3Kr(2T z$WDvtmR;F37`YxT{{<5-S^Y6i!^J3se z2-7ZPx;w~|FZ)jjxE>LGNle}mvk#?IKuSFyCH=n#ZVQrh*p6fob4zSM#Q?M5QG&pK zOKct{I+fDn69kCKD$CthU!BWtpMUfD7OEd-`^C%z&Q3^4uLO87%ueB1IU?q^ggp8s zbX34lJkE@j5crNOV&J}%I*HRh5q(?ieX^^CG3{4jgddZCcjREdiVb?BUNC zr;zIXd*F4Fd`9S%L}#$PCqt$ZTDY0{b!7tD*#2>JS;cFK+$9m?6ElB}p!&q**Ixqx z9QaZ~xo+?d!nV{3X(t{_(V~DKrxs39D za!?{-{8G{`V0*A1j^fE2p_j|g#>@PZb(>3xd2RSAIiJZy*wt_X-d8?bHN=XplaSP$dL2kL6&RzHpA7 zd$6cb8DtF(2G>aoBXIwHf}WD<<^3KtVU^4MQ&Ou$#14wN76Eq_VT;f*Il{!joMCf< zZ#})+NOo)3-V6C!oH{ajZ37;C(3qq9fZUDP@{k01m%l}#lE};V$kA+hRh-ls8}uYj z3X(zegbZAu?@X715kZ?6IrsQ|4)ayJ+F z5Go6x(jg`u`rHk1ao=;fJiugTDtU>cPd~E2{`CCuxF^8Y>cD-$)|-L_!+bWkecOGs z@W=F!5dqmHxECr}J&AJ`%zwx%&l7dUMsveb@`;e_$FnL0Y>nz^yMWBOtR6wQ#brQ3 zpd}8za0`A_0^dnRxI!MkK(LX(bJ_%e4)$k4+bGxwz=;79Q)Hx>EUpG-a}g#L+3zf4 z-dQi&x1H-3aqS|YCz*R|DO&(v+p=?I*AMZ+`~=DEukUwV%wZ1`0?L0K^~w zzyJV%fO6BX=wKok_8*ph s0xE&o3bVZc!VHH0A6vkP7v9+nsQLf;vu|fB|8|7W7yy`0059(U1+M-H$N&HU literal 0 HcmV?d00001 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 0000000000000000000000000000000000000000..7ce0faf69cd0d8e2406db55399f49d88ba21af1b GIT binary patch literal 15978 zcmcIr1zc9w`@bNFHEYvN=XCyExNw`>)ah*OnmTpZUD(}IXCNj9qL_$M3KAkAAz%lh z2q+?A(7e1IH=qCayn?t*KZ~DxKInV7@4e?d=ZWtV=g_31)@{EJ9b zKnBv1s3S7tRg20xjzC7Ujep8^6C+z+@SjOn8{BM=^nK*+BS3FPpJ62@8BJ zna$w42wzKPUNDo1a@f;q1&aZRM#x1VMY8_(ivPd>V^5L{_>gphMkWnWu_BsC&@gty z5;Esm`Fh3M?3SL)8l{jV5^s3T+TuLC-^fATy0uyv@z6vD9!p|sdF}MpF%>p7DU2Wu zNs=Huq7;9(BVIc%rV(2Tn;NP3pwAG>Cr z>-K$*61Lwk-q^M>6P5^bs?hVF7{J;jSShRy1DPcS)?|sB;$nX^BjeL(6GrXoko8WxVt<}8@GBR~1^&|~V_ zb++@lp|2RgdP|0q;P%IqwH;=S>^tn#ca@rqZ9cg3fFY+hyH0Ws>9FN+*WF$@iG%j& zNRiD_g)zY@pgZ&48K!5sMFZTw`^I;6$G3;?O-gPZFmLq~FPD3+queI-uvxh}AwP}i z{NmR!z`#Qk>0%6BPmYfC8e7MvdHaK-LLQyn5O8?n{GZnLu^m6k=civ1+MI(cDDaRM zBs2F5*a;YFe>{5Zmu&_vi~at3>BX$HT-ZR&@Ma`(BfWu6Mg0aq{9tpQ!jG|KCn=+@N^_KXHqHp!&Xu^eX1nWu&O#wUzs#C-v=A_5J3bc6U5R?ez>V%gI9Xi^zQCf^X;-zWG;I zt0}#123x2e3I%}a0f35t3wB9re7ue@Gag02wy>3pFlr-s;w91*4BvF5>9P2J4LqH@ ze6u8)!nVO*Nwy&P>3Kyux6PzCURxLwa?$5vdW7fMA4!7R#>@=x*{qNgPz8c1mDrp}HzaGc(!(IZ zS2-2)v}VM<2wlYFI!h1D7;-a{T7|OjkTqz*!0IEVwAIZwb6!@vjozB#KBQOwE^mM- zm>@@Rf!TlU^MOaemjbyMa4} zsaZol%L)yq>xoZK`b4{CPM#bE$GcC+2VW3O8~#nSyJZQCy9Bus@!7KFmrfR`1m9^W zb68dTUNgshTg5d4bD50DXy8>=iCG7+2qI*&J^8amEAIca@94a(hjNP>Fgpcsi2_Zq zkXBIVU3}<&d1Zjx5~f#(2AEn-kd#!aTE03?MCCo{N|sr2mX`Tnu-oj&W(=0i7c`hhWk48uajBata) zrU&f`cyv8{$f2`L{ke+xk`Wuopt&?>1^OHM&6J26Erj zvirYxYdLnURhR29WYD|EJ$f=lF!h#^h*VEe5kIOl^yHEbPQylBh;`OGvAIQv+k7HQ zR^{dLu04*rUl>NC1SXm?g5;2dsbP|nNh!*XpErXW(~RRbaSmMbx8A8UwEGgz^uCTw zE7@~)%|<)gaMf+=G;y z7t%96n+dLOT?*WhS(7A+mVl&wYoo4C+EZMrpSJNAoeZ`HA>$yKVx+1U^6b3b(AQWDIfSqEo8A`Q1@P8ELaUgrHp zLpL3bIDYQQfgI~R0%@o4ma8!_;m7?KpKzYt@utkGvKJ(4z=QKfNwsUSM^&twYs+zU zI2+q)oJ|dmvu|Yo1y}8xoTdY7)_R|-^npER&pFuFuhC$-GTqlYh6$5Hq8122p{Vp^ z?=~NS`F3&ZQiIR1vW=4`ntb~ZguiW_51W-QxeK!jkRq8QBw zZp3?^+4Wubferc%)b9bLu#%1Lt>N{dnNN~}ewsNUsjy2XY_oj*3|mQ?FwdO5WmFT6 ztH;??u3yQfGRI-@b~apV2RrVq2HcPCDT~I}+w`F0G{&86C4A>lsp_%P%>ZVWQ9L&` z_&d!pXbW%8n3#}!?nYenQ2-cAG|Z=V-8+7G+2}>PCoXO^&DbH2N?sVD%uw~#H1c!% zX$a?7!}bHNdR5NOwjtM;t7LD>eZ?&w!ErOWP~Tx&`?u{lC98iO4kD;p8BS97yTrnY zMuw*f+!>-)%cLKn4qZ0WanR^tqr9>`JutsyfrQi>Dcg|Y?=^LG`q}___}v#K$Up+Y za$=TeaQo@?>^h8tbQ?Hw4z?Wk9#_c@rtnU~DqQV7b>jRc&+QT}jiK2NHq{z)H93b5 zYS;a62c@{0*($LJfHLA_)LfIVW3yIv%T6uwPtMzc@CI3%1e#Y`tjdU*HFN%m1woQq zICCCERJ;S2kYtxszoqrCEdqzcJ&;%YTt5I z9Dd$4;}+eGoH?M|fS^Qxvn&nqTyx`Iq7)T#XXtPjkEDp@mEWzgri=_YwtJrf3Em@F0wS60OA+;+z`V2#l`ORMMsfm+fT zjowjPhxBgLu;yo+U8CVMSDt^!z)OPOL@^JVLcEe_h+F^d$B&Nh)4X+j2}y?3z*DLB zLsm>^RK@0tPG6r}V~|8vubFAr*`N+hyN%m8cj}(jo?EZXzJPd%o)3JnKlGiM>b3CX z_%(em?APwb>RDo`HS?@7>)@Vr8Lw((34aoQ0a{RV;9x2 zZ`lVyOo3ZXxo?1R376*&^VqVjRp8K5Dl#G)SQhK^Q_ae6f7NZqu$^lIwo838nGFCV zWVzpCG5Ny12|=HJ&aDn#V>qv|Xkh>*Iy>xq=RK{sMq|19t8bSua4-TG;3R^43gyvr z)hdO^RM$*OuQb*73G}T(TgsJnCyZp+*|hbcksnPz+IUJt#IKX$E;U{W{qI<)J4n*{++8@h-NhqwESA^U?KdU=Ca6RxMY8Dy&h@*R0UQ*Svg+jOs4yVg({2{`U)2 znMRKd_3MopID-ou_4P8ILfvcI+Huuwx*)XyT3|v!tJP8Wj<-YJ<+wYDu6SP(SOs=1 ztx$a0Xh#eT=e}JJFUqClBMkhIn$ld)-HvY!o&K&zq~r#9>C`Dru9)XPCB(^((E zY6Sp1dG#Ypq4tVyVY~kA1KKX^-GlpV=O(X~AJnbf`z^Wc(3=m^zCzI!f%5o zWJc1Ib9pK<=&>}6s;AT*IZx#$Q3t-PH{$2z(|-o&xHz_J)c^u;W|o5d5)2^6Qw6ti zS)id|o-D#YxR8D^VwoP(S#CUo{ac^WHr*f_`H;O>sxl;v)B@#S(?J>rDm8GQuh8=eiXi}x3rK8HNdItj#Io^D zPP4`>SiSO@_d*YCVsX%Ico|HlPS9z42szkT2kr)7@yntt+ewI3Zn zsnRi*kdKiX7GQ*~EHkywSb|0tbzG^U!@E(R;)zmW1iG>;b-7i&KPx9R?oWZRED0$l zW&T9}pf5%on>k}w=t5KKj_VPp3ddw45yF@ZRDijVu|$)T3+~+Z>b7eCaxZ_o`ai5{ zVLx@8>wAwGgC?dZ3n1=kAdxR=5nV(=r;gdMZjX^wrGepuF0)PwuYKFVe03Uo9xY{7 z*Yj0k^ZLyR*frWC`e4vqzs$!=CdNsMhR`B1qv?rg1P-V;Dm>}&^tjF27e0=d+w63M z-m5=Zx4j#(Rk#wvS0hh+W)9Svj06LLrD%ykAG2`pz#TD#kiJevO^8wCTfO<19V>{!bVO1GPWIhnM_Ofe4cu7difibyV z>+Wp5DZU9~?e`=FBTnLWaHq~gZQkOz?|TfCj1bUeU>fA88?GSw6;@;3~l~_BzVzM-y^qgst@Ha>ymYP>bB&)_XZw)iN&%P z#4s=*N(T38P2ZjNwr!0ae0mf*98_|T;lGIvZZM9rsqy_+RWn!`E3OqIe+~e3H^;%kcINXj8fdfr(TbjK1&F4u{^%Yv5fT(WR8XE!NbHRdrL2K^#|Ku zgi6?gZj%K8M5gxhDszq@5MgE}uBDXP@ppfDz!H?Z z;7OG8#k5F^m>E|66;Bo?V_A^)F`Y&}WMf;Uk#v@4YZYXp%=R(#Vo#)sQ_xG35Ud$g zDP$;lW@FoJWWPy=F)!OrFyi(f2$qcoU+O4ICXLU@_=H`mvsG}zD)QMCK^MHFIeOWP>wK9-TbY~{6f*La|>oYG&z(3HOvjt2D$?qlGfb!+2D&{ z%|H|iC@3NE*qJN?mcxFS$^MxvD%hJD*~F+BTXT~rH#^p>S@jf4`U7bv2q-6IELbYc zH}Bi97ySt-67I%2WDHnzSl#G_0sXv+MWYTKLTrD@^n}Eq0OIwcptU}UTYn^|&&r@6 zJR3PeFoZLV3V8*q1zp%p7MrnJfdykTone9ya1X;mxq8yLQo3&(*g=zp*&!O?BCX0~ zu8$JU$Yy#ipsS6QaF7?&8d`a?l!0@_ z8cb}J_(2@tSqg-dRgp6{(B%{J4FX!Kn9>^eiK4-t)qcyzeC4MoX(R}VEqA{Ofwuf1 zQ>ir`M(>MCv!Ki?zio|@lFm?6uc_08cDTcW4b^pO69Bb3%xPpC{kaoy<1;UXcpaA!(S4gI%P}42?93*UhMt zykY;mYo!nZ%h1tT+|}=wVddlf_2)BM&IT-hP*HT0{cJf_bQiZ?YQbWElt(+>in=Ct zA0mJX^VgnUXwaMV3)_$Q37ka(5sca~H5QeR_u5Z`6;F-QW14=HwfbI=K!xTLtfh9= z#EQ0ZG6N~VrT&TU#M9OtJJ_d!_OWTgwV}8zVn|*sO;0bAq$#DCt+Ci`j zu#Qs@=fI3{YXA$tf1d;cqKZI^R7gf-E%c#Kc3i^H&9N3Z1sY2Dj^PyZeTIM#kY&fN znsJ139qLvn$FY<1Sz`DI8)CL!G7`CYg)RLRCnCmxz&5x@JgciHOE5neymgu;dE0X* zM+%E>8;d+_HxE9Cn!;~KWgQvJ*xxC_lxE)^?|QR+5S?PiSqDYayHtEBru-EH3dSa( zeIj;PzBFvd>pR;fwg?kH=*TMAv^30L4+(%4+4dN;^ zj(OAHCFBf30QvXozo6Y5;NIB;7KM!%-1RT9su$c(<=kU;*oIl8jB~O{-6kaK;EcE!qn(M6#jK9nYz#{VK-6EuxS!aWF>y zhQZ9U=pczFwDU7?4#^5%ilkw?f^mI=!AAvj{}msMaU&SVJ`T$>_aLtW>=C&~FJ{U7 z%l52-XtpbuIvG_u5CW5&rh*gJH;rs}fJ%$fr&c}0Jhg)JzhZzCgg^_X#$-_B0f-Rj zPSPc><=Ba2srPf@iy&w=;d;^Uk-#m$#Cwi?Yxf5(BYVHCr$wCm2~z8c7?NzZBMQbnVmlmG#U2 zHZcPdL>vTToRB)u+D`}gh=Q;ySFxtX*0GAQE=keKsj(>lZRQTph*j>W7yub^7qH%+Law8qL=Gibug*Wc=vszx+Fe;XuAcvoO7L1zk4eQ|I zJ#4`;ne7|mx@dO4bF4!Q)i4nIhXk>syrg}s6NZ7Af-@q_3ZNI$vP{36v|U35Y_XyO zVj{z9%;t>Gwk`^}p4sNU0yNMeIbiqy8L@~D2spwsk6;R>(m3A?EHt0cU0{kWr;t&& zYdubYG(pGA4R&i#k*GG($S}r}qOh}l|CB^TS`pP5c$Z}n4SzcIXq7+Mu^`Y?EC|OO z*56}t7SJx%!2wDj3MM3cpt1AIc2Y4D#C!jg1Qb=geCsmH?*ImpXedZ7vTXN*UeJE3 zP^yaLab~O+VG;R}g=I+CPXNCvw4Ov-Hi#fJAmu+MEE4FV8jlo|=^e%ehj7(rpV2aq zs1O0%KK$z|ECFVMfx59n&Fqjx2{q4mOcU~-o6$ez00S_Wo`K=4IVJKGk!BQAtT))f zmu19CWMyifEOvlJD#27DX4fK`^SXj8UEslkRIGaI>Ypn-sktbP9Xiz3! z^f4ZkPzb#s9NQxy__r(*PAs99smbF*w)btvaV`H3efF;t(D;GA{)Gtu23Tb+o{fSL z z|4R}VTaQgu46tTXK{8u4qvv>FJ!zpi)^4-!&c#C(KeWOD0M&A1)xVtc_pdbsyzmw0 zfo?>nox;gtWGJwEI2@8gkjS&cNEdto$4uNN00ZvMwI1uSFZ5k%%!<6!LCiV_JD;D9t+1o^z1REW&f3XS4b!&!86>EK*zLhyzdKnEBS7brTB9o}RL zKxU#hWQpn$>LR7ky}LNg0Q477(&@9}kdi*8_N=UVQ-mVh#Peud4PVFtJN%AqSU)^m zq$PRa)d<6O2Fln4K#?Hpbn+Pu-7h|Umx1(~A~XYlHKHMBK?LP60K|fkDMTrkD5HHi z&0$>=*3JM5^P&()+J}4)JIVK^N#XAYWEYi`@Xw~iuANZ>wpe8GYDM9tmcqB z%HRiHMrrV-33ir0iM0Wqr+12yk>pE!JecQ@~2Srq+>N1s7vU&XNQyLXPQi^IAaP*f&YTER9vwz zlW-@A4xkP(_+2=5!6f=!bI$N_p^|4e^olVDe~|UY2`J1?mzR^Mx|Pnh!6;?_>Z~+f zUc%|vq_HPW`H^g|&~mT*vH$Qhl)r{eQnM*~?U9p0Zv4s1s@ZRoF*^2Q37VW&DU~6l z@jnnm`I3aIfeeFXOHlZOL_X(cbmEz>os6m;qrdb_^`|h`Cn!>p%d&*+KO#-2j6a*R zJiAwT@RsG`?Zn5cY9-Qw2&euZZ=JpC2e&ay0&g-g`SUU~53olf7Lq2ZeqKrB?O>NC zS!$=|ZMY^?xPh_pC$Lp1mBaR*U;f|kpp%7-RU;K5TCeD}KlMcFk;;j*)Zj5}#VI#u zEFFzjcf_BceEq+fRJma8p6xpr&;lxF{=5YDE^k|3hMbri7yHs>y6I zlxV|3BUdCB-#R(I)#4Zn{%)@bCq=FM+W!>?2tGUxuOJmLp=F+-HwbqE_T87{M?Mi} zj~%*t2Cc2%chmkWM#{!j-Aoe=mrsX1(y}yNe3MDp-{f4c;RS)$mmLbP!0f+zy%xvW zRN`znj$4a=Hf7h#acx_6T?N;b%C6aSm0!B9iQ~>6;9mQVIPq^|XB~$b-Pb zzwDZg|8Cjy%klT$4Q=eL?~cGY@0VRqz;&aS-fdoXjbr6j>NBu=&vsL1FKRJu^7u(D e7R>s}dG6E?TYlSiY0GbM@*30&{}{v8&;JLTd)T=E literal 0 HcmV?d00001 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)