Справочник функций

Ваш аккаунт

Войти через: 
Забыли пароль?
Регистрация
Информацию о новых материалах можно получать и без регистрации:

Последние темы форума

Показать новые сообщения »
реклама
Баня бочка под ключ цена готовые бани бочки от производителя под ключ.

Почтовая рассылка

Подписчиков: 11656
Последний выпуск: 19.06.2015

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.

Оставить комментарий

Комментарий:
можно использовать BB-коды
Максимальная длина комментария - 4000 символов.
 

Комментарии

1.
50K
25 мая 2009 года
Romario1990
0 / / 25.05.2009
Мне нравитсяМне не нравится
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?
4.
Аноним
+1 / -0
Мне нравитсяМне не нравится
28 марта 2005, 00:11:30
Ох... Теперь это все бы еще на С++ перевести... :)
Реклама на сайте | Обмен ссылками | Ссылки | Экспорт (RSS) | Контакты
Добавить статью | Добавить исходник | Добавить хостинг-провайдера | Добавить сайт в каталог