{$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.
more
