[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]