include "scanfile.s7i";
include "bytedata.s7i";
include "draw.s7i";
include "keybd.s7i";
include "pixelimage.s7i";
const string: PBM_ASCII_MAGIC is "P1";
const string: PBM_BINARY_MAGIC is "P4";
const proc: readPbmAsciiImage (inout pixelImage: image,
in integer: height, in integer: width, inout file: pbmFile) is func
local
const pixel: whitePixel is rgbPixel(65535, 65535, 65535);
var integer: line is 0;
var integer: column is 0;
var char: ch is ' ';
begin
for line range 1 to height do
for column range 1 to width do
repeat
ch := getc(pbmFile);
until ch not in white_space_char;
if ch = '0' then
image[line][column] := whitePixel;
elsif ch <> '1' then
raise RANGE_ERROR;
end if;
end for;
end for;
end func;
const proc: readPbmBinaryImageLine (inout pixelArray: imageLine,
in integer: width, inout file: pbmFile) is func
local
const pixel: whitePixel is rgbPixel(65535, 65535, 65535);
var string: pixelData is "";
var integer: byteIndex is 1;
var integer: bitNumber is 7;
var integer: currentByte is 0;
var integer: column is 0;
begin
pixelData := gets(pbmFile, succ(pred(width) div 8));
currentByte := ord(pixelData[1]);
for column range 1 to width do
if not odd(currentByte >> bitNumber) then
imageLine[column] := whitePixel;
end if;
if bitNumber > 0 then
decr(bitNumber);
else
bitNumber := 7;
incr(byteIndex);
if byteIndex <= length(pixelData) then
currentByte := ord(pixelData[byteIndex]);
end if;
end if;
end for;
end func;
const proc: readPbmBinaryImage (inout pixelImage: image,
in integer: height, in integer: width, inout file: pbmFile) is func
local
var integer: line is 0;
begin
for line range 1 to height do
readPbmBinaryImageLine(image[line], width, pbmFile);
end for;
end func;
const func PRIMITIVE_WINDOW: readPbm (inout file: pbmFile) is func
result
var PRIMITIVE_WINDOW: pixmap is PRIMITIVE_WINDOW.value;
local
var string: magic is "";
var integer: width is 0;
var integer: height is 0;
var pixelImage: image is pixelImage.value;
begin
magic := gets(pbmFile, length(PBM_ASCII_MAGIC));
if magic = PBM_ASCII_MAGIC or magic = PBM_BINARY_MAGIC then
pbmFile.bufferChar := getc(pbmFile);
skipWhiteSpace(pbmFile);
while pbmFile.bufferChar = '#' do
skipLineComment(pbmFile);
pbmFile.bufferChar := getc(pbmFile);
skipWhiteSpace(pbmFile);
end while;
width := integer(getDigits(pbmFile));
skipWhiteSpace(pbmFile);
while pbmFile.bufferChar = '#' do
skipLineComment(pbmFile);
pbmFile.bufferChar := getc(pbmFile);
skipWhiteSpace(pbmFile);
end while;
height := integer(getDigits(pbmFile));
image := pixelImage[.. height] times
pixelArray[.. width] times pixel.value;
if magic = PBM_ASCII_MAGIC then
readPbmAsciiImage(image, height, width, pbmFile);
else
readPbmBinaryImage(image, height, width, pbmFile);
end if;
pixmap := getPixmap(image);
end if;
end func;
const func PRIMITIVE_WINDOW: readPbm (in string: pbmFileName) is func
result
var PRIMITIVE_WINDOW: pixmap is PRIMITIVE_WINDOW.value;
local
var file: pbmFile is STD_NULL;
begin
pbmFile := open(pbmFileName, "r");
if pbmFile <> STD_NULL then
pixmap := readPbm(pbmFile);
close(pbmFile);
end if;
end func;
const func string: str (in PRIMITIVE_WINDOW: pixmap, PBM) is func
result
var string: stri is PBM_BINARY_MAGIC;
local
var integer: height is 0;
var integer: width is 0;
var pixelImage: image is pixelImage.value;
var integer: line is 0;
var pixel: pix is pixel.value;
var color: col is color.value;
var integer: luminance is 0;
var integer: bitNumber is 0;
var integer: currentByte is 0;
begin
height := height(pixmap);
width := width(pixmap);
stri &:= "\n" <& width <& " " <& height <& "\n";
image := getPixelImage(pixmap);
for line range 1 to height do
currentByte := 0;
bitNumber := 7;
for pix range image[line] do
col := pixelToColor(pix);
luminance := round(0.299 * float(col.redLight) +
0.587 * float(col.greenLight) +
0.114 * float(col.blueLight));
if luminance < 32768 then
currentByte +:= 1 << bitNumber;
end if;
if bitNumber > 0 then
decr(bitNumber);
else
stri &:= chr(currentByte);
currentByte := 0;
bitNumber := 7;
end if;
end for;
if bitNumber <> 7 then
stri &:= chr(currentByte);
end if;
end for;
end func;
const proc: writePbm (in string: pbmFileName, in PRIMITIVE_WINDOW: pixmap) is func
local
var file: pbmFile is STD_NULL;
begin
pbmFile := open(pbmFileName, "w");
if pbmFile <> STD_NULL then
write(pbmFile, str(pixmap, PBM));
close(pbmFile);
end if;
end func;