[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]

    {
    From: nigelg@lpilsley.demon.co.uk (Nigel Goodwin)
    > Can anyone tell me where to find some pascal source code that reads simple
    > bi-level TIFF format images. It should support the standard TIFF compression
    > schemes used for bi-level images.

    Here's a TIFF program I downloaded from Compuserve, hope it may be of help.
    }

    Program tiffread;

    {Written by Alan B.}

    {$I-,R+}

    uses  printer,crt,dos,graph;

    type  binstr     = string[8];
          screenarray= array[1..11000] of byte;

          stripinfoptr = ^stripinfo;
          stripinfo    = record
                           size: word;
                           offset: word;
                           stripinfolink: stripinfoptr;
                         end;
          stripobytesptr =^stripobytes;
          stripobytes    = record
                             value: byte;
                             stripobyteslink: stripobytesptr;
                           end;
          lineobytesptr    = ^lineobytes;
          lineobytes       = record
                               bits: byte;
                               lineobyteslink: lineobytesptr;
                             end;

    var   fin,
          fout                   : file;
          i,j,k,rr               : integer;
          l,m,
          column,
          bytepos                : byte;
          row                    : integer;
          count                  : shortint;
          rownum                 : integer;
          TifFileName            :   String[45];
          dot: boolean;
          rowstir                : integer;
          fentries,
          nexttag,
          nextlength             : word;
          tbyte                  : byte;
          fimagewidth,
          fimagelength,
          fstripoffsetsoffset,
          fstrips,
          fstripbytecountsoffset,
          bytetoread,
          largeststrip           : word;
          first,
          last,
          p                      : stripinfoptr;
          firstbyte,
          lastbyte,
          pbyte                  : stripobytesptr;
          firstline,
          lastline,
          pline                  : lineobytesptr;
          columns                : integer;
          compression            : word;
          regs                   : registers;
          screen                 : ^screenarray;
          header                 : array[1..10] of byte;
          page                   : array[1..8,1..100] of byte;
          printcolumns           : integer;

    {reads a file into the image array}
    {assumes StripOffsets start directly after stripbytcounts}
    {read down to where stripbytecounts starts}
    {fill stripbytecounts with size in bytes of each offset}
    {read each strip into linked list}

    procedure Writebytes;
    begin
    {this displays the contents of the linked list on the printer}
      pbyte:= firstbyte;
      while pbyte^.stripobyteslink <> nil do
        begin
          write(lst,pbyte^.value:3,' ');
          pbyte:= pbyte^.stripobyteslink;
        end;
      writeln(lst);
    end;

    procedure WriteStripInfo;
    begin
    {this displays the contents of the linked list on the printer}
      p:= first;
      while p <> nil do
        begin
          write(lst,p^.size:3,' ');
          writeln(lst,p^.offset:4,' ');
          p:= p^.stripinfolink;
        end;
      writeln(lst,#12);
    end;

    Procedure SetVMode(newmode:integer);
    begin
      FillChar(Regs,SizeOf(regs),0);
      Regs.AX:= newmode;
      Intr($10,Regs);
    end;

    Function BitOn(Position, TestByte:byte):boolean;
    var
      bt,
      i:byte;
    begin
      bt:= $01;
      bt:= bt shl position;
      biton:= (bt and testbyte) > 0;
    end;

    procedure Pictoprinter(row:integer);
    var bytepos,
        j,i,
        pinlabel,
        pin,
        column   : integer;
        trow     : integer;
    begin
      write(lst,#27,'A',#8); {8 lines per inch}
      bytepos:=0;
      write(lst,#27,'L',Chr((columns*8) mod 256),chr((columns*8) div 256));
    {graphics mode}
      for column:=1 to columns do
      begin
        for bytepos:=0 to 7 do
        begin
          trow:=1;
          pinlabel:=0;
          if not biton(abs(bytepos-7),page[trow][column]) then
            pinlabel:= 128;
          inc(trow);
          if not biton(abs(bytepos-7),page[trow][column]) then
            inc(pinlabel,64);
          inc(trow);
          if not biton(abs(bytepos-7),page[trow][column]) then
            inc(pinlabel,32);
          inc(trow);
          if not biton(abs(bytepos-7),page[trow][column]) then
            inc(pinlabel,16);
          inc(trow);
          if not biton(abs(bytepos-7),page[trow][column]) then
            inc(pinlabel,8);
          inc(trow);
          if not biton(abs(bytepos-7),page[trow][column]) then
            inc(pinlabel,4);
          inc(trow);
          if not biton(abs(bytepos-7),page[trow][column]) then
            inc(pinlabel,2);
          inc(trow);
          if not biton(abs(bytepos-7),page[trow][column]) then
            inc(pinlabel);
          write(lst,char(pinlabel))
        end;
      end;
      write(lst,#13,#10);
    end;

    procedure Pictoscreen(row:integer);

    var storagebyte : byte;
        i,j,wl,wr,wb,wt,
        column      : integer;

    procedure SetPixal(xpos,ypos:integer);
    begin
      FillChar(Regs,SizeOf(regs),0);
      Regs.ah:= $0c;
      Regs.al:= 1;
      Regs.cx:= xpos;
      Regs.dx:= ypos;
      intr($10,Regs);
    end;

    begin
      column:= 1;
      printcolumns:= 0;
      while pline <> nil do
        begin
          if ((row mod 8) = 0) then
            page[8,column]:= pline^.bits
          else
            page[row mod 8,column]:= pline^.bits;
          for i:= 0 to 7 do
            if biton(i,pline^.bits) then
            begin
              SetPixal((column*8-7)+abs(i-7),row);
              inc(printcolumns)
            end;
          pline:= pline^.lineobyteslink;
          inc(column)
        end;
    end;

    Procedure GetFileName;

    Function fileexists(searchfile: string):boolean;
    var
      f:   file;
      ok:  boolean;
    begin
      assign(f,searchfile);
      (*$I-*)
      reset(f,1);
      (*$I+*)
      ok:= ioresult = 0;
      if not ok then
        fileexists:= false
      else
        begin
          close(f);
          fileexists:= true;
        end;
    end;

    begin
      TifFileName:='____________';
      i:=ParamCount;
      if i>1 then
      begin
        Write(#07,' Invalid Number of Paramaters');
        Halt;
      end
      else
      if i=0 then
      begin
        write('Enter File Name: ');
        ReadLn(tifFileName);
        if Length(tifFileName)=0 then
          Halt;
      end
      else
      begin
        tifFileName:=ParamStr(1);
      end;
      Dot:=False;
      for i:=1 to Length(tifFileName) do
        if tifFileName[i]='.' then
            Dot:=True;
      if Dot=False then
        tifFileName:=tifFileName+'.TIF';
      if not(FileExists(tifFileName)) then
      begin
        Write(#07,'File ',tifFileName,' Not on Disk');
        Halt;
      end;
    end;

    Procedure GetFileInfo;
    begin
      assign(fin,tiffilename);
      reset(fin,1);
      blockread(fin,header,8);
      writeln('***********');
            {we're assuming the ifd is right after the header}
      blockread(fin,fentries,2);
      for i:=1 to fentries do
        begin
          blockread(fin,nexttag,2);
          case nexttag of
             {i really need a 32 bit unsigned type here. since i dont have
              one file witdth should be limited to 65535}
            256: begin                        {imagewidth}
                   blockread(fin,header,6);
                   blockread(fin,fimagewidth,2);
                   Columns:= (fimagewidth div 8);
                   if (fimagewidth mod 8) <> 0 then
                     inc(Columns);
    {               writeln('columns: ',columns);}
                   blockread(fin,header,2);
                 end;
            257:begin                         {imagelength}
                  blockread(fin,header,6);
                  blockread(fin,fimagelength,2);
    {              writeln('rows: ',fimagelength);}
                  blockread(fin,header,2);
                end;
            259:begin
                  blockread(fin,header,6);
                  blockread(fin,Compression,2);
                  if compression <> 32773 then
                    begin
                      writeln('I can''t read this. A computer is a terrible thing to waste, isn''t it.');
                      readln;
                      halt;
                    end;
                  blockread(fin,header,2);
                end;
            273:begin                         {stripOffsets}
                  blockread(fin,header,2);    {read past field type}
                  blockread(fin,fstrips,2);      {length}
                  writeln('strips: ',fstrips);
                  blockread(fin,header,2);
                  blockread(fin,fstripoffsetsoffset,2);
                  blockread(fin,header,2);
                end;
            279:begin                         {StripByteCounts}
                  blockread(fin,header,6);
                  blockread(fin,fstripbytecountsoffset,2);
                  writeln('stripbytecountoffset: ',fstripbytecountsoffset);
                  blockread(fin,header,2);
                end;
            else blockread(fin,header,10);
          end;  {case}
        end; {for i:= 1 to fentries}
    end;

    Procedure GetStripCounts;

    procedure add(fcount:word);
    {we're assuming theres at least 1 byte in the list}
    begin
      if first = nil then
        begin
          new(first);
          last:= first;
          first^.size:= fcount;
        end
      else      {the list has already been started so just add to it}
        begin
          new(p);
          p^.size:= fcount;
          last^.stripinfolink:=p;
          last:= p;
        end;
    end;

    begin
    {here we're assuming the stripbytecount values will fit in a word}
    {this part reads stripbytecounts into the linkedlist}
      first:= nil;
      reset(fin,1);
      seek(fin,fstripbytecountsoffset);
      for i:= 1 to fstrips do
        begin
          blockread(fin,bytetoread,2);
          add(bytetoread);
        end;
      if first <> nil then last^.stripinfolink:= nil;
    end;

    Procedure GetStripOffsets;
    begin
    {this part reads in the strip offsets into the linked list}
      p:= first;
      reset(fin,1);
      seek(fin,fstripoffsetsoffset);
      for i:= 1 to fstrips do
        begin
          blockread(fin,bytetoread,2);
          p^.offset:= bytetoread;
          p:=p^.stripinfolink;
          blockread(fin,bytetoread,2);
        end;
    end;

    procedure DisposeStrip;
    var
    tpointer:stripobytesptr;
    begin
      tpointer:= firstbyte^.stripobyteslink;
      dispose(firstbyte);
      firstbyte:= tpointer;
      while tpointer^.stripobyteslink <> nil do
      begin
        tpointer:= tpointer^.stripobyteslink;
        dispose(firstbyte);
        firstbyte:= tpointer;
      end;
      dispose(tpointer);
    end;

    Procedure ReadAStrip;

    procedure addbyte(fcount:word);
    {we're assuming there's at least 1 byte in the list}
    begin
      if firstbyte = nil then
        begin
          new(firstbyte);
          lastbyte:= firstbyte;
          firstbyte^.value:= fcount;
        end
      else      {the list has already been started so just add to it}
        begin
          new(pbyte);
          pbyte^.value:= fcount;
          lastbyte^.stripobyteslink:=pbyte;
          lastbyte:= pbyte;
        end;
    end;

    begin
    {this part jumps down to the right place in the file and reads a strip into
     a linked list.  We'll just read in one strip for now.}

      firstbyte:= nil;
      reset(fin,1);
      seek(fin,p^.offset);
      for i:= 1 to p^.size + 1 do  {+1 for not / by 8 evenly}
        begin
          blockread(fin,tbyte,1);
          addbyte(tbyte);
        end;
      if firstbyte <> nil then lastbyte^.stripobyteslink:= nil;
    end;

    Procedure DecodeStrip;

    var
      spot     : integer;

    procedure disposeline;
    var
    tpointer:lineobytesptr;
    begin
      tpointer:= firstline^.lineobyteslink;
      dispose(firstline);
      firstline:= tpointer;
      while tpointer^.lineobyteslink <> nil do
      begin
        tpointer:= tpointer^.lineobyteslink;
        dispose(firstline);
        firstline:= tpointer;
      end;
      dispose(tpointer);
    end;

    procedure ResetPage;
    begin
      if firstline <> nil then lastline^.lineobyteslink:= nil;
      pline:= firstline;
      pictoscreen(rownum);
      {if ((rownum div 8) >= 1) and ((rownum mod 8) = 0) then
        pictoprinter(rownum);}
      inc(rownum);
      disposeline;
      firstline:= nil;
      spot:= 1;
    end;

    procedure addline(fcount:word);
    {we're assuming there's at least 1 byte in the list}
    begin
      if firstline = nil then
        begin
          new(firstline);
          lastline:= firstline;
          firstline^.bits:= fcount;
        end
      else      {the list has already been started so just add to it}
        begin
          new(pline);
          pline^.bits:= fcount;
          lastline^.lineobyteslink:=pline;
          lastline:= pline;
        end;
    end;

    begin
    {now lets try and decode the strip in the linked list}
      firstline:= nil;
      spot:= 1;
      pbyte:= firstbyte;
      while pbyte^.stripobyteslink <> nil do {convert the strip 8 rows per strip}
        begin
          Count:= shortint(pbyte^.value);
          if Count < 0 then    {copy the next byte -n+1 times}
            begin
              pbyte:= pbyte^.stripobyteslink; {point to the byte to copy -n+1
    times}
              for i:= 1 to (-Count+1) do
                begin
                  addline(pbyte^.value);
                  inc(spot);
                  if spot > columns then
                    resetpage;
                end;
            end
          else                  {copy the next n+1 bytes literally}
            for i:= 1 to (Count+1) do {no error checking for nil}
              begin
                pbyte:= pbyte^.stripobyteslink; {point the the next literal byte}
                addline(pbyte^.value);
                inc(spot);
                if spot > columns then
                  resetpage;
              end;
          pbyte:= pbyte^.stripobyteslink;
        end;
    end;

    var ch:char;
    begin
      GetFileName;
      GetFileInfo;
      GetStripCounts;
      GetStripOffsets;
      p:= first;
      SetVMode($10);
      new(screen);
      screen:= ptr($A000,$0000);
      rownum:= 1;
      while p^.stripinfolink <> nil do
        begin
          ReadAStrip;
          DecodeStrip;
          DisposeStrip;
          p:= p^.stripinfolink;
        end;
      close(fin);
      assign(input,'');
      reset(input);
      readln;
      SetVMode($3);
      {write(lst,#12,#13);}

      {enhancements needed

      adjust for aspect ratio
      mask out extra stuf at right side when displaying
      add ega support
      add interface
      write direct to memory
      }

    end.

[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]