home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / UTILITY / SCREEN / HERCAP10.ZIP / CHR2TIFF.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-01-13  |  9.1 KB  |  243 lines
  1. Program chr2tiff;
  2. { liest eine Datei ein, die Blanks und Nicht-Blanks (für gesetzte/nicht      }
  3. { gesetzte Pixel) enthält, und wandelt sie in TIFF-Format um.                }
  4. { Zur Zeit nur einfarbige Bilder, ohne Datenkompression.                     }
  5. { Die erste Zeile muß Zeilenlänge und Zeilenzahl (in Pixel) enthalten.       }
  6. { TapirSoft Gisbert W.Selke, 13 Jan 1991                                     }
  7.  
  8. {$A+,B-,D+,E+,F-,I-,L+,N-,O-,R+,S+,V- }
  9. {$M 65520,0,480000 }
  10.  
  11.   Uses Crt;
  12.  
  13.   Const progname     = 'CHR2TIFF';
  14.         version      = '1.0';
  15.         copyright    = 'Freeware by TapirSoft Gisbert W.Selke, Jan 1991';
  16.         descript : string = 'Converted from text file'#0;
  17.         make     : string = 'TapirSoft Gisbert W.Selke'#0;
  18.         bufsize      = 30000;
  19.         nifd         = 13;
  20.         Tab          = $09;
  21.         LF           = $0A;
  22.         CR           = $0D;
  23.         Return : char= #13;
  24.         CtrlZ        = $1A;
  25.         Blank        = $20;
  26.         IgnoreSet : Set Of byte = [LF, CR, CtrlZ];
  27.         Digits : Set Of byte = [Ord('0')..Ord('9')];
  28.  
  29.   Type iobuf = Array [1..bufsize] Of byte;
  30.        tiffheader = Record
  31.                       format  : word;
  32.                       version : word;
  33.                       ifdoffset : longint;
  34.                       ntags   : word;
  35.                     End;
  36.        ifdentry   = Record
  37.                       tag : word;
  38.                       typ : word;
  39.                       length : longint;
  40.                       longdata : longint;
  41.                     End;
  42.  
  43.   Var inf, outf : File;
  44.       inbuf, outbuf : iobuf;
  45.       tiffhdr : tiffheader;
  46.       ifd : Array [1..nifd] Of ifdentry;
  47.       endhdr, npix, nrows, inbufct, inct, outbufct : word;
  48.       ires, i, k, bitct : word;
  49.       l, b : byte;
  50.       zend : boolean;
  51.  
  52.   Procedure abort(msg : string; icode : byte);
  53.   { gibt Fehlermeldung aus und stirbt dahin                                  }
  54.   Begin                                                              { abort }
  55.     If IOResult <> 0 Then;
  56.     writeln(progname,': ',msg);
  57.     Halt(icode);
  58.   End;                                                               { abort }
  59.  
  60.   Procedure writehdr;
  61.   { schreibt TIFF-Header und wichtige Tags                                   }
  62.  
  63.     Var software : string;
  64.  
  65.     Procedure fillhdr;
  66.     { füllt Header mit den wichtigsten Angaben                               }
  67.       Var i : byte;
  68.           hdrsize : word;
  69.     Begin                                                          { fillhdr }
  70.       hdrsize := SizeOf(tiffhdr) + SizeOf(ifd) + SizeOf(endhdr);
  71.       software := progname + ' ' + version + #0;
  72.       tiffhdr.format    := $4949;           { byte order : intel             }
  73.       tiffhdr.version   := 42;              { version #                      }
  74.       tiffhdr.ifdoffset := 8;               { length of first part of header }
  75.       tiffhdr.ntags     := 13;              { number of tags to come         }
  76.       For i := 1 To tiffhdr.ntags Do
  77.       Begin
  78.         Case i Of
  79.           1 : ifd[i].tag :=  $FF;           { sub file               }
  80.           2 : ifd[i].tag := $100;           { image width            }
  81.           3 : ifd[i].tag := $101;           { image height           }
  82.           4 : ifd[i].tag := $102;           { bits per sample        }
  83.           5 : ifd[i].tag := $103;           { no compression         }
  84.           6 : ifd[i].tag := $106;           { 0 is code for black    }
  85.           7 : ifd[i].tag := $10E;           { where do we come from  }
  86.           8 : ifd[i].tag := $10F;           { vanity                 }
  87.           9 : ifd[i].tag := $111;           { strip offset           }
  88.          10 : ifd[i].tag := $115;           { samples per pixel      }
  89.          11 : ifd[i].tag := $117;           { strip byte count       }
  90.          12 : ifd[i].tag := $11C;           { planar configuration   }
  91.          13 : ifd[i].tag := $131;           { more vanity            }
  92.         End;
  93.         ifd[i].typ      := 3;
  94.         ifd[i].length   := 1;
  95.         ifd[i].longdata := 1;
  96.       End;
  97.       ifd[2].longdata := npix;
  98.       ifd[3].longdata := nrows;
  99.       ifd[6].longdata := 1;
  100.       ifd[7].typ := 2;
  101.       ifd[7].length   := Length(descript);  { file description }
  102.       ifd[7].longdata := hdrsize;
  103.       ifd[8].typ := 2;
  104.       ifd[8].length   := Length(make);
  105.       ifd[8].longdata := hdrsize + Length(descript);
  106.       ifd[9].typ := 4;
  107.       ifd[9].longdata := hdrsize + Length(descript) + Length(make) +
  108.                          Length(software);
  109.       ifd[11].typ := 4;
  110.       ifd[11].longdata := nrows * ((npix+7) Div 8);
  111.       ifd[13].typ := 2;
  112.       ifd[13].length := Length(software);
  113.       ifd[13].longdata := hdrsize + Length(descript) + Length(make);
  114.       endhdr := 0;
  115.     End;                                                           { fillhdr }
  116.  
  117.   Begin                                                           { writehdr }
  118.     fillhdr;
  119.     Move(tiffhdr,outbuf,SizeOf(tiffhdr));
  120.     outbufct := SizeOf(tiffhdr);
  121.     Move(ifd,outbuf[Succ(outbufct)],SizeOf(ifd));
  122.     outbufct := outbufct + SizeOf(ifd);
  123.     Move(endhdr,outbuf[Succ(outbufct)],SizeOf(endhdr));
  124.     outbufct := outbufct + SizeOf(endhdr);
  125.     Move(descript[1],outbuf[Succ(outbufct)],Length(descript));
  126.     outbufct := outbufct + Length(descript);
  127.     Move(make[1],outbuf[Succ(outbufct)],Length(make));
  128.     outbufct := outbufct + Length(make);
  129.     Move(software[1],outbuf[Succ(outbufct)],Length(software));
  130.     outbufct := outbufct + Length(software);
  131.   End;                                                            { writehdr }
  132.  
  133.   Function getbyte(extra : boolean) : byte;
  134.   { liest ein Byte aus dem Datenstroom. Wenn extra=False, dann blockieren    }
  135.   { Return, LineFeed, CtrlZ das weitere Einlesen (d.h.: es werden bis zum    }
  136.   { nächsten Aufruf mit extra=True nur ' ' zurückgeliefert).                 }
  137.   Begin                                                            { getbyte }
  138.     If inbufct >= inct Then
  139.     Begin
  140.       If Not zend Then BlockRead(inf,inbuf,SizeOf(inbuf),inct);
  141.       zend := inct = 0;
  142.       inbufct := 0;
  143.     End;
  144.     If zend Then getbyte := Blank
  145.     Else
  146.     Begin
  147.       Inc(inbufct);
  148.       If extra Or Not (inbuf[inbufct] In IgnoreSet) Then
  149.                                                  getbyte := inbuf[inbufct]
  150.       Else
  151.       Begin
  152.         Dec(inbufct);
  153.         getbyte := Blank;
  154.       End;
  155.     End;
  156.   End;                                                             { getbyte }
  157.  
  158.   Procedure skipeoln;
  159.   { überspringt Eingabe bis zum nächsten Zeilentrenner                       }
  160.   Begin                                                           { skipeoln }
  161.     While (getbyte(True) <> LF) And Not zend Do ;
  162.   End;                                                            { skipeoln }
  163.  
  164.   Function getnumber : word;
  165.   { liest eine Zahl aus dem Puffer                                           }
  166.     Var w : longint;
  167.         b : byte;
  168.   Begin                                                          { getnumber }
  169.     w := 0;
  170.     While (Not (b In Digits)) And (b <> CR) Do b := getbyte(True);
  171.     While b In Digits Do
  172.     Begin
  173.       If b In Digits Then w := 10*w + (b-Ord('0'));
  174.       If w >= 65536 Then abort('Fehler beim Lesen der Eingabedatei',2);
  175.       b := getbyte(False);
  176.     End;
  177.     getnumber := w;
  178.   End;                                                           { getnumber }
  179.  
  180.   Procedure putbyte(Var b : byte);
  181.   { schreibt ein Byte in den Ausgabe-Puffer und diesen ggf. auf Platte       }
  182.   Begin                                                            { putbyte }
  183.     If outbufct >= SizeOf(outbuf) Then
  184.     Begin
  185.       BlockWrite(outf,outbuf,outbufct,ires);
  186.       If outbufct <> ires Then abort(
  187.                              'Fehler beim Schreiben der Ausgabedatei',3);
  188.       outbufct := 0;
  189.     End;
  190.     Inc(outbufct);
  191.     outbuf[outbufct] := b;
  192.     b := 0;
  193.     bitct := 0;
  194.   End;                                                             { putbyte }
  195.  
  196. Begin
  197.   writeln(progname,' ',version,' ',copyright);
  198.   writeln('Einfacher Textdatei-nach-TIFF-Konverter');
  199.   Assign(inf,'');
  200.   Assign(outf,'');
  201.   b := FileMode;
  202.   FileMode := 0;
  203.   Reset(inf,1);
  204.   FileMode := b;
  205.   Rewrite(outf,1);
  206.   inbufct := Succ(SizeOf(inbuf));
  207.   inct  := 0;
  208.   zend  := False;
  209.   npix  := getnumber;
  210.   nrows := getnumber;
  211.   If IOResult <> 0 Then abort('Fehler beim Lesen der Eingabedatei, 1. Zeile',2);
  212.   If (npix = 0) Or (nrows = 0) Then abort('Größenangaben fehlen',4);
  213.   skipeoln;
  214.   writehdr;
  215.   i := 1;
  216.   write('1     von ',nrows,' Zeilen');
  217.   While i <= nrows Do
  218.   Begin
  219.     If (i And $F) = 0 Then write(Return,i);
  220.     b := 0;
  221.     bitct := 0;
  222.     For k := 1 To npix Do
  223.     Begin
  224.       If getbyte(False) = Blank Then b := (b ShL 1)
  225.                                 Else b := (b ShL 1) Or 1;
  226.       Inc(bitct);
  227.       If bitct = 8 Then putbyte(b);
  228.     End;
  229.     If bitct > 0 Then
  230.     Begin
  231.       b := b ShL (8-bitct);
  232.       putbyte(b);
  233.     End;
  234.     skipeoln;
  235.     Inc(i);
  236.   End;
  237.   write(Return,nrows);
  238.   BlockWrite(outf,outbuf,outbufct,ires);
  239.   If outbufct <> ires Then abort('Fehler beim Schreiben der Ausgabedatei',3);
  240.   Close(inf);
  241.   Close(outf);
  242. End.
  243.