home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Pascal / Applications / NIH Image 1.55 / Source / Background.p < prev    next >
Encoding:
Text File  |  1994-04-07  |  40.0 KB  |  613 lines  |  [TEXT/PJMM]
  1. unit Background;
  2. {************************************************************************}
  3. {*     by Michael Castle and Janice Keller                                                                                                    *}
  4. {*     University of Michigan Mental Health Research Institute (MHRI)                                                     *}
  5. {*     e-mail address: mike.castle@med.umich.edu                                                                                  *}
  6. {****************            xval := xpt - patchwidth + ptsbelowlastpatch;
  7.                                 xpt2 := ptsbelowlastpatch;
  8.                                 ballpt := ballpt + ptsbelowlastpatch;
  9.                                 backgrpt := ybackgrpt + (xval - left + 1) * shrinkfactor;
  10.                                 while xpt2 <= patchwidth do begin     {for all the points in the ball patch}
  11.                                         if ((xval >= left) and (xval <= right) and (yval >= top) and (yval <= bottom)) then begin
  12.                                                 p1 := ptr(ballpt);
  13.                                                 zadd := zctr + BAND(p1^, 255);
  14.                                                 p1 := ptr(backgrpt);
  15.                                                 if (zadd > BAND(p1^, 255)) then  {keep largest adjustment}
  16.                                                     p1^ := zadd;
  17.                                             end;
  18.                                         ballpt := ballpt + 1;
  19.                                         xval := xval + 1;
  20.                                         xpt2 := xpt2 + 1;
  21.                                         backgrpt := backgrpt + shrinkfactor;     {move to next point in x}
  22.                                     end;  {while xpt2}
  23.                                 yval := yval + 1;
  24.                                 ypt2 := ypt2 + 1;
  25.                                 ybackgrpt := ybackgrpt + ybackgrinc;       {move to next point in y}
  26.                             end;  {while ypt2}
  27.                     end;  {for xpt }
  28.                 if ((ypt mod 5) = 0) or not FasterBackgroundSubtraction then begin
  29.                         UpdateMeter(20 + ((ypt - top) * 70) div (bottom + patchwidth - top), 'Finding Background...');
  30.                         if CommandPeriod then begin
  31.                                 beep;
  32.                                 Aborting := true;
  33.                                 Exit(RollBall);
  34.                             end;
  35.                     end;
  36.             end;  {for ypt}
  37.     end;
  38.  
  39.  
  40.     function MinIn2DMask {(xmaskmin,ymaskmin: integer)}
  41.         : integer;
  42. {*******************************************************************************}
  43. {*     MinInMask finds the minimum pixel value in a shrinkfactor X shrinkfactor mask.                                           *}
  44. {*******************************************************************************}
  45.         var
  46.             i, j,                                           {loop indices to step through mask}
  47.             thispixel,                                  {value at current pixel in mask}
  48.             min,                                          {temporary minimum value in mask}
  49.             nextrowoffset: integer;             {distance in memory from end of mask in this row to beginning in next}
  50.             paddr: longint;                           {address of current mask pixel}
  51.             p: ptr;                                        {pointer to current pixel in mask}
  52.     begin
  53.         with info^ do begin
  54.                 min := 255;
  55.                 nextrowoffset := bytesperrow - shrinkfactor;
  56.                 paddr := ord4(PicBaseAddr) + longint(ymaskmin) * bytesperrow + xmaskmin;
  57.                 for j := 1 to shrinkfactor do begin
  58.                         for i := 1 to shrinkfactor do begin
  59.                                 p := ptr(paddr);
  60.                                 thispixel := BAND(p^, 255);
  61.                                 if (thispixel < min) then
  62.                                     min := thispixel;
  63.                                 paddr := paddr + 1;
  64.                             end;     {for i}
  65.                         paddr := paddr + nextrowoffset;
  66.                     end;     {for j}
  67.                 MinIn2DMask := min;
  68.             end; {with}
  69.     end;
  70.  
  71.  
  72.     procedure GetRollingBall;
  73. {******************************************************************************}
  74. {*     This procedure computes the location of each point on the rolling ball patch relative to the center of the     *}
  75. {*  sphere containing it.  The patch is located in the top half of this sphere.  The vertical axis of the sphere         *}
  76. {*  passes through the center of the patch.  The projection of the patch in the xy-plane below is a square.           *}
  77. {******************************************************************************}
  78.         var
  79.             rsquare,                                                                         {rolling ball radius squared}
  80.             xtrim,                                                                            {# of pixels trimmed off each end of ball to make patch}
  81.             xval, yval,                                                                     {x,y-values on patch relative to center of rolling ball}
  82.             smallballradius, diam,                                                  {radius and diameter of rolling ball}
  83.             temp,                                                                             {value must be >=0 to take square root}
  84.             halfpatchwidth: integer;                                                {distance in x or y from center of patch to any edge}
  85.             i,                                                                                    {index into rolling ball patch memory}
  86.             ballsize: Size;                                                                {size of rolling ball memory}
  87.             p: ptr;                                                                            {pointer to current point on the ball patch}
  88.     begin
  89.         smallballradius := ballradius div shrinkfactor;           {operate on small-sized image with small-sized ball}
  90.         if smallballradius < 1 then
  91.             smallballradius := 1;
  92.         rsquare := smallballradius * smallballradius;
  93.         diam := smallballradius * 2;
  94.         xtrim := (ArcTrimPer * diam) div 100;                      {only use a patch of the rolling ball}
  95.         patchwidth := diam - xtrim - xtrim;
  96.         halfpatchwidth := smallballradius - xtrim;                   {this is half the patch width}
  97.         ballsize := longint(patchwidth + 1) * longint(patchwidth + 1);
  98.         ballptr := NewPtrToClearBuf(ballsize);
  99.         p := ballptr;
  100.         for i := 0 to ballsize - 1 do begin
  101.                 xval := i mod (patchwidth + 1) - halfpatchwidth;
  102.                 yval := i div (patchwidth + 1) - halfpatchwidth;
  103.                 temp := rsquare - (xval * xval) - (yval * yval);
  104.                 if (temp >= 0) then
  105.                     p^ := round(sqrt(temp))
  106.                 else
  107.                     p^ := 0;
  108.                 p := ptr(ord4(p) + 1);
  109.             end;
  110.     end;
  111.  
  112.  
  113.     procedure InterpolateBackground2D; {(leftroll, rightroll, toproll, bottomroll: integer; backgroundaddr: longint)}
  114. {******************************************************************************}
  115. {*     This procedure uses bilinear interpolation to find the points in the full-scale background given the points *}
  116. {*  from the shrunken image background.  Since the shrunken background is found from an image composed of    *}
  117. {*  minima (over a sufficiently large mask), it is certain that no point in the full-scale interpolated                 *}
  118. {*  background has a higher pixel value than the corresponding point in the original image.                                  *}
  119. {******************************************************************************}
  120.         var
  121.             i, ii,                                                   {horizontal loop indices}
  122.             j, jj,                                                  {vertical loop indices}
  123.             hloc, vloc,                                          {position of current pixel in calculated background}
  124.             vinc,                                                   {memory offset from current calculated pos to current interpolated pos}
  125.             lastvalue, nextvalue: integer;           {calculated pixel values between which we are interpolating}
  126.             p,                                                        {pointer to current interpolated pixel value}
  127.             bglastptr, bgnextptr: ptr;                 {pointers to calculated pixel values between which we are interpolating}
  128.     begin
  129.         vloc := 0;
  130.         with BoundRect do begin
  131.                 for j := 1 to bottomroll - toproll - 1 do begin     {interpolate to find background interior}
  132.                         hloc := 0;
  133.                         vloc := vloc + shrinkfactor;
  134.                         for i := 1 to rightroll - leftroll do begin
  135.                                 hloc := hloc + shrinkfactor;
  136.                                 bgnextptr := ptr(backgroundaddr + vloc * longint(right - left) + hloc);
  137.                                 bglastptr := ptr(ord4(bgnextptr) - shrinkfactor);
  138.                                 nextvalue := BAND(bgnextptr^, 255);
  139.                                 lastvalue := BAND(bglastptr^, 255);
  140.                                 for ii := 1 to shrinkfactor - 1 do begin     {interpolate horizontally}
  141.                                         p := ptr(ord4(bgnextptr) - ii);
  142.                                         p^ := lastvalue + (shrinkfactor - ii) * (nextvalue - lastvalue) div shrinkfactor;
  143.                                     end;     {for ii}
  144.                                 for ii := 0 to shrinkfactor - 1 do begin     {interpolate vertically}
  145.                                         bglastptr := ptr(backgroundaddr + (vloc - shrinkfactor) * longint(right - left) + hloc - ii);
  146.                                         bgnextptr := ptr(backgroundaddr + vloc * longint(right - left) + hloc - ii);
  147.                                         lastvalue := BAND(bglastptr^, 255);
  148.                                         nextvalue := BAND(bgnextptr^, 255);
  149.                                         vinc := 0;
  150.                                         for jj := 1 to shrinkfactor - 1 do begin
  151.                                                 vinc := vinc - right + left;
  152.                                                 p := ptr(ord4(bgnextptr) + vinc);
  153.                                                 p^ := lastvalue + (shrinkfactor - jj) * (nextvalue - lastvalue) div shrinkfactor;
  154.                                             end;     {for jj}
  155.                                     end;     {for ii}
  156.                             end;     {for i}
  157.                     end;     {for j}
  158.             end;   {with boundrect}
  159.     end;
  160.  
  161.  
  162.     procedure ExtrapolateBackground2D; {(leftroll, rightroll, toproll, bottomroll: integer; backgroundaddr: longint)}
  163. {******************************************************************************}
  164. {*     This procedure uses linear extrapolation to find pixel values on the top, left, right, and bottom edges of      *}
  165. {*  the background.  First it finds the top and bottom edge points by extrapolating from the edges of the                *}
  166. {*  calculated and interpolated background interior.  Then it uses the edge points on the new calculated,               *}
  167. {*  interpolated, and extrapolated background to find all of the left and right edge points.  If extrapolation yields *}
  168. {*  values below zero or above 255, then they are set to zero and 255 respectively.                                              *}
  169. {******************************************************************************}
  170.         var
  171.             ii, jj,                                                 {horizontal and vertical loop indices}
  172.             hloc, vloc,                                          {position of current pixel in calculated/interpolated background}
  173.             edgeslope,                                          {difference of last two consecutive pixel values on an edge}
  174.             pvalue,                                               {current extrapolated pixel value}
  175.             lastvalue, nextvalue: integer;           {calculated pixel values from which we are extrapolating}
  176.             p,                                                        {pointer to current extrapolated pixel value}
  177.             bglastptr, bgnextptr: ptr;                 {pointers to calculated pixel values from which we are extrapolating}
  178.     begin
  179.         with BoundRect do begin
  180.                 for hloc := shrinkfactor to shrinkfactor * (rightroll - leftroll) - 1 do begin     {extrapolate on top and bottom}
  181.                         bglastptr := ptr(backgroundaddr + shrinkfactor * longint(right - left) + hloc);
  182.                         bgnextptr := ptr(backgroundaddr + (shrinkfactor + 1) * longint(right - left) + hloc);
  183.                         lastvalue := BAND(bglastptr^, 255);
  184.                         nextvalue := BAND(bgnextptr^, 255);
  185.                         edgeslope := nextvalue - lastvalue;
  186.                         p := bglastptr;
  187.                         pvalue := lastvalue;
  188.                         for jj := 1 to shrinkfactor do begin
  189.                                 p := ptr(ord4(p) - right + left);
  190.                                 pvalue := pvalue - edgeslope;
  191.                                 if (pvalue < 0) then
  192.                                     p^ := 0
  193.                                 else if (pvalue > 255) then
  194.                                     p^ := 255
  195.                                 else
  196.                                     p^ := pvalue;
  197.                             end;     {for jj}
  198.                         bglastptr := ptr(backgroundaddr + (shrinkfactor * (bottomroll - toproll - 1) - 1) * longint(right - left) + hloc);
  199.                         bgnextptr := ptr(backgroundaddr + shrinkfactor * (bottomroll - toproll - 1) * longint(right - left) + hloc);
  200.                         lastvalue := BAND(bglastptr^, 255);
  201.                         nextvalue := BAND(bgnextptr^, 255);
  202.                         edgeslope := nextvalue - lastvalue;
  203.                         p := bgnextptr;
  204.                         pvalue := nextvalue;
  205.                         for jj := 1 to (bottom - top - 1) - shrinkfactor * (bottomroll - toproll - 1) do begin
  206.                                 p := ptr(ord4(p) + right - left);
  207.                                 pvalue := pvalue + edgeslope;
  208.                                 if (pvalue < 0) then
  209.                                     p^ := 0
  210.                                 else if (pvalue > 255) then
  211.                                     p^ := 255
  212.                                 else
  213.                                     p^ := pvalue;
  214.                             end;     {for jj}
  215.                     end;     {for hloc}
  216.                 for vloc := top to bottom - 1 do begin     {extrapolate on left and right}
  217.                         bglastptr := ptr(backgroundaddr + (vloc - top) * longint(right - left) + shrinkfactor);
  218.                         bgnextptr := ptr(ord4(bglastptr) + 1);
  219.                         lastvalue := BAND(bglastptr^, 255);
  220.                         nextvalue := BAND(bgnextptr^, 255);
  221.                         edgeslope := nextvalue - lastvalue;
  222.                         p := bglastptr;
  223.                         pvalue := lastvalue;
  224.                         for ii := 1 to shrinkfactor do begin
  225.                                 p := ptr(ord4(p) - 1);
  226.                                 pvalue := pvalue - edgeslope;
  227.                                 if (pvalue < 0) then
  228.                                     p^ := 0
  229.                                 else if (pvalue > 255) then
  230.                                     p^ := 255
  231.                                 else
  232.                                     p^ := pvalue;
  233.                             end;     {for ii}
  234.                         bgnextptr := ptr(backgroundaddr + (vloc - top) * longint(right - left) + shrinkfactor * (rightroll - leftroll - 1) - 1);
  235.                         bglastptr := ptr(ord4(bgnextptr) - 1);
  236.                         lastvalue := BAND(bglastptr^, 255);
  237.                         nextvalue := BAND(bgnextptr^, 255);
  238.                         edgeslope := nextvalue - lastvalue;
  239.                         p := bgnextptr;
  240.                         pvalue := nextvalue;
  241.                         for ii := 1 to (right - left - 1) - shrinkfactor * (rightroll - leftroll - 1) + 1 do begin
  242.                                 p := ptr(ord4(p) + 1);
  243.                                 pvalue := pvalue + edgeslope;
  244.                                 if (pvalue < 0) then
  245.                                     p^ := 0
  246.                                 else if (pvalue > 255) then
  247.                                     p^ := 255
  248.                                 else
  249.                                     p^ := pvalue;
  250.                             end;     {for ii}
  251.                     end;     {for vloc}
  252.             end;   {with BoundRect}
  253.     end;
  254.  
  255.  
  256.     procedure SubtractBackground2D;
  257. {*****************************************************************************}
  258. {*     This procedure subtracts each pixel from the calculated/interpolated/extrapolated background from the  *}
  259. {*  corresponding pixel value in the original image.  The resulting image is stored in place of the original        *}
  260. {*  image.  Any pixel subtractions with results below zero are given the value zero.                                           *}
  261. {*****************************************************************************}
  262.         var
  263.             hloc, vloc,                                          {current pixel location in image and background}
  264.             pvalue: integer;                                 {difference at current pixel location}
  265.             offset,                                                 {offset in memory from beginning of original image to current scan line}
  266.             backgrpt: LongInt;                              {offset to current point in background}
  267.             p: ptr;                                                {temporary pointer to image or background points}
  268.             Databand: Linetype;                           {current scan line in image}
  269.             ControlKey: boolean;
  270.     begin
  271.         backgrpt := 0;
  272.         ControlKey := ControlKeyDown;
  273.         with Info^, BoundRect do begin
  274.                 for vloc := top to bottom - 1 do begin
  275.                         GetLine(0, vloc, pixelsperline, Databand);
  276.                         for hloc := left to right - 1 do begin
  277.                                 p := ptr(backgroundaddr + backgrpt);
  278.                                 pvalue := Databand[hloc] - BAND(p^, 255);
  279.                                 if ControlKey then
  280.                                     pvalue := BAND(p^, 255);
  281.                                 if pvalue < 0 then
  282.                                     Databand[hloc] := 0
  283.                                 else
  284.                                     Databand[hloc] := pvalue;
  285.                                 backgrpt := backgrpt + 1;
  286.                             end;     {for}
  287.                         offset := LongInt(vloc) * BytesPerRow;
  288.                         p := ptr(ord4(PicBaseAddr) + offset);
  289.                         BlockMove(@Databand, p, pixelsperline);
  290.                     end;  {for}
  291.             end;     {with}
  292.     end;
  293.  
  294.  
  295.     procedure Background2D;
  296. {******************************************************************************}
  297. {*     This procedure implements a rolling-ball algorithm for the removal of smooth continuous background       *}
  298. {*  from a two-dimensional gel image.  It rolls the ball (actually a square patch on the top of a sphere) on a       *}
  299. {*  low-resolution (by a factor of 'shrinkfactor' times) copy of the original image in order to increase speed     *}
  300. {*  with little loss in accuracy.  It uses interpolation and extrapolation to blow the shrunk image to full size.     *}
  301. {******************************************************************************}
  302.         var
  303.             tport: Grafptr;
  304.             i,                                     {loop index for shrunk image memory}
  305.             backgroundsize,              {size of the background memory}
  306.             smallimagesize: Size;     {size of the shrunk image memory}
  307.             p: ptr;                             {pointer to current pixel in shrunk image memory}
  308.             table: FateTable;             {not used}
  309.     begin
  310.         ShowWatch;
  311.         UpdateMeter(0, 'Building Rolling Ball...');
  312.         GetPort(tPort);
  313.         with Info^ do begin
  314.                 SetPort(GrafPtr(osPort));
  315.                 BoundRect := roiRect;
  316.             end;
  317.         GetRollingBall;                                                                  {precompute the rolling ball}
  318.         UpdateMeter(3, 'Building Rolling Ball...');
  319.         balladdr := ord4(ballptr);
  320.         with BoundRect do begin
  321.                 leftroll := left div shrinkfactor;                                  {left and right edges of shrunken image or roi}
  322.                 rightroll := right div shrinkfactor - 1;                      {on which to roll ball}
  323.                 toproll := top div shrinkfactor;
  324.                 bottomroll := bottom div shrinkfactor - 1;
  325.                 backgroundsize := longint(right - left) * longint(bottom - top);
  326.                 backgroundptr := NewPtrToClearBuf(backgroundsize);
  327.                 Aborting := backgroundptr = nil;
  328.                 backgroundaddr := ord4(backgroundptr);
  329.                 smallimagesize := longint(rightroll - leftroll + 1) * longint(bottomroll - toproll + 1);
  330.                 smallimageptr := NewPtrToClearBuf(smallimagesize);
  331.                 Aborting := Aborting or (smallimageptr = nil);
  332.                 smallimageaddr := ord4(smallimageptr);
  333.                 if not aborting then begin
  334.                         UpdateMeter(6, 'Smoothing Image ');
  335.                         filter(unweightedAvg, 1, table);                                {smooth image before shrinking}
  336.                         UpdateMeter(10, concat('Shrinking Image ', long2str(shrinkfactor), ' times...'));
  337.                         for i := 0 to smallimagesize - 1 do begin                {create a lower resolution image for ball-rolling}
  338.                                 p := ptr(smallimageaddr + i);
  339.                                 xmaskmin := left + shrinkfactor * (i mod (rightroll - leftroll + 1));
  340.                                 ymaskmin := top + shrinkfactor * (i div (rightroll - leftroll + 1));
  341.                                 p^ := MinIn2DMask;                            {each point in small image is minimum of its neighborhood}
  342.                             end;
  343.                         if not aborting then begin
  344.                                 Undo;        {restore original unsmoothed image}
  345.                                 RollBall;
  346.                             end;
  347.                     end
  348.                 else
  349.                     beep;
  350.                 if not Aborting then begin
  351.                         UpdateMeter(90, 'Interpolating Background...');
  352.                         InterpolateBackground2D;                              {interpolate to find background interior}
  353.                         UpdateMeter(95, 'Extrapolating Background...');
  354.                         ExtrapolateBackground2D;                             {extrapolate on top and bottom}
  355.                         UpdateMeter(98, 'Subtracting Background...');
  356.                         SubtractBackground2D;                                  {subtract background from original image}
  357.                         UpdateMeter(100, 'Subtracting Background...');
  358.                     end;
  359.             end;   {with boundrect}
  360.         DisposPtr(backgroundptr);                           {free up background, rolling ball, shrunk image memory}
  361.         DisposPtr(ballptr);
  362.         DisposPtr(smallimageptr);
  363.         DisposeWindow(MeterWindow);
  364.         MeterWindow := nil;
  365.         SetPort(tPort);
  366.     end;
  367.  
  368.  
  369.     procedure RollArc (left, rightminusone, diam: integer; var background, ballpoints: IntRow; var Dataline: Linetype);
  370.         var
  371.             xpt, xpt2, xval, ydif, ymin, yctr, bpt, yadd: integer;
  372.     begin
  373.         for xpt := left to rightminusone do begin
  374.                 background[xpt] := -255;         {init background curve to minimum values}
  375.             end;
  376.         yctr := 0;                                   {start y-center at the x axis}
  377.         for xpt := left to (rightminusone + diam - 1) do {while semicircle is tangent to edges or within curve...}
  378.             begin                                       {xpt is far right edge of semi-circle}
  379. {do we have to move the circle?...}
  380.                 ymin := 256;                          {highest could ever be 255}
  381.                 bpt := 0;
  382.                 xpt2 := xpt - diam;                {xpt2 is far left edge of semi-circle}
  383.                 while xpt2 <= xpt do            {check every point on semicircle}
  384.                     begin
  385.                         if ((xpt2 >= left) and (xpt2 <= rightminusone)) then begin  {only examine points on curve}
  386.                                 ydif := dataline[xpt2] - (yctr + ballpoints[bpt]);                {curve minus circle points}
  387.                                 if (ydif < ymin) then begin {keep most negative, since ball should always be below curve}
  388.                                         ymin := ydif;
  389.                                     end;
  390.                             end;  {if xpt2 }
  391.                         bpt := bpt + 1;
  392.                         xpt2 := xpt2 + 1;
  393.                     end;  {while xpt2 }
  394.                 if (ymin <> 256) then{if we found a new minimum...}
  395.                     yctr := yctr + ymin;   {move circle up or down}
  396. {now compare every point on semi with background,  and keep highest number}
  397.                 xval := xpt - diam;
  398.                 xpt2 := 0;
  399.                 while xpt2 <= diam do begin  {for all the points in the semicircle}
  400.                         if ((xval >= left) and (xval <= rightminusone)) then begin
  401.                                 yadd := yctr + ballpoints[xpt2];
  402.                                 if (yadd > background[xval]) then  {keep largest adjustment}
  403.                                     background[xval] := yadd;
  404.                             end;
  405.                         xval := xval + 1;
  406.                         xpt2 := xpt2 + 1;
  407.                     end;  {while xpt2}
  408.             end;  {for xpt }
  409.     end;
  410.  
  411.  
  412.     function MinIn1DMask (var Databand: LineType; xcenter: integer): integer;
  413. {*******************************************************************************}
  414. {*     MinIn1DMask finds the minimum pixel value in a (2*shrinkfactor-1) mask about the point xcenter in the *}
  415. {*  current line.  This code must run FAST because it gets called OFTEN!                                                                   *}
  416. {*******************************************************************************}
  417.         var
  418.             i,                                                                              {index to pixels in the mask}
  419.             temp: integer;                                                          {temporary minimum value}
  420.     begin
  421.         temp := Databand[xcenter - shrinkfactor + 1];
  422.         for i := xcenter - shrinkfactor + 2 to xcenter + shrinkfactor - 1 do
  423.             if (Databand[i] < temp) then
  424.                 temp := Databand[i];
  425.         MinIn1DMask := temp;
  426.     end;
  427.  
  428.  
  429. {******************************************************************************}
  430. {*     This procedure computes the location of each point on the rolling arc relative to the center of the circle     *}
  431. {*  containing it.  The arc is located in the top half of this circle.  The vertical axis of the circle passes through  *}
  432. {*  the midpoint of the arc.  The projection of the arc on the x-axis below is a line segment.                                 *}
  433. {******************************************************************************}
  434.     procedure GetRollingArc (var arcpoints: IntRow; var arcwidth: integer);
  435.         var
  436.             xpt,                                                                                 {x-point along arc}
  437.             xval,                                                                               {x-point in arc array}
  438.             rsquare,                                                                         {shrunken arc radius squared}
  439.             xtrim,                                                                            {points to be trimmed off each end of arc}
  440.             smallballradius,                                                            {radius of shrunken arc which actually rolls}
  441.             diam: integer;                                                                 {diameter of shrunken arc's circle}
  442.     begin
  443.         smallballradius := ballradius div shrinkfactor;            { operate on small-sized image with small-sized ball}
  444.         rsquare := smallballradius * smallballradius;
  445.         for xpt := -smallballradius to smallballradius do        { find the ballpoints for arc based at  (x,y)=(0,0) }
  446.             begin
  447.                 xval := xpt + smallballradius;                                     {offset, can't have negative index}
  448.                 arcpoints[xval] := round(sqrt(abs(rsquare - (xpt * xpt))));  {Ys are positive, top half of circle}
  449.             end;
  450.         diam := smallballradius * 2;
  451.         xtrim := (ArcTrimPer * diam) div 100;                       {how many points to trim off each end}
  452.         arcwidth := diam - xtrim - xtrim;
  453.         for xpt := -smallballradius to smallballradius - xtrim - xtrim do begin
  454.                 xval := xpt + smallballradius;
  455.                 arcpoints[xval] := arcpoints[xval + xtrim];
  456.             end;
  457.         for xpt := smallballradius - xtrim - xtrim + 1 to smallballradius do begin
  458.                 xval := xpt + smallballradius;
  459.                 arcpoints[xval] := 0;
  460.             end;
  461.     end;
  462.  
  463.  
  464.     procedure ExtrapolateBackground1D (var Backline, Dataline: LineType; background: IntRow; leftroll, rightroll: integer);
  465. {******************************************************************************}
  466. {*     This procedure uses linear extrapolation to find pixel values on the left and right edges of the current        *}
  467. {*  line of the background.  It finds the edge points by extrapolating from the edges of the calculated and               *}
  468. {*  interpolated background interior.  If extrapolation yields values below zero or above 255, then they are set *}
  469. {*  to zero and 255 respectively.                                                                                                                               *}
  470. {*********umpixels);            {fast whole line write}
  471.                             end;
  472.                     RollingVerticalArc: 
  473.                         PutColumn(vloc, 0, numpixels, Dataline);         {slow whole column write}
  474.                 end;     {case}
  475.                 if ((vloc mod 8) = 0) and (vloc > 16) then begin
  476.                         UpdateMeter((LongInt(vloc - top) * 100) div (bottom - top - 1), str);
  477.                         if CommandPeriod then begin
  478.                                 beep;
  479.                                 Aborting := true;
  480.                                 leave;
  481.                             end;
  482.                     end;
  483.             end;
  484.         UpdateMeter(100, str);
  485.         DisposeWindow(MeterWindow);
  486.         MeterWindow := nil;
  487.         SetPort(tPort);
  488.     end;
  489.  
  490.     procedure SetUpGel;
  491.         var
  492.             frame: rect;
  493.             AutoSelectAll: boolean;
  494.             p: ptr;
  495.     begin
  496.         if NotinBounds or NotRectangular then
  497.             exit(SetUpGel);
  498.         StopDigitizing;
  499.         AutoSelectAll := not Info^.RoiShowing;
  500.         if AutoSelectAll then
  501.             SelectAll(false);
  502.         SetupUndoFromClip;
  503.         with info^ do begin
  504.                 frame := roiRect;
  505.                 if ((LutMode = GrayScale) or (LutMode = CustomGrayscale)) and (not IdentityFunction) then
  506.                     ApplyLookupTable;
  507.                 changes := true;
  508.             end;
  509.         case BackSubKind of
  510.             RollingHorizontalArc, RollingVerticalArc: 
  511.                 Background1D;    {--------------> call background subtract <-------------------}
  512.             RollingBall: 
  513.                 Background2D;
  514.             RollingBothArcs:  begin
  515.                     BackSubKind := RollingHorizontalArc;           {remove horizontal streaks}
  516.                     Background1D;
  517.                     BackSubKind := RollingVerticalArc;               {remove vertical streaks}
  518.                     if not aborting then
  519.                         Background1D;
  520.                     BackSubKind := RollingBothArcs;                   {leave BackSubKind as we found it}
  521.                 end;
  522.         end;     {case}
  523.         UpdatePicWindow;
  524.         SetUpRoiRect;
  525.         WhatToUndo := UndoFilter;
  526.         Info^.changes := true;
  527.         ShowWatch;
  528.         if AutoSelectAll then
  529.             KillRoi;
  530.         if Aborting then begin
  531.                 Undo;
  532.                 WhatToUndo := NothingToUndo;
  533.                 UpdatePicWindow;
  534.             end;
  535.     end;
  536.  
  537.  
  538.     procedure GetBallRadius;
  539.         var
  540.             SaveRadius: integer;
  541.             canceled: boolean;
  542.     begin
  543.         SaveRadius := BallRadius;
  544.         BallRadius := GetInt('Rolling BallRadius:', BallRadius, canceled);
  545.         if (BallRadius < 1) or (BallRadius > 319) or canceled then begin
  546.                 BallRadius := SaveRadius;
  547.                 if not canceled then
  548.                     beep;
  549.             end;
  550.     end;
  551.  
  552.  
  553.     procedure DoBackgroundMenuEvent (MenuItem: integer);
  554.         var
  555.             map_array: Ptr;
  556.     begin
  557.         MeterWindow := nil;
  558.         Aborting := false;
  559.         case MenuItem of
  560.             HorizontalItem, VerticalItem:  begin
  561.                     if FasterBackgroundSubtraction then begin
  562.                             ArcTrimPer := 20;
  563.                             shrinkfactor := 4;
  564.                         end
  565.                     else begin
  566.                             ArcTrimPer := 10;
  567.                             shrinkfactor := 2;
  568.                         end;
  569.                     if MenuItem = HorizontalItem then
  570.                         BackSubKind := RollingHorizontalArc
  571.                     else
  572.                         BackSubKind := RollingVerticalArc;
  573.                     SetUpGel;
  574.                 end;
  575.             Sub2DItem:  begin
  576.                     if FasterBackgroundSubtraction then begin
  577.                             if BallRadius > 15 then begin
  578.                                     ArcTrimPer := 20;     {trim 40% in x and y}
  579.                                     shrinkfactor := 8;
  580.                                 end
  581.                             else begin
  582.                                     ArcTrimPer := 16;  {trim 32% in x and y}
  583.                                     shrinkfactor := 4;
  584.                                 end
  585.                         end
  586.                     else begin  {faster not checked}
  587.                             if BallRadius > 15 then begin
  588.                                     ArcTrimPer := 16;  {trim 32% in x and y}
  589.                                     shrinkfactor := 4;
  590.                                 end
  591.                             else begin
  592.                                     ArcTrimPer := 12;   {trim 24% in x and y}
  593.                                     ShrinkFactor := 2;
  594.                                 end
  595.                         end;
  596.                     BackSubKind := RollingBall;
  597.                     SetUpGel;
  598.                 end;
  599.             RemoveStreaksItem:  begin
  600.                     ArcTrimPer := 20;
  601.                     shrinkfactor := 4;
  602.                     BackSubKind := RollingBothArcs;
  603.                     SetUpGel;
  604.                 end;
  605.             FasterItem: 
  606.                 FasterBackgroundSubtraction := not FasterBackgroundSubtraction;
  607.             RadiusItem: 
  608.                 GetBallRadius;
  609.         end; {case}
  610.     end;
  611.  
  612.  
  613. end.