Category : Pascal Source Code
Archive   : CAMERA.ZIP
Filename : CAMERA.PAS
uses dos, crt, Keyboard, Paradise, DIO48_Def, Update,
CameraBit, Camera_Interrupt;
const
ClrExt = '.CLR';
Max_Color = 15;
Max_X = 127;
Max_Y = 127;
Offset_X = 160;
Offset_Y = 120;
PicExt = '.PIC';
type
ColorMapEntry = record
ColorSelect : word;
Max_Allowed : word;
end;
var
ColorFile : text;
ColorMap : array [1..Max_Color] of ColorMapEntry;
Filename : string [24];
Picture : array [0..Max_X, 0..Max_Y] of word;
SaveMode : integer;
Scale_X : integer;
Scale_Y : integer;
Size_X : integer;
Size_Y : integer;
procedure WriteBlock (Color, Col, Row : integer);
var
I,J : integer;
OffX, OffY : integer;
begin
OffX := Offset_X + Col * Scale_X;
OffY := Offset_Y + Row * Scale_Y;
for I := 0 to pred (Scale_X) do begin
for J := 0 to pred (Scale_Y) do begin
WriteDot (Color, OffX+I, OffY+J);
if Data_Ready then exit;
end;
end;
end;
procedure SetPalettes;
var
I : integer;
begin
for I := 1 to 15 do begin
SetPalette (I, ColorMap [I].ColorSelect);
end;
end;
procedure AdjustColors;
const
SizeX = 80 div 8;
SizeY = 8;
TextX = 8;
TextY = 16;
var
C : word;
CursorX : integer;
CursorY : integer;
I,J : integer;
Ltr : char;
Save : boolean;
procedure SetCursor (C : integer);
begin
CursorX := (80 div 8) * (C mod 8)+1;
CursorY := 10 * (C div 8) + 3;
end;
procedure DrawSquare (C : integer);
const
SquareX = 32;
SquareY = SquareX;
var
X,Y : integer;
begin
SetCursor (C);
for Y := 1 to SquareY do begin
for X := 1 to SquareX do begin
WriteDot (C, CursorX*TextX + X, CursorY*TextY + Y);
end; {for X}
end; {for Y}
end;
begin
SetMode (Paradise_Graph_640x480);
SetPalettes;
for I := 1 to 15 do begin
DrawSquare (I);
gotoxy (CursorX, CursorY-2);
write (ColorMap [I].Max_Allowed:5);
end; {for I}
gotoxy (1,21);
writeln ('Use
writeln ('Use
writeln ('Use
writeln ('Press
write ('Press
I := 1;
SetCursor (I);
gotoxy (CursorX+2, CursorY-1);
write ('*');
repeat
with ColorMap [I] do begin
gotoxy (37,17);
write ('rgbRGB');
gotoxy (30,18);
write ('Color: ');
C := ColorSelect;
for J := 1 to 6 do begin
if (C and $20) = 0 then write ('0') else write ('1');
C := C shl 1;
end;
Ltr := readkey;
case Ltr of
#00 :
begin
Ltr := readkey;
case Ltr of
K2 :
begin
if ColorSelect > 1 then begin
ColorSelect := pred (ColorSelect);
SetPalette (I, ColorSelect);
end;
end;
K3 :
begin
if ColorSelect > 8 then begin
ColorSelect := ColorSelect - 8;
SetPalette (I, ColorSelect);
end;
end;
K4 :
begin
gotoxy (CursorX+2, CursorY-1);
write (' ');
if I > 1 then begin
I := pred (I);
end else begin
I := 15;
end;
SetCursor (I);
gotoxy (CursorX+2, CursorY-1);
write ('*');
end;
K6 :
begin
gotoxy (CursorX+2, CursorY-1);
write (' ');
if I < 15 then begin
I := succ (I);
end else begin
I := 1;
end;
SetCursor (I);
gotoxy (CursorX+2, CursorY-1);
write ('*');
end;
K8 :
begin
if ColorSelect < 63 then begin
ColorSelect := succ (ColorSelect);
SetPalette (I, ColorSelect);
end;
end;
K9 :
begin
if ColorSelect < 56 then begin
ColorSelect := ColorSelect + 8;
SetPalette (I, ColorSelect);
end;
end;
end; {2nd case}
Ltr := ' ';
end; {case #00}
CR :
begin
gotoxy (30,19);
write ('Limit: ');
UpdateWord (Max_Allowed);
gotoxy (30,19);
write (' ');
gotoxy (CursorX, CursorY-2);
writeln (Max_Allowed:5);
end;
else {1st case}
Ltr := upcase (Ltr);
end; {1st case}
end; {with}
until Ltr = ESC;
SetMode (SaveMode);
write ('Save colors settings to a file? ');
Save := true;
UpdateBoolean (Save, yn);
if Save then begin
write ('What file name? ');
readln (Filename);
{$I-}
assign (ColorFile, Filename + ClrExt);
rewrite (ColorFile);
for I := 1 to 15 do begin
with ColorMap [I] do begin
writeln (ColorFile, ColorSelect:4, Max_Allowed:8);
end;
end;
close (ColorFile);
{$I+}
if ioresult <> 0 then begin
writeln ('Error writing color file. Disk full?');
end;
end;
end;
procedure GetColors (Default : boolean);
var
X,Y : integer;
begin
{$I-}
if Default then begin
assign (ColorFile, 'COLORS'+ClrExt);
end else begin
write ('What file name? ');
readln (Filename);
assign (ColorFile, Filename + ClrExt);
end;
reset (ColorFile);
for X := 1 to Max_Color do begin
with ColorMap [X] do begin
readln (ColorFile, ColorSelect, Max_Allowed);
writeln (ColorSelect:2, Max_Allowed:8);
end;
end;
{$I+}
if ioresult = 0 then begin
writeln ('Color file loaded.');
end else begin
writeln ('Color file not found.');
if Default then begin
writeln ('Setting default colors.');
for X := 1 to Max_Color do begin
with ColorMap [X] do begin
ColorSelect := X;
Max_Allowed := X;
end;
end;
end else begin
writeln ('Colors not changed.');
end;
end;
end;
function MappedColor (X : word) : word;
var
I : word;
begin
for I := 1 to Max_Color do begin
with ColorMap [I] do begin
if X <= Max_Allowed then begin
MappedColor := I;
exit;
end;
end;
end; {for}
MappedColor := Max_Color;
end;
procedure Scale;
begin
write ('New X scaling ');
UpdateInteger (Scale_X);
write ('New Y scaling ');
UpdateInteger (Scale_Y);
end;
procedure Paint;
var
Index_X : integer;
Index_Y : integer;
Ltr : char;
begin
SetMode (Paradise_Graph_640x480);
SetPalettes;
for Index_Y := 0 to Size_Y do begin
for Index_X := 0 to Size_X do begin
WriteBlock (MappedColor (Picture [Index_X,Index_Y]),
Index_X, Index_Y);
end;
end;
writeln ('Press any key to continue.');
Ltr := readkey;
SetMode (SaveMode);
end;
procedure LoadData;
var
Index_X : integer;
Index_Y : integer;
PicFile : file;
Result : word;
begin
{$I-}
write ('Input file name? ');
readln (FileName);
assign (PicFile, FileName + PicExt);
reset (PicFile, 2);
blockread (PicFile, Size_X, 1, Result);
blockread (PicFile, Size_Y, 1, Result);
Size_X := pred (Size_X);
Size_Y := pred (Size_Y);
for Index_Y := 0 to Size_Y do begin
for Index_X := 0 to Size_X do begin
blockread (PicFile, Picture [Index_X,Index_Y], 1, Result);
end;
end;
close (PicFile);
{$I+}
if ioresult = 0 then begin
writeln ('Load complete.');
end else begin
writeln ('Error loading picture. File not found? ');
end;
end;
procedure SaveData;
var
Index_X : integer;
Index_Y : integer;
PicFile : file;
Result : word;
begin
{$I-}
write ('Output file name? ');
readln (FileName);
assign (PicFile, FileName + PicExt);
rewrite (PicFile, 2);
Size_X := succ (Size_X);
Size_Y := succ (Size_Y);
blockwrite (PicFile, Size_X, 1, Result);
blockwrite (PicFile, Size_Y, 1, Result);
Size_X := pred (Size_X);
Size_Y := pred (Size_Y);
for Index_Y := 0 to Size_Y do begin
for Index_X := 0 to Size_X do begin
blockwrite (PicFile, Picture [Index_X,Index_Y], 1, Result);
end;
end;
close (PicFile);
{$I+}
if ioresult = 0 then begin
writeln ('Save complete.');
end else begin
writeln ('File write error. Disk full? ');
end;
end;
procedure Collect;
var
Index1,Index2 : integer;
Index_X : integer;
Index_Y : integer;
Index_Z : word;
Ltr : char;
begin
SetMode (Paradise_Graph_640x480);
SetPalettes;
Size_X := 0;
Size_Y := 0;
Index1 := 1;
for Index_X := 0 to Max_X do begin
for Index_Y := 0 to Max_Y do begin
Picture [Index_X, Index_Y] := 0;
end;
end;
StartCount;
repeat
if Data_Ready then begin
Receive (Index_X, Index_Y, Index_Z);
if (Index_X in [0..Max_X]) and
(Index_Y in [0..Max_Y]) then begin
Index_Z := -Index_Z;
Picture [Index_X, Index_Y] := Index_Z;
if Index_X > Size_X then Size_X := Index_X;
if Index_Y > Size_Y then Size_Y := Index_Y;
WriteBlock (MappedColor (Index_Z), Index_X, Index_Y);
gotoxy (1,1);
writeln (Index_X:5, Index_Y:5, Index_Z:8);
end else begin
gotoxy (1,25);
write ('Out of bounds: ', Index_X:5, Index_Y:5, Index_Z:5);
end;
end;
Ltr := ' ';
if keypressed then begin
Ltr := upcase (readkey);
case Ltr of
^X : port [Port_F] := SetX;
^Y : port [Port_F] := SetY;
^Z :
begin
port [Port_F] := TestZ;
port [Port_F] := Operate;
end;
end;
end;
for Index2 := 1 to Index1 do begin
port [Port_F] := TestZ;
port [Port_F] := Operate;
end;
if (Index1 mod 16) = 0 then begin
port [Port_F] := SetY;
end else begin
port [Port_F] := SetX;
end;
Index1 := succ (Index1);
if Index1 > 241 then Ltr := ESC;
until Ltr = ESC;
SetMode (SaveMode);
SaveData;
end; {Collect}
var
Ltr : char;
begin {Main}
SaveMode := GetMode;
directvideo := false;
Scale_X := 1;
Scale_Y := 1;
GetColors (true);
repeat
writeln (CR,'Menu:');
writeln (' Adjust colors');
writeln (' Built in test');
writeln (' Collect data');
writeln (' Get colors');
writeln (' Load picture');
writeln (' Paint picture');
writeln (' Save data');
writeln (' Quit');
write ('Your choice? ');
Ltr := upcase (readkey);
writeln (Ltr, CR);
case Ltr of
'A' : AdjustColors;
'B' : BIT;
'C' : Collect;
'G' : GetColors (false);
'L' : LoadData;
'P' : Paint;
'S' : SaveData;
'X' : Scale;
end;
until Ltr = 'Q';
end.
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/