Category : Science and Education
Archive   : AIMAY89.ZIP
Filename : AIBINA.PAS

{$R-} {Range checking off}
{$B+} {Boolean complete evaluation on}
{$S+} {Stack checking on}
{$I+} {I/O checking on}

Unit aiBINA;

Interface

Uses
DOS, CRT, aiglob,
GLOBUNIT, JWINUNIT,
Grafunit;

Type
Mtype = array[1..6] of string;

Var
Menux,
Menu1,
Menu2 : Mtype;


procedure HistogramStretch(Var hx,lx : byte);
procedure HistogramEqual;
Procedure Digitlocate(var xdig,ydig,butdig,errdig : integer);
Procedure SetUpMenu;
Function ChooseMenu(MenuData,x,y:byte):byte;
Procedure DisplayMenu(DoAll:boolean);
Procedure SetSubMenu1;
Procedure SetSubMenu2;
Procedure DisplaySubMenu1(Doall:boolean);
Procedure DisplaySubMenu2(DoAll:boolean);
Procedure ZapMwindow;
Function AskWindow:boolean;
function Askwindow2:boolean;
Procedure Fixit;
Procedure MakeAnotherWindow;
Procedure Message1;
procedure Message2;
procedure Message3;
Procedure Message4;
Procedure Message6;
Procedure Message7;
Procedure Message8;
{===========================================================================}

Implementation

{$F+}
procedure DigitLocate(var XDig,YDig,ButDig,ErrDig : integer);
{===============================================================}
var
M1,M2,M3,M4 : Integer;

procedure Mouse(var M1,M2,M3,M4 : Integer);

begin
with Reg do begin
AX := M1; { Set up ax,bx,cx,dx for interrupt }
BX := M2;
CX := M3;
DX := M4;
end;
Intr(51,Reg); { Trip interrupt 51 }
with Reg do begin
M1 := AX;
M2 := BX;
M3 := CX;
M4 := DX
end
end; { of procedure Mouse }

begin { procedure DigitLocate }
if keypressed then;
M1 := 3; { Get Mouse Button Status }
Mouse(M1,M2,M3,M4);
ButDig := M2;
case ButDig of
0 : ButDig := 0;
1 : ButDig := 1;
2 : ButDig := 3;
3 : ButDig := 3;
4 : ButDig := 2;
5 : ButDig := 3;
6 : ButDig := 3;
7 : ButDig := 3;
end;

M1 := 11; { Read Mouse Motion Counters }
{Mouse(M1,M2,M3,M4);}
if M3 > 1000 then M3 := M3 - 65536;
XDig := XDig + M3;
if XDig < 0 then XDig := 0;
if XDig > 511 then XDig := 511;
if M4 > 1000 then M4 := M4 - 65536;
YDig := YDig + M4;
if YDig < 0 then YDig := 0;
if YDig > 511 then YDig := 511;
ErrDig := 0;
(*
if (CorrectforShading = TRUE) then
begin
CorrectforShading := FALSE;
NewShadingCorrect;
end;
*)
end; { of procedure DigitLocate }
{$F-}


procedure SelectLUTMode(i : integer);
{ ++++++++++++++++++++++++++++++++++++++++++++++++++ }
var Temp : byte;
begin

{$IFDEF PCVISION}
Temp := Port[ConLow] and $F9; {1111 1001}
case i of
0 : Port[ConLow] := Temp + 6; { input : ---- -11- }
1 : Port[ConLow] := Temp; { red : ---- -00- }
2 : Port[ConLow] := Temp + 2; { green : ---- -01- }
3 : Port[ConLow] := Temp + 4; { blue : ---- -10- }
end;
{$ENDIF}

{$IFDEF PCPLUS}
Temp := Port[LUTControl] and $FC; {1111 1100}
case i of
0 : Port[LUTControl] := Temp + 3; { input : ---- --11 }
1 : Port[LUTControl] := Temp; { red : ---- --00 }
2 : Port[LUTControl] := Temp + 1; { green : ---- --01 }
3 : Port[LUTControl] := Temp + 2; { blue : ---- --10 }
end;
{$ENDIF}
end;

procedure SelectInpLUT(i : integer);
{ ++++++++++++++++++++++++++++++++++++++++++++++++++ }
var Temp : byte;
begin

{$IFDEF PCVISION}
Temp := Port[ConLow] and $3F; {0011 1111}
case i of
0 : Port[ConLow] := Temp; {0: 00-- ---- }
1 : Port[ConLow] := Temp + $40; {1: 01-- ---- }
2 : Port[ConLow] := Temp + $80; {2: 10-- ---- }
3 : Port[ConLow] := Temp + $C0; {3: 11-- ---- }
end;
{$ENDIF}

{$IFDEF PCPLUS}
Temp := Port[LUTControl] and $E3; {1110 0011}
case i of
0 : Port[LUTControl] := Temp; {0: ---0 00-- }
1 : Port[LUTControl] := Temp + $04; {1: ---0 01-- }
2 : Port[LUTControl] := Temp + $08; {2: ---0 10-- }
3 : Port[LUTControl] := Temp + $0C; {3: ---0 11-- }
4 : Port[LUTControl] := Temp + $10; {4: ---1 00-- }
5 : Port[LUTControl] := Temp + $14; {5: ---1 01-- }
6 : Port[LUTControl] := Temp + $18; {6: ---1 10-- }
7 : Port[LUTControl] := Temp + $1C; {7: ---1 11-- }
end;
{$ENDIF}
end;

procedure SelectOutLUT(i : integer);
{ ++++++++++++++++++++++++++++++++++++++++++++++++++ }
var Temp : byte;
begin

{$IFDEF PCVISION}
Temp := Port[ConHigh] and $9F; {1001 1111}
case i of
0 : Port[ConHigh] := Temp; {0: -00- ---- }
1 : Port[ConHigh] := Temp + $20; {1: -01- ---- }
2 : Port[ConHigh] := Temp + $40; {2: -10- ---- }
3 : Port[ConHigh] := Temp + $60; {3: -11- ---- }
end;
{$ENDIF}

{$IFDEF PCPLUS}
Temp := Port[LUTControl] and $1F; {0001 1111}
case i of
0 : Port[LUTControl] := Temp; {0: 000- ---- }
1 : Port[LUTControl] := Temp + $20; {1: 001- ---- }
2 : Port[LUTControl] := Temp + $40; {2: 010- ---- }
3 : Port[LUTControl] := Temp + $60; {3: 011- ---- }
4 : Port[LUTControl] := Temp + $80; {4: 100- ---- }
5 : Port[LUTControl] := Temp + $A0; {5: 101- ---- }
6 : Port[LUTControl] := Temp + $C0; {6: 110- ---- }
7 : Port[LUTControl] := Temp + $E0; {7: 111- ---- }
end;
{$ENDIF}

end;


Procedure StretchLUT;
{++++++++++++++++++++++}
Var M : real;
B,
ValueA : integer;

Begin

b := StretchLow; { intercept }
if StretchHigh = StretchLow then StretchHigh := StretchHigh + 1;
m := 255 / (StretchHigh - StretchLow); { slope }

SelectOutLUT(1); { LUT 1 = for overlay }
for i := 1 to 3 do
begin
SelectLUTMode(i); { select R, G, and B output LUTs }
for ValueA := 0 to 255 do
begin
Port[LUTAddress] := ValueA;
if ((ValueA and 1) = 1) then {if Bit 0 = on}
case i of
1 : Port[LUTData] := 255;
2 : Port[LUTData] := 0;
3 : Port[LUTData] := 0; {draw overlay in red}
end {case}
else if (ValueA <= StretchLow) then Port[LUTData] := 0
else if (ValueA >= StretchHigh) then Port[LUTData] := 254
else Port[LUTData] := (round(m*(ValueA - b)) and $FE);
end;
end;

end;{end procedure stretchlut}



Procedure FindLowHigh(VAR LowVal,HighVal : integer);
{+++++++++++++++++++++++++++++++++++++++++++++++++++++}
Var Offset : word;
x,
y : word;
Temp : integer;
Block,
Blocktemp : word;
i : byte;
done : boolean;

Begin

for Temp := 0 to 255 do
GLHistogram[Temp] := 0;

Lowval := 255;
Highval := 0;

For Block := 0 to 3 do

begin

{$IFDEF PCPLUS}
Blocktemp := Port[Control] and $1F;
Case Block of
0 : Port[Control] := blocktemp;
1 : Port[Control] := blocktemp + $20;
2 : Port[Control] := blocktemp + $40;
3 : Port[Control] := blocktemp + $60;
end;

For Y := 0 to 31 do
For X := 15 to 127 do
Begin
Offset := 2048*y + (4*x);
{$ENDIF}
{$IFDEF PCVISION}
Port[FBB0] := Block;

For Y := 0 to 63 do
For X := 15 to 63 do
Begin
Offset := 1024*y + (4*x);
{$ENDIF}

Temp := Mem[MemBase : Offset];
{$IFDEF PCPLUS}
If NOT((block = 3) and (offset >= 49152)) then
{$ENDIF}
{$IFDEF PCVISION}
If NOT(((Block = 2) or (Block = 3)) and (Y > 223)) then
{$ENDIF}
begin
GLHistogram[Temp] := GLHistogram[Temp] + 1;

end;

end;{loop}

end;{block loop}
done := FALSE;
i := 1;
repeat
if GLHistogram[i] > 40 then
begin
done := TRUE;
LowVal := i;
end
else if i = 255 then
done := TRUE;
i := i + 1;
until done;
done := FALSE;
i := 255;
repeat
if GLHistogram[i] > 40 then
begin
done := TRUE;
HighVal := i;
end
else if i = 0 then
done := TRUE;
i := i - 1;
until done;

end;{end procedure}


Procedure SetUpMenu;
begin
SetNoCursor;
menux[1] := 'Pixel Finder ';
menux[2] := 'Set Up Parameters ';
menux[3] := 'Auto Scan ';
menux[4] := 'Manual Fill ';
menux[5] := 'Manual Erase ';
menux[6] := 'Exit ';
end;

Procedure SetSubMenu1;
begin
Menu1[1] := 'Store Shading ';
Menu1[2] := 'Shading Correct ';
Menu1[3] := 'Set Critical Data ';
Menu1[4] := 'Histogram Stretch ';
Menu1[5] := 'World Interface ';
Menu1[6] := 'Exit ';
end;

Procedure SetSubMenu2;
begin
Menu2[1] := 'Display Data ';
Menu2[2] := 'Learn Mode ';
Menu2[3] := 'Initialize ';
Menu2[4] := 'Report to Printer ';
Menu2[5] := 'Set Scan Box ';
Menu2[6] := 'Exit ';
end;

Procedure DisplayMenu(DoAll:boolean);
Var i : byte;
begin
If Doall then
begin
Makewindow2;
end;
For i := 1 to 6 do
Writetopage(menux[i],attr(lightred,blue),0,8+i,34);
end;

Procedure DisplaySubMenu1(DoAll:boolean);
Var i : byte;
begin
If DoAll then
Makewindow1;
For i := 1 to 6 do
Writetopage(menu1[i],attr(lightred,blue),0,7+i,30);
end;

Procedure MakeAnotherWindow;
begin
scanpage;
createwindow(11,30,8,40,blue,cyan,lightgreen,black);
end;

Procedure DisplaySubMenu2(DoAll:boolean);
Var i : byte;
begin
If doAll then
MakeAnotherwindow;

If LearnMode then
Menu2[2] := 'Learn Mode ON '
else
Menu2[2] := 'Learn Mode OFF ';
For i := 1 to 6 do
writetoPage(menu2[i],attr(blue,cyan),0,10+i,40);
end;

Procedure Message1;
begin
Explode(' ',14,36,blue,cyan,10);
Explode(' Mark the Largest Cell ',14,36,blue,cyan,10);
end;

Procedure Message2;
begin
Explode(' ',14,36,blue,cyan,10);
Explode(' Mark the Smallest Cell ',14,36,blue,cyan,10);
end;

Procedure Message3;
begin
Explode(' ',14,36,blue,cyan,10);
Explode('Mark the Brightest Clear Cell',14,36,blue,cyan,10);
end;

Procedure Message4;
begin
Explode(' ',14,36,blue,cyan,10);
Explode(' Mark the Darkest Clear Cell ',14,36,blue,cyan,10);
end;

Procedure Message6;
begin
Explode(' ',14,36,blue,cyan,10);
Explode(' Please add cell of interest ',14,36,blue,cyan,10);
end;

Procedure Message7;
begin
Explode(' ',14,36,blue,cyan,10);
Explode(' check nucleolus shading ',14,36,blue,cyan,10);
end;

Procedure Message8;
begin
Explode(' ',14,36,blue,cyan,10);
Explode('1 if overshded,2 if undershad',14,36,blue,cyan,10);
end;

Function GetOption(Ydig : integer):word;
begin
If Ydig < 85 then
GetOption := 1
else if Ydig < 170 then
GetOption := 2
else if Ydig < 255 then
GetOption := 3
else if Ydig < 340 then
GetOption := 4
else if Ydig < 425 then
GetOption := 5
else
GetOption := 6;
end;{end GetOption}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

Function ChooseMenu(MenuData,x,y:byte):byte;
Var Choice,
Last : byte;
Mdata : Mtype;
colorx : byte;
colorf : byte;
Begin

Choice := 3;
Last := 4;

If MenuData = 0 then
begin
colorx := blue;
colorf := lightred;
Mdata := Menux;
end
else if Menudata = 1 then
begin
colorx := blue;
colorf := lightred;
Mdata := Menu1;
end
else if Menudata = 2 then
begin
colorx := cyan;
colorf := blue;
Mdata := Menu2;
end;


Repeat

repeat
If Choice <> Last then
begin
Writetopage(mData[choice],attr(lightgreen,colorx),0,y+choice,x);
Writetopage(mData[last],attr(colorf,colorx),0,y+last,x);
Last := Choice;
end;
butdig := 0;
DigitLocate(xdig,ydig,butdig,errdig);
Choice := GetOption(Ydig);
until (butdig <> 0);

Until ((Butdig = 1) or (ButDig = 2));

ChooseMenu := Last;

end;



Procedure ZapMWindow;
begin
zapwindow;
end;

Function Askwindow:boolean;
Var ch : char;
done : boolean;

begin
zoomeffect := true;
blinkeffect := false;
zoomdelay := 20;
shadoweffect := right;
borderstyle := mixed;
scanpage;
createwindow(14,37,6,35,lightgray,magenta,green,black);
Explode('Is this acceptable? (y/n)',16,42,lightgray,magenta,10);
done := FALSE;
Repeat
ch := readkey;
If (ch = 'y') or (ch = 'Y') then
begin
Done := TRUE;
AskWindow := TRUE;
end
else if (ch = 'n') or (ch = 'N') then
begin
Done := TRUE;
Askwindow := FALSE;
end;
Until Done;
Zapwindow;
end;

Function Askwindow2:boolean;
Var ch : char;
done : boolean;

begin
zoomeffect := true;
blinkeffect := false;
zoomdelay := 20;
shadoweffect := right;
borderstyle := mixed;
scanpage;
createwindow(14,37,6,35,lightgray,magenta,green,black);
Explode('Want to add an area? (y/n)',16,42,lightgray,magenta,10);
done := FALSE;
Repeat
ch := readkey;
If (ch = 'y') or (ch = 'Y') then
begin
Done := TRUE;
AskWindow2 := TRUE;
end
else if (ch = 'n') or (ch = 'N') then
begin
Done := TRUE;
Askwindow2 := FALSE;
end;
Until Done;
Zapwindow;
end;


procedure HistogramStretch(Var hx,lx: byte);
{ ++++++++MOD 6/29/88 for AI++++++++++++++++++++++++++++++++++++++ }
var i,x,y,yy : integer;

begin
setnocursor;
StretchLow := 0;
StretchHigh := 255;
MakeWindow1;
Gotoxy(34,11);
Writeln('Please Wait');
if ((hx = 255) and (lx = 0)) then
FindLowHigh(Stretchlow,StretchHigh)
else
begin
stretchlow := lx;
stretchhigh := hx;
end;
Beep;
UnMakeWindow1;

MakeScreenWindow;
DrawHistogram(GLHistogram);
SetThresholds;
textbackground(black);

UnMakeScreenWindow;
repeat
DigitLocate(XDig,YDig,ButDig,ErrDig)
until (ButDig = 0);
end;

Procedure fixit;
begin
stretchlow := 0;
stretchhigh := 255;
stretchlut;
end;

Procedure HistogramEqual;
{+++++++++++++++++++++++++}
Begin

MakeWindow1;
Gotoxy(34,11);
Writeln('Please Wait');
FindLowHigh(Stretchlow,StretchHigh);
Beep;
StretchLUT;
UnMakeWindow1;

end;{end procedure HistogramEqual}




End.