_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.