ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/AI_MAY89.ZIP/AIEDGE2.PAS

Pascal/Delphi Source File | 1988-10-04 | 54.4 KB | 1,717 lines

unit AiEdge2;

Interface

uses aiglob,bordunit,aimath,aiuser;

Var ProAddr : pointer;


Function IsItForeground(x,y:word;backgroundvalue:byte;distance:integer):boolean;
Function IsItBackground(x,y:word;backgroundvalue:byte;distance:integer):boolean;
Function IsItForegroundv(x,y:word;backgroundvalue:byte;distance:integer):boolean;
Function IsItBackgroundv(x,y:word;backgroundvalue:byte;distance:integer):boolean;
Procedure Erosion(x1,y1,x2,y2 : word);
Procedure Erosion2(x1,y1,x2,y2:word);

Function IntensityCheck(x,y:word;size:byte):boolean;
Function SpotContrast(x,y:word;nucsize:byte;Var goodifsmall:boolean):boolean;
Function ScanEdge(x1,y1,x2,y2:word):word;
Function FindArea(x1,y1,x2,y2:word;Var _fore,_std:double):word;
Procedure MakeDark(x1,y1,x2,y2:word);

Procedure SetAddress;
Procedure FillIn(x1,y1,x2,y2:word;small:boolean;
         nucsize:byte;observed:byte);
Procedure HowMuchFore(x,y:word;size:byte;Var AmtFore,_stdev:double);
Procedure EScan(x,y:word;Nucsize,Cv:byte;
            Var da,db:byte);
Function Mscan(x,y:word;size:byte;Var bstuff:double):byte;

Procedure LearnFromDeletion(Num:byte);
Procedure LearnFromAddition(x,y:word;Nucsize,Width,Height:byte;Mval:double);
Procedure HistoAnalysis(x,y:word;nucsize:byte;Var below:byte;
    var ku,stout,rx,rx2:double;Var CytCond,Abscyt : boolean);
Function ShellScan(x,y,nucsize:word;Uncertain:boolean;
                    Var goodifnucleolus:boolean):boolean;

Implementation

{These two routines are used by the four routines immediately below them.}

function digit(x,y:word):byte;
begin
  digit := oldgrayvalue(x,y);
end;

Procedure Setaddress;
begin
 proaddr := @digit;
end;

{The following functions, given (x,y), scan DISTANCE pixels to the right or
 left (depending on the sign) in order to determine how many consecutive
 pixels are above or below the backgroundvalue.  Two functions scan
 horizontally, the other two scan vertically.}

function isitbackground(x,y:word;backgroundvalue:byte;distance:integer):boolean;
begin
inline($8b/$4e/<distance/        {mov cx,distance}
       $83/$f9/$00/              {cmp cx,00}
       $74/$24/                  {jz dgd}
{again}$8b/$46/<x/               {mov ax,x}
       $03/$c1/                  {add ax,cx}
       $51/                      {push cx}
       $50/                      {push ax}
       $ff/$76/<y/               {push y}
       $ff/$16/proaddr/          {call digit}
       $59/                      {pop cx}
       $3a/$46/<backgroundvalue/ {cmp al,backgroundvalue}
       $72/$05/                  {jb dchk}
{nogd} $b3/$00/                  {mov bl,00}
       $eb/$0e/                  {jmp done}
       $90/
{dchk} $83/$f9/$00/              {cmp cx,+00}
       $7f/$03/                  {ja pos}
 {neg} $41/                      {inc cx}
       $eb/$da/                  {jmp again}
 {pos} $49/                      {dec cx}
       $eb/$d7/                  {jmp again}
 {dgd} $b3/$01/                  {mov bl,01}
 {done}$88/$5e/$ff);             {mov [bp-01],bl}
end;

function isitforeground(x,y:word;backgroundvalue:byte;distance:integer):boolean;
begin
inline($8b/$4e/<distance/        {mov cx,distance}
       $83/$f9/$00/              {cmp cx,00}
       $74/$24/                  {jz dgd}
{again}$8b/$46/<x/               {mov ax,x}
       $03/$c1/                  {add ax,cx}
       $51/                      {push cx}
       $50/                      {push ax}
       $ff/$76/<y/               {push y}
       $ff/$16/proaddr/               {call digit}
       $59/                      {pop cx}
       $3a/$46/<backgroundvalue/ {cmp al,backgroundvalue}
       $77/$05/                  {ja dchk}
{nogd} $b3/$00/                  {mov bl,00}
       $eb/$0e/                  {jmp done}
       $90/
{dchk} $83/$f9/$00/              {cmp cx,+00}
       $7f/$03/                  {ja pos}
 {neg} $41/                      {inc cx}
       $eb/$da/                  {jmp again}
 {pos} $49/                      {dec cx}
       $eb/$d7/                  {jmp again}
 {dgd} $b3/$01/                  {mov bl,01}
 {done}$88/$5e/$ff);             {mov [bp-01],bl}
end;


function isitbackgroundv(x,y:word;backgroundvalue:byte;distance:integer):boolean;
begin
inline($8b/$4e/<distance/        {mov cx,distance}
       $83/$f9/$00/              {cmp cx,00}
       $74/$24/                  {jz dgd}
{again}$8b/$46/<y/               {mov ax,y}
       $03/$c1/                  {add ax,cx}
       $51/                      {push cx}
       $ff/$76/<x/               {push x}
       $50/                      {push ax}
       $ff/$16/proaddr/          {call digit}
       $59/                      {pop cx}
       $3a/$46/<backgroundvalue/ {cmp al,backgroundvalue}
       $72/$05/                  {jb dchk}
{nogd} $b3/$00/                  {mov bl,00}
       $eb/$0e/                  {jmp done}
       $90/
{dchk} $83/$f9/$00/              {cmp cx,+00}
       $7f/$03/                  {ja pos}
 {neg} $41/                      {inc cx}
       $eb/$da/                  {jmp again}
 {pos} $49/                      {dec cx}
       $eb/$d7/                  {jmp again}
 {dgd} $b3/$01/                  {mov bl,01}
 {done}$88/$5e/$ff);             {mov [bp-01],bl}
end;

function isitforegroundv(x,y:word;backgroundvalue:byte;distance:integer):boolean;
begin
inline($8b/$4e/<distance/        {mov cx,distance}
       $83/$f9/$00/              {cmp cx,00}
       $74/$24/                  {jz dgd}
{again}$8b/$46/<y/               {mov ax,y}
       $03/$c1/                  {add ax,cx}
       $51/                      {push cx}
       $ff/$76/<x/               {push x}
       $50/                      {push ax}
       $ff/$16/proaddr/               {call digit}
       $59/                      {pop cx}
       $3a/$46/<backgroundvalue/ {cmp al,backgroundvalue}
       $77/$05/                  {ja dchk}
{nogd} $b3/$00/                  {mov bl,00}
       $eb/$0e/                  {jmp done}
       $90/
{dchk} $83/$f9/$00/              {cmp cx,+00}
       $7f/$03/                  {ja pos}
 {neg} $41/                      {inc cx}
       $eb/$da/                  {jmp again}
 {pos} $49/                      {dec cx}
       $eb/$d7/                  {jmp again}
 {dgd} $b3/$01/                  {mov bl,01}
 {done}$88/$5e/$ff);             {mov [bp-01],bl}
end;

{Find lone RED pixels}

Function Erode1(x,y : word):boolean;
begin
  Erode1 := TRUE;
  If (oldgrayvalue(x-1,y-1) and 1 = 1) or (oldgrayvalue(x,y-1) and 1 = 1) or
     (oldgrayvalue(x+1,y-1) and 1 = 1) or (oldgrayvalue(x-1,y) and 1 = 1) or
     (oldgrayvalue(x+1,y) and 1 = 1) or (oldgrayvalue(x-1,y+1) and 1 = 1) or
     (oldgrayvalue(x,y+1) and 1 = 1) or (oldgrayvalue(x+1,y+1) and 1 = 1) then
     Erode1 := FALSE;
end; {end function erode1}


{Erase single red dots}

Procedure Erosion(x1,y1,x2,y2 : word);
Var
    j,k : word;
begin
   newgrayvalue(1,1,oldgrayvalue(1,1));
   For k := y1 to y2 do
     for j := x1 to x2 do
       If (oldgrayvalue(j,k) and 1 = 1) and Erode1(j,k) then
     newgrayvalue(j,k,(oldgrayvalue(j,k) and $FE));
end; {end procedure erosion}

{Erase all red dots}

Procedure Erosion2(x1,y1,x2,y2 : word);
Var
    j,k : word;
begin
   newgrayvalue(1,1,oldgrayvalue(1,1));
   For k := y1 to y2 do
     for j := x1 to x2 do
       If (oldgrayvalue(j,k) and 1 = 1) then
     newgrayvalue(j,k,(oldgrayvalue(j,k) and $FE));
end; {end procedure erosion}

{This function scans within the region defined by (x1,y1,x2,y2) and
 counts the number of RED marks to calculate the area.  In addition,
 the routine calculates the average gray level and standard deviation
 of the shaded region.}

Function FindArea(x1,y1,x2,y2:word;Var _fore,_std:double):word;
Var j,k:word;
    area : word;
    gray1 : byte;
    count : word;
    imagdata : imagtype2;
begin
  area := 0;
  count := 0;
  For k := y1 to y2 do                {scan within box}
    for j := x1 to x2 do
    begin
      gray1 := oldgrayvalue(j,k);     {get value}
      If gray1 and 1 = 1 then         {is it RED?}
      begin
    area := area + 1;             {increment area count}
    If gray1 > lowdiv then        {is it part of nucleolus?}
    begin
      count := count+1;           {If not then use value to calculate   }
      imagdata[count] := gray1;   {Mean and StDev.  This helps to focus }
    end;                          {only values describing the nucleus.  }
      end;
  end;
  _fore := Mean(imagdata,1,count);
  _std := stdev(imagdata,1,count,_fore);
  FindArea := area;
end;{end function findarea}

{In this procedure we fill in the object by alternating between different
 erosion and dilating techniques.
 SMALL describes whether the main program thinks it is a big nucleus or
 a small one, and NUCSIZE is a value bigger than the largest Nucleus
 diameter and is used as a maximum scanning distance.}

Procedure FillIn(x1,y1,x2,y2:word;small:boolean;
         nucsize:byte;observed:byte);
Var
    j,k      : word;                      {general x,y counters}
    gray1    : byte;                      {gray level value}
    xa,ya    : word;                      {center coord}
    i,q,r    : word;                      {common variables}
    f        : integer;                   {used in erase routine}
    Highest,                              {high gray value}
    lowest   : byte;                      {low gray value}
    debug    : boolean;
    redcount :word;                       {used when counting red dots}
    leg      : word;                      {largest diagonal from center
                         to corner}
    imagdata : imagtype2;                 {used to find backgnd}
    count    : byte;
    _mean,_f : double;
    EraseMode: boolean;                   {used in erase routine}
    diagdist : byte;                      {used in erase routine}
    halfnuc,                              {size parameter of cell}
    hnuc     : byte;
    xhigh,                                {coordinates of brightest pixel}
    yhigh    : word;
    xpart,ypart,                          {width and height variables}
    backgnd,                              {background threshold}
    lowcount : byte;                      {amount of nucleolus}
    adjust,
    obs_adjust   : double;

begin
  {..............................scan for values....................}

    nucsize := round(1.1*nucsize);                  {get a larger value     }
    xa := (x1+x2) shr 1;                            {get center and diagonal}
    ya := (y1+y2) shr 1;                            {   to the corner       }
    leg := max(abs(xa-x1),abs(ya-y1));
    leg := round (sqrt( sqr(leg+1) + sqr(leg+1) ));
    diagdist := nucsize;
    debug := true;
    halfnuc := nucsize shr 1;                       {size up other variables}
    hnuc := round(halfnuc/2);
    If hnuc = 1 then
       hnuc := 2;

    highest := 0;                                  {find highest and lowest}
    lowest  := 255;                                {values within a sampled}
    count := 0;                                    {region as well as coords}
    lowcount := 0;                                 {of highest pixel value}
    for k := ya-(halfnuc shr 1) to ya+(halfnuc shr 1) do
    for j := xa-(halfnuc) to xa+(halfnuc) do
    begin
      gray1 := oldgrayvalue(j,k);
      count := count+1;
      imagdata[count] := gray1;
      If gray1 < lowdiv then
        lowcount := lowcount+1;
      if (gray1 > highest) then
      begin
        highest := gray1;
        xhigh := j;
        yhigh := k;
      end
      else if gray1 < lowest then
        lowest := gray1;
    end;

    highest := 0;                                  {move to highest region  }
    lowest  := 255;                                {and scan again for high }
    count := 0;                                    {and low values.         }
    for k := yhigh-(hnuc shr 1) to yhigh+(hnuc shr 1) do
    for j := xhigh-(hnuc shr 1) to xhigh+(hnuc shr 1) do
    begin
      gray1 := oldgrayvalue(j,k);
          If gray1 > lowdiv then
          begin
        count := count+1;
        imagdata[count] := gray1;
          end;
      if (gray1 > highest) then
        highest := gray1
      else if gray1 < lowest then
        lowest := gray1;
    end;
    _mean := mean(imagdata,1,count);               {compute a Mean gray level}

{...........................Determine background threshold.................}
    adjust := 0;
    obs_adjust := 1;

   If previous then
     backgnd := round( (0.85 + (observed*0.01))*_mean)
   else
     backgnd := round(0.85*_mean);
   lowdiv := 60;

   nucsize := round(nucsize/1.1);               {reset nucsize}
   xpart := round(0.95*nucsize);                {Make width shorter and }
   ypart := round(1.3*nucsize);                 {height longer since the }
                 {spot-scanner will probably start finding values}
                 {at the top of the nucleus.                     }

{........................................pass1...............................}
    for k := ya-nucsize to ya+ypart do           {scan horizontally}
      for j := xa-xpart to xa+xpart do           {If pixel is within bounds }
      begin                                      {and is in line with 3 other}
       gray1 := oldgrayvalue(j,k);               {pixels above backgnd value }
       if  (gray1 < 1.005*highest) and           {then shade RED (OR low bit)}
       (isitforeground(j,k,backgnd,4) or isitforeground(j,k,backgnd,-4))
    then
       newgrayvalue(j,k,oldgrayvalue(j,k) or 1);
       end;
{..............................pass2...................................}
    for j := xa-xpart to xa+xpart do             {scan vertically}
      for k := ya-nucsize to ya+ypart do
      begin
    gray1 := oldgrayvalue(j,k);
    if (gray1 < 1.005*highest) and
       (isitforegroundv(j,k,backgnd,4)  or isitforegroundv(j,k,backgnd,-4))
    or (gray1 < lowdiv) then
       newgrayvalue(j,k,gray1 or 1);
      end;

{-------------------------filter little stuff-------------------------------}

for k := ya-ypart to ya+ypart do
  for j := xa-xpart to xa+xpart do
    if (oldgrayvalue(j,k) and 1 = 1) then            {matrix 3x3}
    begin
      q := 0;
      for f := k-1 to k+1 do
    for r := j-1 to j+1 do
      if (oldgrayvalue(r,f) and 1 = 1) then
        q := q + 1;
      if q < 5 then
    newgrayvalue(j,k,oldgrayvalue(j,k) and $FE);
    end;
            {determine if shaded region after first
             filtering is within size limits          }

q := findarea(x1,y1,x2,y2,_f,_f);

If (q > minarea) and (q < 1.5*maxarea) then   {if area in limits}
begin
{-----------------------rebuild inside along both axis----------------------}
   newgrayvalue(1,1,1);
    for k := ya-nucsize to ya+nucsize do             {rebuild}
    begin
     for j := xa to xa+nucsize do
       if (oldgrayvalue(j+1,k) and 1 = 1) then
     newgrayvalue(j,k,(oldgrayvalue(j,k) or 1));
     j := xa;
     while (j >= xa-nucsize) do
     begin
       if (oldgrayvalue(j-1,k) and 1 = 1) then
     newgrayvalue(j,k,(oldgrayvalue(j,k) or 1));
       j := j - 1;
     end;
    end;{for k}

    newgrayvalue(1,1,1);

    for j := xa-nucsize to xa+nucsize do             {rebuild}
    begin
     for k := ya to ya+nucsize do
       if (oldgrayvalue(j,k+1) and 1 = 1) then
     newgrayvalue(j,k,(oldgrayvalue(j,k) or 1));
     k := ya;
     while (k >= ya-nucsize) do
     begin
       if (oldgrayvalue(j,k-1) and 1 = 1) then
     newgrayvalue(j,k,(oldgrayvalue(j,k) or 1));
       k := k - 1;
     end;
    end;{for j}

{These filters scan the UPPER and LOWER RIGHT and LEFT QUADRANTS.  The
 filter starts scaning from the center of the box.  If a nucleus exists then
 a round region should be shaded in the center. The cytoplasm, which is
 darker, should not be shaded except for some lightly stained regions.  The
 region between bordering cells may also be shaded because it is lighter.
 The routine scans line by line outward from the center, counting the number
 of unshaded regions.  If the gap is large enough then all pixels beyond that
 point on the same line are erased.  In theory, this will erase
 everything outside of the shaded nucleus.}


{------------------filter regions not connected to center region------------}

{first four scan for HORIZONTAL gaps}

k := ya;                             {erase nocontinuos segments}
while (k > ya-nucsize-2) do          {scan from center up}
begin
  redcount := 0;                     {no RED found yet}
  EraseMode := FALSE;                {do not erase pixels yet}
  for j := xa to xa+nucsize do       {scan from center to right, making this}
  begin                              {an UPPER RIGHT QUADRANT scan.}
    if EraseMode then                {If erase mode is set then erase RED}
       NewGrayvalue(j,k,Oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 <> 1 then  {else if NOT RED then up count}
       redcount := redcount+1;
    If Redcount > 3 then             {If less than three REDs have been found}
       EraseMode := TRUE;            {we must be in a gap so start erasing}
  end;
  k := k-1;                          {move up one line}
end;
k := ya;                             {reset to vertical center}
while (k > ya-nucsize-2) do          {scan UPPER LEFT QUADRANT}
begin
  redcount := 0;
  J := xa;
  erasemode := false;
  while (j > xa-nucsize) do
  begin
    if EraseMode then
       NewGrayvalue(j,k,Oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 <> 1 then
       redcount := redcount+1;
    If Redcount > 3 then
       EraseMode := TRUE;
    j := j-1;
  end;
  k := k-1;
end;
for k := ya to ya+nucsize+2 do       {scan LOWER QUADRANTS}
begin
  redcount := 0;
  erasemode := false;
  for j := xa to xa+nucsize do
  begin
    If EraseMode then
      NewGrayvalue(j,k,oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 <> 1 then
      redcount := redcount+1;
    If Redcount > 3 then
       EraseMode := TRUE;
  end;
end;
for k := ya to ya+nucsize+2 do
begin
  redcount := 0;
  erasemode := false;
  j := xa;
  while (j > xa-nucsize) do
  begin
    If EraseMode then
      NewGrayvalue(j,k,oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 <> 1 then
      redcount := redcount+1;
    If Redcount > 3 then
       EraseMode := TRUE;
    j := j-1;
  end;
end;

{these four scan for VERTICAL gaps}

j := xa;
while (j > xa-nucsize-2) do
begin
  redcount := 0;
  EraseMode := FALSE;
  for k := ya to ya+nucsize do
  begin
    if EraseMode then
       NewGrayvalue(j,k,Oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 <> 1 then
       redcount := redcount+1;
    If Redcount > 3 then
       EraseMode := TRUE;
  end;
  j := j-1;
end;
j := xa;
while (j > xa-nucsize-2) do
begin
  redcount := 0;
  k := ya;
  erasemode := false;
  while (k > ya-nucsize) do
  begin
    if EraseMode then
       NewGrayvalue(j,k,Oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 <> 1 then
       redcount := redcount+1;
    If Redcount > 3 then
       EraseMode := TRUE;
    k := k-1;
  end;
  j := j-1;
end;
for j := xa to xa+nucsize+2 do
begin
  redcount := 0;
  erasemode := false;
  for k := ya to ya+nucsize do
  begin
    If EraseMode then
      NewGrayvalue(j,k,oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 <> 1 then
      redcount := redcount+1;
    If Redcount > 3 then
       EraseMode := TRUE;
  end;
end;
for j := xa to xa+nucsize+2 do
begin
  redcount := 0;
  erasemode := false;
  k := ya;
  while (k > ya-nucsize) do
  begin
    If EraseMode then
      NewGrayvalue(j,k,oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 <> 1 then
      redcount := redcount+1;
    If Redcount > 3 then
       EraseMode := TRUE;
    k := k-1;
  end;
end;

{After the filtering above some unfiltered regions may still exits.  This
 pass filter attempts to remove these regions.  The filter is basically
 the same except now there are only UPPER and LOWER QUADRANTS.  A whole
 line is scanned.  If there are not enough red pixels on that line then
 all parallel lines above are erased.}

{---------filter again: erase segments not fully connected to center------}

k := ya;                             {erase nocontinuos segments}
EraseMode := FALSE;                  {first verticals}
nucsize := round(nucsize*1.5);
while (k > ya-nucsize-2) do          {scan up from center}
begin
  redcount := 0;
  for j := xa-nucsize to xa+nucsize do     {scan entire horizontal line}
    if EraseMode then
       NewGrayvalue(j,k,Oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 = 1 then
       redcount := redcount+1;
  If Redcount <= 3 then                     {If less than four REDs then }
    EraseMode := TRUE;                      {erase all lines parallel.   }
  k := k-1;
end;
EraseMode := FALSE;
for k := ya to ya+nucsize+2 do
begin
  redcount := 0;
  for j := xa-nucsize to xa+nucsize do
    If EraseMode then
      NewGrayvalue(j,k,oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 = 1 then
      redcount := redcount+1;
    If Redcount <= 3 then
       EraseMode := TRUE;
end;
j := xa;                             {now horizontals}
EraseMode := FALSE;
while (j > xa-nucsize-2) do
begin
  redcount := 0;
  for k := ya-nucsize to ya+nucsize do
    if EraseMode then
       NewGrayvalue(j,k,Oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 = 1 then
       redcount := redcount+1;
  If RedCount <= 3 then
    EraseMode := TRUE;
  j := j-1;
end;
EraseMode := FALSE;
for j := xa to xa+nucsize+2 do
begin
  redcount := 0;
  for k := ya-nucsize to ya+nucsize do
    If EraseMode then
      NewGrayvalue(j,k,oldgrayvalue(j,k) and $FE)
    else if oldgrayvalue(j,k) and 1 = 1 then
      Redcount := redcount+1;
    If RedCount <= 3 then
       EraseMode := TRUE;
end;

{........use a simple matrix filter again to remove small spots of RED......}

for k := ya-nucsize to ya+nucsize do
  for j := xa-nucsize to xa+nucsize do
    if (oldgrayvalue(j,k) and 1 = 1) then            {matrix 3x3}
    begin
      q := 0;
      for f := k-1 to k+1 do
    for r := j-1 to j+1 do
      if (oldgrayvalue(r,f) and 1 = 1) then
        q := q + 1;
      if q < 5 then
    newgrayvalue(j,k,oldgrayvalue(j,k) and $FE);
    end;

end;{end if findarea}
end;{end procedure FillIn}

{This is the first Unit called and is part of the Spot-Scanner.  If looks
 at three pixels and determines which is the brightest.  If it is above
 the lowest allowable value and below the highest the routine looks to
 see if there is a contasting region nearby.  If so then the value of
 TRUE is returned.  This is an ON/OFF unit.}

Function IntensityCheck(x,y:word;Size:byte):boolean;
Const Ratio = 1.05;                  {contrast ratio}
Var j,k:word;
    gray1,gray2 : byte;
    high,low : word;
    Rfactor,rf2  : double;
Begin
 high := 0;
 low := 255;
 IntensityCheck := false;            {get maximum brightness}
 gray1 := Max(oldgrayvalue(x,y),oldgrayvalue(x-1,y));
 gray1 := Max(gray1,oldgrayvalue(x+1,y));
                     {check if within bounds}
 If (gray1 > graystrike) then
 begin
   for j := x-size to x+size do
   begin
     gray2 := oldgrayvalue(j,y);
     if gray2 > high then
       high := gray2
     else if gray2 < low then
       low := gray2;
    end;
    Rfactor := High/(low+1);
                     {check if horizontal contrast}
    if ((Rfactor > ratio) and (gray1 > 0.9*high)) then
    begin
      low := 255;
      high := 0;
      for k := y-size to y+size do
      begin
    gray2 := oldgrayvalue(x,k);
    if gray2 > high then
      high := gray2
    else if gray2 < low then
      low := gray2;
      end;
      Rf2 := High/(low+1);
                     {check if vertical contrast}
      if ((Rf2 > ratio) and (gray1 > 0.9*high)) then
      IntensityCheck := TRUE
      else
      IntensityCheck := FALSE;
      end
    else
      IntensityCheck := FALSE;
  end
  else
      IntensityCheck := FALSE;
end;{end function IntensityCheck}

{This unit returns the %foreground and standard deviation of a pixel
 sampling of the nucleus.  The SIZE of the sample is related to the
 value of NUCSIZE.  The values returned are mainly for use when
 Learning is required.}

Procedure HowMuchFore(x,y:word;size:byte;Var AmtFore,_stdev:double);
Var
    j,k      : word;
    count    : byte;
    mark     : byte;
    gray1    : byte;
    imagdata : imagtype2;
    _mean    : double;
begin
    count := 0;
    mark := 0;
    for k := y-size to y+size do                  {sample region}
      for j := x-size to x+size do
      begin
    gray1 := oldgrayvalue(j,k);               {get pixel value}
    if ((gray1 > criticalvalue) or (gray1 < lowdiv)) then
      count := count+1;                       {store if good}
    if (gray1 > criticalvalue) then           {do not include nucleolus}
    begin                                     { when calculating st. dev.}
      mark := mark + 1;
      imagdata[mark] := gray1;
    end;
      end;
    _mean  := mean(imagdata,1,mark);
    _stdev := stdev(imagdata,1,mark,_mean);
    AmtFore := Count/(((2*size) + 1)*((2*size) + 1));
end;

{This routine returns the average gray level of a sample and the
 amount of nucleolus found.}

Function Mscan(x,y:word;size:byte;Var bstuff:double):byte;
var
    j,k          : word;
    count,count2 : byte;
    imagdata     : imagtype2;
    gray1        : byte;
begin
  count := 0;
  count2 := 0;
  for k := y-size to y+size do              {sample region}
    for j := x-size to x+size do
    begin
      gray1 := oldgrayvalue(j,k);
      If gray1 > lowdiv then                {store values above nucleolus}
      begin
    count := count+1;
    imagdata[count] := gray1;
      end
      else
    count2 := count2+1;
    end;
    Bstuff := count2/(count2+count);        {number of nucleolus pixels}
    Mscan := round(mean(imagdata,1,count)); {all values above nucleolus}
end; {end procedure Mscan}


{This procedure will scan top,bottom,left,and right cytoplasm values vs.
 the nuclear gray level.  A critical ratio must be met.  In order to account
 for size variation the scan begins at a maximum nuclear-radius and moves
 inward if acceptable values are not found.  Then the values must fall with
 a certain range in order to assure uniformity.  Finally, "random data" is
 generated and compared with the limits.}

Function SpotContrast(x,y:word;nucsize:byte;Var goodifsmall:boolean):boolean;
Const
     cratio  = 1.3;            {critical upper nuc/cyt segment ratio}
     uratio  = 1.03;
     Ul      = 0.96;            {lower limit}
     UsumMin = 3;            {minimum sum}
     UsumMax = 9;             {maximum sum}
     pzhigh  = 1.6;                   {random data thresholds}
     pzlow   = 1.4;
     pzszlow = 0.31;
     pzszhigh = 0.36;
     upzhigh = 0.36;
     upzlow  = 0.30;
     diffx  = 0.004;
     upzszlow  = 6;
     upzszhigh = 7.1;
var j,k,
    s,t          : word;
    debug        : boolean;
    nold         : byte;                   {minimum distance from nucleus}
    notdone,                               {flag to check if routine is done}
    continue     : boolean;                {flag to check ratio limits}
    mean1,mean2,                           {nuclear and cytoplasm averages}
    ratio        : double;                 {nuclear/cytoplasm ratio}
    displ15,                               {displacements}
    displ14,
    displ13      : byte;
    r1,r2,r3,r4,                           {individual ratios}
    a,b,                                   {used with Uniformity_ratio}
    uniform_ratio,                         {uniformity of ratios}
    sumz,prodz   : double;                 {sums and products of ratios}
begin
  j := x;
  k := y;
  debug := false;
  SpotContrast := FALSE;

  notdone := TRUE;
  Nold    := 1+(nucsize shr 2);           {set smallest distance}
  Mean2 := 0;                             {get nuclear sample value}
  for s := x-1 to x+1 do
     for t := y-1 to y+1 do
      mean2:=oldgrayvalue(s,t)+Mean2;
  Mean2 := Round(Mean2/3);

  If Mean2/3 > 0.98*graystrike then
    goodifsmall := FALSE
  else
    goodifsmall := TRUE;

  If Mean2/3 > 0.95*graystrike then
                      {scan for cytoplasm values}
  WHILE (NotDone) DO                      {Repeat until good energy is     }
  BEGIN                                   {achieved or NUCSIZE becomes too }
                                          {small.                          }
    displ15 := nucsize+3;                 {Displacement values }
    displ14 := nucsize+2;
    displ13 := nucsize+1;
                                           {Sample of cytoplasm consists of
                                           three points}
    mean1:=oldgrayvalue(x-displ15,k)+oldgrayvalue(x-displ14,k)+
      oldgrayvalue(x-displ13,k);

    ratio := Mean2/(Mean1+1);               {compute nuclear/cytoplasm ratio}
    if debug then writeln('RATIO1: ',ratio);
    r1:=ratio;
    If (ratio > cratio) then              {If ratio is above threshold  }
     continue := TRUE                     {then continue                }
    else
     continue := FALSE;
    If continue then                      {get next cytoplasm value}
    begin
     Mean1:=oldgrayvalue(x+displ15,k)+oldgrayvalue(x+displ14,k)+
        oldgrayvalue(x+displ13,k);

     ratio := Mean2/(mean1+1);
     if debug then writeln('ratio2: ',ratio);
     r2 := ratio;
     If (ratio>cratio) then
       continue := TRUE
     else
       continue := FALSE;
    end;
    If continue then
    begin
      Mean1:=oldgrayvalue(j,y+displ15)+oldgrayvalue(j,y+displ14)+
        oldgrayvalue(j,y+displ13);

      ratio := Mean2/(mean1+1);
      if debug then writeln('ratio3: ',ratio);
    r3 := ratio;
      If (ratio>cratio) then
       continue := TRUE
      else
       continue := FALSE;
    end;
    If continue then
    begin
      Mean1:=oldgrayvalue(j,y-displ15)+oldgrayvalue(j,y-displ14)+
        oldgrayvalue(j,y-displ13);

      ratio := Mean2/(mean1+1);
      if debug then writeln('ratio4: ',ratio);
      r4:=ratio;
      If (ratio>cratio) then
       continue := TRUE
      else
       continue := FALSE;
    end;
{    if continue then
    begin
      spotcontrast := TRUE;
      notdone := false;
    end;
 }

  {If this point is reached then the individual ratios are ok. Now
   generate random data to check if the relationships amoung these ratios
   is compatable with the desired pattern.}

    If continue then
    begin
     A := MaxMinRatio(r1,r2);          {Uniform_ratio checks that the    }
     B := MaxMinRatio(r3,r4);          {difference between the cytoplasm }
     Uniform_ratio := A/B;             {gray levels on opposite sides is }
     sumz := r1+r2+r3+r4;
     prodz := r1*r2*r3*r4;
     writeln('UNIFORM: ',uniform_ratio:5:3,' USUM: ',sumz:5:3,
         'U*: ',prodz/sumz:5:5,'up: ',uniform_ratio*prodz/sumz:5:3);
     If (Uniform_ratio > 0.8) and (Uniform_ratio < 3) and
        (sumz < 10) and (Prodz/sumz < 2) then
     begin
       notdone := FALSE;
       spotcontrast := TRUE;
     end;
   end;

    If Nucsize-1 > Nold then                     {Decrease distance from    }
     Nucsize := nucsize-1                        {nucleus. If too small then}
    else                                         {then end routine and pass }
     NotDone := FALSE;                           {back FALSE.               }


   END;

end;{end function SpotContrast}

{This routine will track around the edge of an object, where the boundary
 is delimited by RED.  A box sets the limits on where the object is.  The
 routine scans for the first RED pixel and start from there.}

Function ScanEdge(x1,y1,x2,y2:word):word;
{                      7              This is the chain code. The numbers
            6     0           represent eight orientations about
          5    x    1         the center point.
            4     2
               3
}
Const
    OffsetDir = 6;                    {Starting direction}
var j,k : word;
    x_old,y_old : word;
    j_old,k_old : word;
    ChainCode,
    ChainStart   : byte;
    foundfirst,
    finished,
    done        : boolean;
    Perimeter   : word;
                         {This subroutine is given the current (x,y)
                          coordinates and chaincode.  It then
                          calculates the new (x,y) coordinates to
                          look for an edge.}
Procedure GetPoint(Var x,y:word;ChainCode : byte);
begin
  Case ChainCode of
  1:    x := x+1;                                {y unchanged}
  2:  begin
    x := x+1;
    y := y+1;
      end;
  3:    y := y+1;
  4:  begin
    x := x-1;
    y := y+1;
      end;
  5:    x := x-1;
  6:  begin
    x := x-1;
    y := y-1;
      end;
  7:  y := y-1;
  0:  begin
    x := x+1;
    y := y-1;
      end;
  end;{end case}
end; {end procedure GetPoint}
                              {This function transforms the chain code where
                               the edge was found and determines how many
                               chain codes from chain code '1' it is
                               located going clockwise.}
Function TransChain(ChainCode:byte):byte;
Var
    temp : byte;
begin
    temp := (7+ChainCode) mod 8;
    TransChain := temp;
end;{end function Transchain}

begin
  Perimeter := 0;                                {perimeter is zero}
  foundfirst := false;                           {look for first red}
  finished := FALSE;
  k := y1;
  Repeat                                         {vertical values}
    j := x1;
    Repeat                                       {scan horizontally}
      If oldgrayvalue(j,k) and 1 = 1 then
    foundfirst := TRUE
      else
      j := j+1;
    Until (j > x2) or FoundFirst;
    If Not(FoundFirst) then
      k := k+1;
  Until (k > y2) or FoundFirst;

  If foundfirst then                                {did we find a RED?}
  begin
    x_old := j;                                     {Set to coordinates of}
    y_old := k;                                     {first RED pixel      }
    Perimeter := 1;
    chainCode := OffsetDir;                         {this is first direction}
                  {Within this Repeat loop we scan around the
                   entire object till we come back to the staring point}
    REPEAT                                          {scan whole object}
      Done := False;
      ChainStart := ChainCode;
      j_old := j;                                   {Save our position      }
      k_old := k;                                   {so we can look around  }
                                                    {in all eight directions}
                 {Within this loop we scan around a red point in
                  search of the next red (edge) point. If none are found
                  then there must be only one RED point and the routine is
                  done.}
      Repeat
       GetPoint(j,k,chaincode);                     {get point to scan}
       If oldgrayvalue(j,k) and 1 = 1 then          {is it RED?}
     done := TRUE
       else                                         {If not then             }
            ChainCode := (ChainCode+1) mod 8;          {look in next direction  }
       If Not(done) then                            {If we didn't find an    }
       begin                                        {edge reset center point.}
     j := j_old;
     k := k_old;
       end;
      Until done or (chaincode = chainstart); {then perimeter = 1}
      If (j = x_old) and (k = y_old) then            {did we go around object?}
     Finished := TRUE                            {if so then we are done}
      else
      begin                          {otherwise we                         }
     Perimeter := Perimeter+1;   {increment the perimeter and ROTATE   }
                                     {the chain code matrix around the edge}
         ChainCode := (OffsetDir + TransChain(ChainCode)) mod 8;
                  (*The formula above says:  We always start scanning in the
                    6 (OffsetDir) direction.  We simply figure how many
                    chain codes from chain code 1 we moved and add this to
                    OffsetDir.  Modular division by eight simply insures
                    that we only have eight chain codes.
        SUPPOSE that we are at (0,0) and the next edge is at (1,-1).  The
        chain code direction is 2. TransChain says this is 1 chain code
        away from chain code 1.  We want to start scanning for the next
        edge at chain code 6 RELATIVE to current point which is why 6 is
        added making    7
        seven the     6   0
        next chain   5  x  1      <--Starting axis for first point horizont.
        code.            .              New axis is diagonal relative to
                          . 7           the first.
                          6.  0
                         5  x          Basically, an algorithm was needed
                                       that would give us the first point
                                       to scan that was immediately after the
                                       imaginary line between the two x's in
                                       the clockwise direction.  If we rotate
                                       the line between the two x's and make
                                       it horizontal (1 chain code
                                       counterclockwise) we see that
                                       relative to the second x-point
                                       we are scanning at chain code 6.*)
      end;
    UNTIL finished;
    ScanEdge := Perimeter;
  end;
end;{end function scanedge}

{After all nuclei are found they are converted from being shaded
 RED to having a gray value of 20 (dark).}

Procedure MakeDark(x1,y1,x2,y2:word);
var j,k : word;
begin
  for k := y1 to y2 do
    for j := x1 to x2 do
      if oldgrayvalue(j,k) and 1 = 1 then
    newgrayvalue(j,k,20);
end; {end procedure MakeDark}

{This procedure scans the region and determines the distances from the
 center-point (x,y).  These distances are returned as the length and
 width of the nucleus (DA,DB).}

Procedure EScan(x,y:word;Nucsize,cv:byte;var da,db:byte);
Var
    j,k   : word;
    done  : boolean;
    temp,
    gray1,
    valx  : byte;
begin
  valx := round(0.95*cv);             {get threshold}
  done := FALSE;
  j := x;                             {scan along horizontal}
  While (j <= x+nucsize) and Not(done) do
  begin
    gray1 := oldgrayvalue(j,y);
    newgrayvalue(j,y,gray1 or 1);
    If (isitbackground(j,y,valx,3)) and (gray1 > lowdiv) then
      done := TRUE
    else
      j := j+1;
  end;
  temp := j-x;
  done := FALSE;
  j := x;
  While (j > x-nucsize) and Not(done) do
  begin
    gray1 := oldgrayvalue(j,y);
    newgrayvalue(j,y,gray1 or 1);
    If (isitbackground(j,y,valx,-3)) and (gray1 > lowdiv) then
      done := TRUE
    else
      j := j-1;
  end;
  da := temp + (x-j);
  done := FALSE;
  k := y;                             {scan along vertical}
  While (k <= y+nucsize) and Not(done) do
  begin
    gray1 := oldgrayvalue(x,k);
    newgrayvalue(x,k,gray1 or 1);
    If (isitbackgroundv(x,k,valx,3)) and (gray1 > lowdiv) then
      done := TRUE
    else
      k := k+1;
  end;
  temp := k-y;
  done := FALSE;
  k := y;
  While (k > y-nucsize) and Not(done) do
  begin
    gray1 := oldgrayvalue(x,k);
    newgrayvalue(x,k,gray1 or 1);
    If (isitbackgroundv(x,k,valx,-3)) and (gray1 > lowdiv) then
      done := TRUE
    else
      k := k-1;
  end;
  db := temp + (y-k);
end;{end procedure EScan}

{This is an Energy routine.  It sets up several concentric square shells
 around the point (x,y) and samples the pixel values.  It then computes
 a ratio with the center sample.  Based on the relationship of these
 ratios and the state of SEENBEFORE the function returns TRUE or FALSE.
 However, certain values require information from other units.
 GOODIFNUCLEOUS, if TRUE, says that the ratios are
 good only if there is a nucleolus in this nucleolus.  The presence of
 one is determined by other units so the value is returned.}

Function ShellScan(x,y,nucsize:word;Uncertain:boolean;
                    var goodifnucleolus:boolean):boolean;
var
    j,k,
    r                : word;
   rq                : double;
   rx                : array[1..4] of double;
   gray1             : byte;
   q1,q2,q3          : double;
   count             : word;
   sum               : double;
   s,w,
   lowcount          : byte;
begin
  r := 0;
  for k := y-1 to y+1 do                    {sample center}
    for j := x-1 to x+1 do
    begin
      gray1 := oldgrayvalue(j,k);
      If gray1 > lowdiv then
    r := r+gray1
      else
    r := r+graystrike;
    end;
  rq := r/9;                                 {center average}
  s := 1;
  For w := 1 to 4 do                         {Get four other samples}
  begin                                      { around the center    }
    count := 0;
    s := s+2;
    rx[w] := 0;
    for j := x-s to x+s do                   {get top and bottom}
    begin
      gray1 := oldgrayvalue(j,y-s);
      If gray1 > lowdiv then
      begin
    count := count+1;
    rx[w] := rx[w]+gray1;
      end;
      gray1 := oldgrayvalue(j,y+s);
      If gray1 > lowdiv then
      begin
    count := count+1;
    rx[w] := rx[w]+gray1;
      end;
    end;
    for k := y-(s-1) to y+(s-1) do           {get right and left sides}
    begin
      gray1 := oldgrayvalue(x-s,k);
      If gray1 > lowdiv then
      begin
    count := count+1;
    rx[w]:= rx[w]+gray1;
      end;
      gray1 := oldgrayvalue(x+s,k);
      If gray1 > lowdiv then
      begin
    count := count+1;
    rx[w] := rx[w]+gray1;
      end;
    end;
    rx[w] := rx[w]/count;
    rx[w] := rq/rx[w];                       {store value}
  end;{end w}
  lowcount := 0;

  q1 := rx[2]/rx[1];
  q2 := rx[3]/rx[2];
  q3 := rx[4]/rx[3];
  count := round(int(q1) + int(q2) + int(q3));
  sum := abs(rx[1]-rx[2])+abs(rx[2]-rx[3])+abs(rx[3]-rx[4]);
  writeln('BEGIN SHELL ROUTINE');
  writeln('r1: ',rx[1]:5:5,' r2: ',rx[2]:5:5,' r3: ',
      rx[3]:5:5,' r4: ',rx[4]:5:5);


If   ( (Uncertain and (rx[1] > 1)) or (rx[1] > 1.02) ) and
     (rx[1] < rx[2]) and  (rx[2] < rx[3]) and (rx[2] < 1.5) and
     (rx[3] - rx[4] < 0.03) and (rx[4] < 1.65) then
begin
      if rx[3] < rx[4] then
        goodifnucleolus := FALSE
      else
        goodifnucleolus := TRUE;
      ShellScan := TRUE;
end
else
begin
      ShellScan := FALSE;
end;

end; {end procedure ShellScan}

{As the procedure name says, this computes the center of gravity of
 a RED shaded nucleus.}

Procedure FindCenterGravity(x,y,nucsize:word;var xc,yc,w:word);
Var
   j,k   : word;
   gray1 : byte;
   xc1,
   yc1   : double;
begin
   w := 0;
   xc1 := 0;
   yc1 := 0;
   for k := y-nucsize to y+nucsize do
     for j := x-nucsize to x+nucsize do
     begin
    gray1 := oldgrayvalue(j,k);
    If gray1 and 1 = 1 then
    begin
      xc1 := xc1+j;
      yc1 := yc1+k;
      w  := w+1;
    end;
     end;
   If w > 0 then
   begin
     xc := round(xc1/w);
     yc := round(yc1/w);
   end
   else
   begin
     xc := round(xc1);
     yc := round(yc1);
   end;
end;{end procedure findcentergravity}

{This routine performs several unit functions.  The outputs of these
 units are evaluated in the main routine with the outputs of other
 units.  Thus, this is part of an energy routine.  The routine determines
 the amount of nucleolus, the kurtosis and st. dev. of the nucleus, two
 nuclear/cytoplasm ratios, and the st. dev. of the immediately surrounding
 cytoplasm.}

Procedure HistoAnalysis(x,y:word;nucsize:byte;var below:byte;
      var ku,stout,rx,rx2:double;Var CytCond,AbsCyt : boolean);
Const
    histratio = 0.94;
    histcrit  = 0.85;
    histdiff  = 0.015;
    histdiff2 = 0.019;
Var
    j,k       : word;
    gray1     : byte;
    imagdata,
    im2       : imagtype2;
    _mean,
    outval    : double;
    w,w2,
    xc,yc,
    ns,
    meanx     : word;
    meanq,
    c1,c2,
    c3,c4,
    tot,
    mn,stmn  : double;
begin                         {Get centergrav and area (w)}
   findcentergravity(x,y,nucsize,xc,yc,w);
   c1 := 0;
   c2 := 0;
   c3 := 0;
   c4 := 0;
   below := 0;
   ns := round(1.2*sqrt(w/pi));  {approximate radius slightly larger}
   w := 0;                       {than true radius.  Thus, we draw a}
   w2 := 0;                      {square around the nucleus.        }
   below := 0;
   for k := yc-ns to yc+ns do
     for j := xc-ns to xc+ns do
     begin
       gray1 := oldgrayvalue(j,k);
       if (gray1 and 1 <> 1) then   {Get data on surrounding cytoplasm}
       begin
      w := w+1;
      imagdata[w] := gray1;
       end
       else if (gray1 > lowdiv) then  {get data on nucleus}
       begin
      w2 := w2+1;
      im2[w2] := gray1;
       end
       else
     below := below+1;            {store data on nucleolus}
     end;

    for j := xc-ns to xc+ns do
    begin
      c1 := c1 + oldgrayvalue(j,yc-ns);
      c2 := c2 + oldgrayvalue(j,yc+ns);
    end;
    for k := yc-ns to yc+ns do
    begin
      c3 := c3 + oldgrayvalue(xc-ns,k);
      c4 := c4 + oldgrayvalue(xc+ns,k);
    end;
    tot := 1+ (2*ns);
    c1 := c1/tot;
    c2 := c2/tot;
    c3 := c3/tot;
    c4 := c4/tot;


    outval := round(mean(imagdata,1,w));   {get avg gray-level of cytoplasm}
    stout  := stdev(imagdata,1,w,outval);  {get st. dev. of cytoplasm}
    _mean  := mean(im2,1,w2);              {get mean gray-level of nucleus}
    ku := kurtosis(im2,w2,round(_mean));            {get ku of nucleus}

    c1 := outval/(1+c1);
    c2 := outval/(1+c2);
    c3 := outval/(1+c3);
    c4 := outval/(1+c4);
    If (c1 < histcrit) or (c2 < histcrit) or (c3 < histcrit) or
       (c4 < histcrit) then
       Abscyt := FALSE
    else
       Abscyt := TRUE;
    mn := (c1+c2+c3+c4)/4;
    stmn := sqr(c1-mn) + sqr(c2-mn) + sqr(c3-mn) + sqr(c4-mn);
    stmn := sqrt(stmn)/3;
    If (c1 > histratio) and (c2 > histratio) and
       (c3 > histratio) and (c4 > histratio) and
       (mn < 1.1) and (mn > 0.95) and
       (stmn < 0.1) then
       CytCond := TRUE
    else
       CytCond := FALSE;

    writeln('ratios       : ',c1:5:5,' ',c2:5:5,' ',c3:5:5,' ',c4:5:5);
    writeln('diffs:         ',abs(c1-c3):5:5,' ',abs(c2-c4):5:5);
    writeln('sums :         ',c1+c2+c3+c4:5:5);
    writeln('mean,st :      ',mn:5:5,' ',stmn:5:5);
    writeln('d2   : ',abs(c1-mn):5:5,' ',abs(c2-mn):5:5,' ',abs(c3-mn):5:5,
            ' ',abs(c4-mn):5:5);

  meanx := 0;
  for k := y-1 to y+1 do             {sampe center 9 pixels}
    for j := x-1 to x+1 do
    begin
      gray1 := oldgrayvalue(j,k);
      If gray1 > lowdiv then
    meanx := meanx+gray1
      else
    meanx := meanx+graystrike;
     end;
  meanq := meanx/9;                  {get center ratio}
  If outval > 0 then
  begin
    rx := Meanq/outval;              {ratio of sample/cytoplasm}
    rx2 := _mean/outval;             {ratio of whole nucleus/cytoplasm}
  end
  else
  begin
    rx := 0;
    rx2 := 0;
  end;
end;{end procedure Histoanalysis}

{--------------------------LEARNING ALGORITHMS-------------------------}

Procedure LearnFromDeletion(Num:byte);
Var i,
    graylow,
    grayhigh : byte;
    AreaLow,
    AreaHigh,
    DaDbmin  : word;
    BlackMin,
    BlackMax,
    stqmax,
    stqxmax,
    forxmin,
    forgndmin,
    MvalMax,
    MvalMin,
    ShapeInd,
    ShapeMax,
    ShapeMin,
    Kumax,Kumin,
    cytomax,hypmin,
    rx2max,rx2min,
    rx1min,rx1max   : double;
begin
  graylow := 255;
  grayhigh := 0;
  AreaLow  := 9999;
  AreaHigh := 0;
  BlackMin := 250;
  blackMax := 0;
  StqMax   := 0;
  StqxMax  := 0;
  Forgndmin := 250;
  ForxMin  := 250;
  MvalMax  := 0;
  MvalMin  := 250;
  DaDbMin  := 250;
  ShapeMax := 0;
  ShapeMin := 250;
  kumax    := 0;
  kumin    := 255;
  rx2min     := 255;
  rx1min     := 255;
  rx2max     := 0;
  rx1max     := 0;
  cytomax    := 0;
  hypmin     := 255;

  For i := 1 to cellcount do               {set values to compare with}
  If AiCells[i].good then
  With Aicells[i] do
   begin
     If gray > grayhigh then
       grayhigh := gray
     else if gray < graylow then
       graylow := gray;
     If area > areahigh then
       areahigh := area
     else if area < arealow then
       arealow := area;
     If (black > blackmax) then
       blackmax := black
     else if (black < blackmin) and (black <> 0) then
       blackmin := black;
     If _stdev > stqmax then
       stqmax := _stdev;
     If stdx > stqxmax then
       stqxmax := stdx;
     If Mval > MvalMax then
       MvalMax := Mval
     else if Mval < MvalMin then
       MvalMin := Mval;
     If (black = 0) and (dadb < dadbmin) then
       DaDbmin := dadb;
     If area/dadb < hypmin then
       hypmin := area/dadb;
     If forx < ForxMin then
       ForxMin := Forx;
     If foregnd < Forgndmin then
       forgndmin := foregnd;
     ShapeInd := perimeter*perimeter/(Area*12.56);
     If shapeInd > ShapeMax then
       ShapeMax := shapeInd
     else if shapeInd < shapeMin then
       Shapemin := shapeInd;
     If kux > kumax then
       kumax := kux
     else if kux < kumin then
       kumin := kux;
     If cytost > cytomax then
       cytomax := cytost;
     If rx2 < rx2min then
       rx2min := rx2
     else if rx2 > rx2max then
       rx2max := rx2;
     If rx1 < rx1min then
       rx1min := rx1
     else if rx1 > rx1max then
       rx1max := rx1;
   end;

   If BlackMin > 1 then
     blackMin := MinBlack;
   If BlackMax = 0 then
     blackMax := MaxBlack;

  With Aicells[num] do
  begin
    If (gray = graylow) then
      graystrike := round(1.01*graylow)
    else if (gray = grayhigh) then
      CriticalHigh := round(0.99*grayhigh);
    If (area = arealow) then
      MinArea := round(1.01*AreaLow)
    else if (area = areaHigh) then
      MaxArea := round(0.99*AreaHigh);
    If (Black = BlackMin) and (Black >= MinBlack) then
      MinBlack := (1.01)*BlackMin
    else if (black = blackMax) and (blackmax > blackmin) then
      MaxBlack := (0.99)*BlackMax;
    If (_stdev = stqmax) then
      _stqset := (0.99)*Stqmax;
    If (stdx = stqxmax) then
      _stqxset := (0.99)*stqxmax;
    If (Mval = MvalMin) then
      Mvalx := (1.01)*Mvalmin;

   If (black = 0) and (dadb = dadbmin) then
     DaDbx := dadbmin+2;
   If area/dadb < hypmin then
     lowhyp := 1.01*hypmin;
   If forx = forxmin then
      forxset := 1.01*ForxMin;
   If foregnd = forgndmin then
      forset := 1.01*forgndmin;

   shapeInd := perimeter*perimeter/(12.56*Area);
   If ShapeInd > ShapeMax then
     ShapeHigh := 0.99*ShapeInd
   else if shapeInd < shapeMin then
     ShapeLow := 1.01*ShapeInd;

   If kux < kumin then
     kulow := 1.01*kumin
   else if kux > kumax then
     kuhigh := 0.99*kumax;
   If cytoset > cytomax then
     cytoset := 0.99*cytomax;

   If rx2 < rx2min then
     rx2low := 1.01*rx2min
   else if rx2 > rx2max then
     rx2high := 0.99*rx2max;
   If rx1 < rx1min then
     rx1low := 1.01*rx1min
   else if rx1 > rx1max then
     rx1high := 0.99*rx1max;
  end;
end;{end procedure learnfromdeletion}

Procedure LearnFromAddition(x,y:word;Nucsize,Width,Height:byte;Mval:double);
Var i : byte;
    Grayx : byte;
    aq,pq : word;
    mvq      : double;
    ShapeInd,
    _forex,_stdx : double;
    Cmval : double;
    blackcomp : double;
    da,db : byte;
    s,t : word;
    Mhigh : byte;
    xm,ym : word;
    forecomp,_stdev : double;
    below    : byte;
    ku,stout,rxa,rx2a : double;
    cytcond,abscyt : boolean;

begin

   histoanalysis(x,y,20,below,ku,stout,rxa,rx2a,cytcond,abscyt);

   If rxa < rx2a then
   begin
     mvq := rx2a;
     rx2a := rxa;
     rxa  := mvq;
   end;

   If ku < kulow then
     kulow := 0.99*ku
   else if ku > kuhigh then
     kuhigh := 1.01*ku;
   If stout > cytoset then
     cytoset := 1.01*stout;
   If rx2a < rx2low then
     rx2low := 0.99*rx2a
   else if rx2a > rx2high then
     rx2high := 1.01*rx2a;

   If rxa > rx1high then
     rx1high := 1.01*rxa
   else if rxa < rx1low then
     rx1low := 0.99*rxa;


   Grayx := oldgrayvalue(x,y);
   mvq   := getgray(x,y,5);
   If (0.96*mvq) < criticalvalue then
   begin
     If 0.95*mvq < mvalx then
       mvalx := 0.95*mvq;
     criticalvalue := (criticalvalue + round(0.96*mvq)) shr 1;
     graystrike    := (graystrike + round(1.03*criticalvalue)) shr 1;
   end;

   if 0.98*Grayx > criticalhigh then
     CriticalHigh := round(1.01*criticalHigh);

   Aq := 1+findarea(x-(width shr 1),y-(height shr 1),
             x+(width shr 1),y+(height shr 1),_forex,_stdx);
   Pq := scanedge(x-(width shr 1),y-(height shr 1),
             x+(width shr 1),y+(height shr 1));

   escan(x,y,nucsize,round(mval),da,db);


   shapeInd := pq*pq/(12.56*Aq);
   If (shapeind > shapehigh) then
     ShapeHigh := 1.01*ShapeInd
   else if (shapeind < shapelow) then
     ShapeLow := 0.99*ShapeInd;

   If (Aq < Minarea) then
     MinArea := round(0.99*Aq)
   else if (Aq > MaxArea) then
     MaxArea := round(1.01*Aq);

   If (_forex < forxset) then
     ForxSet := 0.99*_Forex;
   If (_stdx > _stqxset) then
     _StqxSet := 1.01*_Stdx;

   If (da*db <> 0) and (aq/(da*db) > dadbq) then
     dadbq := aq/(da*db);
   If (da*db <> 0) and (aq/(da*db) < lowhyp) then
     lowhyp := aq/(da*db);
   Cmval := Mscan(x,y,round(nucsize/3),blackcomp);

   If (blackcomp < Minblack) and (blackcomp <> 0) then
       MinBlack := 0.99*Blackcomp
   else if (blackcomp > Maxblack) and (blackcomp < 1) then
       MaxBlack := 1.01*Blackcomp;

   If Cmval < Mvalx then
     Mvalx := 0.99*cMval;
   If (blackcomp = 0) and ((da*db)-1 > 0) and (da*db < dadbx) then
     DaDbx := round(da*db);

   Mhigh := 0;
   for t := y-2 to y+2 do
     for s := x-2 to x+2 do
     begin
       grayx := oldgrayvalue(s,t);
       if grayx > Mhigh then
       begin
     Mhigh := grayx;
     xm := s;
     ym := t;
       end;
     end;
     Howmuchfore(xm,ym,(nucsize shr 2)+1,forecomp,_stdev);
     If (forecomp < forset) then
       forset := 0.99*forecomp;
     If (_stdev > _stqset) then
       _StqSet := 1.01*_stdev;

   {-------enter data for printer report---------------}
   cellcount := cellcount+1;
   with aicells[cellcount] do
   begin
     area := aq;
     perimeter := pq;
     _area := aq;
     _perim := pq;
     good := true;
              { ..........set values..........}
     gray := grayx;
     black := MinBlack;
     foregnd := forset;
     _stdev := _stqset;
     _forex := forxset;
     _stdx  := _stqxset;
     dadb   := da*db;
     mval   := mvalx;
     xcoord := x;
     ycoord := y;
     rx1    := rxa;
     rx2    := rx2a;
     cytost := stout;
     kux    := ku;
   end;
end;  {end procedure learnfromaddition}

END.