| Unit1.pas |
The pascal source code for IMGCOLOR.exe is mostly in one
unit, Unit1.pas. (I am competent in Pascal but still only
a beginner in Delphi, so this software is not beautifully
well structured, sorry).
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms,
Dialogs, StdCtrls, Menus;
type
TImgColors = class(TForm)
Source: TButton;
Report: TMemo;
ProgramLabel: TLabel;
SrcFile: TOpenDialog;
procedure SrcBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
testing: boolean;
ImgColors: TImgColors;
ImgFile, PapFile, PatFile: file;
ImgPtr, PapPtr, PatPtr: integer;
ImgBuffer: array[1..8] of byte;
PapBuffer: array[1..8] of byte;
PatBuffer: array[1..8] of byte;
implementation
{$R *.dfm}
function max(a,b,c: integer): integer;
var
n: integer;
begin
n := a;
if (n<b) then n := b;
if (n<c) then n := c;
max := n;
end;
function min(a,b,c: integer): integer;
var
n: integer;
begin
n := a;
if (n>b) then n := b;
if (n>c) then n := c;
min := n;
end;
function mid(a,b,c: integer): integer;
var
x, y, z: integer;
begin
x := max(a,b,c);
y := min(a,b,c);
if (a=x) then
begin
if (b=y) then z := c;
if (c=y) then z := b;
end;
if (b=x) then
begin
if (a=y) then z := c;
if (c=y) then z := a;
end;
if (c=x) then
begin
if (a=y) then z := b;
if (b=y) then z := a;
end;
mid := z;
end;
function WrHex(n: integer): ShortString;
var
i: integer;
number: ShortString;
begin
number := ' ';
i := n div 16;
if (i<10) then number := number+char(i+48)
else number := number+char(i+55);
i := n mod 16;
if (i<10) then number := number+char(i+48)
else number := number+char(i+55);
WrHex := number;
end;
procedure HueOf(R, G, B: integer; var Hu, Sa, Br: integer);
var
bri, midi: integer;
desat, offset, base, H, S: real;
begin
bri := max(R,G,B);
if (bri=0) then
begin
H := 0.0;
S := 0.0;
end else begin
desat := min(R,G,B);
if (desat=bri) then
begin
H := 0.0;
S := 0.0;
end else begin
S := 1 - desat/bri;
midi := mid(R,G,B);
offset := (midi-desat)/(6*(bri-desat));
if (bri=R) then
begin
if (midi=G) then base := (0/6)
else begin
base := (5/6);
offset := (1/6)-offset;
end;
end else begin
if (bri=G) then
begin
if (midi=B) then base := (2/6)
else begin
base := (1/6);
offset := (1/6)-offset;
end;
end else begin
{ bri=B }
if (midi=R) then base := (4/6)
else begin
base := (3/6);
offset := (1/6)-offset;
end;
end;
end;
H := base+offset;
end;
end;
Hu := round(360*H) mod 360;
Sa := round(S*100);
Br := round(100*bri/255);
end;
procedure RGB(Hue,Sat,Bri: real; var R,G,B: integer);
var
domOffset: real;
begin
if (Bri=0) then
begin
R := 0;
G := 0;
B := 0;
end
else
if (Sat=0) then
begin
R := trunc(255*Bri);
G := trunc(255*Bri);
B := trunc(255*Bri);
end
else
if (Hue<(1/6)) then
begin
domOffset := Hue;
R := trunc(255*Bri);
B := trunc(255*(Bri*(1.0-Sat)));
G := trunc(255*(B/255+(((Bri-(B/255))*domOffset*6))));
end
else
if (Hue<(2/6)) then
begin
domOffset := Hue - (1/6);
G := trunc(255*Bri);
B := trunc(255*(Bri*(1.0-Sat)));
R := trunc(255*(G/255 -(((Bri-(B/255))*domOffset*6))));
end
else
if (Hue<(3/6)) then
begin
domOffset := Hue -(2/6);
G := trunc(255*Bri);
R := trunc(255*(Bri*(1.0-Sat)));
B := trunc(255*(R/255+(((Bri-(R/255))*domOffset*6))));
end
else
if (Hue<(4/6)) then
begin
domOffset := Hue-(3/6);
B := trunc(255*Bri);
R := trunc(255*(Bri*(1.0-Sat)));
G := trunc(255*(B/255-(((Bri-(R/255))*domOffset*6))));
end
else
if (Hue<(5/6)) then
begin
domOffset := Hue-(4/6);
B := trunc(255*Bri);
G := trunc(255*(Bri*(1.0-Sat)));
R := trunc(255*(G/255+(((Bri-(G/255))*domOffset*6))));
end
else
begin
domOffset := Hue-(5/6);
R := trunc(255*Bri);
G := trunc(255*(Bri*(1.0-Sat)));
B := trunc(255*(R/255-(((Bri-(G/255))*domOffset*6))));
end;
end;
procedure ImgWrite(n: byte);
var
i: integer;
begin
ImgPtr := ImgPtr+1;
ImgBuffer[ImgPtr] := n;
if (ImgPtr=8) then
begin
blockwrite(ImgFile,ImgBuffer,1);
for i := 1 to 8 do ImgBuffer[i] := 0;
imgPtr := 0;
end;
end;
procedure PapWrite(n: byte);
var
i: integer;
begin
PapPtr := PapPtr+1;
PapBuffer[PapPtr] := n;
if (PapPtr=8) then
begin
blockwrite(PapFile,PapBuffer,1);
for i := 1 to 8 do PapBuffer[i] := 0;
PapPtr := 0;
end;
end;
procedure PatWrite(n: byte);
var
i: integer;
begin
PatPtr := PatPtr+1;
PatBuffer[PatPtr] := n;
if (PatPtr=8) then
begin
blockwrite(PatFile,PatBuffer,1);
for i := 1 to 8 do PatBuffer[i] := 0;
PatPtr := 0;
end;
end;
procedure PatchImg(Filename: ShortString; Hue: integer);
var
i, PatR, PatG, PatB: integer;
begin
AssignFile(PatFile,Filename);
Rewrite(PatFile,8);
for i := 1 to 8 do PatBuffer[i] := 0;
PatPtr := 0;
{ 2 headers }
PatWrite(66); { 42 4D - 2 bytes }
PatWrite(77);
PatWrite(56); { file size 4 bytes }
PatWrite(3);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(54); { offset }
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(40); { header size }
PatWrite(0);
PatWrite(0); { image width - 4 bytes }
PatWrite(0);
PatWrite(16);
PatWrite(0);
PatWrite(0); { image height - 4 bytes }
PatWrite(0);
PatWrite(16);
PatWrite(0);
PatWrite(0); { image planes }
PatWrite(0);
PatWrite(1);
PatWrite(0);
PatWrite(24); { bits per pixel }
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(18); { horizontal resolution }
PatWrite(11);
PatWrite(0);
PatWrite(0);
PatWrite(18); { vertical resolution }
PatWrite(11);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatWrite(0);
PatR := 0; PatG := 0; PatB := 0;
RGB((Hue/360),1.0,1.0,PatR,PatG,PatB);
for i := 1 to 256 do
begin
PatWrite(PatB);
PatWrite(PatG);
PatWrite(PatR);
end;
PatWrite(0);
PatWrite(0);
CloseFile(PatFile);
end;
{ HANTSMAP }
{ file:IMGCOLOR.exe MN: 15.3.2004 }
{ version 1.6 : 23.3.2004}
procedure TImgColors.SrcBtnClick(Sender: TObject);
var
PaperImg, CountLetters: boolean;
InFile, PaperFile: file;
InFileRoot, Mkr: ShortString;
OutFile: TextFile;
OutFilename, ImgFilename, PapFilename, PaperFilename,
PatFilename: ShortString;
i, j, InPtr, NumIn, CharCount, PixCount, LineCount: integer;
R, G, B, Hue, Sat, Bri, imgW, imgH, BriMin, SatMin: integer;
HueCount, PixelsCount: integer;
paperHmax,paperHmin,paperSmax,paperSmin,paperBmax,
paperBmin: integer;
HuePlus, BriPlus, SatPlus: integer;
InBuffer: array[1..128] of byte;
onenum, numword: ShortString;
ImgColor: array[0..359,1..5] of real;
ScalingRatio: integer;
begin
PaperImg := true;
CountLetters := false;
testing := false;
BriMin := 31;
SatMin := 10;
HuePlus := 5; SatPlus := 50; BriPlus := 50;
if SrcFile.Execute then
begin
{ open source files, set up }
{ report file and report }
{ image file }
{ NB no protection against }
{ missing source file }
AssignFile(InFile,SrcFile.Filename);
Reset(InFile,128);
InFileRoot := SrcFile.Filename;
i := length(InFileRoot)+1;
repeat i := i-1;
until (InFileRoot[i]='\') or (i=0);
InFileRoot := copy(InFileRoot,1,i+4);
Mkr := copy(InFileRoot,length(InFileRoot)-4,length(InFileRoot));
OutFilename := InFileRoot+'_col.htm';
AssignFile(OutFile, OutFilename);
Rewrite(OutFile);
{ html page start }
writeln(OutFile,'<html>');
writeln(OutFile,'<head>');
writeln(OutFile,'<title>IMGCOLOR.exe report</title>');
writeln(OutFile,'</head>');
writeln(OutFile,'<body bgcolor="#FFFFDD">');
writeln(OutFile,'');
writeln(OutFile,'<table>');
writeln(OutFile,'<tr>');
writeln(OutFile,'<td><img src="',Mkr,'Tit1.jpg" alt="" /></td>');
writeln(OutFile,'<td>');
writeln(OutFile,'<h3>IMGCOLOR.exe</h3>');
writeln(OutFile,'</td>');
writeln(OutFile,'</tr>');
{ paper file }
PaperFilename := InFileRoot+'_pap.bmp';
if PaperImg then
begin
if FileExists(PaperFilename) then
begin
PaperImg := true;
AssignFile(PaperFile,PaperFilename);
writeln(OutFile,'<tr>');
writeln(OutFile,'<td valign="top" align="right">');
writeln(OutFile,'<small><b>paper</b></small> ');
writeln(OutFile,'</td>');
writeln(OutFile,'<td valign="top">');
writeln(OutFile,'paper file = ',PaperFilename,'<br /><br />');
Reset(PaperFile,128);
{ initialise for paper file }
InPtr := 128;
j := 0;
CharCount := 0;
PixCount := 0; LineCount := 1;
paperHmax := 0; paperHmin := 360;
paperSmax := 0; paperSmin := 100;
paperBmax := 0; paperBmin := 100;
Hue := 0; Sat := 0; Bri := 0;
{ blockread and process }
{ paper file }
repeat
if (InPtr=128) and not eof(PaperFile) then
begin
blockread(PaperFile,InBuffer,1);
InPtr := 0;
end;
if (CharCount=0) then
begin
ImgW := (InBuffer[19]+256*InBuffer[20]);
ImgW := ImgW+256*256*(InBuffer[17]+256*InBuffer[18]);
ImgH := (InBuffer[23]+256*InBuffer[24]);
ImgH := ImgH+256*256*(InBuffer[21]+256*InBuffer[22]);
InPtr := 54;
CharCount := 54;
PixCount := 0;
{ ignore the rest of the }
{ headers }
end;
InPtr := InPtr+1;
NumIn := InBuffer[InPtr];
CharCount := CharCount+1;
j := j+1;
if (PixCount>=ImgW) then
begin
if (((CharCount-54) mod 4)=0) then
begin
PixCount := 0;
j := 0;
LineCount := LineCount+1;
end;
end else begin
case j of
1: B := NumIn;
2: G := NumIn;
3: R := NumIn;
end;
{onenum := WrHex(NumIn);}
str(NumIn,onenum);
if (j=1) then numword := onenum
else numword := numword+' '+onenum;
{ end of triplet }
if (j=3) then
begin
HueOf(R,G,B,Hue,Sat,Bri);
PixCount := PixCount+1;
{ check for max and min }
if paperHmax<Hue then paperHmax := Hue;
if paperHmin>Hue then paperHmin := Hue;
if paperSmax<Sat then paperSmax := Sat;
if paperSmin>Sat then paperSmin := Sat;
if paperBmax<Bri then paperBmax := Bri;
if paperBmin>Bri then paperBmin := Bri;
{
if testing then
begin
if (CharCount<25) then
begin
write(OutFile,'pixel (',PixCount,',',LineCount);
writeln(OutFile,') bytes to ',CharCount,' = ',numword,'<br />');
end;
end;
}
j:= 0;
if (PixCount=ImgW) and (((CharCount-54) mod 4)=0) then
begin
PixCount := 0;
LineCount := LineCount+1;
end;
end;
end;
until (eof(PaperFile) and (InPtr=128));
writeln(OutFile,'</td>');
writeln(OutFile,'</tr>');
writeln(OutFile,'<tr>');
writeln(OutFile,'<td valign="top" align="right">');
writeln(OutFile,'<small><b>paper colour</b></small> ');
writeln(OutFile,'</td>');
writeln(OutFile,'<td valign="top">');
str(paperHmax,numword);
str(paperHmin,onenum);
writeln(OutFile,'Hue: max = ',numword,' min = ',onenum,'<br />');
str(paperSmax,numword);
str(paperSmin,onenum);
writeln(OutFile,'Saturation: max = ',numword,' min = ',onenum,'<br />');
str(paperBmax,numword);
str(paperBmin,onenum);
writeln(OutFile,'Brightness: max = ',numword,' min = ',onenum,'<br />');
writeln(OutFile,'Pixels roughly within these bounds are taken to ');
writeln(OutFile,'be ''paper'', their hues not counted.');
writeln(OutFile,'<br />');
writeln(OutFile,'</td>');
writeln(OutFile,'</tr>');
{ close paper file }
CloseFile(PaperFile);
end;
end else begin
PaperImg := false;
paperHmax := 0; paperHmin := 360;
paperSmax := 0; paperSmin := 100;
paperBmax := 0; paperBmin := 100;
end;
{ screen report lines }
Report.Lines.Add('');
Report.Lines.Add('IMGCOLOR.exe source data:-');
Report.Lines.Add('');
Report.Lines.Add('source file = '+SrcFile.Filename);
if PaperImg then
begin
Report.Lines.Add('');
Report.Lines.Add('paper file = '+PaperFilename);
end;
if not(CountLetters) then
begin
Report.Lines.Add('''lettering'' pixels, etc, not counted');
writeln(OutFile,'<tr>');
writeln(OutFile,'<td valign="top" align="right">');
writeln(OutFile,'<small><b>letters</b></small> ');
writeln(OutFile,'</td>');
writeln(OutFile,'<td valign="top">');
writeln(OutFile,'''lettering'' pixels not counted ');
writeln(OutFile,'ie Brightness less than ',BriMin,'.<br />');
writeln(OutFile,'Saturation less than ',SatMin,' not counted.<br />');
writeln(OutFile,'Hue counts weighted by Brightness*Saturation.<br />');
writeln(OutFile,'</td>');
writeln(OutFile,'</tr>');
end;
{ file report lines }
writeln(OutFile,'<tr>');
writeln(OutFile,'<td valign="top" align="right">');
writeln(OutFile,'<small><b>source</b></small> ');
writeln(OutFile,'</td>');
writeln(OutFile,'<td valign="top">');
writeln(OutFile,'Source data:-<br />');
writeln(OutFile,'source file:- <b>',SrcFile.Filename,'</b><br />');
writeln(OutFile,'</td>');
writeln(OutFile,'</tr>');
if testing then
begin
writeln(OutFile,'<tr>');
writeln(OutFile,'<td valign="top" align="right">');
writeln(OutFile,'header');
writeln(OutFile,'</td>');
writeln(OutFile,'<td valign="top">');
writeln(OutFile,'headers and start data:-<br />');
writeln(OutFile,'<br />');
end;
{ initialise values for }
{ main process }
InPtr := 128;
j := 0;
CharCount := 0;
PixCount := 0;
HueCount := 0;
PixelsCount := 0;
for i := 0 to 359 do
begin
{ ImgColor array holds }
{ 5 values for each Hue i }
{ 1 - sum of 'counted' pixels }
{ 2/3/4 - R/G/B values of Hue }
{ 5 - sum of 'discounted' pix }
ImgColor[i,1] := 0;
RGB(i/360,1.0,1.0,R,G,B);
ImgColor[i,2] := R;
ImgColor[i,3] := G;
ImgColor[i,4] := B;
ImgColor[i,5] := 0;
end;
R := 0; G := 0; B := 0;
Hue := 0; Sat := 0; Bri := 0;
{ blockread and process }
{ image file }
Report.Lines.Add('');
Report.Lines.Add('WAIT: the processing is long!');
repeat
if (InPtr=128) and not eof(InFile) then
begin
blockread(InFile,InBuffer,1);
InPtr := 0;
end;
if (CharCount=0) then
begin
ImgW := (InBuffer[19]+256*InBuffer[20]);
ImgW := ImgW+256*256*(InBuffer[17]+256*InBuffer[18]);
ImgH := (InBuffer[23]+256*InBuffer[24]);
ImgH := ImgW+256*256*(InBuffer[21]+256*InBuffer[22]);
InPtr := 54;
CharCount := 54;
PixCount := 0;
{ ignore the rest of the }
{ headers }
end;
if testing then
begin
writeln(OutFile,'<tr>');
writeln(OutFile,'<td valign="top" align="right">');
writeln(OutFile,'<small><b>image size</b></small> ');
writeln(OutFile,'</td>');
writeln(OutFile,'<td valign="top">');
writeln(OutFile,'image width = ',ImgW,'<br />');
writeln(OutFile,'image height = ',imgH,'<br />');
writeln(OutFile,'</td>');
writeln(OutFile,'</tr>');
end;
InPtr := InPtr+1;
NumIn := InBuffer[InPtr];
CharCount := CharCount+1;
j := j+1;
if (PixCount>=ImgW) then
begin
if (((CharCount-54) mod 4)=0) then
begin
PixCount := 0;
j := 0;
end;
end else begin
{ in data section of file }
{ j counts triplets of RGB }
{ values }
{ NB .bmp files are BGR order }
{ beware line end padding }
case j of
1: B := NumIn;
2: G := NumIn;
3: R := NumIn;
end;
{ number into string for }
{ reports }
onenum := WrHex(NumIn);
if (j=1) then numword := onenum
else numword := numword+onenum;
{ end of triplet }
if (j=3) then
begin
PixCount := PixCount+1;
PixelsCount := PixelsCount+1;
{
if testing then
begin
if (CharCount<104) then
writeln(OutFile,'chars to ',CharCount,' = ',numword,'<br />');
end;
}
j:= 0;
if (PixCount=ImgW) and (((CharCount-54) mod 4)=0) then
begin
PixCount := 0;
LineCount := LineCount+1;
end;
{ calculate Hue, Saturation, }
{ Brightness from RGB triplet }
Hue := 0; Sat := 0; Bri := 0;
HueOf(R, G, B, Hue, Sat, Bri);
{ if not paper colour }
if ( (Hue>paperHmax+HuePlus) or (Hue<paperHmin-HuePlus)
or (Sat>paperSmax+SatPlus) { or (Sat<paperSmin) }
{ or (Bri>paperBmax) } or (Bri<paperBmin-BriPlus)
or not(PaperImg) )
and
{ exclude dark ie letters etc }
( (Bri>BriMin)
or CountLetters )
and
{ exclude low saturation }
(Sat>SatMin) then
begin
{
if testing then
begin
if (PixelsCount<50) then
begin
writeln(OutFile,'<tr><td></td><td>');
writeln(OutFile,'R/G/B = ',R,' / ',G,' / ',B);
writeln(OutFile,' H/S/B = ',Hue,' / ',Sat,' / ',Bri,'<br />');
writeln(OutFile,'</td></tr>');
end;
end;
}
{ count tint Hue }
{ weighted by Sat and Bri }
ImgColor[Hue,1] := ImgColor[Hue,1]+1*(Sat/10)*(Bri/10);
HueCount := HueCount+1;
end else begin
{ count ?paper Hue }
{ weighted by Sat and Bri }
ImgColor[Hue,5] := ImgColor[Hue,5]+1*(Sat/10)*(Bri/10);
end;
end;
end;
until (eof(InFile) and (InPtr=128));
if testing then
begin
writeln(OutFile,'</td>');
writeln(OutFile,'</tr>');
end;
{ close source }
CloseFile(InFile);
{ reports }
{ histogram of tint counts }
{
writeln(OutFile,'<tr>');
writeln(OutFile,'<td valign="top" align="right">');
writeln(OutFile,'<small><b>histogram</b></small> ');
writeln(OutFile,'</td>');
writeln(OutFile,'<td valign="top">');
writeln(OutFile,'Histogram of hues in <b>',Mkr,'</b>:-<br />');
writeln(OutFile,'Hue, degrees / frequency as counted<br />');
writeln(OutFile,'<br />');
for i := 0 to 359 do
writeln(OutFile,'hue ',i,' = ',round(ImgColor[i,1]),'<br />');
writeln(OutFile,'<br /><br />');
writeln(OutFile,'total hues = ',HueCount,'<br />');
writeln(OutFile,'total pixels = ',PixelsCount,'<br />');
write(OutFile,'pixels ingnored = ');
writeln(OutFile,(PixelsCount-HueCount),'<br />');
writeln(OutFile,'<br /></td>');
writeln(OutFile,'</tr>');
}
{ scale frequencies to }
{ 1 to 100 }
j := 0;
for i := 0 to 359 do
if (j<round(ImgColor[i,1])) then j := round(ImgColor[i,1]);
ScalingRatio := j;
for i := 0 to 359 do
ImgColor[i,1] := round(100*ImgColor[i,1]/j);
j := 0;
for i := 0 to 359 do
if (j<round(ImgColor[i,5])) then j := round(ImgColor[i,5]);
ScalingRatio := round(j/ScalingRatio);
for i := 0 to 359 do
ImgColor[i,5] := round(100*ImgColor[i,5]/j);
{ tints colour chart }
writeln(OutFile,'<tr>');
writeln(OutFile,'<td valign="top" align="right">');
writeln(OutFile,'<small><b>tint colours</b></small> ');
writeln(OutFile,'</td>');
writeln(OutFile,'<td valign="top">');
writeln(OutFile,'Histogram of hues in <b>',Mkr,'</b>:-<br />');
writeln(OutFile,'<br />');
writeln(OutFile,'<br />');
writeln(OutFile,'<img src="',InFileRoot,'_col.bmp" ');
writeln(OutFile,'alt="Histogram of hues in image" ');
writeln(OutFile,'/><br />');
writeln(OutFile,'Hues 0-359 degrees <br />');
writeln(OutFile,'Frequency scaled 1 to 100<br />');
writeln(OutFile,'<br />');
writeln(OutFile,'</td>');
writeln(OutFile,'</tr>');
{ local maxima }
writeln(OutFile,'<tr>');
writeln(OutFile,'<td valign="top" align="right">');
writeln(OutFile,'<small><b>maxima?</b></small> ');
writeln(OutFile,'</td>');
writeln(OutFile,'<td valign="top">');
for i := 0 to 359 do
begin
{ if Hue frequency larger }
{ than values to left and }
{ to right }
{ with 2 levels of smoothing }
{ and more than 20 }
if (ImgColor[i,1]>20)
and ((ImgColor[i,1]
+ImgColor[(i+1) mod 360,1]
+imgColor[(i+2) mod 360,1])
>
(ImgColor[(i-3+360) mod 360,1]
+ImgColor[(i-2+360) mod 360,1]
+ImgColor[(i-1+360) mod 360,1]))
and ((ImgColor[(i-2+360) mod 360,1]
+ImgColor[(i-1+360) mod 360,1]
+ImgColor[i,1])
>
(ImgColor[(i+1) mod 360,1]
+ImgColor[(i+2) mod 360,1]
+ImgColor[(i+3) mod 360,1])) then
begin
str(i,PatFilename);
while (length(PatFilename)<3) do PatFilename := '0'+PatFilename;
PatFilename := InFileroot+'h'+PatFilename+'.bmp';
PatchImg(PatFilename,i);
writeln(OutFile,'<img src="',PatFilename,'" ');
writeln(OutFile,'alt="colour patch" /> ');
writeln(OutFile,'hue',i,'<br /><br />');
end;
end;
writeln(OutFile,'</td>');
writeln(OutFile,'</tr>');
{ ?paper colour chart }
writeln(OutFile,'<tr>');
writeln(OutFile,'<td valign="top" align="right">');
writeln(OutFile,'<small><b>paper colours</b></small> ');
writeln(OutFile,'</td>');
writeln(OutFile,'<td valign="top">');
writeln(OutFile,'Histogram of hues in <b>',Mkr,'</b>:-<br />');
writeln(OutFile,'<br />');
writeln(OutFile,'<br />');
writeln(OutFile,'<img src="',InFileRoot,'pcol.bmp" ');
writeln(OutFile,'alt="Histogram of hues in paper" ');
writeln(OutFile,'/><br />');
writeln(OutFile,'Hues 0-359 degrees <br />');
writeln(OutFile,'Frequency scaled 1 to 100<br />');
writeln(OutFile,'Scaled ',ScalingRatio,'x more than tints<br />');
writeln(OutFile,'<br />');
writeln(OutFile,'</td>');
writeln(OutFile,'</tr>');
writeln(OutFile,'</table>');
{ make colour chart of tints }
{ initialise }
ImgFilename := InFileRoot+'_col.bmp';
AssignFile(ImgFile,ImgFilename);
Rewrite(ImgFile,8);
for i := 1 to 8 do ImgBuffer[i] := 0;
ImgPtr := 0;
{ 2 headers }
ImgWrite(66); { 42 4D - 2 bytes }
ImgWrite(77);
ImgWrite(48); { file size 4 bytes }
ImgWrite(181);
ImgWrite(1);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(54); { offset }
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(40); { header size }
ImgWrite(0);
ImgWrite(0); { image width - 4 bytes }
ImgWrite(0);
ImgWrite(104);
ImgWrite(1);
ImgWrite(0); { image height - 4 bytes }
ImgWrite(0);
ImgWrite(105);
ImgWrite(0);
ImgWrite(0); { image planes }
ImgWrite(0);
ImgWrite(1);
ImgWrite(0);
ImgWrite(24); { bits per pixel }
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(18); { horizontal resolution }
ImgWrite(11);
ImgWrite(0);
ImgWrite(0);
ImgWrite(18); { vertical resolution }
ImgWrite(11);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
ImgPtr := 6;
for j := 1 to 2 do
begin
for i := 0 to 359 do
begin
ImgWrite(round(ImgColor[i,4]));
ImgWrite(round(ImgColor[i,3]));
ImgWrite(round(ImgColor[i,2]));
end;
end;
for i := 0 to 359 do
begin
ImgWrite(0);
ImgWrite(0);
ImgWrite(0);
end;
for j := 1 to 2 do
begin
for i := 0 to 359 do
begin
ImgWrite(221);
ImgWrite(255);
ImgWrite(255);
end;
end;
for j := 1 to 100 do
begin
for i := 0 to 359 do
begin
{ .bmp in BGR order }
if (ImgColor[i,1]<j) then
begin
ImgWrite(221);
ImgWrite(255);
ImgWrite(255);
end else begin
ImgWrite(round(ImgColor[i,4]));
ImgWrite(round(ImgColor[i,3]));
ImgWrite(round(ImgColor[i,2]));
end;
{ NB no padding needed }
end;
end;
{ make colour chart of ?paper }
{ initialise }
PapFilename := InFileRoot+'pcol.bmp';
AssignFile(PapFile,PapFilename);
Rewrite(PapFile,8);
for i := 1 to 8 do PapBuffer[i] := 0;
PapPtr := 0;
{ 2 headers }
PapWrite(66); { 42 4D - 2 bytes }
PapWrite(77);
PapWrite(48); { file size 4 bytes }
PapWrite(181);
PapWrite(1);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(54); { offset }
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(40); { header size }
PapWrite(0);
PapWrite(0); { image width - 4 bytes }
PapWrite(0);
PapWrite(104);
PapWrite(1);
PapWrite(0); { image height - 4 bytes }
PapWrite(0);
PapWrite(105);
PapWrite(0);
PapWrite(0); { image planes }
PapWrite(0);
PapWrite(1);
PapWrite(0);
PapWrite(24); { bits per pixel }
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(18); { horizontal resolution }
PapWrite(11);
PapWrite(0);
PapWrite(0);
PapWrite(18); { vertical resolution }
PapWrite(11);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapWrite(0);
PapPtr := 6;
for j := 1 to 2 do
begin
for i := 0 to 359 do
begin
PapWrite(round(ImgColor[i,4]));
PapWrite(round(ImgColor[i,3]));
PapWrite(round(ImgColor[i,2]));
end;
end;
for i := 0 to 359 do
begin
PapWrite(0);
PapWrite(0);
PapWrite(0);
end;
for j := 1 to 2 do
begin
for i := 0 to 359 do
begin
PapWrite(221);
PapWrite(255);
PapWrite(255);
end;
end;
for j := 1 to 100 do
begin
for i := 0 to 359 do
begin
{ .bmp in BGR order }
if (ImgColor[i,5]<j) then
begin
PapWrite(221);
PapWrite(255);
PapWrite(255);
end else begin
PapWrite(round(ImgColor[i,4]));
PapWrite(round(ImgColor[i,3]));
PapWrite(round(ImgColor[i,2]));
end;
{ NB no padding needed }
end;
end;
{ close report files }
writeln(OutFile);
writeln(OutFile,'</body>');
writeln(OutFile,'</html>');
writeln(OutFile);
Flush(OutFile);
CloseFile(OutFile);
if (ImgPtr<>0) then
repeat ImgPtr := ImgPtr+1;
ImgWrite(0);
until (ImgPtr=0);
CloseFile(ImgFile);
if (PapPtr<>0) then
repeat PapPtr := PapPtr+1;
PapWrite(0);
until (PapPtr=0);
CloseFile(PapFile);
Report.Lines.Add('');
Report.Lines.Add('all done; results see'+OutFilename);
end;
end;
end.
|
