unit Functions; {} interface uses QuickDraw, OSIntf, PickerIntf, ToolIntf, PrintTraps, globals, Utilities, Graphics, File1, Analysis, Camera, Edit; procedure ApplyTable (var table: LookupTable); procedure ApplyLookupTable; procedure MakeBinary; procedure Filter (ftype: FilterType; pass: integer; var table: FateTable); procedure PhotoMode; procedure Animate; procedure EnhanceContrast; procedure EqualizeHistogram; procedure SortPalette (item: integer); procedure Convolve; procedure Do3DPlot; procedure MakeSkeleton; procedure DoErosion; procedure DoDilation; procedure DoOpening; procedure DoClosing; procedure SetIterations; procedure ChangeValues; procedure PropagateLUT; procedure DoArithmetic (MenuItem: integer); procedure UpdateEditMenu; { moved here from Edit (unit size limits) - Arlo } implementation const MaxW = 4000; type ktype = array[0..MaxW] of integer; var PixelsRemoved: LongInt; procedure ApplyTableToLine (data: ptr; var table: LookupTable; width: LongInt); {$IFC false} type lptr = ^LineType; var line: lptr; i: integer; begin line := lptr(data); for i := 0 to width - 1 do Line^[i] := table[Line^[i]]; end; {$ENDC} {a0 = data} {a1 = lookup table} {d0 = width } {d1 = pixel value} inline $4E56, $0000, { link a6,#0} $48E7, $C0C0, { movem.l a0-a1/d0-d1,-(sp)} $206E, $000C, { move.l 12(a6),a0} $226E, $0008, { move.l 8(a6),a1} $202E, $0004, { move.l 4(a6),d0} $5380, { subq.l #1,d0} $4281, { clr.l d1} $1210, {L move.b (a0),d1} $10F1, $1000, { move.b 0(a1,d1.w),(a0)+} $51C8, $FFF8, { dbra d0,L} $4CDF, $0303, { movem.l (sp)+,a0-a1/d0-d1} $4E5E, { unlk a6} $DEFC, $000C; { add.w #12,sp} procedure PutLineUsingMask (h, v, count: integer; var line: LineType); var aLine, MaskLine: LineType; i: integer; SaveInfo: InfoPtr; begin GetLine(h, v, count, aline); SaveInfo := Info; Info := UndoInfo; GetLine(h, v, count, MaskLine); for i := 0 to count - 1 do if MaskLine[i] = BlackIndex then aLine[i] := line[i]; info := SaveInfo; PutLine(h, v, count, aLine); end; procedure ApplyTable; {(var table: LookupTable)} var width, NumberOfLines, i, hloc, vloc: integer; offset: LongInt; p: ptr; UseMask: boolean; TempLine: LineType; AutoSelectAll: boolean; begin if NotInBounds then exit(ApplyTable); StopDigitizing; AutoSelectAll := not Info^.RoiShowing; if AutoSelectAll then SelectAll(false); ShowWatch; with info^.osroiRect, info^ do begin if RoiType <> RectRoi then UseMask := SetupMask else UseMask := false; WhatToUndo := UndoTransform; SetupUndoFromClip; offset := LongInt(top) * BytesPerRow + left; if UseMask then p := @TempLine else p := ptr(ord4(PicBaseAddr) + offset); width := right - left; NumberOfLines := bottom - top; hloc := left; vloc := top; end; if width > 0 then for i := 1 to NumberOfLines do if UseMask then begin GetLine(hloc, vloc, width, TempLine); ApplyTableToLine(p, table, width); PutLineUsingMask(hloc, vloc, width, TempLine); vloc := vloc + 1 end else begin ApplyTableToLine(p, table, width); p := ptr(ord4(p) + info^.BytesPerRow); end; with info^ do begin UpdateScreen(roiRect); Info^.changes := true; end; SetupRoiRect; if AutoSelectAll then KillRoi; end; function DoApplyTableDialogBox: boolean; const Button1 = 3; Button2 = 4; Button3 = 5; Button4 = 6; var mylog: DialogPtr; item: integer; SaveA, SaveB: boolean; procedure SetButtons; begin SetDialogItem(mylog, Button1, ord(ThresholdToForeground)); SetDialogItem(mylog, Button2, ord(not ThresholdToForeground)); SetDialogItem(mylog, Button3, ord(NonThresholdToBackground)); SetDialogItem(mylog, Button4, ord(not NonThresholdToBackground)); end; begin InitCursor; SaveA := ThresholdToForeground; SaveB := NonThresholdToBackground; mylog := GetNewDialog(40, nil, pointer(-1)); SetButtons; OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); if (item = Button1) or (item = button2) then begin ThresholdToForeground := not ThresholdToForeground; SetButtons; end; if (item = Button3) or (item = button4) then begin NonThresholdToBackground := not NonThresholdToBackground; SetButtons; end; until (item = ok) or (item = cancel); DisposDialog(mylog); if item = cancel then begin ThresholdToForeground := SaveA; NonThresholdToBackground := SaveB; DoApplyTableDialogBox := false end else DoApplyTableDialogBox := true; end; procedure ApplyLookupTable; var table: LookupTable; ConvertingColorPic, GrayScaleImage: boolean; begin with info^ do begin GrayScaleImage := (LUTMode = Grayscale) or (LUTMode = CustomGrayscale); ConvertingColorPic := not GrayScaleImage and not Thresholding; if ConvertingColorPic then KillRoi; if thresholding then begin if not DoApplyTableDialogBox then exit(ApplyLookupTable); end; if deltax <= 1 then BinaryPic := true; GetLookupTable(table); if GrayscaleImage or ConvertingColorPic then ResetGrayMap; ApplyTable(table); if ConvertingColorPic then WhatToUndo := NothingToUndo; end; {with} end; procedure MakeBinary; var table: LookupTable; SaveBackground, SaveForeground: integer; begin if not thresholding and (info^.deltax > 1) then PutMessage('Sorry, but you must be thresholding to use Make Binary.') else begin ThresholdToForeground := true; NonThresholdToBackground := true; SaveBackground := BackgroundIndex; SaveForeground := ForegroundIndex; BackgroundIndex := WhiteIndex; ForegroundIndex := BlackIndex; GetLookupTable(table); ResetGrayMap; ApplyTable(table); BackgroundIndex := SaveBackground; ForegroundIndex := SaveForeground; info^.BinaryPic := true; end; end; procedure Filter (ftype: FilterType; pass: integer; var table: FateTable); const PixelsPerUpdate = 5000; var row, width, r1, r2, r3, c, value, error, sum, center: integer; tmp, mark, NewMark, LinesPerUpdate, LineCount: integer; t1, t2, t3, t4: integer; MaskRect, frame, trect: rect; L1, L2, L3, result: LineType; tPort: GrafPtr; pt: point; a: SortArray; AutoSelectAll, UseMask: boolean; OptionKeyWasDown: boolean; L, T, R, B, index: integer; StartTicks: LongInt; begin if NotinBounds then exit(Filter); OptionKeyWasDown := OptionKeyDown; StopDigitizing; AutoSelectAll := not Info^.RoiShowing; if AutoSelectAll then begin SelectAll(false); PenNormal; PenPat(pat[PatIndex]); FrameRect(info^.wrect); end; ShowWatch; if info^.RoiType <> RectRoi then UseMask := SetupMask else UseMask := false; WhatToUndo := UndoFilter; if pass = 0 then begin SetupUndoFromClip; ShowMessage('Command-Period to cancel'); end; with info^ do if ((LutMode = GrayScale) or (LutMode = CustomGrayscale)) and (not IdentityFunction) then ApplyLookupTable; frame := info^.osroiRect; StartTicks := TickCount; with frame, Info^ do begin changes := true; RoiShowing := false; if left > 0 then left := left - 1; if right < PicRect.right then right := right + 1; width := right - left; LinesPerUpdate := PixelsPerUpdate div width; if ftype = ReduceNoise then LinesPerUpdate := LinesPerUpdate div 3; GetLine(left, top, width, L2); GetLine(left, top + 1, width, L3); Mark := roiRect.top; LineCount := 0; for row := top + 1 to bottom - 1 do begin {Move Convolution Window Down} BlockMove(@L2, @L1, width); BlockMove(@L3, @L2, width); GetLine(left, row + 1, width, L3); {Process One Row} case ftype of EdgeDetect: for c := 1 to width - 2 do begin t1 := L1[c] + L1[c + 1] + L1[c + 2] - L3[c] - L3[c + 1] - L3[c + 2]; t1 := abs(t1); t2 := L1[c + 2] + L2[c + 2] + L3[c + 2] - L1[c] - L2[c] - L3[c]; t2 := abs(t2); if t1 > t2 then tmp := t1 else tmp := t2; if OptionKeyWasDown then begin if tmp > 255 then tmp := 255; if tmp < 0 then tmp := 0; end else if tmp > 35 then tmp := 255 else tmp := 0; result[c - 1] := tmp; end; ReduceNoise: {Median Filter} for c := 1 to width - 2 do begin a[1] := L1[c]; a[2] := L1[c + 1]; a[3] := L1[c + 2]; a[4] := L2[c]; a[5] := L2[c + 1]; a[6] := L2[c + 2]; a[7] := L3[c]; a[8] := L3[c + 1]; a[9] := L3[c + 2]; result[c - 1] := FindMedian(a); end; Dither: {Floyd-Steinberg Algorithm} for c := 1 to width - 2 do begin value := L2[c + 1]; if value < 128 then begin result[c - 1] := 0; error := -value; end else begin result[c - 1] := 255; error := 255 - value end; tmp := L2[c + 2]; {A} tmp := tmp - (7 * error) div 16; if tmp < 0 then tmp := 0; if tmp > 255 then tmp := 255; L2[c + 2] := tmp; tmp := L3[c + 2]; {B} tmp := tmp - error div 16; if tmp < 0 then tmp := 0; if tmp > 255 then tmp := 255; L3[c + 2] := tmp; tmp := L3[c + 1]; {C} tmp := tmp - (5 * error) div 16; if tmp < 0 then tmp := 0; if tmp > 255 then tmp := 255; L3[c + 1] := tmp; tmp := L3[c]; {D} tmp := tmp - (3 * error) div 16; if tmp < 0 then tmp := 0; if tmp > 255 then tmp := 255; L3[c] := tmp; end; UnweightedAvg: for c := 1 to width - 2 do begin tmp := (L1[c] + L1[c + 1] + L1[c + 2] + L2[c] + L2[c + 1] + L2[c + 2] + L3[c] + L3[c + 1] + L3[c + 2]) div 9; if tmp > 255 then tmp := 255; if tmp < 0 then tmp := 0; result[c - 1] := tmp; end; WeightedAvg: for c := 1 to width - 2 do begin tmp := (L1[c] + L1[c + 1] + L1[c + 2] + L2[c] + L2[c + 1] * 4 + L2[c + 2] + L3[c] + L3[c + 1] + L3[c + 2]) div 12; if tmp > 255 then tmp := 255; if tmp < 0 then tmp := 0; result[c - 1] := tmp; end; fsharpen: for c := 1 to width - 2 do begin if OptionKeyWasDown then tmp := L2[c + 1] * 9 - L1[c] - L1[c + 1] - L1[c + 2] - L2[c] - L2[c + 2] - L3[c] - L3[c + 1] - L3[c + 2] else begin tmp := L2[c + 1] * 12 - L1[c] - L1[c + 1] - L1[c + 2] - L2[c] - L2[c + 2] - L3[c] - L3[c + 1] - L3[c + 2]; tmp := tmp div 4; end; if tmp > 255 then tmp := 255; if tmp < 0 then tmp := 0; result[c - 1] := tmp; end; Erosion: for c := 1 to width - 2 do begin center := L2[c + 1]; if center = BlackIndex then begin sum := L1[c] + L1[c + 1] + L1[c + 2] + L2[c] + L2[c + 2] + L3[c] + L3[c + 1] + L3[c + 2]; if sum < 1275 then center := WhiteIndex; end; result[c - 1] := center; end; Dilation: for c := 1 to width - 2 do begin center := L2[c + 1]; if center = WhiteIndex then begin sum := L1[c] + L1[c + 1] + L1[c + 2] + L2[c] + L2[c + 2] + L3[c] + L3[c + 1] + L3[c + 2]; if sum > 765 then center := BlackIndex; end; result[c - 1] := center; end; OutlineFilter: for c := 1 to width - 2 do begin center := L2[c + 1]; if center = BlackIndex then begin if (L2[c] = WhiteIndex) or (L1[c + 1] = WhiteIndex) or (L2[c + 2] = WhiteIndex) or (L3[c + 1] = WhiteIndex) then center := BlackIndex else center := WhiteIndex; end; result[c - 1] := center; end; Skeletonize: for c := 1 to width - 2 do begin center := L2[c + 1]; if center = BlackIndex then begin index := 0; if L1[c] = BlackIndex then index := bor(index, 1); if L1[c + 1] = BlackIndex then index := bor(index, 2); if L1[c + 2] = BlackIndex then index := bor(index, 4); if L2[c + 2] = BlackIndex then index := bor(index, 8); if L3[c + 2] = BlackIndex then index := bor(index, 16); if L3[c + 1] = BlackIndex then index := bor(index, 32); if L3[c] = BlackIndex then index := bor(index, 64); if L2[c] = BlackIndex then index := bor(index, 128); if odd(pass) then begin if table[index] = 2 then begin center := WhiteIndex; PixelsRemoved := PixelsRemoved + 1; end; end else begin if table[index] = 1 then begin center := WhiteIndex; PixelsRemoved := PixelsRemoved + 1; end; end; end; {if} result[c - 1] := center; end; {for} end; {case} if UseMask then PutLineUsingMask(left + 2, row, width - 3, result) else PutLine(left + 2, row, width - 3, result); LineCount := LineCount + 1; if LineCount = LinesPerUpdate then begin pt.h := roiRect.left; pt.v := row + 1; OffscreenToScreen(pt); NewMark := pt.v; with roiRect do SetRect(MaskRect, left, mark, right, NewMark); UpdateScreen(MaskRect); LineCount := 0; Mark := NewMark; if magnification > 1.0 then Mark := Mark - 1; if CommandPeriod then begin UpdatePicWindow; beep; PixelsRemoved := 0; if AutoSelectAll then KillRoi; exit(filter) end; end; end; {for row:=...} trect := frame; InsetRect(trect, 1, 1); ShowTime(StartTicks, trect); end; {with} if LineCount > 0 then begin with frame do SetRect(MaskRect, left, mark, right, bottom); UpdateScreen(MaskRect) end; SetupRoiRect; if AutoSelectAll then KillRoi; end; procedure PhotoMode; {Erases the screen to the background color and then redraws} {the contents of the active image window . } var tPort: GrafPtr; event: EventRecord; WinRect: rect; SaveVisRgn: rgnHandle; begin if info <> NoInfo then with info^ do begin KillRoi; if OptionKeyWasDown then begin {Move window up to top of screen.} GetWindowRect(wptr, WinRect); MoveWindow(wptr, WinRect.left, 0, false); end; with wptr^ do begin SaveVisRgn := visRgn; visRgn := NewRgn; RectRgn(visRgn, ScreenBits.Bounds); end; FlushEvents(EveryEvent, 0); GetPort(tPort); EraseScreen; UpdatePicWindow; repeat until WaitNextEvent(mDownMask + KeyDownMask, Event, 5, nil); with wptr^ do begin DisposeRgn(visRgn); visRgn := SaveVisRgn; end; RestoreScreen; SetPort(tPort); FlushEvents(EveryEvent, 0); if OptionKeyWasDown then begin MoveWindow(wptr, WinRect.left, WinRect.top, false); end; end else beep; end; procedure Animate; var TempInfo, TempInfo2: InfoPtr; n, last, DelayTicks: integer; tPort: GrafPtr; Event: EventRecord; ch: char; b: boolean; SourceRect, DestRect: rect; SingleStep, GoForward, NewKeyDown, AllSameSize, UseWholeScreen: boolean; SaveLUTMode: LUTModeType; SaveVisRgn: RgnHandle; nFrames, StartTicks: LongInt; begin if nPics < 2 then begin PutMessage('There must be at least two image windows open in order to do animation.'); exit(Animate) end; KillRoi; AllSameSize := true; for n := 2 to nPics do begin TempInfo := pointer(WindowPeek(PicWindow[n - 1])^.RefCon); TempInfo2 := pointer(WindowPeek(PicWindow[n])^.RefCon); AllSameSize := AllSameSize and EqualRect(TempInfo^.PicRect, TempInfo2^.PicRect); end; SaveLutMode := info^.LutMode; last := nPics; getPort(tPort); UseWholeScreen := OptionKeyWasDown or not AllSameSize; if UseWholeScreen then EraseScreen else begin ShowWatch; ShowMessage(concat('Use 1...9 keys to control speed', cr, 'Use arrow keys to single step', cr, 'Press mouse button to stop')); end; FlushEvents(EveryEvent, 0); DelayTicks := 0; n := 1; GoForward := true; SingleStep := false; if UseWholeScreen then with info^ do begin SetPort(wptr); with wptr^ do begin SaveVisRgn := visRgn; visRgn := NewRgn; RectRgn(visRgn, ScreenBits.Bounds); end; end; nFrames := 0; StartTicks := TickCount; repeat repeat b := WaitNextEvent(EveryEvent, Event, 0, nil); NewKeyDown := event.what = KeyDown; until (not SingleStep) or NewKeyDown or (event.what = MouseDown); if NewKeyDown then begin Ch := chr(BitAnd(Event.message, 127)); SingleStep := false; case ord(ch) of 28: begin SingleStep := true; GoForward := false; DelayTicks := 0 end; {left} 29: begin SingleStep := true; GoForward := true; DelayTicks := 0 end; {right} 57: DelayTicks := 0; {9} 56: DelayTicks := 1; {8} 55: DelayTicks := 3; {7} 54: DelayTicks := 5; {6} 53: DelayTicks := 8; {5} 52: DelayTicks := 12; {4} 51: DelayTicks := 18; {3} 50: DelayTicks := 30; {2} 49: DelayTicks := 60; {1} otherwise ; end; end; if DelayTicks <> 0 then delay(DelayTicks, ticks); if GoForward then begin n := n + 1; if n > last then n := 1 end else begin n := n - 1; if n < 1 then n := last end; TempInfo := pointer(WindowPeek(PicWindow[n])^.RefCon); with TempInfo^ do begin if not AllSameSize then if (LutMode <> SaveLutMode) or (LutMode = Custom) or (LutMode = CustomGrayscale) or SingleStep then LoadLut(cTable); SaveLutMode := LutMode; with TempInfo^ do begin if UseWholeScreen then begin SourceRect := SrcRect; DestRect := wrect; end else with Info^ do begin SourceRect := SrcRect; DestRect := wrect; end; hlock(handle(osPort^.portPixMap)); hlock(handle(CGrafPort(ThePort^).PortPixMap)); CopyBits(BitMapHandle(osPort^.portPixMap)^^, BitMapHandle(CGrafPort(ThePort^).PortPixMap)^^, SourceRect, DestRect, SrcCopy, nil); hunlock(handle(osPort^.portPixMap)); hunlock(handle(CGrafPort(ThePort^).PortPixMap)); nFrames := nFrames + 1; end; if SingleStep and (not UseWholeScreen) then SetWTitle(info^.wptr, title); end; {with} until event.what = MouseDown; {SelectWindow(PicWindow[n]);} if UseWholeScreen then begin RestoreScreen; with info^.wptr^ do begin DisposeRgn(visRgn); visRgn := SaveVisRgn; end; end; SetPort(tPort); ShowFrameRate('', StartTicks, nFrames); UpdatePicWindow; ShowCursor; FlushEvents(EveryEvent, 0); if not UseWholeScreen then ShowMagnification; end; procedure EnhanceContrast; var AutoSelectAll: boolean; min, max, i, threshold: integer; found: boolean; sum: LongInt; begin with info^ do if (LUTMode <> GrayScale) and (LUTMode <> CustomGrayscale) then begin PutMessage('Sorry, but you can only contrast enhance grayscale images.'); exit(EnhanceContrast) end; if NotInBounds or (ClipBuf = nil) then exit(EnhanceContrast); StopDigitizing; AutoSelectAll := not Info^.RoiShowing; if AutoSelectAll then SelectAll(false); if info^.RoiType = RectRoi then GetRectHistogram else GetNonRectHistogram; sum := 0; for i := 0 to 255 do sum := sum + histogram[i]; threshold := sum div 5000; i := -1; repeat i := i + 1; found := histogram[i] > threshold; until found or (i = 255); min := i; i := 256; repeat i := i - 1; found := histogram[i] > threshold; until found or (i = 0); max := i; if max > min then with info^ do begin p1x := 255 - max; p1y := 0; p2x := 255 - min; p2y := 255; SetGrayScaleLUT; DrawGrayMap; WhatToUndo := UndoContrastEnhancement; end; info^.changes := true; IdentityFunction := false; if AutoSelectAll then KillRoi; end; procedure EqualizeHistogram; var AutoSelectAll: boolean; i, sum, v: integer; isum: LongInt; ScaleFactor: extended; begin with info^ do if (LUTMode <> GrayScale) and (LutMode <> CustomGrayscale) then begin PutMessage('Sorry, but you can only do histogram equalization on grayscale images.'); exit(EqualizeHistogram) end; if NotInBounds or (ClipBuf = nil) then exit(EqualizeHistogram); StopDigitizing; AutoSelectAll := not Info^.RoiShowing; if AutoSelectAll then SelectAll(false); if info^.RoiType = RectRoi then GetRectHistogram else GetNonRectHistogram; FindThresholdingMode; ComputeResults; isum := 0; for i := 0 to 255 do isum := isum + histogram[i]; ScaleFactor := 255.0 / isum; sum := 0; with info^ do begin for i := 255 downto 0 do with cTable[i].rgb do begin sum := round(sum + histogram[i] * ScaleFactor); if sum > 255 then sum := 255; v := sum * 256; red := v; green := v; blue := v; end; LoadLUT(cTable); LUTMode := CustomGrayscale; changes := true; end; DrawGrayMap; WhatToUndo := UndoEqualization; IdentityFunction := false; if AutoSelectAll then KillRoi; end; procedure SortPalette (item: integer); type MyHSVColor = record lHue, lSaturation, lValue: LongInt; end; HSVRec = record index: integer; hsv: MyHSVColor; end; HSVArrayType = array[0..255] of HSVRec; var TempTable: MyCSpecArray; i: integer; HSVArray: HSVArrayType; h, s, v: LongInt; fHue, fSaturation, fValue: fixed; TempHSV: HSVColor; table: LookupTable; procedure SortByHue; var i, j: integer; x: HSVRec; begin for i := 2 to 254 do begin for j := 254 downto i do if HSVArray[j - 1].hsv.lHue > HSVArray[j].hsv.lHue then begin x := HSVArray[j - 1]; HSVArray[j - 1] := HSVArray[j]; HSVArray[j] := x; end; end; end; procedure SortBySaturation; var i, j: integer; x: HSVRec; begin for i := 2 to 254 do begin for j := 254 downto i do if HSVArray[j - 1].hsv.lSaturation > HSVArray[j].hsv.lSaturation then begin x := HSVArray[j - 1]; HSVArray[j - 1] := HSVArray[j]; HSVArray[j] := x; end; end; end; procedure SortByValue; var i, j: integer; x: HSVRec; begin for i := 2 to 254 do begin for j := 254 downto i do if HSVArray[j - 1].hsv.lValue > HSVArray[j].hsv.lValue then begin x := HSVArray[j - 1]; HSVArray[j - 1] := HSVArray[j]; HSVArray[j] := x; end; end; end; begin ShowWatch; StopThresholding; with info^ do begin for i := 1 to 254 do begin HSVArray[i].index := i; rgb2hsv(cTable[i].rgb, TempHSV); with TempHSV do begin fHue := SmallFract2Fix(hue); fSaturation := SmallFract2Fix(saturation); fValue := SmallFract2Fix(value); end; with HSVArray[i].hsv do begin lHue := LongInt(band(fHue, $ffff)); lSaturation := LongInt(band(fSaturation, $ffff)); lValue := LongInt(band(fValue, $ffff)); end; end; case item of byHueItem: SortByHue; bySaturationItem: SortBySaturation; byBrightnessItem: SortByValue; end; for i := 1 to 254 do begin with HSVArray[i].hsv do begin TempHSV.hue := Fix2SmallFract(fixed(lHue)); TempHSV.saturation := Fix2SmallFract(fixed(lSaturation)); TempHSV.value := Fix2SmallFract(fixed(lValue)); end; hsv2rgb(TempHSV, cTable[i].rgb); end; LoadLUT(cTable); if info <> NoInfo then begin table[0] := 0; table[255] := 255; for i := 1 to 254 do table[HSVArray[i].index] := i; ApplyTable(table); end; WhatToUndo := NothingToUndo; if LutMode = AppleDefault then LutMode := custom; end; {with} end; function GetNum (f: integer; var EndOfLine, done: boolean): integer; var err: osErr; a: packed array[1..2] of char; c: char; ByteCount, L: LongInt; str: str255; begin str := ''; EndOfLine := false; repeat ByteCount := 1; err := fsRead(f, ByteCount, @a); c := a[1]; done := err <> NoErr; until ((c >= '0') and (c <= '9')) or (c = '-') or done; if not done then begin str := concat(str, c); repeat ByteCount := 1; err := fsRead(f, ByteCount, @a); c := a[1]; EndOfLine := c = cr; done := err <> NoErr; if not done and (c >= '0') and (c <= '9') then str := concat(str, c); until (c < '0') or (c > '9') or done; StringToNum(str, L); GetNum := L; end else GetNum := -MaxInt; end; function GetKernel (var kernel: ktype; var n, count: integer; var name: str255): boolean; var where: Point; typeList: SFTypeList; reply: SFReply; err: OSErr; f, i, w, max: integer; EndOfLine, done: boolean; begin where.v := 120; where.h := 120; typeList[0] := 'TEXT'; SFGetFile(Where, '', nil, 1, typeList, nil, reply); i := 0; if reply.good then with reply do begin ShowWatch; err := FSOpen(fname, vRefNum, f); err := SetFPos(f, fsFromStart, 0); n := 0; max := MaxW; repeat w := GetNum(f, EndOfLine, done); if (n = 0) and EndOfLine then begin n := i + 1; max := n * n; end; if i < max then kernel[i] := w else done := true; if w <> -MaxInt then i := i + 1; until done; err := fsclose(f); count := i; name := fname; GetKernel := true; end else GetKernel := false; end; procedure DoOnePixel (nLess1, PixelsPerLine: integer; corner: LongInt; var sum: LongInt; var kernel: ktype); {$IFC false} var row, column, k: integer; pp: ptr; begin k := 0; sum := 0; for row := 0 to nless1 do begin corner := corner + PixelsPerLine; pp := ptr(corner); for column := 0 to nless1 do begin sum := sum + band(pp^, 255) * kernel[k]; k := k + 1; pp := ptr(ord(pp) + 1); end; end; end; {$ENDC} {a0=^corner/^sum} {a1=^kernel} {a2=^pixels} {d0=n-1} {d1=PixelsPerLine} {d2=sum} {d3=n-1(outer loop)} {d4=n-1(inner loop)} {d5=temp} inline $4E56, $0000, { link a6,#0} $48E7, $FCE0, { movem.l a0-a2/d0-d5,-(sp)} $4280, { clr.l d0} $302E, $0012, { move.w 18(a6),d0} $4281, { clr.l d1} $322E, $0010, { move.w 16(a6),d1} $206E, $000C, { movea.l 12(a6),a0} $226E, $0004, { movea.l 4(a6),a1} $4282, { clr.l d2} $2600, { move.l d0,d3} $D1C1, {A adda.l d1,a0} $2448, { move.l a0,a2} $2800, { move.l d0,d4} $4285, {B clr.l d5 (2)} $1A1A, { move.b (a2)+,d5 (6) } $CBD9, { muls (a1)+,d5 (29!)} $D485, { add.l d5,d2 (2)} $51CC, $FFF6, { dbra d4,B (6)} $51CB, $FFEC, { dbra d3,A} $206E, $0008, { move.l 8(a6),a0} $2082, { move.l d2,(a0)} $4CDF, $073F, { movem.l (sp)+,a0-a2/d0-d5} $4E5E, { unlk a6} $DEFC, $0010; { add.w #16,sp} procedure DoConvolution (var kernel: ktype; n: integer); var row, width, column, value, error: integer; margin, i, nless1: integer; frame, MaskRect, tRect: rect; AutoSelectAll: boolean; SrcCenter, DstCenter, sum, max, offset, wsum, cscale, StartTicks: LongInt; p: ptr; str, str2: str255; begin if NotinBounds or NotRectangular then exit(DoConvolution); StopDigitizing; AutoSelectAll := not Info^.RoiShowing; if AutoSelectAll then SelectAll(false); SetupUndoFromClip; WhatToUndo := UndoFilter; frame := info^.osroiRect; with frame, Info^ do begin if ((LutMode = GrayScale) or (LutMode = CustomGrayscale)) and (not IdentityFunction) then ApplyLookupTable; changes := true; margin := n div 2; if left < margin then left := left + margin; if right > (PicRect.right - margin) then right := right - margin; if top < margin then top := top + margin; if bottom > (PicRect.bottom - margin) then bottom := bottom - margin; PenNormal; PenPat(pat[PatIndex]); tRect := frame; OffscreenToScreenRect(tRect); FrameRect(tRect); width := right - left; max := n * n - 1; wsum := 0; for i := 0 to max do wsum := wsum + kernel[i]; NumToString(n, str); NumToString(wsum, str2); ResultsMessage := Concat(str, ' x ', str, ' kernel', cr, 'sum = ', str2, cr, cr, 'Command-Period to cancel'); ShowResults; if wsum <> 0 then cscale := wsum else cscale := 1; offset := -(n div 2) * PixelsPerLine - PixelsPerLine - n div 2; nless1 := n - 1; StartTicks := TickCount; for row := top to bottom - 1 do begin SrcCenter := ord4(ClipBufInfo^.PicBaseAddr) + LongInt(row) * PixelsPerLine + left; DstCenter := ord4(PicBaseAddr) + LongInt(row) * BytesPerRow + left; for column := left to left + width - 1 do begin DoOnePixel(nless1, PixelsPerLine, SrcCenter + offset, sum, kernel); value := sum div cscale; if value > 255 then value := 255; if value < 0 then value := 0; p := ptr(DstCenter); p^ := BAND(value, 255); SrcCenter := SrcCenter + 1; DstCenter := DstCenter + 1; end; {for column:=} SetRect(MaskRect, left, row, right, row + 1); OffscreenToScreenRect(MaskRect); UpdateScreen(MaskRect); if CommandPeriod then begin UpdatePicWindow; beep; exit(DoConvolution) end; end; {for row:=...} ShowTime(StartTicks, frame); end; {with} UpdatePicWindow; SetupRoiRect; if AutoSelectAll then KillRoi; end; procedure MakeWindowFromKernel (var kernel: ktype; n: integer; name: str255); var h, v, value, i, min, offset: integer; begin if NewPicWindow(name, 256, 256) then begin SelectAll(true); DoOperation(eraseOp); KillRoi; min := 9999; for i := 0 to n * n - 1 do if kernel[i] < min then min := kernel[i]; if min < 0 then offset := -min else offset := 0; i := 0; for v := 0 to n - 1 do for h := 0 to n - 1 do begin value := kernel[i] + offset; PutPixel(h, v, value); i := i + 1; end; end; end; procedure Convolve; var kernel: ktype; n, count: integer; error: boolean; str1, str2, name: str255; ok: boolean; OptionKeyWasDown: boolean; begin OptionKeyWasDown := OptionKeyDown; ok := GetKernel(kernel, n, count, name); if not ok then exit(convolve); error := false; if n > 63 then begin error := true; str1 := 'Kernel size must be <= 63.'; end; if count < (n * n) then begin error := true; str1 := 'Not enough kernel coefficients.'; end; if OptionKeyWasDown then begin MakeWindowFromKernel(kernel, n, name); exit(convolve); end; if not error then begin UpdatePicWindow; DoConvolution(kernel, n); end else PutMessage(str1); end; procedure Do3DPlot; var hend, vend, h, v, DataWidth, DataHeight, i: integer; htemp, vtemp, ivalue: integer; SaveForeground, SaveBackground, skip: integer; hLoc, vLoc, hMin, hMax, vMin, vMax, MinIValue, MaxIValue: integer; hstart, vstart, dh, dv, hbase, vbase, vscale, nPlotLines, cvalue: extended; peak, MaxPeak, hinc, vinc, nLines, MinCValue, MaxCValue: extended; tPort: GrafPtr; poly: PolyHandle; SaveInfo: InfoPtr; aLine: LineType; MaskRect: rect; AutoSelectAll, ApplyLUT: boolean; table: LookupTable; StartTicks: LongInt; procedure FindVinc; begin with info^.PicRect do begin vstart := 5.0 + MaxPeak - dv * DataWidth; skip := round(DataHeight / ((bottom - vstart - 5.0) / vinc)); if skip = 0 then skip := 1; nPlotLines := DataHeight / skip; vinc := (bottom - vstart - 5.0) / nPlotLines; vinc := vinc / 0.95; repeat vinc := vinc * 0.95; hinc := vinc / 2.0; until (5.0 + hinc * nPlotLines + dh * DataWidth) < right; end; end; begin if NotRectangular or NotInBounds then exit(Do3DPlot); StopDigitizing; StopThresholding; AutoSelectAll := not Info^.RoiShowing; ShowWatch; if AutoSelectAll then SelectAll(true); with info^ do if ScaleToFitWindow or (magnification <> 1.0) then UnZoom; with info^ do ApplyLUT := ((LutMode = GrayScale) or (LutMode = CustomGrayscale)) and (not IdentityFunction); if ApplyLUT then GetLookupTable(table); Measure; UndoLastMeasurement; with results do begin MinIValue := MinIndex; MaxIValue := MaxIndex; end; if ApplyLut then begin MinIvalue := table[MinIValue]; MaxIvalue := table[MaxIValue]; end; MinCValue := 10e100; MaxCValue := -10e100; for i := MinIValue to MaxIValue do begin ivalue := i; if ApplyLUT then ivalue := table[ivalue]; cvalue := value[i]; if cvalue < minCValue then minCValue := cvalue; if cvalue > maxCValue then maxCValue := cvalue; end; KillRoi; SetupUndo; if not AutoSelectAll then RedoSelection := true; WhatToUndo := UndoPlot; SetupUndoInfoRec; SaveInfo := Info; GetPort(tPort); with Info^, info^.osroiRect do begin SaveForeground := ForegroundIndex; SaveBackground := BackgroundIndex; SetForegroundColor(BlackIndex); SetBackgroundColor(WhiteIndex); changes := true; SetPort(GrafPtr(osPort)); PenNormal; EraseRect(PicRect); UpdatePicWindow; with results do if (MaxValue - MinValue) <> 0.0 then vscale := (255.0 / (MaxValue - MinValue)) * 0.5 else vscale := 0.5; DataWidth := right - left; DataHeight := bottom - top; dh := (0.65 * PicRect.right) / DataWidth; dv := -0.4 * dh; hstart := 5.0; vinc := 2.0; MaxPeak := (MaxCValue - MinCValue) * vscale * 0.5; FindVinc; {First estimate} MaxPeak := MaxPeak * 2.0; hmin := right + round(MaxPeak / dv); if hmin < 0 then hmin := 0; vmax := top + round(MaxPeak / vinc); if vmax > bottom then vmax := bottom; MaxPeak := 0.0; vloc := top; Info := UndoInfo; skip := 3; repeat hloc := hmin; repeat ivalue := MyGetPixel(hloc, vloc); if ApplyLUT then ivalue := table[ivalue]; cvalue := value[ivalue]; peak := (cvalue - MinCValue) * vscale + (right - hloc) * dv - (vloc - top) * vinc; if peak > MaxPeak then MaxPeak := peak; hloc := hloc + skip; until hloc > right; vloc := vloc + skip; until vloc > vmax; FindVinc; v := top; StartTicks := TickCount; repeat hmax := 0; vmin := 9999; Info := UndoInfo; poly := OpenPoly; hbase := hstart; vbase := vstart; GetLine(left, v, DataWidth, aLine); if ApplyLUT then ApplyTableToLine(@aLine, table, DataWidth); MoveTo(round(hbase), round(vbase - vscale * (value[aLine[0]] - MinCValue))); for i := 0 to DataWidth - 1 do begin hbase := hbase + dh; vbase := vbase + dv; hLoc := round(hbase); vLoc := round(vbase - vscale * (value[aLine[i]] - MinCValue)); LineTo(hloc, vloc); if hloc > hmax then hmax := hloc; if vloc < vmin then vmin := vloc; end; LineTo(round(hbase), round(vbase)); LineTo(round(hstart), round(vstart)); LineTo(round(hstart), round(vstart - vscale * (value[aLine[0]] - MinCValue))); hmin := round(hstart); vmax := round(vstart); ClosePoly; ErasePoly(poly); FramePoly(poly); KillPoly(poly); info := SaveInfo; SetRect(MaskRect, hmin, vmin, hmax, vmax); OffscreenToScreenRect(MaskRect); UpdateScreen(MaskRect); hstart := hstart + hinc; vstart := vstart + vinc; v := v + skip; until (v >= bottom) or CommandPeriod; end; {with} ShowTime(StartTicks, info^.osroiRect); if CommandPeriod then beep; SetForegroundColor(SaveForeground); SetBackgroundColor(SaveBackground); SetPort(tPort); end; procedure MakeSkeleton; const s999 = '01234567890123456789012345678901'; s000 = '00020012000020220000000010001011'; s032 = '00000000000010002000000010001011'; s064 = '00000000000000000000000000000000'; s096 = '10000000100010001000000010001010'; s128 = '02020002000000020000000000000002'; s160 = '02000000000000001100000000000000'; s192 = '12220002000000020000000000000000'; s224 = '1202002210001000120200001100100'; var table: FateTable; s: str255; i, pass: integer; begin s := concat(s000, s032, s064, s096, s128, s160, s192, s224); for i := 0 to 254 do table[i] := ord(s[i + 1]) - ord('0'); table[255] := 0; pass := 0; repeat PixelsRemoved := 0; filter(skeletonize, pass, table); pass := pass + 1; if not CommandPeriod then filter(skeletonize, pass, table); pass := pass + 1; until (PixelsRemoved = 0) or CommandPeriod; end; procedure DoErosion; var i: integer; t: FateTable; begin for i := 0 to BinaryIterations - 1 do begin filter(Erosion, i, t); if CommandPeriod then leave; end; end; procedure DoDilation; var i: integer; t: FateTable; begin for i := 0 to BinaryIterations - 1 do begin filter(Dilation, i, t); if CommandPeriod then leave; end; end; procedure DoOpening; var i: integer; t: FateTable; begin for i := 0 to BinaryIterations - 1 do begin filter(Erosion, i, t); if CommandPeriod then exit(DoOpening); end; for i := 0 to BinaryIterations - 1 do begin filter(Dilation, i + BinaryIterations, t); if CommandPeriod then exit(DoOpening); end; end; procedure DoClosing; var i: integer; t: FateTable; begin for i := 0 to BinaryIterations - 1 do begin filter(Dilation, i, t); if CommandPeriod then exit(DoClosing); end; for i := 0 to BinaryIterations - 1 do begin filter(Erosion, i + BinaryIterations, t); if CommandPeriod then exit(DoClosing); end; end; procedure SetIterations; var TempIterations: integer; begin TempIterations := GetInt('Number of Iterations:', BinaryIterations); if TempIterations >= 1 then BinaryIterations := TempIterations else beep; end; procedure ChangeValues; {Changes all the pixels in the current selection from the foreground} {color(index) to the background color(index).} var id, i, value: integer; table: LookupTable; begin ParamText(long2str(ForegroundIndex), long2str(BackgroundIndex), '', ''); id := alert(700, nil); if id = ok then begin for i := 0 to 255 do begin value := i; if value = ForegroundIndex then value := BackgroundIndex; table[i] := value; end; ApplyTable(table); end; end; procedure PropagateLUT; {Copies the current Look-Up Table to all opne windows} var TempInfo: InfoPtr; i: integer; procedure CopyLUTInfo; begin with info^ do begin TempInfo^.RedX := RedX; TempInfo^.GreenX := GreenX; TempInfo^.BlueX := BlueX; TempInfo^.ColorStart := ColorStart; TempInfo^.ColorWidth := ColorWidth; TempInfo^.LutMode := LUTMode; TempInfo^.cTable := cTable; TempInfo^.p1x := p1x; TempInfo^.p1y := p1y; TempInfo^.p2x := p2x; TempInfo^.p2y := p2y; TempInfo^.DeltaX := DeltaX; TempInfo^.DeltaY := DeltaY; end; end; begin TempInfo := NoInfo; CopyLUTInfo; for i := 1 to nPics do begin TempInfo := pointer(WindowPeek(PicWindow[i])^.RefCon); if Info <> TempInfo then CopyLUTInfo; end; end; procedure DoArithmetic (MenuItem: integer); var table: LookupTable; i, tmp: integer; constant: extended; begin case menuItem of AddItem: constant := GetReal('Constant to add:', 25); SubtractItem: constant := GetReal('Constant to subtract:', 25); MultiplyItem: begin constant := GetReal('Constant to multiply by:', 1.25); if constant < 0.0 then begin PutMessage('Constant must be positive.'); exit(DoArithmetic); end; end; DivideItem: begin constant := GetReal('Constant to divide by:', 1.25); if constant <= 0.0 then begin PutMessage('Constant must be nonzero and positive.'); exit(DoArithmetic); end; end; end; if constant = BadReal then exit(DoArithmetic); {cancel} for i := 0 to 255 do begin case MenuItem of AddItem: tmp := round(i + constant); SubtractItem: tmp := round(i - constant); MultiplyItem: tmp := round(i * constant); DivideItem: tmp := round(i / constant); end; if tmp < 0 then tmp := 0; if tmp > 255 then tmp := 255; table[i] := tmp; end; ApplyTable(table); end; procedure UpdateEditMenu; { moved here from Edit (unit size limits) - Arlo } var DimUndo, ShowItems: boolean; str: str255; kind, i: integer; WhichWindow: WindowPtr; begin WhichWindow := FrontWindow; kind := WindowPeek(WhichWindow)^.WindowKind; if kind < 0 then begin {DA is active, so activate Edit menu.} SetItem(EditMenuH, UndoItem, 'Undo'); SetItem(EditMenuH, CutItem, 'Cut'); SetItem(EditMenuH, CopyItem, 'Copy'); SetMenuItem(EditMenuH, UndoItem, true); for i := CutItem to ClearItem do SetMenuItem(EditMenuH, i, true); exit(UpdateEditMenu); end; DimUndo := WhatToUndo = NothingToUndo; SetMenuItem(EditMenuH, UndoItem, not DimUndo); if DimUndo then SetItem(EditMenuH, UndoItem, 'Undo'); case WhatToUndo of UndoEdit: str := 'Editing'; UndoFlip: str := 'Flip'; UndoRotate: str := 'Rotate'; UndoScale: str := 'Scaling'; UndoFilter: str := 'Filtering'; UndoPaste: str := 'Paste'; UndoMeasurement: str := 'Measurement'; UndoTransform: str := 'Transformation'; UndoClear: str := 'Clear'; UndoContrastEnhancement: str := 'Contrast Enhancement'; UndoEqualization: str := 'Equalization'; UndoZoom: str := 'Zoom'; UndoPlot: str := '3D Plot'; UndoOutline: str := 'Outline'; {$IFC Arlo } UndoMask: str := 'Mask'; {$ENDC } otherwise str := ''; end; SetItem(EditMenuH, UndoItem, concat('Undo ', str)); FindWhatToCopy; if WhatToCopy = CopySelection then str := 'Cut Selection' else str := 'Cut'; SetItem(EditMenuH, CutItem, str); SetMenuItem(EditMenuH, CutItem, WhatToCopy = CopySelection); case WhatToCopy of NothingToCopy: str := ''; CopySelection: str := 'Selection'; CopyCLUT: str := 'Palette'; CopyGrayMap: str := 'Gray Map'; CopyPlot: str := 'Plot'; CopyCalibrationPlot: str := 'Calibration Plot'; CopyHistogram: str := 'Histogram'; CopyRegions: str := 'Measurements'; CopyLengths: str := 'Lengths'; CopyPoints: str := 'Points'; CopyColor: str := 'Color'; end; SetItem(EditMenuH, CopyItem, concat('Copy ', str)); SetMenuItem(EditMenuH, CopyItem, WhatToCopy <> NothingToCopy); SetMenuItem(EditMenuH, ClearItem, WhatToCopy = CopySelection); ShowItems := (WhatsOnClip <> nothing) or (OldScrapCount <> GetScrapCount); SetMenuItem(EditMenuH, PasteItem, ShowItems); SetMenuItem(EditMenuH, ShowClipboardItem, ShowItems); ShowItems := info <> NoInfo; with Info^ do begin for i := FillItem to DrawBoundaryItem do SetMenuItem(EditMenuH, i, ShowItems); if RoiShowing and EqualRect(osroiRect, PicRect) then SetItem(EditMenuH, SelectAllItem, 'Deselect All') else SetItem(EditMenuH, SelectAllItem, 'Select All'); for i := SelectAllItem to ScaleSelectionItem do SetMenuItem(EditMenuH, i, ShowItems); for i := RotateLeftItem to RotateAndScaleItem do SetMenuItem(EditMenuH, i, ShowItems); SetMenuItem(EditMenuH, UnZoomItem, ShowItems and ((magnification <> 1.0) or ScaleToFitWindow)); end; {$IFC Arlo } SetMenuItem(EditMenuH, CutItem, not InFrequencyDomain); for i := PasteItem to ClearItem do SetMenuItem(EditMenuH, i, not InFrequencyDomain); for i := FillItem to DrawBoundaryItem do SetMenuItem(EditMenuH, i, not InFrequencyDomain); SetMenuItem(EditMenuH, ScaleSelectionItem, not InFrequencyDomain); for i := RotateLeftItem to RotateAndScaleItem do SetMenuItem(EditMenuH, i, not InFrequencyDomain); SetMenuItem(EditMenuH, ShowClipboardItem, not InFrequencyDomain); {$ENDC } end; end.