Category : Files from Magazines
Archive   : DDJ0691.ZIP
Filename : TELSCOPE.ASC

 
Output of file : TELSCOPE.ASC contained in archive : DDJ0691.ZIP

_CELESTIAL PROGRAMMING WITH TURBO PASCAL_
by Lars Frid-Neilson and Alex Lane


[LISTING ONE]

unit Video;
{*******************************************************}
interface
{*******************************************************}

{ Global constants }
CONST

{--- defaults for Supervision card setup }
Aport = $2F0; { first port on the card }
Bport = $2F1; { second port on the card }

{--- field control bytes }
fieldsync = $40; { new field! }
linesync = $41; { new line }
fldend = $42; { end of field }
rep1 = $80; { repeat x1 }
rep16 = $90; { repeat x16 }

{--- image structure }
maxbit = $3F; { bits used in pel }
maxpel = 255; { highest pel index }
maxline = 252; { highest line index }
maxbuffer = 32766; { highest "INT" index }

{ Global types }

TYPE
bitrng = 0..maxbit; { bit range }
pelrng = 0..maxpel; { pel indexes }
framerng = 0..maxline; { line indexes }
subrng = 0..maxbuffer; { raw data indexes }
pelrec = RECORD { one scan line }
syncL : BYTE;
pels : ARRAY[pelrng] OF BYTE;
END;
framerec = RECORD { complete binary field }
syncF : BYTE;
lines : ARRAY[framerng] OF pelrec;
syncE : BYTE;
END;
rawrec = ARRAY[subrng] OF INTEGER;
picptr = ^pictype; { picture ptr }
pictype = RECORD CASE INTEGER OF { picture formats}
0 : (fmt : framerec);
1 : (words : rawrec);
END;
histtype = ARRAY[bitrng] OF Word; { pel histograms }
regrec = RECORD CASE INTEGER OF
1 : (AX : INTEGER;
BX : INTEGER;
CX : INTEGER;
DX : INTEGER;
BP : INTEGER;
SI : INTEGER;
DI : INTEGER;
DS : INTEGER;
ES : INTEGER;
FLAGS : INTEGER);
2 : (AL,AH : BYTE;
BL,BH : BYTE;
CL,CH : BYTE;
DL,DH : BYTE);
END;
byteptr = ^BYTE; { general ptr }
strtype = STRING[255]; { strings }
Hextype = STRING[4];

{ Global functions and procedures }

PROCEDURE Add(pic1,pic2 : picptr);
PROCEDURE Subtract(pic1,pic2 : picptr);
PROCEDURE Mask(pic1,pic2 : picptr);
PROCEDURE Compare(pic1,pic2 : picptr);
PROCEDURE Offset(pic1 : picptr; newoffs : BYTE);
PROCEDURE Negoffset(pic1 : picptr; newoffs : BYTE);
PROCEDURE Multiply(pic1 : picptr; newscale : REAL);
PROCEDURE Threshold(pic1 : picptr; level : BYTE);
PROCEDURE Invert(pic1 : picptr);
PROCEDURE Filter1(pic1,pic2 : picptr);
PROCEDURE Edge(pic1,pic2 : picptr);
PROCEDURE Histogram(pic1 :picptr; VAR histo : histtype);
PROCEDURE PicSetup(VAR newpic : picptr);

function SavePicture(filespec : strtype; pic : picptr): integer;
function LoadPicture(filespec : strtype; pic : picptr): integer;

PROCEDURE SetSyncs(pic1 : picptr);
PROCEDURE Card;

function Capture: BOOLEAN;

PROCEDURE Scan(pic1 : picptr);

{*******************************************************}
implementation
{*******************************************************}

{ Do pic1 + pic2 into pic3 }
{ Sticks at maxbit }

PROCEDURE Add(pic1,pic2 : picptr);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }
pelval : INTEGER; { pel value }

BEGIN
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO BEGIN
pelval := pic1^.fmt.lines[lndx].pels[pndx] +
pic2^.fmt.lines[lndx].pels[pndx];
IF pelval > maxbit THEN
pic1^.fmt.lines[lndx].pels[pndx] := maxbit
ELSE
pic1^.fmt.lines[lndx].pels[pndx] := pelval;
END;
END;

{ Do pic1 - pic2 into pic3 }
{ Sticks at zero for pic1 < pic2 }

PROCEDURE Subtract(pic1,pic2 : picptr);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }

BEGIN
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO
IF pic1^.fmt.lines[lndx].pels[pndx] >=
pic2^.fmt.lines[lndx].pels[pndx]
THEN
pic1^.fmt.lines[lndx].pels[pndx] :=
pic1^.fmt.lines[lndx].pels[pndx] -
pic2^.fmt.lines[lndx].pels[pndx]
ELSE
pic1^.fmt.lines[lndx].pels[pndx] := 0;

END;

{ Do pic1 masked by pic2 into pic3 }
{ Only pic1 pels at non-zero pic2 pels go to pic3 }

PROCEDURE Mask(pic1,pic2 : picptr);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }

BEGIN
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO
IF pic2^.fmt.lines[lndx].pels[pndx] = 0 then
pic1^.fmt.lines[lndx].pels[pndx] := 0;
END;

{ Do Abs(pic1 - pic2) into pic3 }
{ Detects changes in images }

PROCEDURE Compare(pic1,pic2: picptr);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }

BEGIN
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO
pic1^.fmt.lines[lndx].pels[pndx] := Abs(
pic1^.fmt.lines[lndx].pels[pndx] -
pic2^.fmt.lines[lndx].pels[pndx]);

END;

{ Add a constant to pic1 }

PROCEDURE Offset(pic1 : picptr;
newoffs : BYTE);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }
pelval : INTEGER; { pel value }

BEGIN
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO BEGIN
pelval := newoffs + pic1^.fmt.lines[lndx].pels[pndx];
IF (pelval AND $FFC0) = 0 THEN
pic1^.fmt.lines[lndx].pels[pndx] := pelval
ELSE
pic1^.fmt.lines[lndx].pels[pndx] := maxbit;
END;
END;

{ subtract a value from a picture }

PROCEDURE Negoffset(pic1 : picptr;
newoffs : BYTE);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }
pelval : INTEGER; { pel value }

BEGIN
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO BEGIN
pelval := pic1^.fmt.lines[lndx].pels[pndx] - newoffs;
IF (pelval AND $FFC0) = 0 THEN
pic1^.fmt.lines[lndx].pels[pndx] := pelval
ELSE
pic1^.fmt.lines[lndx].pels[pndx] := maxbit;
END;
END;

{ Multiply pic1 by a value }
{ Sticks at maximum value }

PROCEDURE Multiply(pic1 : picptr; newscale : REAL);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }
pelval : INTEGER; { pel value }

BEGIN
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO BEGIN
pelval := Trunc(newscale * pic1^.fmt.lines[lndx].pels[pndx]);
IF (pelval AND $FFC0) = 0 THEN
pic1^.fmt.lines[lndx].pels[pndx] := pelval
ELSE
pic1^.fmt.lines[lndx].pels[pndx] := maxbit;
END;
END;

{ Threshold pic1 at a brightness level }

PROCEDURE Threshold(pic1 : picptr;
level : BYTE);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }

BEGIN
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO
IF pic1^.fmt.lines[lndx].pels[pndx] < level
THEN pic1^.fmt.lines[lndx].pels[pndx] := 0;
END;

{ Invert pel values }

PROCEDURE Invert(pic1 : picptr);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }

BEGIN
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO
pic1^.fmt.lines[lndx].pels[pndx] := maxbit AND
(NOT pic1^.fmt.lines[lndx].pels[pndx]);
END;

{ Filter by averaging vertical and horizontal neighbors }

PROCEDURE Filter1(pic1,pic2 : picptr);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }

BEGIN
FOR lndx := 1 TO (maxline-1) DO
FOR pndx := 1 TO (maxpel-1) DO
pic2^.fmt.lines[lndx].pels[pndx] :=
(pic1^.fmt.lines[lndx-1].pels[pndx] +
pic1^.fmt.lines[lndx+1].pels[pndx] +
pic1^.fmt.lines[lndx].pels[pndx-1] +
pic1^.fmt.lines[lndx].pels[pndx+1])
SHR 2;
END;

{ Edge detection }

PROCEDURE Edge(pic1,pic2 : picptr);
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }

BEGIN
FOR lndx := 1 TO (maxline-1) DO
FOR pndx := 1 TO (maxpel-1) DO
pic2^.fmt.lines[lndx].pels[pndx] :=
(Abs(pic1^.fmt.lines[lndx-1].pels[pndx] -
pic1^.fmt.lines[lndx+1].pels[pndx]) +
Abs(pic1^.fmt.lines[lndx].pels[pndx-1] -
pic1^.fmt.lines[lndx].pels[pndx+1]) +
Abs(pic1^.fmt.lines[lndx-1].pels[pndx-1] -
pic1^.fmt.lines[lndx+1].pels[pndx+1]) +
Abs(pic1^.fmt.lines[lndx+1].pels[pndx-1] -
pic1^.fmt.lines[lndx-1].pels[pndx+1]))
SHR 2;
END;

{ Compute intensity histogram for pic1 }

PROCEDURE Histogram(pic1 :picptr;
VAR histo : histtype);
VAR
hndx : bitrng; { histogram bin number }
lndx : framerng; { line number }
pndx : pelrng; { pel number }

BEGIN
FOR hndx := 0 TO maxbit DO { reset histogram }
histo[hndx] := 0;
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO
histo[pic1^.fmt.lines[lndx].pels[pndx]] :=
histo[pic1^.fmt.lines[lndx].pels[pndx]] + 1;
END;

{ Allocate and initialize the picture buffer }

PROCEDURE PicSetup(VAR newpic : picptr);
VAR
pels : pelrng;
lines : framerng;

BEGIN
IF newpic <> NIL { discard if allocated }
THEN Dispose(newpic);
New(newpic); { allocate new array }
END;

{ Save picture file on disk }
{ Uses the smallest number of blocks to fit the data }

function SavePicture(filespec : strtype; pic : picptr): integer;
VAR
ndx : subrng; { index into word array }
rndx : REAL; { real equivalent }
nblocks : INTEGER; { number of disk blocks }
xfered : INTEGER; { number actually done }
pfile : FILE; { untyped file for I/O }
RtnCode : integer;

BEGIN
RtnCode := 0;
Assign(pfile,filespec);
Rewrite(pfile);
ndx := 0; { start with first word }
WHILE (ndx < maxbuffer) AND { WHILE not end of pic }
(Lo(pic^.words[ndx]) <> fldend) AND
(Hi(pic^.words[ndx]) <> fldend) DO
ndx := ndx + 1;

ndx := ndx + 1; { fix 0 origin }

rndx := 2.0 * ndx; { allow >32K numbers... }
nblocks := ndx DIV 64; { 64 words = 128 bytes }
IF (ndx MOD 64) <> 0 { partial block? }
THEN nblocks := nblocks + 1;
rndx := 128.0 * nblocks; { actual file size }
BlockWrite(pfile,pic^.words[0],nblocks,xfered);

IF xfered <> nblocks then RtnCode := IOresult;
SavePicture := IOresult;
Close(pfile);
END;

{ Load picture file from disk }

function LoadPicture(filespec : strtype;
pic : picptr): integer;
var
picfile : FILE OF pictype;
RtnCode : integer;

BEGIN
Assign(picfile,filespec);
{$I- turn off I/O checking }
Reset(picfile);
RtnCode := IOresult;
{$I+ turn on I/O checking again }
IF RtnCode = 0 then
begin
{$I- turn off I/O checking }
Read(picfile,pic^); { this does the read }
RtnCode := IOresult;
{$I+ turn on I/O checking again }

{ IF NOT (IOresult IN [0,$99]) then
RtnCode := -1;}
RtnCode := 0;
end;
LoadPicture := RtnCode;
end;

{ Set up frame and line syncs in a buffer }
{ This should be done only in freshly allocated buffers }

PROCEDURE SetSyncs(pic1 : picptr);
VAR
lndx : framerng; { index into lines }

BEGIN
pic1^.fmt.syncF := fieldsync; { set up empty picture }

FOR lndx := 0 TO maxline DO BEGIN
pic1^.fmt.lines[lndx].syncL := linesync;
FillChar(pic1^.fmt.lines[lndx].pels[0],maxpel+1,0);
END;

pic1^.fmt.syncE := fldend; { set ending control }
END;

{ Test for the Supervisor card }
PROCEDURE Card;
var test: byte;

Begin
writeln ('testing for vgrab card');
Port[Bport] := 0; { reset the output lines }
Port[Aport] := 0;
test := Port[Aport]; { look for the card }
if (test and $0C0) = 0 then Begin
Port[Aport] := $03;
test := Port[Aport];
if (test and $0C0) <> $0C0 then
writeln ('No Supervision card found');
end;
Port[Bport] := 0; { reset the address lines}
end;

{ Capture routine for the Supervisor card }
function Capture: BOOLEAN;
var
TimeOut : integer;
Begin
Port[Bport] := 0; { reset everything }

Port[Aport] := $03; { start the capture }
TimeOut := 15000;
while ((Port[Aport] and $0C0) = $0C0) and (TimeOut > 0) do
TimeOut := pred(TimeOut);

Port[Bport] := 0; { reset everything }
Capture := TimeOut <> 0;
end;

{ Scan data routine for the Supervisor card }
PROCEDURE Scan(pic1 : picptr);

(*
VAR
lndx : framerng; { line number }
pndx : pelrng; { pel number }
*)

BEGIN

(* This is the original pascal code:
=================================

Port[Bport] := 0; { reset everything }
FOR lndx := 0 TO maxline DO
FOR pndx := 0 TO maxpel DO Begin
pic1^.fmt.lines[lndx].pels[pndx]
:= (Port[Aport] and $3F);
Port[Aport] := $02; { next address }
Port[Aport] := 0; { idle the lines }
end;

Port[Bport] := 0; { reset everything }

Now replaced by the following assembler code:
============================================= *)

asm
mov dx,2F1H
xor al,al
out dx,al
mov bx,maxline
les di,pic1
inc di (* skip syncF byte *)
cld
mov dx,2F0H
@ReadBoard: mov cx,maxpel+1
inc di (* skip syncL *)
@ReadLine: in al,dx
and al,3FH
stosb
mov al,2
out dx,al
xor al,al
out dx,al
loop @ReadLine
dec bx
jnz @ReadBoard
mov dx,2F1H
xor al,al
out dx,al
end
end;

{*******************************************************}

end.



[LISTING TWO

{$X+,S-}
{$M 16384,8192,655360}
uses
Crt, Dos, Objects, Drivers, Memory, Views, Menus,
StdDlg, MsgBox, App, Video, Vga, Dialogs;

const
cmFOpen = 1000;
cmFSave = 1001;
cmFSaveAs = 1002;
cmExpMon = 2000;
cmExpInteg = 2001;
cmExpGrab = 2002;
cmMrgCompare = 3000;
cmMrgAdd = 3001;
cmMrgSub = 3002;
cmMrgMask = 3003;
cmProEdge = 4000;
cmProFilter = 4001;
cmProHist = 4002;
cmProMult = 4003;
cmProInvert = 4004;
cmProOffset = 4005;
cmProThreshold = 4006;
cmDisplay = 5000;
cmOptVga = 6000;
cmOptAutoD = 6001;
cmOptPhotoS = 6002;

VgaHiResTxt : TMenuStr ='~V~GA HiRes ';
AutoDisplayTxt: TMenuStr ='~A~uto Display ';
PhotoModeTxt :TMenuStr ='~P~hoto session ';
OnTxt : string[4] =' On';
OffTxt : string[4] ='Off';

type
pHistoView = ^HistoView;
HistoView = object(TView)
histo : histtype;
constructor Init(Bounds: TRect);
procedure Draw; virtual;
procedure Update(Picture : picptr);
end;

pHistoWindow = ^HistoWindow;

HistoWindow = object(TWindow)
HistoView: pHistoView;
constructor Init;
end;

pCCDpgm = ^CCDpgm;
CCDpgm = object(TApplication)
CurPicture: PicPtr;
CurFileName: PathStr;
PictureDirty: boolean;
HistoGram: pHistoWindow;
procedure FileOpen(WildCard: PathStr);
procedure FileSave;
procedure FileSaveAs(WildCard: PathStr);
procedure DisplayImage;
procedure InitMenuBar; virtual;
procedure HandleEvent(var Event: TEvent); virtual;
procedure InitStatusLine; virtual;
procedure SetMenuItem(Item: string; Value: boolean);
procedure UpdateHistoGram;
end;

var
CCD: CCDpgm;

procedure GraphicsStart;
begin
DoneSysError;
DoneEvents;
DoneVideo;
DoneMemory;
end;

procedure GraphicsStop;
begin
InitMemory;
TextMode(3);
InitVideo;
InitEvents;
InitSysError;
Application^.Redraw;
end;

function TypeInDialog(var S: PathStr; Title:string):boolean;
var
D: PDialog;
Control: PView;
R: TRect;
Result:Word;
begin
R.Assign(0, 0, 30, 7);
D := New(PDialog, Init(R, Title));
with D^ do
begin
Options := Options or ofCentered;
R.Assign(5, 2, 25, 3);
Control := New(PInputLine, Init(R, sizeof(PathStr)-1));
Insert(Control);
R.Assign(3, 4, 15, 6);
Insert(New(PButton, Init(R, 'O~K~', cmOk, bfDefault)));
Inc(R.A.X, 12); Inc(R.B.X, 12);
Insert(New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)));
SelectNext(False);
end;
D := PDialog(Application^.ValidView(D));
if D <> nil then
begin
Result := DeskTop^.ExecView(D);
if (Result <> cmCancel) then D^.GetData(S);
Dispose(D, Done);
end;
TypeInDialog := Result <> cmCancel;
end;

constructor HistoWindow.Init;
var
R:TRect;
begin
R.Assign(0, 0, 68,21);
TWindow.Init(R, 'Histogram', 0);
Palette := wpCyanWindow;
GetExtent(R);
Flags := Flags and not (wfZoom + wfGrow); { Not resizeable }
GrowMode := 0;
R.Grow(-1, -1);
HistoView := New(pHistoView, Init(R));
Insert(HistoView);
end;

constructor HistoView.Init(Bounds: TRect);
begin
TView.Init(Bounds);
Update(CCD.CurPicture);
end;

procedure HistoView.Update(Picture : picptr);
begin
Histogram(Picture,histo);
DrawView;
end;

procedure HistoView.Draw;
const
barchar = $DB; { display char for bar }
halfbar = $DC; { half length bar }
maxbar = 16; { length of longest bar }

var
x,y : Integer;
binID : Integer;
maxval : Word; { the largest bin value }
maxval1 : Word; { the next largest bin }
barbase : Word; { bottom of bar }
barmid : Word; { middle of bar }
barstep : Word; { height of steps }
halfstep : Word; { half of barstep }
barctr : Integer; { character within bar }

begin
TView.Draw;
maxval := 1; { find largest value }
maxval1 := maxval;
binID := 0;
for binID := 0 to maxbit do
begin
if histo[binID] > maxval then
begin { new all-time high? }
maxval1 := maxval; { save previous high }
maxval := histo[binID]; { set new high }
end
else if histo[binID] > maxval1 then { 2nd highest? }
maxval1 := histo[binID];
end;

barstep := maxval1 div maxbar; { steps between lines }
halfstep := barstep div 2; { half of one step }
y := 0;

for barctr := maxbar downto 1 do
begin { down bars }
barbase := Trunc(barstep * barctr);
barmid := barbase + halfstep;
x := 1;
for binID := 0 TO maxbit do { for each bin }
begin
if histo[binID] > barmid then
WriteChar(x,y,Chr(barchar),7,1)
else if histo[binID] > barbase then
WriteChar(x,y,Chr(halfbar),7,1)
else WriteChar(x,y,'_',7,1);
x := succ(x);
end;
y := succ(y); { new line }
end;

for binID := 0 to maxbit do { fill in bottom }
if histo[binID] > halfstep then
WriteChar(binID+1,y,Chr(barchar),7,1)
else if histo[binID] > 0 then
WriteChar(binID+1,y,Chr(halfbar),7,1)
else WriteChar(binID+1,y,'_',7,1);

y := succ(y);
x := 1;
WriteStr(x,y, '0 1 2 3 ' +
'4 5 6 ',7);
y :=succ(y);
WriteStr(x,y,'0123456789012345678901234567890123456789' +
'012345678901234567890123',7);
end;

procedure CCDpgm.InitMenuBar;
var
R: TRect;
begin
GetExtent(R);
R.B.Y := R.A.Y+1;
MenuBar := New(PMenuBar, Init(R, NewMenu(
NewSubMenu('~F~ile', 0, NewMenu(
NewItem('~O~pen ...', 'F3', kbF3, cmFOpen, 0,
NewItem('~S~ave', 'F2', kbF2, cmFSave, 0,
NewItem('Save ~A~s ...', '', kbNoKey, cmFSaveAs, 0,
NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, 0, nil))))),
NewSubMenu('~E~xpose', 0, NewMenu(
NewItem('~M~onitor','F9', kbF9, cmExpMon, 0,
NewItem('~I~ntegrated Exposure ...', 'F10', kbF10, cmExpInteg, 0,
NewItem('~G~rab', 'Shift-F9', kbShiftF9, cmExpGrab, 0,nil)))),
NewSubMenu('~M~erge', 0, NewMenu(
NewItem('~C~ompare Images ...','', kbNoKey, cmMrgCompare, 0,
NewItem('~A~dd Images ...', '', kbNoKey, cmMrgAdd, 0,
NewItem('~S~ubtract Images ...', '', kbNoKey, cmMrgSub, 0,
NewItem('~M~ask Images ...', '', kbNoKey, cmMrgMask, 0,nil))))),
NewSubMenu('~P~rocess', 0, NewMenu(
NewItem('~E~dge Enhance','', kbNoKey, cmProEdge, 0,
NewItem('~F~ilter', '', kbNoKey, cmProFilter, 0,
NewItem('~H~istogram', '', kbNoKey, cmProHist, 0,
NewItem('~M~ultiply ...', '', kbNoKey, cmProMult, 0,
NewItem('~I~nvert', '', kbNoKey, cmProInvert, 0,
NewItem('~O~ffset', '', kbNoKey, cmProOffset, 0,
NewItem('~T~hreshold ...', '', kbNoKey, cmProThreshold, 0,nil)))))))),
NewItem('~D~isplay', '', kbShiftF10, cmDisplay, 0,
NewSubMenu('~O~ptions', 0, NewMenu(
NewItem(VgaHiResTxt,'', kbNoKey, cmOptVga, 0,
NewItem(AutoDisplayTxt, '', kbNoKey, cmOptAutoD, 0,
NewItem(PhotoModeTxt, '', kbNoKey, cmOptPhotoS, 0,nil)))),
nil)))))))));
end;

procedure CCDpgm.InitStatusLine;
var
R: TRect;
begin
GetExtent(R);
R.A.Y := R.B.Y - 1;
StatusLine := New(PStatusLine, Init(R,
NewStatusDef(0, $FFFF,
NewStatusKey('~F10~ Expose', kbF10, cmExpInteg,
NewStatusKey('~F9~ Monitor', kbF9, cmExpMon,
NewStatusKey('~ShiftF9~ Grab', kbShiftF9,cmExpGrab,
NewStatusKey('~F3~ Open', kbF3, cmFOpen,
NewStatusKey('~F2~ Save', kbF2, cmFSave,
NewStatusKey('~AltX~ Exit', kbAltX, cmQuit,
NewStatusKey('~ShiftF10~ Display', kbShiftF10, cmDisplay, nil))))))), nil)));
end;

procedure CCDpgm.FileSaveAs(WildCard: PathStr);
var
D: PFileDialog;
begin
D := New(PFileDialog, Init(WildCard, 'Save as',
'~N~ame', fdOkButton + fdHelpButton, 100));
D^.HelpCtx := 0;
if ValidView(D) <> nil then
begin
if Desktop^.ExecView(D) <> cmCancel then
begin
D^.GetFileName(CurFileName);
FileSave;
end;
Dispose(D, Done);
end;
end;

procedure CCDpgm.FileSave;
begin
if CurFileName[0] = chr(0) then
FileSaveAs('*.CCD')
else
begin
if SavePicture(CurFileName,CurPicture) <> 0 then
MessageBox('Can''t Save File!', nil, mfError + mfOkButton);
end;
end;

procedure CCDpgm.FileOpen(WildCard: PathStr);
var
D: PFileDialog;
wkPic: PicPtr;
begin
D := New(PFileDialog, Init(WildCard, 'Open a File',
'~N~ame', fdOpenButton + fdHelpButton, 100));
D^.HelpCtx := 0;
if ValidView(D) <> nil then
begin
if Desktop^.ExecView(D) <> cmCancel then
begin
D^.GetFileName(CurFileName);
PicSetup(CurPicture);
if LoadPicture(CurFileName,CurPicture) <> 0 then
MessageBox('Error Loading File!', nil, mfError + mfOkButton)
end;
Dispose(D, Done);
end;
end;

procedure CCDpgm.DisplayImage;
begin
GraphicsStart;
Display_Image(CurPicture);
ReadKey;
GraphicsStop;
end;

procedure CCDpgm.SetMenuItem(Item: string; Value: boolean);
var
mText : TMenuStr;

function SearchItem(pI : PMenuItem): boolean;
begin
if pI = NIL then
SearchItem := true
else if Pos(mText,pI^.Name^) <> 0 then
begin
SearchItem := false;
if Value then
pI^.Name^ := Concat(mText,OnTxt)
else
pI^.Name^ := Concat(mText,OffTxt)
end
else
SearchItem := SearchItem(pI^.Next);
end;

var
pI: PMenuItem;
begin
mText := Copy(Item,1,Length(Item)-3);
pI := MenuBar^.Menu^.Items;
while pI <> NIL DO
begin
if pI^.SubMenu <> NIL then
if not SearchItem(pI^.SubMenu^.Items) then
pI := Nil
else
pI := pI^.Next
else
pI := pI^.Next;
end;
end;

procedure NotImplemented;
begin
MessageBox('This command has not been implemented yet!', nil, mfError + mfOkButton);
end;

procedure CCDpgm.UpdateHistoGram;
begin
if (HistoGram <> NIL) and (CurPicture <> NIL) then
begin
HistoGram^.HistoView^.Update(CurPicture)
end;
end;

procedure CCDpgm.HandleEvent(var Event: TEvent);
var
wkStr: PathStr;
wkI,Result: integer;
DoAutoDisplay: boolean;
wkPicture: PicPtr;
resPicture: PicPtr;
begin
DoAutoDisplay := false;
TApplication.HandleEvent(Event);
case Event.What of
evCommand:
begin
case Event.Command of
cmFOpen: begin
FileOpen('*.CCD');
UpdateHistoGram;
DoAutoDisplay := true;
end;
cmFSave: FileSave;
cmFSaveAs: FileSaveAs('*.CCD');
cmExpMon: begin
GraphicsStart;
if not Continuous(CurPicture) then
begin
GraphicsStop;
MessageBox('Camera not responding!', nil, mfError + mfOkButton);
if CurPicture <> NIL then
begin
dispose(CurPicture);
CurPicture := NIL;
end;
end
else
GraphicsStop;
end;
cmExpInteg: NotImplemented;
cmExpGrab: begin
PicSetup(CurPicture);
SetSyncs(CurPicture);
if Capture then
Scan(CurPicture)
else
MessageBox('Camera not responding!', nil, mfError + mfOkButton);
end;
cmMrgCompare: if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else
begin
WkPicture := CurPicture;
CurPicture := NIL;
FileOpen('*.CCD');
Compare(WkPicture,CurPicture);
Dispose(CurPicture);
CurPicture:= WkPicture;
UpdateHistoGram;
DoAutoDisplay := true;
end;
cmMrgAdd: if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else
begin
WkPicture := CurPicture;
CurPicture := NIL;
FileOpen('*.CCD');
Add(WkPicture,CurPicture);
Dispose(CurPicture);
CurPicture:= WkPicture;
UpdateHistoGram;
DoAutoDisplay := true;
end;
cmMrgSub: if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else
begin
WkPicture := CurPicture;
CurPicture := NIL;
FileOpen('*.CCD');
Subtract(WkPicture,CurPicture);
Dispose(CurPicture);
CurPicture:= WkPicture;
UpdateHistoGram;
DoAutoDisplay := true;
end;
cmMrgMask: if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else
begin
WkPicture := CurPicture;
CurPicture := NIL;
FileOpen('*.CCD');
Mask(WkPicture,CurPicture);
Dispose(CurPicture);
CurPicture:= WkPicture;
UpdateHistoGram;
DoAutoDisplay := true;
end;
cmProEdge: begin
if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else
begin
wkPicture:= NIL; { get output array }
PicSetup(wkPicture);
SetSyncs(wkPicture);
Edge(CurPicture,wkPicture);
Dispose(CurPicture);
CurPicture:= wkPicture;
UpdateHistoGram;
DoAutoDisplay := true;
end;
end;
cmProFilter: begin
if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else
begin
wkPicture := NIL;
PicSetup(wkPicture);
SetSyncs(wkPicture);
Filter1(CurPicture,wkPicture);
Dispose(CurPicture);
CurPicture := wkPicture;
UpdateHistoGram;
DoAutoDisplay := true;
end;
end;
cmProHist: begin
if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else
begin
HistoGram := new(pHistoWindow,Init);
Desktop^.Insert(ValidView(HistoGram));
end
end;
cmProMult: if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else
begin
if TypeInDialog(wkStr,'Enter Mult Factor') then
begin
Val(wkStr,wkI,Result);
if Result = 0 then
Multiply(CurPicture,wkI);
DoAutoDisplay := true;
UpdateHistoGram;
end;
end;
cmProInvert: begin
if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else
begin
Invert(CurPicture);
DoAutoDisplay := true;
UpdateHistoGram;
end;
end;
cmProOffset: if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else if TypeInDialog(wkStr,'Enter Offset') then
begin
Val(wkStr,wkI,Result);
if Result = 0 then
begin
if (wkI<0) then
begin
wkI:= abs(wkI);
Negoffset(CurPicture,wkI);
end
else
Offset(CurPicture,wkI);
DoAutoDisplay := true;
UpdateHistoGram;
end;
end;
cmProThreshold: if (CurPicture = NIL) then
MessageBox('No picture!', nil, mfError + mfOkButton)
else if TypeInDialog(wkStr,'Enter Threshold') then
begin
Val(wkStr,wkI,Result);
if Result = 0 then
Threshold(CurPicture,wkI);
DoAutoDisplay := true;
UpdateHistoGram;
end;
cmDisplay: DisplayImage;
cmOptVga: begin
VGAhiRes := not VGAhiRes;
SetMenuItem(VgaHiResTxt,VGAhiRes);
end;
cmOptAutoD: begin
AutoDisplay := not AutoDisplay;
SetMenuItem(AutoDisplayTxt,AutoDisplay);
end;
cmOptPhotoS: begin
PhotoMode := not PhotoMode;
SetMenuItem(PhotoModeTxt,PhotoMode);
end;
else
Exit;
end;
ClearEvent(Event);
if DoAutoDisplay and AutoDisplay then
DisplayImage;
end;
end;
end;

begin
CCD.Init;
CCD.CurPicture := NIL;
CCD.CurFileName := '';
CCD.SetMenuItem(VgaHiResTxt,False);
CCD.SetMenuItem(AutoDisplayTxt,False);
CCD.SetMenuItem(PhotoModeTxt,False);
VGAhiRes := FALSE;
AutoDisplay := FALSE;
PhotoMode := FALSE;
CCD.Run;
CCD.Done;
end.


[LISTING THREE]

unit Vga;
{*******************************************************}

interface
USES Video, DOS, CRT;
var
VGAhiRes: boolean;
AutoDisplay: boolean;
PhotoMode: boolean;

Procedure Display_Image(pic1: PicPtr);
function Continuous(var pic1: PicPtr): boolean;

implementation

{--- Sets the VGA display planes }
Procedure Set_Plane (plane : byte);

var old : byte;

begin
Port[$01CE] := $0B2; { plane select mask }
old := (Port[$01CF] and $0E1); { get the old plane value }
Port[$01CE] := $0B2; { plane select mask }
Port[$01CF] := ((plane shl 1) or old); { new plane register value }

end;

procedure DisplayInVgaMode(pic1: PicPtr);
begin
(*
col := 32;
for row := 0 to 200 do
begin
Move(pic1^.fmt.lines[row].pels[0],MEM[$A000:col],256);
col := col + 320;
end;
*)
asm
push ds
lds si,pic1
inc si (*Sync1*)
mov bx,201
mov ax,0A000H
mov es,ax
mov di,32
cld
@LineLoop: inc si (*SyncL*)
mov cx,128
rep movsw
add di,320-256
dec bx
jne @LineLoop
pop ds
end;
end;

{--- Show picture on VGA in 320x200x256 or }
{ 640x400x256 color mode }
Procedure Display_Image(pic1: PicPtr);

var
r : registers; { BIOS interface regs }
row,col : INTEGER; { Screen coordinates }
Vmode : char;
shade : byte;
mode, i : integer;
plane : byte;

const
VideoInt : byte = $10;
Set_DAC_Reg : integer = $1010;

begin
if VGAhiRes then
begin
r.AX := ($00 SHL 8) OR $61;
Intr(VideoInt,r); { set 640x400x256 color mode}
mode := 1;
end
else
begin
r.AX := ($00 SHL 8) OR $13;
Intr(VideoInt,r); { set 320x200x256 color mode}
mode := 0;
end;
for shade := 0 to 63 do
begin
r.ax := Set_DAC_Reg;
r.bx := shade;
r.ch := shade;
r.cl := shade;
r.dh := shade;
INTR(VideoInt,r);
end;
if mode = 0 then
begin
DisplayInVgaMode(pic1);
end
else
begin
for row := 0 to 102 do
begin
col := row * 640;
Move(pic1^.fmt.lines[row].pels[0],MEM[$A000:col],256);
end;
plane := 1;
Set_Plane ( plane );
for row := 103 to 204 do
begin
col := (row - 103) * 640 + 384;
Move(pic1^.fmt.lines[row].pels[0],MEM[$A000:col],256);
end;
plane := 2;
Set_Plane ( plane );
for row := 205 to 240 do
begin
col := (row - 205) * 640 + 128;
Move(pic1^.fmt.lines[row].pels[0],MEM[$A000:col],256);
end;
end;
end;

function Continuous(var pic1: PicPtr): boolean;
var
r : registers; { BIOS interface regs }
row,col : INTEGER; { Screen coordinates }
Vmode : char;
shade : byte;
cont : boolean;
CONST
VideoInt : byte = $10;
Set_DAC_Reg : integer = $1010;

begin
PicSetup(pic1); { set up even picture array }
SetSyncs(pic1);

r.AX := ($00 SHL 8) OR $13;
Intr(VideoInt,r); { set 320x200x256 color mode }

FOR shade := 0 to 63 do begin { set VGA to gray scale }
r.ax := Set_DAC_Reg;
r.bx := shade;
r.ch := shade;
r.cl := shade;
r.dh := shade;
INTR(VideoInt,r);
End;
repeat
if capture then
begin
scan(pic1);
DisplayInVgaMode(pic1);
Cont := true;
end
else
Cont := false;
until not Cont or KeyPressed;
Continuous := Cont;
END;
end.