home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-386-Vol-2of3.iso / h / hercap10.zip / TIFF2CHR.PAS < prev   
Pascal/Delphi Source File  |  1991-01-13  |  7KB  |  224 lines
  1. Program tiff2chr;
  2. { liest eine TIFF-Datei ein, gibt das Bild mit '*' für gesetzte Pixel als    }
  3. { Textdatei aus. Simple Form: versteht nur wenige Tags, 1 Bild je Datei,     }
  4. { 1 Bit/Sample, 1 Sample/Pixel. Versteht Run-Length-Encoded TIFF.            }
  5. { TapirSoft Gisbert W.Selke, 13 Jan 1991                                     }
  6.  
  7. {$A+,B-,D+,E+,F-,I-,L+,N-,O-,R+,S+,V- }
  8. {$M 65520,0,480000 }
  9.  
  10.   Uses Crt;
  11.  
  12.   Const progname     = 'TIFF2CHR';
  13.         version      = '1.0';
  14.         copyright    = 'Freeware by TapirSoft Gisbert W.Selke, Jan 1991';
  15.         bufsize      = 30000;
  16.         NoCompressed = 1;
  17.         RLE          = 32773;
  18.         Return : char= #13;
  19.  
  20.   Type iobuf = Array [1..bufsize] Of byte;
  21.        tiffheader = Record
  22.                       format  : word;
  23.                       version : word;
  24.                       ifdoffset : longint;
  25.                     End;
  26.        ifdentry   = Record
  27.                       tag : word;
  28.                       typ : word;
  29.                       length : longint;
  30.                       Case boolean Of
  31.                         True:  (longdata : longint);
  32.                         False: (shortdata : word;
  33.                                 filler    : word;);
  34.                     End;
  35.  
  36.   Var inf : File;
  37.       outf : text;
  38.       inbuf, outbuf : iobuf;
  39.       header : tiffheader;
  40.       ifd : ifdentry;
  41.       ifdentries : word;
  42.       byteptr, inct, i, outinrow, rowct, comprtype : word;
  43.       b, k, run, ncopy, lastbyte : byte;
  44.       black, white : char;
  45.       totpxl, totct, height, width, stripoff, striplen : longint;
  46.  
  47.   Procedure abort(msg : string; icode : byte);
  48.   { gibt Fehlermeldung aus und stirbt dahin                                  }
  49.   Begin                                                              { abort }
  50.     writeln(progname,': ',msg);
  51.     Halt(icode);
  52.   End;                                                               { abort }
  53.  
  54.   Procedure readhdr;
  55.   { liest TIFF-Header und wichtige Tags ein                                  }
  56.  
  57.     Var longval : longint;
  58.         iread : word;
  59.         i : byte;
  60.  
  61.     Function word2str(w : word) : string;
  62.     { wandelt Word in String um                                              }
  63.       Var stemp : string;
  64.     Begin                                                         { word2str }
  65.       Str(w,stemp);
  66.       word2str := stemp;
  67.     End;                                                          { word2str }
  68.  
  69.   Begin                                                            { readhdr }
  70.     width  := 0;
  71.     height := 0;
  72.     stripoff := 0;
  73.     striplen := 0;
  74.     black := ' ';
  75.     white := '*';
  76.     BlockRead(inf,header,SizeOf(header),iread);
  77.     If (iread <> SizeOf(header)) Or (header.format <> $4949) Or
  78.        (header.version <> 42) Then abort('Falscher Header',2);
  79.     Seek(inf,header.ifdoffset);
  80.     BlockRead(inf,ifdentries,SizeOf(ifdentries),iread);
  81.     If iread <> SizeOf(ifdentries) Then abort('Falscher Header',2);
  82.     For i := 1 To ifdentries Do
  83.     Begin
  84.       BlockRead(inf,ifd,SizeOf(ifd),iread);
  85.       If iread <> SizeOf(ifd) Then abort('Falscher Tag-Eintrag',3);
  86.       Case ifd.typ Of
  87.         2 : longval := ifd.longdata;
  88.         3 : longval := ifd.shortdata;
  89.         4 : longval := ifd.longdata;
  90.         Else Begin
  91.                writeln('Unbekannter Tag-Typ "',ifd.typ,'" für Tag "',
  92.                        ifd.tag,'"');
  93.                longval := 0;
  94.              End;
  95.       End;
  96.       Case ifd.tag Of
  97.         $FF  : ; { subfile at full resolution }
  98.         $100 : width  := longval;
  99.         $101 : height := longval;
  100.         $102 : If longval <> 1 Then
  101.                          abort('Nur 1 Bit/Sample wird unterstützt',5);
  102.         $103 : Begin
  103.                  If (longval <> NoCompressed) And (longval <> RLE) Then abort(
  104.             'Nur un- und lauflängenkomprimierte Dateien werden unterstützt',5);
  105.                  comprtype := longval;
  106.                End;
  107.         $106 : Begin  { Photometric Interpretation }
  108.                  If longval <> 1 Then
  109.                  Begin
  110.                    black := '*';
  111.                    white := ' ';
  112.                  End;
  113.                End;
  114.         $111 : Begin
  115.                  If Not (ifd.typ In [3,4]) Then abort('Z.Zt. nur 1 Strip!',4);
  116.                  stripoff := longval;
  117.                End;
  118.         $115 : If longval <> 1 Then
  119.                          abort('Nur 1 Sample/Pixel wird unterstützt',5);
  120.         $117 : striplen := longval;
  121.         $11C : If longval <> 1 Then
  122.                          abort('Nur planare Konfiguration wird unterstützt',5);
  123.         $10E, $10F, $131, $132, $13B, $13C : ; { ignore informational tags }
  124.         Else writeln('Unbekannte Tag-Kennung ',ifd.tag);
  125.       End;
  126.     End;
  127.   End;                                                             { readhdr }
  128.  
  129.   Function getbyte : byte;
  130.   { gets one byte from input stream, possibly compressed                     }
  131.   Begin                                                            { getbyte }
  132.     If run > 0 Then
  133.     Begin
  134.       getbyte := lastbyte;
  135.       Dec(run);
  136.     End
  137.     Else
  138.     Begin
  139.       If byteptr >= inct Then
  140.       Begin
  141.         BlockRead(inf,inbuf,bufsize,inct);
  142.         byteptr := 0;
  143.       End;
  144.       Inc(byteptr);
  145.       If comprtype = NoCompressed Then getbyte := inbuf[byteptr]
  146.       Else
  147.       Begin
  148.         If ncopy > 0 Then
  149.         Begin
  150.           getbyte := inbuf[byteptr];
  151.           Dec(ncopy);
  152.         End
  153.         Else
  154.         Begin
  155.           lastbyte := inbuf[byteptr];
  156.           If lastbyte > 127 Then
  157.           Begin
  158.             ncopy := 1;
  159.             getbyte := getbyte;
  160.             run := -lastbyte + 256;
  161.             lastbyte := inbuf[byteptr];
  162.           End
  163.           Else
  164.           Begin
  165.             If lastbyte = 128 Then getbyte := getbyte
  166.             Else
  167.             Begin
  168.               ncopy   := Succ(lastbyte);
  169.               getbyte := getbyte;
  170.             End
  171.           End
  172.         End
  173.       End
  174.     End
  175.   End;                                                             { getbyte }
  176.  
  177. Begin
  178.   writeln(progname,' ',version,' ',copyright);
  179.   writeln('Einfacher TIFF-nach-Textdatei-Konverter');
  180.   Assign(inf,'');
  181.   Reset(inf,1);
  182.   Assign(outf,'');
  183.   Rewrite(outf);
  184.   SetTextBuf(outf,outbuf);
  185.   readhdr;
  186.   Seek(inf,stripoff);
  187.   outinrow := 0;
  188.   rowct := 0;
  189.   totpxl := height*width;
  190.   inct := 0;
  191.   byteptr := 1;
  192.   run := 0;
  193.   ncopy := 0;
  194.   totct := 0;
  195.   writeln(outf,width,' ',height);
  196.   write('1     von ',height,' Zeilen');
  197.   While totct < totpxl Do
  198.   Begin
  199.     b := getbyte;
  200.     For k := 1 To 8 Do
  201.     Begin
  202.       If (b And $80) = 0 Then write(outf,black)
  203.                          Else write(outf,white);
  204.       b := (b And $7F) ShL 1;
  205.     End;
  206.     totct := totct + 8;
  207.     outinrow := outinrow + 8;
  208.     If outinrow >= width Then
  209.     Begin
  210.       writeln(outf);
  211.       outinrow := 0;
  212.       Inc(rowct);
  213.       If (rowct And $F) = 0 Then write(Return,rowct);
  214.     End;
  215.     If IOResult <> 0 Then abort('Fehler beim Schreiben der Ausgabedatei',6);
  216.   End;
  217.   write(Return,rowct);
  218.   Flush(outf);
  219.   Close(inf);
  220.   Close(outf);
  221.   If IOResult <> 0 Then abort('Fehler beim Schreiben der Ausgabedatei',6);
  222.   If rowct <> height Then writeln('Falsche Anzahl von Zeilen gelesen');
  223. End.
  224.