home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Pascal / Applications / NIH Image 1.55 / Source / User.p < prev    next >
Encoding:
Text File  |  1994-04-20  |  10.5 KB  |  404 lines  |  [TEXT/PJMM]
  1. am3: extended);
  2.  
  3.  
  4. implementation
  5.  
  6. {User global variables go here.}
  7.     var
  8.         color, MinSpacing: integer;
  9.         SaveInfo: InfoPtr;
  10.         PeakRadius, Peakedness: extended;
  11.  
  12.  
  13.     procedure InitUser;
  14.     begin
  15.         UserMenuH := GetMenu(UserMenu);
  16.         InsertMenu(UserMenuH, 0);
  17.         DrawMenuBar;
  18. {Additional user initialization code goes here.}
  19.     end;
  20.  
  21.  
  22.     procedure DrawDot (row, column, RowOffset, ColumnOffset: integer; big: boolean);
  23.         var
  24.             h, v: integer;
  25.     begin
  26.         if big then begin
  27.                 for h := -1 to 1 do
  28.                     for v := -1 to 1 do
  29.                         PutPixel(column * 16 + ColumnOffset * 4 + h + 16, row * 16 + RowOffset * 4 + v + 16, color)
  30.             end
  31.         else
  32.             PutPixel(column * 16 + ColumnOffset * 4 + 16, row * 16 + RowOffset * 4 + 16, color);
  33.     end;
  34.  
  35.     procedure DrawNeighborhood (i, row, column: integer);
  36.  
  37.     begin
  38.         DrawDot(row, column, 0, 0, BitAnd(i, 1) = 1);
  39.         DrawDot(row, column, 0, 1, BitAnd(i, 2) = 2);
  40.         DrawDot(row, column, 0, 2, BitAnd(i, 4) = 4);
  41.         DrawDot(row, column, 1, 2, BitAnd(i, 8) = 8);
  42.         DrawDot(row, column, 2, 2, BitAnd(i, 16) = 16);
  43.         DrawDot(row, column, 2, 1, BitAnd(i, 32) = 32);
  44.         DrawDot(row, column, 2, 0, BitAnd(i, 64) = 64);
  45.         DrawDot(row, column, 1, 0, BitAnd(i, 128) = 128);
  46.         DrawDot(row, column, 1, 1, true);
  47.     end;
  48.  
  49.  
  50.     procedure SetColor (i: integer);
  51. {Color neighborhoods to show which ones would be removed on the first pass(150), second pass(100),}
  52. {or either pass(200) when using the Zhang and Suen thinning algorithm(CACM, Mar. 1984,236-239).}
  53.         var
  54.             p2, p3, p4, p5, p6, p7, p8, p9, A, B: integer;
  55.     begin
  56.         p2 := bsr(band(i, 2), 1);
  57.         p3 := bsr(band(i, 4), 2);
  58.         p4 := bsr(band(i, 8), 3);
  59.         p5 := bsr(band(i, 16), 4);
  60.         p6 := bsr(band(i, 32), 5);
  61.         p7 := bsr(band(i, 64), 6);
  62.         p8 := bsr(band(i, 128), 7);
  63.         p9 := band(i, 1);
  64.         A := 0;
  65.         if (p2 = 0) and (p3 = 1) then
  66.             A := A + 1;
  67.         if (p3 = 0) and (p4 = 1) then
  68.             A := A + 1;
  69.         if (p4 = 0) and (p5 = 1) then
  70.             A := A + 1;
  71.         if (p5 = 0) and (p6 = 1) then
  72.             A := A + 1;
  73.         if (p6 = 0) and (p7 = 1) then
  74.             A := A + 1;
  75.         if (p7 = 0) and (p8 = 1) then
  76.             A := A + 1;
  77.         if (p8 = 0) and (p9 = 1) then
  78.             A := A + 1;
  79.         if (p9 = 0) and (p2 = 1) then
  80.             A := A + 1;
  81.         B := p2 + p3 + p4 + p5 + p6 + p7 + p8 + p9;
  82.         color := 255;
  83.         if A = 1 then
  84.             if (B >= 2) and (B <= 6) then begin
  85.                     if ((p2 * p4 * p6 = 0) and (p4 * p6 * p8 = 0)) and ((p2 * p4 * p8 = 0) and (p2 * p6 * p8 = 0)) then
  86.                         color := 200
  87.                     else if (p2 * p4 * p6 = 0) and (p4 * p6 * p8 = 0) then
  88.                         color := 150
  89.                     else if (p2 * p4 * p8 = 0) and (p2 * p6 * p8 = 0) then
  90.                         color := 100;
  91.                 end;
  92.     end;
  93.  
  94.  
  95.     procedure DoUserCommand1;
  96. {Generates a table showing all possible 3x3 neighborhoods. This table is used}
  97. { for making up the "fate table" used by the Skeletonize command and the Wand tool.}
  98.         var
  99.             row, column, index: integer;
  100.     begin
  101.         row := 0;
  102.         column := 0;
  103.         if NewPicWindow('Fate Table', 600, 200) then
  104.             for index := 0 to 255 do begin
  105.                     SetColor(index);
  106.                     DrawNeighborhood(index, row, column);
  107.                     column := column + 1;
  108.                     if column = 32 then begin
  109.                             row := row + 1;
  110.                             column := 0;
  111.                         end;
  112.                 end;
  113.     end;
  114.  
  115.  
  116.     function isPeak (x, y, MinValue: integer): boolean;
  117.         var
  118.             delta, angle, dx, dy: real;
  119.             v, i, v2, maxv2, x2, y2, v2count, nSamples: integer;
  120.             sample: LineType;
  121.             minlower, count, nLower, maxCount: integer;
  122.             PeakFound: boolean;
  123.             mask: rect;
  124.     begin
  125.         isPeak := false;
  126.         v := MyGetPixel(x, y);
  127.         if v < MinValue then
  128.             exit(isPeak);
  129.         if v <= MyGetPixel(x + 1, y) then
  130.             exit(isPeak);
  131.         if v <= MyGetPixel(x + 1, y + 1) then
  132.             exit(isPeak);
  133.         if v <= MyGetPixel(x, y + 1) then
  134.             exit(isPeak);
  135.         if v <= MyGetPixel(x - 1, y + 1) then
  136.             exit(isPeak);
  137.         if v < MyGetPixel(x - 1, y) then
  138.             exit(isPeak);
  139.         if (v < MyGetPixel(x - 1, y - 1)) then
  140.             exit(isPeak);
  141.         if v < MyGetPixel(x, y - 1) then
  142.             exit(isPeak);
  143.         if v < MyGetPixel(x + 1, y - 1) then
  144.             exit(isPeak);
  145.         nSamples := round(4 * PeakRadius);
  146.         delta := 2.0 * pi / nsamples;
  147.         angle := 0.0;
  148.         maxv2 := round((1.0 - Peakedness) * v);
  149.         for i := 1 to nSamples do begin
  150.                 dx := PeakRadius * cos(angle);
  151.                 dy := PeakRadius * sin(angle);
  152.                 sample[i] := round(GetInterpolatedPixel(x + dx, y + dy));
  153.                 angle := angle + delta;
  154.             end;
  155.         minLower := round(0.677 * nsamples);
  156.         PeakFound := false;
  157.         count := 0;
  158.         i := 1;
  159.         nLower := 0;
  160.         maxCount := nSamples + minLower;
  161.         repeat
  162.             if sample[i] <= maxv2 then
  163.                 nLower := nLower + 1
  164.             else
  165.                 nLower := 0;
  166.             PeakFound := nLower >= minLower;
  167.             i := i + 1;
  168.             if i > nSamples then
  169.                 i := 1;
  170.             count := count + 1;
  171.         until PeakFound or (count = maxCount);
  172.         if PeakFound then begin
  173.                 info := SaveInfo;
  174.                 with info^ do begin
  175.                         SetRect(RoiRect, x - MinSpacing + 1, y - MinSpacing + 1, x + MinSpacing, y + MinSpacing);
  176.                         with RoiRect do begin
  177.                                 if left < 0 then
  178.                                     left := 0;
  179.                                 if top < 0 then
  180.                                     top := 0;
  181.                                 if right > PicRect.right then
  182.                                     right := PicRect.right;
  183.                                 if bottom > PicRect.bottom then
  184.                                     bottom := PicRect.bottom;
  185.                             end;
  186.                         GetRectHistogram;
  187.                         PeakFound := histogram[0] = 0;
  188.                     end; {with}
  189.                 Info := UndoInfo;
  190.             end;
  191.         isPeak := PeakFound;
  192.     end;
  193.  
  194.  
  195.     procedure FindPeaks (MinValue, PeakRadiusP, PeakednessP: extended);
  196.         var
  197.             x, y, i, iMinValue: integer;
  198.             AutoSelectAll: boolean;
  199.             srect, mask: rect;
  200.             count: LongInt;
  201.             t: FateTable;
  202.     begin
  203.         if NotRectangular or NotInBounds or NoUndo then
  204.             exit(FindPeaks);
  205.         iMinValue := round(MinValue);
  206.         if iMinValue < 10 then
  207.             iMinValue := 10;
  208.         if iMinValue > 150 then
  209.             iMinValue := 150;
  210.         PeakRadius := PeakRadiusP;
  211.         if PeakRadius = 0.0 then
  212.             PeakRadius := 6.0;
  213.         if PeakRadius < 1.0 then
  214.             PeakRadius := 1.0;
  215.         if PeakRadius > 50.0 then
  216.             PeakRadius := 50.0;
  217.         MinSpacing := round(PeakRadius) - 1;
  218.         if MinSpacing < 1 then
  219.             MinSpacing := 1;
  220.         if MinSpacing > 4 then
  221.             MinSpacing := 4;
  222.         Peakedness := PeakednessP;
  223.         if Peakedness = 0.0 then
  224.             Peakedness := 0.2;
  225.         if Peakedness < 0.05 then
  226.             Peakedness := 0.05;
  227.         if Peakedness > 0.95 then
  228.             Peakedness := 0.95;
  229.         AutoSelectAll := not Info^.RoiShowing;
  230.         if AutoSelectAll then
  231.             SelectAll(true);
  232.         ShowWatch;
  233.         SetupUndo;
  234.         WhatToUndo := UndoEdit;
  235.         SetupUndoInfoRec;
  236.         SaveInfo := Info;
  237.         srect := info^.roiRect;
  238.         KillRoi;
  239.         ChangeValues(0, 0, 1);
  240.         info := UndoInfo;
  241.         count := 0;
  242.         with srect do
  243.             for y := top to bottom - 1 do begin
  244.                     if CommandPeriod then begin
  245.                             beep;
  246.                             Info := SaveInfo;
  247.                             leave;
  248.                         end;
  249.                     for x := left to right - 1 do
  250.                         if isPeak(x, y, iMinValue) then begin
  251.                                 count := count + 1;
  252.                                 Info := SaveInfo;
  253.                                 PutPixel(x, y, 0);
  254. {PutPixel(x - 1, y, 0);}
  255. {PutPixel(x - 1, y - 1, 0);}
  256. {PutPixel(x, y - 1, 0);}
  257.                                 SetRect(mask, x - 1, y - 1, x + 1, y + 1);
  258.                                 UpdateScreen(mask);
  259.                                 Info := UndoInfo;
  260.                                 if count < MaxMeasurements then begin
  261.                                         User1^[count] := x;
  262.                                         User2^[count] := y;
  263.                                     end;
  264.                                 ShowMessage(concat(long2str(y), '  ', long2str(count)));
  265.                             end;
  266.                 end;
  267.         Info := SaveInfo;
  268.         if count < MaxMeasurements then begin
  269.                 UnsavedResults := false;
  270.                 ResetCounter;
  271.                 for i := 1 to count do begin
  272.                         ClearResults(i);
  273.                         xcenter^[i] := User1^[i];
  274.                         ycenter^[i] := User2^[i];
  275.                     end;
  276.                 mCount := count;
  277.                 UpdateList;
  278.                 ShowInfo;
  279.             end
  280.         else
  281.             PutMessage('"Max Measurements" is too small.');
  282.         ShowMessage(concat('Count=', long2str(count), cr, 'Threshold=', long2str(iMinValue)));
  283.     end;
  284.  
  285.  
  286.  
  287.     procedure ComputeBirefringence (scale, offset: real);
  288. {This an example of how to do image math using a UserCode macro routine.}
  289. {It executes the following formula}
  290.  
  291.       {SQRT ( ( I1 - I2 ) ^ 2 + ( I3 - I4 ) ^ 2 ) / ( I1 + I2 - I3 + I4 ) ,}
  292.  
  293. {where I1 , I2 , I3 , I4  are the first four slices of the current stack.}
  294. {The result in the fifth slice of the stack.}
  295.  
  296.         var
  297.             i1, i2, i3, i4, i5: LineType;
  298.             i, slice, row: integer;
  299.             mask: rect;
  300.             v, min, max: real;
  301.             minstr, maxstr: str255;
  302.     begin
  303.         with info^ do begin
  304.                 if StackInfo = nil then
  305.                     exit(ComputeBirefringence);
  306.                 if StackInfo^.nSlices <> 5 then
  307.                     exit(ComputeBirefringence);
  308.                 min := 1.0e12;
  309.                 max := 1.0e-12;
  310.                 for row := 0 to nLines - 1 do begin
  311.                         SelectSlice(1);
  312.                         GetLine(0, row, PixelsPerLine, i1);
  313.                         SelectSlice(2);
  314.                         GetLine(0, row, PixelsPerLine, i2);
  315.                         SelectSlice(3);
  316.                         GetLine(0, row, PixelsPerLine, i3);
  317.                         SelectSlice(4);
  318.                         GetLine(0, row, PixelsPerLine, i4);
  319.                         for i := 0 to PixelsPerLine - 1 do begin
  320.                                 v := sqrt(sqr(I1[i] - I2[i]) + sqr(I3[i] - I4[i])) / (I1[i] + I2[i] - I3[i] + I4[i]);
  321.                                 if v < min then
  322.                                     min := v;
  323.                                 if v > max then
  324.                                     max := v;
  325.                                 if v > 255 then
  326.                                     v := 255;
  327.                                 if v < 0 then
  328.                                     v := 0;
  329.                                 v := v * scale + offset;
  330.                                 i5[i] := round(v);
  331.                             end;
  332.                         SelectSlice(5);
  333.                         PutLine(0, row, PixelsPerLine, i5);
  334.                         SetRect(mask, 0, row, PixelsPerLine, row + 1);
  335.                         UpdateScreen(mask);
  336.                         if CommandPeriod then
  337.                             leave;
  338.                     end;
  339.             end;
  340.         RealToString(min, 1, 4, minstr);
  341.         RealToString(max, 1, 4, maxstr);
  342.         ShowMessage(concat('min=', minstr, cr, 'max=', maxstr));
  343.     end;
  344.  
  345.  
  346.     procedure ShowNoCodeMessage;
  347.     begin
  348.         PutMessage('Requires user written Think Pascal routine. ');
  349.     end;
  350.  
  351.  
  352.     procedure DoUserCommand2;
  353.     begin
  354.         ShowNoCodeMessage
  355.     end;
  356.  
  357.  
  358.     procedure DoUserMenuEvent (MenuItem: integer);
  359.     begin
  360.         case MenuItem of
  361.             1: 
  362.                 DoUserCommand1;
  363.             2: 
  364.                 DoUserCommand2;
  365.         end;
  366.     end;
  367.  
  368.  
  369.     procedure OldUserMacroCode (CodeNumber: integer; Param1, Param2, Param3: extended);
  370.   {Obsolete version kept for backward compatibilty.}
  371.     begin
  372.         case CodeNumber of
  373.             1: 
  374.                 ShowNoCodeMessage;
  375.             2: 
  376.                 ShowNoCodeMessage;
  377.             3: 
  378.                 ShowNoCodeMessage;
  379.             4: 
  380.                 ShowNoCodeMessage;
  381.             5: 
  382.                 FindPeaks(param1, param2, param3);
  383.             otherwise
  384.                 ShowNoCodeMessage;
  385.         end;
  386.     end;
  387.  
  388.  
  389.     procedure UserMacroCode (str: str255; Param1, Param2, Param3: extended);
  390.     begin
  391.         MakeLowerCase(str);
  392.         if pos('peaks', str) <> 0 then begin
  393.                 FindPeaks(param1, param2, param3);
  394.                 exit(UserMacroCode);
  395.             end;
  396.         if pos('birefringence', str) <> 0 then begin
  397.                 ComputeBirefringence(param1, param2);
  398.                 exit(UserMacroCode);
  399.             end;
  400.         ShowNoCodeMessage;
  401.     end;
  402.  
  403.  
  404. end.