TIFF
Program TIFFViewer;
Uses Strings,Crt,Dos,VESA;
Const { TIFF sizes }
TIFFByte = 1;
TIFFASCII = 2; { PChar type string }
TIFFShort = 3; { Word }
TIFFLong = 4;
TIFFRational = 5; { 1st Long / 2nd Long }
{ TIFF compression types (2-4 are monochrome only) }
CompNone = 1; { Simple uncompressed image }
CompHuff = 2; { CCITT Group 3, 1-Dimensional Modified Huffman RLE }
CompFax3 = 3;
CompFax4 = 4;
CompLZW = 5; { GIF style LZW compression }
CompWrdL = $8003; { Word aligned image }
CompPakB = $8005; { PackBits RL encoding }
Type PStrip=^TStrip; { we make a list of strips }
TStrip=Record
num : Word; { which strip it is }
loc : LongInt; { location of the strip in the file }
size : LongInt; { size of the strip in bytes }
next : PStrip; { Next strip in list }
End;
PByte=^Byte;
Var Format : Boolean; { True if Intel format, False if Motorola format }
fl : File;
name : Array[0..63] Of Char;
data,tagnum : Word;
offset,maxstp : LongInt;
Strips : PStrip;
width,height : Word;
palette : Array[0..767] Of Byte;
spp,bps,comp : Word; { samples per pixel, bits per sample, compression methold }
photo,ns,rps : Word; { Photometric interpretation, no. of strips, rows per strip }
buf : PByte;
Function GetWord(Var f:File):Word;
Var temp:Word;
Begin
BlockRead(f,temp,2);
If Not(Format) Then temp:=Swap(temp);
GetWord:=temp;
End;
Function GetLong(Var f:File):LongInt;
Var temp:LongInt;
Begin
BlockRead(f,temp,4);
If Not(Format) Then
GetLong:=((temp And $FF000000)Shr 24)+((temp And $FF0000)Shr 8)+
((temp And $FF00)Shl 8)+((temp And $FF)Shl 24)
Else GetLong:=temp;
End;
Function Power(base,index:Word):LongInt;
Var i:Word;
t:LongInt;
Begin
t:=base;
For i:=1 To index-1 Do t:=t*base;
Power:=t;
End;
Function GetStr(slength,foffset:LongInt):String;
Var strng:Array[0..255] Of Char;
curpos:LongInt;
Begin
If slength>256 Then slength:=256;
curpos:=FilePos(fl);
Seek(fl,foffset);
BlockRead(fl,strng,slength);
Seek(fl,curpos);
GetStr:=StrPas(strng);
End;
Function GetRational(foffset:LongInt):Real;
Var n,d,curpos:LongInt;
Begin
curpos:=FilePos(fl);
Seek(fl,foffset);
n:=GetLong(fl);
d:=GetLong(fl);
GetRational:=n/d;
Seek(fl,curpos);
End;
Procedure GetStripOffsets(len,off:LongInt);
Var curpos : LongInt;
i : Word;
temp,last : PStrip;
Begin
curpos:=FilePos(fl);
Seek(fl,off); ns:=len;
For i:=1 To len Do Begin
New(temp);
temp^.num:=i;
temp^.size:=0;
temp^.loc:=GetLong(fl);
temp^.next:=Nil;
If i=1 Then Strips:=temp Else last^.next:=temp;
last:=temp;
End;
Seek(fl,curpos);
End;
Procedure GetStripSize(len,off:LongInt);
Var curpos : LongInt;
i : Word;
temp : PStrip;
Begin
curpos:=FilePos(fl);
Seek(fl,off);
temp:=Strips;
If (temp=Nil)Or(ns<>len) Then Begin
Writeln('Error in TIFF file');
Close(fl);
Halt;
End;
For i:=1 To len Do Begin
temp^.size:=GetLong(fl);
If temp^.size>maxstp Then maxstp:=temp^.size; { Find largest strip }
temp:=temp^.Next;
End;
Seek(fl,curpos);
End;
Procedure GetPalette(len,off:LongInt);
Var curpos : LongInt;
i,j,c : Word;
Begin
curpos:=FilePos(fl);
Seek(fl,off);
c:=(len Div 3)-1;
For i:=0 To 2 Do For j:=0 To c Do
palette[j*3+i]:=GetWord(fl) Shr 10;
{ Convert 48 bit colour to 18 bit VGA colour }
Seek(fl,curpos);
End;
Procedure ShowImage256(buffer:PByte); Assembler;
Var handle,bank,rows,i,dseg,btg,wide : Word;
loc,size : LongInt;
next : Pointer;
Asm
Mov dseg,ds
Mov bank,0
Mov bx,width
Mov wide,bx
Mov ax,VesaMode.Bytes
Sub ax,bx
Mov btg,ax
Mov es,VesaMode.SegA
Xor di,di
Mov ax,$3D00
Mov dx,offset name
Int $21 { Open the file for assembler }
Jc @Ex
Mov handle,ax
Lds si,Strips
Mov ax,[si+2]
Mov loc.Word[0],ax
Mov ax,[si+4]
Mov loc.Word[2],ax
Mov ax,[si+6]
Mov size.Word[0],ax
Mov ax,[si+8]
Mov size.Word[2],ax
Mov ax,[si+10]
Mov next.Word[0],ax
Mov ax,[si+12]
Mov next.Word[2],ax
Mov ds,dseg
Mov i,0
@Bgn: Mov bx,handle
Mov ax,$4200
Mov cx,loc.Word[2]
Mov dx,loc.Word[0]
Int $21 { Seek to image location }
Mov bx,handle
Mov cx,size.Word[0]
Lds si,buffer
Mov dx,si
Mov ah,$3F
Int $21
Push ds
Mov ds,dseg
Mov ax,rps
Mov rows,ax
Cmp comp,1
Pop ds
Je @0S
{ PackBits compressed TIFF }
@1S: Xor dx,dx { Set DX as the width count }
@10: Xor ah,ah { Clear upper byte }
Lodsb { Get "index" byte }
Test al,$80 { See if high bit is set }
Jz @14 { Jump if following is a string }
{ Repeat byte }
Neg al { count = -index }
Inc ax
Mov cx,ax
Add dx,cx
Lodsb { Load data to repeat "index" times }
Mov bx,di
Add bx,cx
Jc @12
@1A: Mov ah,al
Shr cx,1
Jnc @1B
Stosb
@1B: Rep Stosw
Jmp @20
@12: Stosb { Draw byte to screen }
Or di,di { Check to see if line crosses bank }
Jnz @13
Inc bank { Change bank if crossed }
Call @B1
@13: Loop @12 { Store all repeated bytes }
Jmp @20
{ Dump string }
@14: Inc ax { bytes in string = index + 1 }
Mov cx,ax
Add dx,cx
Mov ax,di
Add ax,cx
Jnc @17
@15: Movsb { Transfer string to screen }
Or di,di
Jnz @16 { bank checking }
Inc bank
Call @B1
@16: Loop @15 { Repeat for string }
Jmp @20
@17: Shr cx,1
Jnc @18
Movsb
@18: Rep Movsw
@20: Cmp dx,wide
Jne @10
Add di,btg { Move screen pointer to start of line }
Jnc @23 { Jump if not crossed bank }
Inc bank { Update bank if crossed }
Call @B1
@23: Dec rows { Update line count }
Jnz @1S { Jump to start if not end of the image }
Jmp @NS { Exit if image drawn }
{ Un-compressed TIFF }
@0S: Mov cx,wide
Mov ax,di
Add ax,cx
Jc @03 { Jump if line crosses bank }
Shr cx,1
Jnc @01
Movsb
@01: Rep Movsw { Show line }
Add di,btg
Jnc @02
Inc bank { See if line above is in another bank }
Call @B1
@02: Dec rows
Jnz @0S
Jmp @NS
@03: Movsb
Or di,di
Jnz @05
Inc bank
Call @B1
@05: Loop @03
Add di,btg
Jnc @06
Inc bank
Call @B1
@06: Dec rows
Jnz @0S
@NS: Lds si,next
Mov ax,[si+2]
Mov loc.Word[0],ax
Mov ax,[si+4]
Mov loc.Word[2],ax
Mov ax,[si+6]
Mov size.Word[0],ax
Mov ax,[si+8]
Mov size.Word[2],ax
Mov ax,[si+10]
Mov next.Word[0],ax
Mov ax,[si+12]
Mov next.Word[2],ax
Mov ds,dseg
Inc i
Mov ax,i
Cmp ax,ns
Jne @Bgn
Jmp @Ex
{ Set bank }
@B1: Push ax
Push ds
Mov ds,dseg
Mov al,vesaon
Or al,al
Jz @B3
Push bx
Push dx
Mov dx,bank
Xor bx,bx
Mov ax,64
Mul dx
Div VesaMode.Gran
Mov dx,ax
Push dx
Call VesaMode.WinFunc
Pop dx
Inc bx
Call VesaMode.WinFunc
Pop dx
Pop bx
@B3: Pop ds
Pop ax
RetN
@Ex: Mov bx,handle { Close the file }
Mov ah,$3E
Int $21
End;
Procedure ShowImage16; Assembler;
Asm
End;
Procedure ShowImage;
Var r : Registers;
Begin
SetMode($101);
r.ax:=$1012;
r.bx:=0;
r.cx:=256;
r.dx:=Ofs(palette);
r.es:=Seg(palette);
Intr($10,r); { Set palette }
GetMem(buf,maxstp);
If bps=8 Then ShowImage256(buf) Else
If bps=4 Then ShowImage16;
FreeMem(buf,maxstp);
Sound(660);
Delay(100);
Sound(880);
Delay(50);
Sound(440);
Delay(75);
NoSound;
ReadKey;
SetMode(3);
End;
Procedure ReadTag;
Var tag,typ : Word;
len,off : LongInt;
Begin
tag:=GetWord(fl);
typ:=GetWord(fl);
len:=GetLong(fl);
off:=GetLong(fl);
If (Not Format)And(typ=TIFFByte)And(len=1) Then off:=off Shr 24;
If (Not Format)And(typ=TIFFShort)And(len=1) Then off:=off Shr 16;
Case tag Of
254 : Writeln(tagnum:2,' - New Subfile Type: ',off); { New Subfile type }
255 : Writeln(tagnum:2,' - Old Subfile Type (obsolete): ',off); { Subfile type }
256 : Begin
Writeln(tagnum:2,' - Image width = ',off,' pixels');
width:=off;
End;
257 : Begin
Writeln(tagnum:2,' - Image height = ',off,' pixels');
height:=off;
End;
258 : Begin
Writeln(tagnum:2,' - Bits per sample = ',off);
bps:=off;
End;
259 : Begin
comp:=off;
Case Word(off) Of { Compression }
CompNone : Writeln(tagnum:2,'Non-compressed image, Byte aligned');
CompHuff : Writeln(tagnum:2,'CCITT Group 3 one-dim. mod Huffman run-len enc');
CompFax3 : Writeln(tagnum:2,'Fax compatible CCITT Group 3 compression');
CompFax4 : Writeln(tagnum:2,'Fax compatible CCITT Group 4 compression');
CompLZW : Writeln(tagnum:2,'GIF style LZW compressed image');
CompWrdL : Writeln(tagnum:2,'Non-compressed image, Word aligned');
CompPakB : Writeln(tagnum:2,'MacPaint style PackBits RL image compression');
Else Writeln(tagnum:2,' - Unrecognized image compression');
End;
End;
262 : Begin { Photometric Interpretation }
Write(tagnum:2,' - Photometric Interpretation: ');
photo:=off;
Case off Of
0 : Writeln('MinSampleValue is white, MaxSampleValue is black');
1 : Writeln('MinSampleValue is black, MaxSampleValue is white');
2 : Writeln('RGB');
3 : Writeln('Paletted colour');
4 : Writeln('Transparency mask');
Else Writeln('Unknown');
End;
End;
263 : Writeln(tagnum:2,' - Thresholding (obsolete): ',off);
264 : Writeln(tagnum:2,' - Cell Width (obsolete) = ',off);
265 : Writeln(tagnum:2,' - Cell Length (obsolete) = ',off);
266 : Writeln(tagnum:2,' - Fill Order (obsolete) = ',off);
269 : Writeln(tagnum:2,' - Document name: ',GetStr(len,off));
270 : Writeln(tagnum:2,' - Image description: ',GetStr(len,off));
271 : Writeln(tagnum:2,' - Manufacturer of scanner or whatever: ',GetStr(len,off));
272 : Writeln(tagnum:2,' - Model name of scanner or whatever: ',GetStr(len,off));
273 : Begin { Strip offset }
Writeln(tagnum:2,' - Number of Strip offsets = ',len);
Writeln(' - Location of Strip offsets = ',off);
GetStripOffsets(len,off);
End;
274 : Writeln(tagnum:2,' - Image Orientation (obsolete): ',off); { Orientation }
277 : Begin
Writeln(tagnum:2,' - Samples per pixel = ',off);
spp:=off;
End;
278 : Begin
Writeln(tagnum:2,' - Rows per strip = ',off); { Rows per Strip }
rps:=off;
End;
279 : Begin
Writeln(tagnum:2,' - Bytes per strip offset = ',off); { Bytes per Strip }
GetStripSize(len,off);
End;
{ Minimum Sample Value }
280 : Writeln(tagnum:2,' - Minimum sample value offset (obsolete): ',off);
{ Maximum Sample Value }
281 : Writeln(tagnum:2,' - Maximum sample value offset (obsolete): ',off);
282 : Writeln(tagnum:2,' - X res = ',GetRational(off):1:1,' pixels per Res Unit');
283 : Writeln(tagnum:2,' - Y res = ',GetRational(off):1:1,' pixels per Res Unit');
284 : Begin { Planar configuration }
Write(tagnum:2,' - Planar configuration: ');
Case off Of
1 : Writeln('Samples are contiguous stored');
2 : Writeln('Each of the RGB samples are stored in separate planes');
End;
End;
{ Page name }
285 : Writeln(tagnum:2,' - Page Name: ',GetStr(len,off));
{ X Position }
286 : Writeln(tagnum:2,' - X Position offset (fraction): ',off);
{ Y Position }
287 : Writeln(tagnum:2,' - Y Position offset (fraction): ',off);
{ Free Offsets }
288 : Writeln(tagnum:2,' - Free Offsets (obsolete) = ',off);
{ Free Bytes Count }
289 : Writeln(tagnum:2,' - Free Bytes Count (obsolete) = ',off);
{ Grey response unit }
290 : Writeln(tagnum:2,' - Gray response unit ',Power(10,off));
{ Grey response curve }
291 : Writeln(tagnum:2,' - Gray response curve offset: ',off);
292 : Writeln(tagnum:2,' - Group 3 Options: ',off); { Group 3 Options }
293 : Writeln(tagnum:2,' - Group 4 Options: ',off); { Group 4 Options }
296 : Begin { Resolution Unit }
Write(tagnum:2,' - Resolution Unit: ');
Case off Of
1 : Writeln('No unit of measurement');
2 : Writeln('Inches');
3 : Writeln('Centimetres');
End;
End;
{ Page number }
297 : Writeln(tagnum:2,' - Page Number offset: ',off);
{ Colour response unit }
300 : Writeln(tagnum:2,' - Colour response unit: ',Power(10,off));
{ Colour response curves }
301 : Writeln(tagnum:2,' - Colour response curve offset = ',off);
305 : Writeln(tagnum:2,' - Software that created the image: ',GetStr(len,off));
306 : Writeln(tagnum:2,' - Date & Time image was created: ',GetStr(len,off));
315 : Writeln(tagnum:2,' - Person who created the image: ',GetStr(len,off));
316 : Writeln(tagnum:2,' - Host computer: ',GetStr(len,off));
317 : Writeln(tagnum:2,' - Predictor = ',off);
320 : Begin
Writeln(tagnum:2,' - Palette offset = ',off);
GetPalette(len,off);
End;
Else Writeln(tagnum:2,' - Unrecognized tag: ',tag);
End;
End;
Begin
If ParamCount>0 Then Begin
Strips:=Nil; maxstp:=0;
If Pos('.',ParamStr(1))=0 Then StrPCopy(name,ParamStr(1)+'.TIF')
Else StrPCopy(name,ParamStr(1));
Assign(fl,name);
{$I-}
Reset(fl,1);
{$I+}
If IOResult=0 Then Begin
data:=GetWord(fl);
If data=$4949 Then Format:=True Else
If data=$4D4D Then Format:=False Else Begin
Writeln('File is not a TIFF');
Halt;
End;
If Format Then Writeln('TIFF stored in Intel format')
Else Writeln('TIFF stored in Motorola format');
data:=GetWord(fl);
Writeln('TIFF version ',data/10:1:1);
offset:=GetLong(fl);
Writeln('Tagged fields at offset ',offset,' bytes');
Seek(fl,offset); { Move to "tags" in file }
data:=GetWord(fl);
Writeln(data,' tagged fields in the directory...');
For tagnum:=1 To data Do ReadTag;
If spp=1 Then Begin { Show image if paletted, not true colour }
Writeln;
Writeln('Press a key to view the image');
ReadKey;
ShowImage;
End;
Close(fl);
End Else Writeln('File not found');
End Else Writeln('Usage: TIFFVIEW <filename>');
End.
Оставить комментарий
Комментарии
1.
25 мая 2009, 14:27:26
Чем компилировать прогу на ассемблере????????
2.
Аноним
22 апреля 2006, 20:46:00
че-ж тут переводить; вот насчет ассемблера, не всегда будет работать
3.
Аноним
+1 / -0
31 мая 2005, 22:54:05
Здорово! Пока ничего не понял, но все равно - клево. По крайней мере теперь ясен порядок и офсеты заголовков. Открываются возмжности коррекции полученого файла (например: изменить X res & Y res) после того, как одна из многих древних OCX большой растр (x*y >> 10000*5000 pixels) сохраняет только с разрешением 100 dpi, а нужно, к примеру, 300 dpi. Будем колдовать. Спасибо!
Hitler kaputt?
Hitler kaputt?
4.
Аноним
+1 / -0
28 марта 2005, 00:11:30
Ох... Теперь это все бы еще на С++ перевести... :)