unit UMMarkup; {Contributed by Edward J. Huff } {Copyright is hereby waived: UMMarkup.p is in the public domain.} {User Macro "Markup" package. } {Macros which use these extensions should specify "requiresUser('Markup',1)".} {These instructions apply if you have received only UMMarkup.p and} {a copy of UMacroDef.p and UMacroRun.p, and want to install the code} {into your copy of NIH Image.} {You need the Think Pascal compiler to use this source code. } {Installation instructions. At the moment, the UMacroDef.p and UMacroRun.p} {have not been accepted for distribution with standard Image. If they are, then} {these instructions will apply. Otherwise, you will have to obtain a copy of image} {with UMacroDef.p etc. already installed. This will typically be available in} {the /pub/nih-image/contrib directory of zippy.nimh.nih.gov and the file} {name will include "UMX".} {If you have no other user macro extension packages installed,} {then just replace the default UMacroDef.p and UMacroRun.p with the enclosed} {versions. Otherwise, you must merge the changes, which should be found only} {at well marked places. Generally, this means simply adding lines, although you } {may also need to add a comma here and there. Changes should be found at} {one place in UMacroDef.p and seven places in UMacroRun.p.} {You will also have to use the "Project/Add File..." menu item to tell Think Pascal } {to compile this file, and use the "Windows/Image.proj" item to get the project window, } {and drag this file from the bottom of the list to somewhere between UMacroDef.p and } {UMacroRun.p.} {Finally, recompile and rebuild: Use "Run/Build" (command B) and } {"Project/Build Application...".} interface uses QuickDraw, Palettes, PrintTraps, Globals, Utilities, Graphics, UMacroDef; procedure UMMarkupInit; procedure UMMarkupFinal; procedure UMMarkupAdd; procedure UMMarkupLookup (var uma: UserMacroArgs); procedure UMMarkupRun (var uma: UserMacroArgs); implementation {Local ("static") variables used by UMMarkup.p} {Space used here counts against the 32k byte limit on global variables,} {so allocate the space dynamically only if any of the macros are actually called.} type localsR = record saveString: Str255; end; localsP = ^localsR; localsH = ^localsP; var locals: localsH; var MarkupWindow: WindowPtr; MarkupUserInfo: UserInfoHandle; MarkupWindowActive: Boolean;{used in Edit.p} MarkupPicBaseHandle: Handle; MarkupOsPort: CGrafPtr; MarkedSum: HistogramType; MarkedBkg: HistogramType; procedure MarkupInitialize; forward; procedure ResizeMarkupWindow (Width, Height: integer); forward; procedure DragMarkupWindow (userInfo: userInfoHandle); forward; procedure CreateMarkupWindow; forward; procedure UpdateMarkupWindow (userInfo: userInfoHandle); forward; procedure CloseMarkupWindow; forward; procedure MarkupCloseHook (userInfo: userInfoHandle); forward; function MarkupReady: Boolean; forward; procedure DoMouseDownInMarkup (userInfo: userInfoHandle); forward; procedure DoMarkupCursor (userInfo: userInfoHandle); forward; procedure ActivateMarkupWindow (userInfo: userInfoHandle); forward; procedure DoMarkupKey (ch: char; KeyCode: Integer); forward; procedure UndoMarkup; forward; type BkgKernelKindType = (ConeKernel, ExponentialKernel, NoKernel); lptr = ^LongInt; iptr = ^Integer; packedUnsignedW = packed record u: 0..65535 end; puwp = ^packedUnsignedW; const maxProfile = 258; minProfile = 70; MarkupCtrlHeight = 75; MarkupCtrlDITL = 1000; UndoCtrlid = 1; KeepCtrlid = 2; RidgeCtrlid = 3; ValleyCtrlid = 4; WorkUpCtrlid = 5; WorkDownCtrlid = 6; WorkLeftCtrlid = 7; WorkRightCtrlid = 8; HideMarksCtrlid = 9; AutomaticCtrlid = 10; WidenCtrlid = 11; NarrowCtrlid = 12; KernelRadiusCtrlid = 13; ConeKernelCtrlid = 14; ExponentialKernelCtrlid = 15; BkgCoefficientCtrlid = 16; AutoBkgCtrlid = 17; CalcBackgroundCtrlid = 18; AutoIntensityCtrlid = 19; CalcIntensityCtrlid = 20; ErodeCtrlid = 21; DilateCtrlid = 22; DataImageCtrlid = 23; MarksImageCtrlid = 24; BkgImageCtrlid = 25; CancelCtrlid = 26; BkgKernelMaxRadius = 30; {maximum value for kernel radius} BkgKernelDimension = BkgKernelMaxRadius * 2; InvalidPicNumber = 'No such image.'; var MarkupDataInfo, MarkupMarkInfo, MarkupBkgInfo, MarkupData16Info: InfoPtr; {all of these should have g prefix for global...} {or should it be u for unit global? The newer ones have g prefix now.} ProfileHeight, ProfileWidth: integer; {MarkupHeight includes MarkupCtrlHeight but offscreen pixmap does not.} MarkupLeft, MarkupTop, MarkupWidth, MarkupHeight: integer; PaneWidth, PaneHeight: integer; MarkupPaneRect: Rect; { area of Markup offscreen pixmap containing original image } {MarkupPaneRect.top and .left must always be zero. } { Areas of Markup offscreen pixmap for marks or profile plot } MarksRowRect, MarksColRect, DataRowRect, DataColRect: rect; ProfileRowRect, ProfileColRect, UpdRowRect, UpdColRect: Rect; LastRowRect, LastColRect: Rect; gDragUndo: Boolean; {true if drag in Markup window is copying from undo buffer} ProfileDragRect: Rect; {Drag this box to resize the profile plots } SourceRect: Rect; { area of original image displayed in Markup pane } DisplayMarks, ScalePlots: Boolean; ScalePlotsButton: Rect; {Safety critical: these six variables are used in PutMarkupPixel range checks} {and also in RefreshMarkupOffscreen which copies all markup pixels to center } {of the big markup window pixels, so they must never be changed without also } {reallocating the offscreen pixmap. Otherwise PutMarkupPixel or RefreshMarkupOffscreen } {could trash memory outside of the pixmap.} SourceHeight, SourceWidth, Magnify, MagCenter: integer; MarkupBytesPerRow, CenterOffset: LongInt; {Copies of the above six variables, checked by MarkupReady } CheckSourceHeight, CheckSourceWidth, CheckMagnify, CheckMagCenter: integer; CheckMarkupBytesPerRow, CheckCenterOffset: LongInt; {Copies of the common image size parameters, checked by MarkupReady } CheckRowBytes, CheckRows, CheckCols: Integer; ThePixel, NewCenterPix: point; {"pix" coordinates } MouseDownLoc, Constraint: point; {"loc" coordinates } CursorMotion: (FreeMotion, Deciding, VerticalOnly, HorizontalOnly); MarkupTool: ToolType; MarkupCursor: ^Cursor; gDrawValues, gBkgUpdReqd: Boolean; gWorkdh, gWorkdv: Integer; gWorkUp, gWorkDown, gWorkLeft, gWorkRight, gWorkSwap: Boolean; gWiden, gAutomatic, gRidge: Boolean; {Background Kernel variables } BkgKernelKind: BkgKernelKindType; {last entry in BkgKernelHandle array is always nil} BkgKernelHandle: array[1..BkgKernelDimension] of Handle; BkgKernelMinRadius: integer; BkgKernelDeltaRadius: integer; BkgKernelSlope: extended; BkgKernelBase: extended; BkgCoefficient: LongInt; gUndoButtonEnabled: Boolean; gAutoBkgEnabled: Boolean; gAutoIntensityEnabled: Boolean; gCanceled: Boolean; {Variables for TempToolSelect and TempToolRestore } gTempToolSelected: Boolean; gTempToolSave: ToolType; {Variables used for automatic mode marking} gAutoPixel, gAutoPlusEnd, gAutoMinusEnd: Point; {Variables used for scaling 16 bit image} gScaleMin, gScaleMax: LongInt; gScaleXlate: Handle; {Variables used when specifying images prior to opening markup window. } {These could be dangling pointers: appropriate care is taken.} newDataInfo, newMarkInfo, newBkgInfo, newData16Info: InfoPtr; {$PUSH} {$D-} procedure MacsBug (str: str255); inline $abff; {$POP} {$S Markup} procedure SelectNewTool (NewTool: ToolType); var SavePort: GrafPtr; begin if NewTool <> CurrentTool then begin GetPort(SavePort); SetPort(ToolWindow); EraseRect(ToolRect[CurrentTool]); InvalRect(ToolRect[CurrentTool]); CurrentTool := NewTool; isSelectionTool := (CurrentTool = SelectionTool) or (CurrentTool = OvalSelectionTool) or (CurrentTool = PolygonTool) or (CurrentTool = FreehandTool) or (CurrentTool = LineTool); EraseRect(ToolRect[CurrentTool]); InvalRect(ToolRect[CurrentTool]); SetPort(SavePort); end; end; procedure TempToolSelect (TempTool: ToolType); begin if not gTempToolSelected then begin gTempToolSelected := true; gTempToolSave := currentTool; end; SelectNewTool(TempTool); end; procedure TempToolRestore; begin if gTempToolSelected then begin gTempToolSelected := false; SelectNewTool(gTempToolSave); end; end; {Maybe these should go in Utilities.p ...} function CommandKeyDown: Boolean; type KeyPtrType = ^KeyMap; var KeyPtr: KeyPtrType; keys: array[0..3] of LongInt; begin KeyPtr := KeyPtrType(@keys); GetKeys(KeyPtr^); CommandKeyDown := (BAND(keys[1], $00008000)) <> 0; end; procedure DrawXCoord (hloc: integer); var tPort: GrafPtr; hstart, vstart: integer; begin hstart := InfoHStart; vstart := InfoVStart; GetPort(tPort); SetPort(InfoWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); MoveTo(xValueLoc, vstart); if hloc < 0 then hloc := -hloc; DrawXDimension(hloc, 0); SetPort(tPort); end; procedure DrawYCoord (vloc: integer); var tPort: GrafPtr; hstart, vstart: integer; begin hstart := InfoHStart; vstart := InfoVStart; GetPort(tPort); SetPort(InfoWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); MoveTo(yValueLoc, vstart + 10); with Info^ do if InvertYCoordinates then vloc := PicRect.bottom - vloc - 1; if vloc < 0 then vloc := -vloc; DrawYDimension(vloc, 0); SetPort(tPort); end; {no doubt this should check calibration, etc... } procedure DrawMarkValues (data, mark, bkg: LongInt); var tPort: GrafPtr; hstart, vstart: integer; begin hstart := InfoHStart; vstart := InfoVStart; GetPort(tPort); SetPort(InfoWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); MoveTo(zValueLoc, vstart + 19); DrawLong(data); DrawString(' / '); DrawLong(mark); DrawString(' / '); DrawLong(bkg); DrawString(' '); SetPort(tPort); end; {Use a DITL resource to position controls in a window which is} {not a dialog. The reason for doing this is to avoid placing } {information about the control locations into the source program. } {The DITL resource type is used because ResEdit can easily create } {and modify DITL resources.} {The rectangle which contains the controls is presently hard coded.} {It should be specified in the resource.} type DITLptr = ^DITLrecord; DITLrecord = record NumItems: Integer; PlaceHolder: LongInt; r: rect; itemTypeLen: packed array[0..255] of Byte; end; procedure MyGetNewControls (wind: WindowPtr; resid: integer); var h: Handle; p: DITLptr; NumItems: Integer; refCon: LongInt; ch: ControlHandle; itemLength: Integer; Title: Str255; const btnCtrlitem = btnCtrl + ctrlitem; chkCtrlitem = chkCtrl + ctrlitem; radCtrlitem = radCtrl + ctrlitem; resCtrlitem = resCtrl + ctrlitem; begin h := GetResource('DITL', resid); if h <> nil then begin p := DITLptr(h^); NumItems := p^.NumItems + 1; refCon := 1; while NumItems > 0 do begin itemLength := p^.itemTypeLen[1]; {It is not obvious how to avoid copying the title, because Str255() cast fails.} BlockMove(@p^.itemTypeLen[1], @Title, itemLength + 1); case p^.itemTypeLen[0] of btnCtrlitem: ch := NewControl(wind, p^.r, Title, true, 0, 0, 1, pushButProc, refCon); chkCtrlitem: ch := NewControl(wind, p^.r, Title, true, 0, 0, 1, checkBoxProc, refCon); radCtrlitem: ch := NewControl(wind, p^.r, Title, true, 0, 0, 1, radioButProc, refCon); resCtrlitem: ; {resCtrlitem not implemented} otherwise ; end; if odd(itemLength) then itemLength := itemLength + 1; p := DITLptr(Ord4(p) + itemLength + 14); NumItems := NumItems - 1; refCon := refCon + 1; end; ReleaseResource(h); end; end; function myGetCtrlItem (wind: WindowPtr; itemNo: Integer): ControlHandle; var theControl: ControlHandle; begin myGetCtrlItem := nil; if wind <> nil then begin theControl := WindowPeek(wind)^.controlList; while theControl <> nil do begin if theControl^^.contrlRfCon <> itemNo then theControl := theControl^^.nextControl else begin myGetCtrlItem := theControl; theControl := nil; end end; end; end; procedure myHiliteControl (wind: WindowPtr; itemNo: integer; hiliteState: Integer); var theControl: ControlHandle; begin theControl := myGetCtrlItem(wind, itemNo); if theControl <> nil then begin HiliteControl(theControl, hiliteState); end; end; procedure mySetCtlValue (wind: WindowPtr; itemNo: integer; theValue: Integer); var theControl: ControlHandle; begin theControl := myGetCtrlItem(wind, itemNo); if theControl <> nil then begin SetCtlValue(theControl, theValue); end; end; procedure MakeOneKernel (r, minr: integer); var i, j: integer; area: LongInt; p: lptr; v, x, y, d, s, m: extended; h: Handle; begin {last entry in BkgKernelHandle array is always nil} if (r > BkgKernelMaxRadius) or (r < 1) then begin beep; exit(MakeOneKernel); end; area := r * 2 + 1; area := area * area; h := BkgKernelHandle[r]; if h = nil then begin h := NewHandle(area * 4); BkgKernelHandle[r] := h; end; if h = nil then begin beep; exit(MakeOneKernel); end; { These kernels are circularly symmetrical, y = f(d),} { where d = sqrt(x*x+y*y). Each kernel depends on } { four parameters: the minimum radius minr, the} { maximum radius r, the kernel kind (cone, expontential),} { and the shape parameter, which is slope for cone kernels and ratio } { for exponential kernels.} { The minimum radius minr is 0 for the smallest kernel, that is,} { the one with r = BkgKernelMinRadius. It is equal to the previous} { value of r for subsequent kernels.} { The maximum radius varies from BkgKernelMinRadius to BkgKernelMaxRadius.} { All values on or outside r+1 are zero: } { f(d) = 0 for all d >= r+1. } { All values on or inside the minimum radius are zero: } { f(d) = 0 for all d <= minr. } { The outermost edges have more than one nonzero value. } { The cone kernel cannot be scaled without changing the slope, } { so the specified slope is always used. } { The exponential kernel is scaled to avoid overflow when all data values are 255. } { cone: y = m(d-r-1), m = specified slope } { exponential: y = s*exp(m*d), m = -ln(specified base), s = scale factor} p := lptr(h^); case BkgKernelKind of NoKernel: beep; ConeKernel: begin for i := -r to r do begin x := i; x := x * x; for j := -r to r do begin y := j; y := y * y; d := sqrt(x + y); p^ := 0; if d > minr then if d < r + 1 then p^ := Round(BkgKernelSlope * (d - r - 1)); p := lptr(ord4(p) + 4); end; end; end; ExponentialKernel: begin v := 0.0; m := -ln(BkgKernelBase); for i := -r to r do begin x := i; x := x * x; for j := -r to r do begin y := j; y := y * y; d := sqrt(x + y); if d > minr then if d <= r + 1 then v := v + exp(m * d); end; end; s := 4194303.0 / v; {2^22-1} for i := -r to r do begin x := i; x := x * x; for j := -r to r do begin y := j; y := y * y; d := sqrt(x + y); p^ := 0; if d > minr then if d < r + 1 then p^ := round(s * exp(m * d)); p := lptr(ord4(p) + 4); end; end; end; end; end; procedure MakeKernel; var r, minr: integer; begin ShowWatch; myHiliteControl(MarkupWindow, KernelRadiusCtrlid, 1); for r := 1 to BkgKernelDimension do if BkgKernelHandle[r] <> nil then begin DisposHandle(BkgKernelHandle[r]); BkgKernelHandle[r] := nil; end; {last entry in BkgKernelHandle array is always nil} r := BkgKernelMinRadius; minr := 0; while r <= BkgKernelMaxRadius do begin MakeOneKernel(r, minr); minr := r; r := r + BkgKernelDeltaRadius; end; myHiliteControl(MarkupWindow, KernelRadiusCtrlid, 0); end; procedure PasteKernel (arg: extended); var r, h, v, c, p: integer; kernel: lptr; value: extended; scale: Boolean; begin if info <> noInfo then begin scale := arg < 0; if scale then arg := -arg; r := trunc(arg); {the radius } c := BkgKernelMaxRadius; arg := arg - r; {the coef } if arg = 0.0 then arg := 1.0; if r > 0 then if r <= BkgKernelMaxRadius then if BkgKernelHandle[r] <> nil then begin kernel := lptr(BkgKernelHandle[r]^); info^.changes := true; if scale then begin value := 0.0; for v := c - r to c + r do begin for h := c - r to c + r do begin if value < kernel^ then value := kernel^; kernel := lptr(Ord4(kernel) + 4); end; end; arg := 255.0 / value; end; kernel := lptr(BkgKernelHandle[r]^); for v := c - r to c + r do begin for h := c - r to c + r do begin value := kernel^ * arg; if value <= 0.0 then value := 0.0 else if value <= 1.0 then value := 1.0 else if value > 255.0 then value := 255.0 else if value > 254.0 then value := 254.0; putPixel(h, v, trunc(value)); kernel := lptr(Ord4(kernel) + 4); end; end; UpdatePicWindow; end; end; end; procedure MarkupInitialize; var r: integer; begin MarkupWindowActive := false; MarkupWindow := nil; MarkupUserInfo := nil; MarkupLeft := 80; MarkupTop := 40; MarkupWidth := 2000; MarkupHeight := 2000; with ThePixel do begin h := -1; v := -1; end; NewCenterPix := ThePixel; MarkupDataInfo := nil; MarkupMarkInfo := nil; MarkupBkgInfo := nil; MarkupData16Info := nil; Magnify := 3; MagCenter := 1; MarkupPicBaseHandle := nil; MarkupOsPort := nil; CursorMotion := FreeMotion; MarkupTool := Pencil; MarkupCursor := nil; SetRect(SourceRect, 0, 0, 0, 0); SourceHeight := 0; SourceWidth := 0; MarkupBytesPerRow := 0; ProfileHeight := MinProfile; ProfileWidth := MinProfile; DisplayMarks := true; ScalePlots := true; SetRect(ScalePlotsButton, 0, 0, 0, 0); {last entry in BkgKernelHandle array is always nil} for r := 1 to BkgKernelDimension do BkgKernelHandle[r] := nil; BkgKernelMinRadius := 5; BkgKernelDeltaRadius := 3; BkgKernelKind := NoKernel; BkgKernelSlope := -10.0; BkgKernelBase := 10.0; gAutomatic := false; gRidge := false; gTempToolSelected := false; gUndoButtonEnabled := false; gAutoBkgEnabled := false; gAutoIntensityEnabled := false; gCanceled := false; BkgCoefficient := 10000; {1.0} gWorkUp := false; gWorkDown := false; gWorkLeft := false; gWorkRight := false; gWorkSwap := false; { Copy of the six critical variables, checked by MarkupReady } CheckSourceHeight := SourceHeight; CheckSourceWidth := SourceWidth; CheckMagnify := Magnify; CheckMagCenter := MagCenter; CheckMarkupBytesPerRow := MarkupBytesPerRow; CheckCenterOffset := CenterOffset; CheckRowBytes := 0; CheckRows := 0; CheckCols := 0; newDataInfo := nil; newMarkInfo := nil; newBkgInfo := nil; newData16Info := nil; gScaleMin := 0; gScaleMax := 0; gScaleXlate := nil; end; procedure enableKeepUndo; begin if not gUndoButtonEnabled then begin gUndoButtonEnabled := true; myHiliteControl(MarkupWindow, KeepCtrlid, 0); myHiliteControl(MarkupWindow, UndoCtrlid, 0); end; end; procedure LocToPix (loc: point; var pix: point); begin with loc do begin pix.h := SourceRect.left + h div Magnify; pix.v := SourceRect.top + v div Magnify; end; end; procedure PixToLoc (pix: point; var loc: point); begin with loc do begin v := (pix.v - SourceRect.top) * Magnify + MagCenter; h := (pix.h - SourceRect.left) * Magnify + MagCenter; end; end; procedure UpdateMarkupRect (r: Rect); var SavePort: GrafPtr; onScreenRect: Rect; begin {Copybits bug: if the source is outside the source pixmap but dest is not, then} {it copies junk. Observed for case where source was top = -1, bottom = 0.} {Fixed by testing for bottom > 0, since the Markup offscreen pixmap has top = 0. } if (MarkupWindow <> nil) and (r.bottom > 0) then begin onScreenRect := r; { The onscreen coordinate system is shifted by -MarkupCtrlHeight vertically,} { so that (0,0) is upper left of window, while the offscreen coordinate system} { has (0,0) at the upper left of the image area. Controls are not present in} {the offscreen pixmap.} OffsetRect(onScreenRect, 0, MarkupCtrlHeight); getPort(SavePort); SetPort(MarkupWindow); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); hlock(handle(MarkupOsPort^.portPixMap)); hlock(handle(CGrafPort(MarkupWindow^).PortPixMap)); CopyBits(BitMapHandle(MarkupOsPort^.PortPixMap)^^, BitMapHandle(CGrafPort(MarkupWindow^).PortPixMap)^^, r, onScreenRect, SrcCopy, nil); hunlock(handle(MarkupOsPort^.portPixMap)); hunlock(handle(CGrafPort(MarkupWindow^).PortPixMap)); DrawMyGrowIcon(MarkupWindow); SetPort(SavePort); end; end; {After changing SourceRect, force ThePixel and gAutoPixel to be on the screen } procedure AdjustPix (var pix: point); begin with pix, SourceRect do begin if h < left then h := left else if h >= right then h := right - 1; if v < top then v := top else if v >= bottom then v := bottom - 1; end; end; procedure DoMarkupCtrl (c: char); forward; procedure AdjustAutoPixel; var oldAutoPixel: point; begin oldAutoPixel := gAutoPixel; AdjustPix(gAutoPixel); {if the value of gAutoPixel changed, then exit automatic mode } if (not EqualPt(gAutoPixel, oldAutoPixel)) and gAutomatic then begin DoMarkupCtrl('A'); beep; end; end; {Safety critical: after calling the procedure, the offscreen pixmap for the } {Markup window must be reallocated to match the new sizes. } procedure AdjustMarkupSize; var vMargin, hMargin: integer; trect: rect; begin if ProfileHeight < minProfile then ProfileHeight := minProfile; if ProfileHeight > maxProfile then ProfileHeight := maxProfile; if ProfileWidth < minProfile then ProfileWidth := minProfile; if ProfileWidth > maxProfile then ProfileWidth := maxProfile; if Magnify <= 4 then begin {1 pixel surrounded by 8 } Magnify := 3; MagCenter := 1; end else if Magnify <= 7 then begin { 4 pixels surrounded by 32 } Magnify := 6; MagCenter := 2; end else begin { 5 pixels in a plus sign array } if Magnify > 21 then Magnify := 21 else if not odd(Magnify) then Magnify := Magnify + 1; MagCenter := Magnify div 2; end; vMargin := Magnify * 2 + ProfileHeight + 3 + MarkupCtrlHeight; hMargin := Magnify * 2 + ProfileWidth + 3; if MarkupTop < 40 then MarkupTop := 40; if MarkupLeft < 0 then MarkupLeft := 0; if MarkupWidth < 50 + hMargin then MarkupWidth := 50 + hMargin; if (MarkupWidth + MarkupLeft + 20) > ScreenWidth then MarkupWidth := ScreenWidth - MarkupLeft - 20; if (MarkupHeight + MarkupTop + 10) > ScreenHeight then MarkupHeight := ScreenHeight - MarkupTop - 10; if MarkupHeight < 50 + vMargin then MarkupHeight := 50 + vMargin; PaneHeight := MarkupHeight - vMargin; PaneWidth := MarkupWidth - hMargin; SourceHeight := (PaneHeight + Magnify - 1) div Magnify; SourceWidth := (PaneWidth + Magnify - 1) div Magnify; with MarkupMarkInfo^, SourceRect do begin {The pane can't be larger than the original image } if SourceHeight > nlines then SourceHeight := nlines; if SourceWidth > PixelsPerLine then SourceWidth := PixelsPerLine; { Set up SourceRect: Put NewCenterPix close to center.} left := NewCenterPix.h - SourceWidth div 2; top := NewCenterPix.v - SourceHeight div 2; { Keep SourceRect rect within the original image offscreen pixmap. } { (probably a lot of Image would break if the origin of image pixmaps weren't (0,0)} { so it shouldn't hurt to assume that the origin is (0,0) here... ???) } if left < 0 then left := 0; if top < 0 then top := 0; right := left + SourceWidth; bottom := top + SourceHeight; if right > PixelsPerLine then begin right := PixelsPerLine; left := PixelsPerLine - SourceWidth; end; if bottom > nlines then begin bottom := nlines; top := nlines - SourceHeight; end; { Now adjust NewCenterPix to remember the new center. } NewCenterPix.h := (left + right) div 2; NewCenterPix.v := (top + bottom) div 2; end; PaneHeight := SourceHeight * Magnify; PaneWidth := SourceWidth * Magnify; MarkupHeight := PaneHeight + vMargin; MarkupWidth := PaneWidth + hMargin; with trect do begin left := 0; right := PaneWidth; top := 0; bottom := PaneHeight; SetRect(MarkupPaneRect, left, top, right, bottom); top := bottom + 1; bottom := top + Magnify; SetRect(MarksRowRect, left, top, right, bottom); top := bottom + 1; bottom := top + Magnify; SetRect(DataRowRect, left, top, right, bottom); top := bottom + 1; bottom := top + ProfileHeight; SetRect(ProfileRowRect, left, top, right, bottom); top := 0; bottom := PaneHeight; left := PaneWidth + 1; right := left + Magnify; SetRect(MarksColRect, left, top, right, bottom); left := right + 1; right := left + Magnify; SetRect(DataColRect, left, top, right, bottom); left := right + 1; right := left + ProfileWidth; SetRect(ProfileColRect, left, top, right, bottom); end; SetRect(UpdRowRect, 0, PaneHeight, PaneWidth + 1, PaneHeight + vMargin); SetRect(UpdColRect, PaneWidth, 0, PaneWidth + hMargin, PaneHeight + 1); SetRect(LastColRect, ProfileColRect.left, -1, ProfileColRect.right, 0); SetRect(LastRowRect, -1, ProfileRowRect.top, 0, ProfileRowRect.bottom); AdjustPix(ThePixel); AdjustAutoPixel; SetRect(ProfileDragRect, PaneWidth, PaneHeight, PaneWidth + 8, PaneHeight + 8); SetRect(ScalePlotsButton, PaneWidth, PaneHeight + 8, MarkupWidth, PaneHeight + (ProfileHeight - 8) div 2); OffsetRect(ScalePlotsButton, 0, (ProfileHeight - 8) div 2); InsetRect(ScalePlotsButton, 4, 4); end; procedure ScaleLine (count, ProfileScale: integer; var values, bkgs: LineType); var min, max, i, v, range, half: integer; begin if count > MaxLine then count := Maxline; if scalePlots then begin min := 255; max := 0; for i := 0 to count - 1 do begin v := values[i]; if min > v then min := v; if max < v then max := v; v := bkgs[i]; if v <> 0 then begin if min > v then min := v; if max < v then max := v; end; end; end else begin min := 0; max := 255; end; range := max - min; half := range div 2; if range <> 0 then for i := 0 to count - 1 do begin values[i] := ((values[i] - min) * ProfileScale + half) div range; if bkgs[i] <> 0 then bkgs[i] := ((bkgs[i] - min) * ProfileScale + half) div range; end else begin v := ProfileScale div 2; for i := 0 to count - 1 do begin values[i] := v; if bkgs[i] <> 0 then bkgs[i] := v; end; end; end; procedure ScaleLine16 (count, ProfileScale: integer; var values, bkgs: LineType); var min, max, i, v, range, half: LongInt; vptr, bptr: puwp; begin if count > MaxLine div 2 then count := Maxline div 2; if scalePlots then begin min := 65535; max := 0; vptr := @values; bptr := @bkgs; for i := 0 to count - 1 do begin v := vptr^.u; if min > v then min := v; if max < v then max := v; v := bptr^.u; if v <> 0 then begin if min > v then min := v; if max < v then max := v; end; vptr := puwp(Ord4(vptr) + 2); bptr := puwp(Ord4(bptr) + 2); end; end else begin min := 0; max := 65535; end; range := max - min; half := range div 2; if range <> 0 then begin vptr := @values; bptr := @bkgs; for i := 0 to count - 1 do begin values[i] := ((vptr^.u - min) * ProfileScale + half) div range; if bptr^.u = 0 then bkgs[i] := 0 else bkgs[i] := ((bptr^.u - min) * ProfileScale + half) div range; vptr := puwp(Ord4(vptr) + 2); bptr := puwp(Ord4(bptr) + 2); end end else begin v := ProfileScale div 2; for i := 0 to count - 1 do begin values[i] := v; bkgs[i] := 0; end; end; end; procedure GetCol16 (hstart, vstart, count: integer; var data: LineType); type WP = ^Integer; {wptr is a field in info, Think Pascal error message leaves a lot to be desired when} {the type name is WPtr rather than WP.} var bpr: LongInt; col, pic: WP; begin if count > MaxLine div 2 then count := MaxLine div 2; col := @data; with Info^ do begin bpr := BytesPerRow; if hstart >= 0 then if vstart >= 0 then if LongInt(hstart) * 2 + 1 < PixelsPerLine then if vstart <= nlines - count then begin pic := WP(Ord4(PicBaseAddr) + LongInt(vstart) * bpr + LongInt(hstart) * 2); while count > 0 do begin col^ := pic^; pic := WP(Ord4(pic) + bpr); col := WP(Ord4(col) + 2); count := count - 1; end; end; end; while count > 0 do begin col^ := BackgroundIndex; col := WP(Ord4(col) + 2); count := count - 1; end; end; procedure UpdateRowDisplay; var SavePort: GrafPtr; trect: Rect; values, bkgs: LineType; i, x, y: integer; SaveInfo: InfoPtr; loc: point; begin SaveInfo := Info; Info := MarkupDataInfo; GetPort(SavePort); SetPort(GrafPtr(MarkupOsPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); { Use copybits to create the enlarged pixels in the offscreen pixmap } with ThePixel, SourceRect do SetRect(trect, left, v, right, v + 1); with MarkupMarkInfo^ do begin hlock(handle(osPort^.portPixMap)); hlock(handle(MarkupOsPort^.PortPixMap)); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, BitMapHandle(MarkupOsPort^.PortPixMap)^^, trect, MarksRowRect, SrcCopy, nil); hunlock(handle(osPort^.portPixMap)); hunlock(handle(MarkupOsPort^.PortPixMap)); end; with MarkupDataInfo^ do begin hlock(handle(osPort^.portPixMap)); hlock(handle(MarkupOsPort^.PortPixMap)); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, BitMapHandle(MarkupOsPort^.PortPixMap)^^, trect, DataRowRect, SrcCopy, nil); hunlock(handle(osPort^.portPixMap)); hunlock(handle(MarkupOsPort^.PortPixMap)); end; PenNormal; PenSize(1, 1); trect := MarksRowRect; InsetRect(trect, -1, -1); FrameRect(trect); trect := DataRowRect; InsetRect(trect, -1, -1); FrameRect(trect); if MarkupData16Info <> nil then begin Info := MarkupData16Info; GetLine(SourceRect.left * 2, ThePixel.v, SourceWidth * 2, values); Info := MarkupBkgInfo; GetLine(SourceRect.left * 2, ThePixel.v, SourceWidth * 2, bkgs); ScaleLine16(SourceWidth, ProfileHeight - 2, values, bkgs); end else begin Info := MarkupDataInfo; GetLine(SourceRect.left, ThePixel.v, SourceWidth, values); Info := MarkupBkgInfo; GetLine(SourceRect.left, ThePixel.v, SourceWidth, bkgs); ScaleLine(SourceWidth, ProfileHeight - 2, values, bkgs); end; x := ProfileRowRect.left + Magnify div 2; y := ProfileRowRect.bottom; EraseRect(ProfileRowRect); trect := ProfileRowRect; InsetRect(trect, -1, -1); FrameRect(trect); MoveTo(x, y - values[0]); for i := 1 to SourceWidth - 1 do begin x := x + Magnify; LineTo(x, y - values[i]); end; x := ProfileRowRect.left + Magnify div 2; MoveTo(x, y - bkgs[0]); for i := 1 to SourceWidth - 1 do begin x := x + Magnify; LineTo(x, y - bkgs[i]); end; PixToLoc(ThePixel, loc); PenMode(PatXor); {??? Here is the dead cursor line bug. Fix it one day...} {(happens when you resize the window so that LastColRect is bad)} MoveTo(LastColRect.left, LastColRect.top); LineTo(LastColRect.right, LastColRect.bottom - 1); MoveTo(LastRowRect.left, LastRowRect.top); LineTo(LastRowRect.right - 1, LastRowRect.bottom); SetPort(MarkupWindow); UpdateMarkupRect(LastColRect); UpdateMarkupRect(LastRowRect); SetPort(GrafPtr(MarkupOsPort)); SetRect(LastColRect, ProfileColRect.left, loc.v, ProfileColRect.right, loc.v + 1); MoveTo(LastColRect.left, LastColRect.top); LineTo(LastColRect.right, LastColRect.bottom - 1); PenNormal; SetPort(MarkupWindow); UpdateMarkupRect(UpdRowRect); UpdateMarkupRect(LastColRect); SetPort(SavePort); Info := SaveInfo; end; procedure UpdateColDisplay; var SavePort: GrafPtr; trect: Rect; values, bkgs: LineType; i, x, y: integer; SaveInfo: InfoPtr; loc: point; begin SaveInfo := Info; Info := MarkupDataInfo; GetPort(SavePort); SetPort(GrafPtr(MarkupOsPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); { Use copybits to create the enlarged pixels in the offscreen pixmap } with ThePixel, SourceRect do SetRect(trect, h, top, h + 1, bottom); with MarkupMarkInfo^ do begin hlock(handle(osPort^.portPixMap)); hlock(handle(MarkupOsPort^.PortPixMap)); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, BitMapHandle(MarkupOsPort^.PortPixMap)^^, trect, MarksColRect, SrcCopy, nil); hunlock(handle(osPort^.portPixMap)); hunlock(handle(MarkupOsPort^.PortPixMap)); end; with MarkupDataInfo^ do begin hlock(handle(osPort^.portPixMap)); hlock(handle(MarkupOsPort^.PortPixMap)); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, BitMapHandle(MarkupOsPort^.PortPixMap)^^, trect, DataColRect, SrcCopy, nil); hunlock(handle(osPort^.portPixMap)); hunlock(handle(MarkupOsPort^.PortPixMap)); end; PenNormal; PenSize(1, 1); trect := MarksColRect; InsetRect(trect, -1, -1); FrameRect(trect); trect := DataColRect; InsetRect(trect, -1, -1); FrameRect(trect); if MarkupData16Info <> nil then begin Info := MarkupData16Info; GetCol16(ThePixel.h, SourceRect.top, SourceHeight, values); Info := MarkupBkgInfo; GetCol16(ThePixel.h, SourceRect.top, SourceHeight, bkgs); ScaleLine16(SourceHeight, ProfileWidth - 2, values, bkgs); end else begin Info := MarkupDataInfo; GetColumn(ThePixel.h, SourceRect.top, SourceHeight, values); Info := MarkupBkgInfo; GetColumn(ThePixel.h, SourceRect.top, SourceHeight, bkgs); ScaleLine(SourceHeight, ProfileWidth - 2, values, bkgs); end; x := ProfileColRect.right; y := ProfileColRect.top + Magnify div 2; EraseRect(ProfileColRect); trect := ProfileColRect; InsetRect(trect, -1, -1); FrameRect(trect); MoveTo(x - values[0], y); for i := 1 to SourceHeight - 1 do begin y := y + Magnify; LineTo(x - values[i], y); end; y := ProfileColRect.top + Magnify div 2; MoveTo(x - bkgs[0], y); for i := 1 to SourceHeight - 1 do begin y := y + Magnify; LineTo(x - bkgs[i], y); end; PixToLoc(ThePixel, loc); PenMode(PatXor); {??? Here is the dead cursor line bug. Fix it one day...} {(happens when you resize the window so that LastColRect is bad)} MoveTo(LastColRect.left, LastColRect.top); LineTo(LastColRect.right, LastColRect.bottom - 1); MoveTo(LastRowRect.left, LastRowRect.top); LineTo(LastRowRect.right - 1, LastRowRect.bottom); SetPort(MarkupWindow); UpdateMarkupRect(LastColRect); UpdateMarkupRect(LastRowRect); SetPort(GrafPtr(MarkupOsPort)); SetRect(LastRowRect, loc.h, ProfileRowRect.top, loc.h + 1, ProfileRowRect.bottom); MoveTo(LastRowRect.left, LastRowRect.top); LineTo(LastRowRect.right - 1, LastRowRect.bottom); PenNormal; SetPort(MarkupWindow); UpdateMarkupRect(UpdColRect); UpdateMarkupRect(LastRowRect); SetPort(SavePort); Info := SaveInfo; end; procedure Calc8Histograms; var L: Longint; rows, cols: integer; RowBytes: LongInt; HistPtr: lptr; MarkPtr, DataPtr, BkgPtr: pup; MarkRow, DataRow, BkgRow: LongInt; HistBase, MarkedSBase, MarkedBBase: Longint; begin ShowWatch; myHiliteControl(MarkupWindow, CalcIntensityCtrlid, 1); myHiliteControl(MarkupWindow, CancelCtrlid, 0); HistBase := Ord4(@histogram[0]); MarkedSBase := Ord4(@MarkedSum[0]); MarkedBBase := Ord4(@MarkedBkg[0]); HistPtr := lptr(HistBase); L := 256; while L > 0 do begin HistPtr^ := 0; HistPtr := lptr(Ord4(HistPtr) + 4); L := L - 1; end; HistPtr := lptr(MarkedSBase); L := 256; while L > 0 do begin HistPtr^ := 0; HistPtr := lptr(Ord4(HistPtr) + 4); L := L - 1; end; L := 256; HistPtr := lptr(MarkedBBase); while L > 0 do begin HistPtr^ := 0; HistPtr := lptr(Ord4(HistPtr) + 4); L := L - 1; end; RowBytes := MarkupMarkInfo^.BytesPerRow; MarkRow := Ord4(MarkupMarkInfo^.PicBaseAddr); DataRow := Ord4(MarkupDataInfo^.PicBaseAddr); BkgRow := Ord4(MarkupBkgInfo^.PicBaseAddr); rows := MarkupMarkInfo^.nlines; cols := MarkupMarkInfo^.PixelsPerLine; if (RowBytes <> MarkupDataInfo^.BytesPerRow) or (RowBytes <> MarkupBkgInfo^.BytesPerRow) or (rows <> MarkupDataInfo^.nlines) or (cols <> MarkupDataInfo^.PixelsPerLine) or (rows <> MarkupBkgInfo^.nlines) or (cols <> MarkupBkgInfo^.PixelsPerLine) then PutMessage('Markup Bug: images not same size'); if rows * cols > $007FFFFF then PutMessage('Markup: MarkedSum could overflow'); while rows > 0 do begin cols := MarkupMarkInfo^.PixelsPerLine; DataPtr := pup(DataRow); MarkPtr := pup(MarkRow); BkgPtr := pup(BkgRow); while cols > 0 do begin L := MarkPtr^.u * 4; HistPtr := lptr(HistBase + L); HistPtr^ := HistPtr^ + 1; HistPtr := lptr(MarkedSBase + L); HistPtr^ := HistPtr^ + DataPtr^.u; HistPtr := lptr(MarkedBBase + L); HistPtr^ := HistPtr^ + BkgPtr^.u; DataPtr := pup(Ord4(DataPtr) + 1); MarkPtr := pup(Ord4(MarkPtr) + 1); BkgPtr := pup(Ord4(BkgPtr) + 1); cols := cols - 1; end; DataRow := DataRow + RowBytes; MarkRow := MarkRow + RowBytes; BkgRow := BkgRow + RowBytes; rows := rows - 1; if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; rows := 0; end; end; myHiliteControl(MarkupWindow, CalcIntensityCtrlid, 0); myHiliteControl(MarkupWindow, CancelCtrlid, 255); end; procedure Calc16Histograms; var L: Longint; rows, cols: integer; RowBytes: LongInt; HistPtr: lptr; MarkPtr: pup; DataPtr, BkgPtr: puwp; MarkRow, DataRow, BkgRow: LongInt; HistBase, MarkedSBase, MarkedBBase: Longint; begin ShowWatch; myHiliteControl(MarkupWindow, CalcIntensityCtrlid, 1); myHiliteControl(MarkupWindow, CancelCtrlid, 0); HistBase := Ord4(@histogram[0]); MarkedSBase := Ord4(@MarkedSum[0]); MarkedBBase := Ord4(@MarkedBkg[0]); HistPtr := lptr(HistBase); L := 256; while L > 0 do begin HistPtr^ := 0; HistPtr := lptr(Ord4(HistPtr) + 4); L := L - 1; end; HistPtr := lptr(MarkedSBase); L := 256; while L > 0 do begin HistPtr^ := 0; HistPtr := lptr(Ord4(HistPtr) + 4); L := L - 1; end; L := 256; HistPtr := lptr(MarkedBBase); while L > 0 do begin HistPtr^ := 0; HistPtr := lptr(Ord4(HistPtr) + 4); L := L - 1; end; RowBytes := MarkupMarkInfo^.BytesPerRow; MarkRow := Ord4(MarkupMarkInfo^.PicBaseAddr); DataRow := Ord4(MarkupData16Info^.PicBaseAddr); BkgRow := Ord4(MarkupBkgInfo^.PicBaseAddr); rows := MarkupMarkInfo^.nlines; cols := MarkupMarkInfo^.PixelsPerLine; if (RowBytes * 2 <> MarkupData16Info^.BytesPerRow) or (RowBytes * 2 <> MarkupBkgInfo^.BytesPerRow) or (rows <> MarkupData16Info^.nlines) or (cols * 2 <> MarkupData16Info^.PixelsPerLine) or (rows <> MarkupBkgInfo^.nlines) or (cols * 2 <> MarkupBkgInfo^.PixelsPerLine) then PutMessage('Markup Bug: images not same size'); if cols <> RowBytes then PutMessage('Markup Bug: cols <> RowBytes'); {added for 16 bit images} if rows * cols > $007FFFFF then PutMessage('Markup: MarkedSum could overflow'); while rows > 0 do begin cols := MarkupMarkInfo^.PixelsPerLine; DataPtr := puwp(DataRow); MarkPtr := pup(MarkRow); BkgPtr := puwp(BkgRow); while cols > 0 do begin L := MarkPtr^.u * 4; HistPtr := lptr(HistBase + L); HistPtr^ := HistPtr^ + 1; HistPtr := lptr(MarkedSBase + L); HistPtr^ := HistPtr^ + DataPtr^.u; HistPtr := lptr(MarkedBBase + L); HistPtr^ := HistPtr^ + BkgPtr^.u; DataPtr := puwp(Ord4(DataPtr) + 2); MarkPtr := pup(Ord4(MarkPtr) + 1); BkgPtr := puwp(Ord4(BkgPtr) + 2); cols := cols - 1; end; DataRow := DataRow + RowBytes + RowBytes; MarkRow := MarkRow + RowBytes; BkgRow := BkgRow + RowBytes + RowBytes; rows := rows - 1; if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; rows := 0; end; end; myHiliteControl(MarkupWindow, CalcIntensityCtrlid, 0); myHiliteControl(MarkupWindow, CancelCtrlid, 255); end; procedure CalculateHistograms; begin if MarkupData16Info <> nil then Calc16Histograms else Calc8Histograms; end; function onebkgpix (bkg, mark, data, kernel, incr, kincr, nc, nr: longint): Boolean; inline {pascal char onebkgpix3( } {char *bkg, } {char *mark, } {unsigned char *data, } {unsigned long *kernel, } {unsigned long incr, } {unsigned long kincr, } {unsigned long nc, } {unsigned long nr) [ } { unsigned long tot,w,kerv; } { unsigned long h; } { } { w = 0; } { tot = 0; } { --nr; } { --nc; } { kincr <<= 2; } { do [ } { h = nc; } { do [ } { if ((*mark++) != 0) [ } { kernel++; } { data++; } { ] else if ((kerv = *kernel++) != 0) [ } { w += kerv; } { tot += kerv * (*data++); } { ] else [ } { data++; } { ] } { ] while(--h >= 0); } { mark += incr; } { data += incr; } { ((char * )kernel) += kincr;} { ] while(--nr >= 0); } { if (w == 0) } { return 0; } { *bkg = (tot + w/2) / w; } { return 1; } {] } {; stack: } {; 0 to 1B save registers } {; 1C nr } {; 20 nc } {; 24 kincr } {; 28 incr } {; 2C kernel } {; 30 data } {; 34 mark } {; 38 bkg } {; 3C return value } {; D0 scratch } {; D1 nr } {; D2 incr } {; D3 nc } {; D4 tot } {; D5 w } {; D6 h } {; D7 kerv } {; A0 mark } {; A1 kincr } {; A3 kernel } {; A4 data } {; } { MACHINE MC68020 } {onebkgpix3 PROC } { MOVEM.L D3-D7/A3/A4,-(A7) ;$1C } { MOVEQ #$00,D5 ;w } { MOVEQ #$00,D4 ;tot } { MOVE.L $1C(A7),D1 ;nr } { SUBQ.L #$1,D1 ;--nr } { MOVE.L $20(A7),D3 ;nc } { SUBQ.L #$1,D3 ;--nc } { MOVE.L $24(A7),D0 ;kincr <<= 2; } { LSL.L #$2,D0 } { MOVEA.L D0,A1 } { MOVE.L $28(A7),D2 ;incr } { MOVEA.L $2C(A7),A3 ;kernel } { MOVEA.L $30(A7),A4 ;data } { MOVEA.L $34(A7),A0 ;mark } {L1: MOVE.L D3,D6 ;h = nc; } {L2: TST.B (A0)+ ;...*mark++... } { BEQ.S L4 ;if ((*mark++) != 0) } { ADDQ.W #$4,A3 ;kernel++ } {L3: ADDQ.W #$1,A4 ;data++ } { DBRA D6,L2 ;while(--h >= 0) } { BRA.S L5 } {L4: MOVE.L (A3)+,D7 ;kerv = *kernel++ } { BEQ.S L3 ;if (kerv != 0) } { ADD.L D7,D5 ;w += kerv } { MOVEQ #0,D0 } { MOVE.B (A4)+,D0 ;...*data++... } { TST.L D0 } { MULU.L D7,D0 } { ADD.L D0,D4 ;tot += kerv * (*data++) } { DBRA D6,L2 ;while(--h >= 0) } {L5: ADDA.L D2,A0 ;mark += incr } { ADDA.L D2,A4 ;data += incr } { ADDA.L A1,A3 ;((char * )kernel ) += kincr } { DBRA D1,L1 ;while(--nr >= 0) } { MOVE.L D5,D0 ;w } { BNE.S L6 ;if (w == 0) } { CLR.B $3C(A7) ;return 0 } { BRA.S L7 } {L6: LSR.L #$1,D0 ;w/2 } { ADD.L D4,D0 ;tot + w/2 } { DIVU.L D5,D0 ;w } { MOVEA.L $38(A7),A0 ;*bkg = (tot + w/2) / w } { MOVE.B D0,(A0) } { MOVE.B #$01,$3C(A7) ;return 1 } {L7: MOVEM.L (A7)+,D3-D7/A3/A4 } { ADDA.L #$20,A7 } { ENDPROC } { END } $48E7, $1F18, $7A00, $7800, $222F, $001C, $5381, $262F,{} $0020, $5383, $202F, $0024, $E588, $2240, $242F, $0028,{} $266F, $002C, $286F, $0030, $206F, $0034, $2C03, $4A18,{} $670A, $584B, $524C, $51CE, $FFF6, $6016, $2E1B, $67F4,{} $DA87, $7000, $101C, $4A80, $4C07, $0000, $D880, $51CE,{} $FFDE, $D1C2, $D9C2, $D7C9, $51C9, $FFD2, $2005, $6606,{} $422F, $003C, $6014, $E288, $D084, $4C45, $0000, $206F,{} $0038, $1080, $1F7C, $0001, $003C, $4CDF, $18F8, $DEFC, {} $0020; function onebkgp16 (bkg, mark, data, kernel, incr, kincr, nc, nr: longint): Boolean; inline {pascal char onebkgpix16(} {unsigned short *bkg,} {char *mark,} {unsigned short *data,} {unsigned long *kernel,} {unsigned long incr,} {unsigned long kincr,} {unsigned long nc,} {unsigned long nr) [} { unsigned long tot,w,kerv,dincr;} { unsigned long h;} {} { w = 0;} { tot = 0;} { --nr;} { --nc;} { kincr <<= 2;} { dincr = incr << 1;} { do [} { h = nc;} { do [} { if (( *mark++) != 0) [} { kernel++;} { data++;} { ] else if ((kerv = *kernel++) != 0) [} { w += kerv;} { tot += kerv * ( *data++);} { ] else [} { data++;} { ]} { ] while(--h >= 0);} { mark += incr;} { ((char * )data) += dincr;} { ((char * )kernel) += kincr;} { ] while(--nr >= 0);} { if (w == 0)} { return 0;} { *bkg = (tot + w/2) / w;} { return 1;} {]} {; The kernel array is an array of longs.} {; Data and bkg are shorts.} {; stack:} {; 0 to 1F save registers} {; 20 nr} {; 24 nc} {; 28 kincr} {; 2C incr} {; 30 kernel} {; 34 data} {; 38 mark} {; 3C bkg} {; 40 return value} {; registers:} {; D0 scratch} {; D1 nr} {; D2 incr} {; D3 nc} {; D4 tot} {; D5 w} {; D6 h} {; D7 kerv} {; A0 mark} {; A1 kincr} {; A2 dincr} {; A3 kernel} {; A4 data} {;} { MACHINE MC68020} {onebkgpix16 PROC} { MOVEA.L A7,A0 ;A0 is temp arg ptr} { MOVEM.L D3-D7/A2-A4,-(A7) ;$20 = 8 registers} { MOVEQ #$00,D5 ;w} { MOVEQ #$00,D4 ;tot} { MOVE.L (A0)+,D1 ;nr} { SUBQ.L #$1,D1 ;--nr} { MOVE.L (A0)+,D3 ;nc} { SUBQ.L #$1,D3 ;--nc} { MOVE.L (A0)+,D0 ;kincr <<= 2} { LSL.L #$2,D0} { MOVEA.L D0,A1} { MOVE.L (A0)+,D2 ;incr} { MOVE.L D2,D0} { LSL.L #$1,D0} { MOVEA.L D0,A2 ;dincr = incr << 1} { MOVEA.L (A0)+,A3 ;kernel} { MOVEA.L (A0)+,A4 ;data} { MOVEA.L (A0)+,A0 ;mark} {L1: MOVE.L D3,D6 ;h = nc;} {L2: TST.B (A0)+ ;...*mark++...} { BEQ.S L4 ;if (( *mark++) != 0)} { ADDQ.W #$4,A3 ;kernel++} {L3: ADDQ.W #$2,A4 ;data++} { DBRA D6,L2 ;while(--h >= 0)} { BRA.S L5} {L4: MOVE.L (A3)+,D7 ;kerv = *kernel++} { BEQ.S L3 ;if (kerv != 0)} { ADD.L D7,D5 ;w += kerv} { MOVEQ #0,D0} { MOVE.W (A4)+,D0 ;...*data++...} { TST.L D0} { MULU.L D7,D0} { ADD.L D0,D4 ;tot += kerv * ( *data++)} { DBRA D6,L2 ;while(--h >= 0)} {L5: ADDA.L D2,A0 ;mark += incr} { ADDA.L A2,A4 ;((char * )data) += dincr} { ADDA.L A1,A3 ;((char * )kernel) += kincr} { DBRA D1,L1 ;while(--nr >= 0)} { MOVE.L D5,D0 ;w} { BNE.S L6 ;if (w == 0)} { CLR.B $40(A7) ;return 0} { BRA.S L7} {L6: LSR.L #$1,D0 ;w/2} { ADD.L D4,D0 ;tot + w/2} { DIVU.L D5,D0 ;w} { MOVEA.L $3C(A7),A0 ;*bkg = (tot + w/2) / w} { MOVE.W D0,(A0)} { MOVE.B #$01,$40(A7) ;return 1} {L7: MOVEM.L (A7)+,D3-D7/A2-A4} { ADDA.L #$20,A7} { ENDPROC} { END} $204F, $48E7, $1F38, $7A00, $7800, $2218, $5381, $2618, {} $5383, $2018, $E588, $2240, $2418, $2002, $E388, $2440, {} $2658, $2858, $2058, $2C03, $4A18, $670A, $584B, $544C, {} $51CE, $FFF6, $6016, $2E1B, $67F4, $DA87, $7000, $301C, {} $4A80, $4C07, $0000, $D880, $51CE, $FFDE, $D1C2, $D9CA, {} $D7C9, $51C9, $FFD2, $2005, $6606, $422F, $0040, $6014, {} $E288, $D084, $4C45, $0000, $206F, $003C, $3080, $1F7C, {} $0001, $0040, $4CDF, $1CF8, $DEFC, $0020; {This code is copied from Functions.p } procedure ApplyTableToLine (data: ptr; var table: LookupTable; width: LongInt); { var } { line: LinePtr; } { i: integer; } { begin } { line := LinePtr(data);} { for i := 0 to width - 1 do} { Line^[i] := table[Line^[i]];} { end;} {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} {Temporary marks are pixel values in marks image } {of nExtraColors+1 to nExtraColors*2} procedure Dilate16; var mark: pup; data16, bkg16: puwp; data16UL, markUL, bkg16UL: Longint; {Upper Left corner pointers} RowBytes, offset, incr: LongInt; RowBytes16, incr16: LongInt; nc, lc, cc: integer; {num cols, line ctr, col ctr} mval, i, j: integer; SaveInfo: InfoPtr; table: LookupTable; begin ShowWatch; myHiliteControl(MarkupWindow, DilateCtrlid, 1); myHiliteControl(MarkupWindow, CancelCtrlid, 0); for i := 0 to 255 do table[i] := i; j := nExtraColors + 1; for i := 1 to nExtraColors do begin table[j] := i; j := j + 1; end; with MarkupMarkInfo^ do begin RowBytes := BytesPerRow; lc := nlines - 2; nc := PixelsPerLine - 2; markUL := Ord4(PicBaseAddr); end; with MarkupData16Info^ do begin RowBytes16 := BytesPerRow; data16UL := Ord4(PicBaseAddr); end; offset := RowBytes + 1; incr := RowBytes - nc; incr16 := RowBytes16 - nc * 2; mark := pup(markUL + offset); with MarkupBkgInfo^ do begin bkg16UL := Ord4(PicBaseAddr); end; while lc > 0 do begin lc := lc - 1; cc := nc; while cc > 0 do begin cc := cc - 1; mval := mark^.u; if mval > 0 then if mval <= nExtraColors then begin mval := mval + nExtraColors; mark := pup(markUL); {scan surrounding marks} data16 := puwp(data16UL); bkg16 := puwp(bkg16UL); i := 3; while i > 0 do begin j := 3; while j > 0 do begin if mark^.u = 0 then begin if gRidge then begin if data16^.u > (bkg16^.u * bkgCoefficient + 5000) div 10000 then mark^.u := mval; end else begin if data16^.u < (bkg16^.u * bkgCoefficient + 5000) div 10000 then mark^.u := mval; end; end; data16 := puwp(Ord4(data16) + 2); mark := pup(Ord4(mark) + 1); bkg16 := puwp(Ord4(bkg16) + 2); j := j - 1; end; {while j > 0} data16 := puwp(Ord4(data16) + rowBytes16 - 6); mark := pup(Ord4(mark) + rowBytes - 3); bkg16 := puwp(Ord4(bkg16) + rowBytes16 - 6); i := i - 1; end; {while i > 0} mark := pup(markUL + offset); {restore mark pointer} end; {if mval > 0 then if mval <= nExtraColors} data16UL := data16UL + 2; markUL := markUL + 1; bkg16UL := bkg16UL + 2; mark := pup(Ord4(mark) + 1); end; {while cc > 0 } data16UL := data16UL + incr16; markUL := markUL + incr; bkg16UL := bkg16UL + incr16; mark := pup(Ord4(mark) + incr); if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; cc := 0; lc := 0; end; end; {while lc > 0} with MarkupMarkInfo^ do begin markUL := Ord4(PicBaseAddr); for i := 1 to nlines do begin ApplyTableToLine(ptr(markUL), table, PixelsPerLine); markUL := markUL + BytesPerRow; end; changes := true; WhatToUndo := UndoEdit; gBkgUpdReqd := true; {redraw the profile plots} EnableKeepUndo; end; SaveInfo := Info; Info := MarkupMarkInfo; UpdatePicWindow; Info := SaveInfo; myHiliteControl(MarkupWindow, DilateCtrlid, 0); myHiliteControl(MarkupWindow, CancelCtrlid, 255); end; {Temporary marks are pixel values in marks image } {of nExtraColors+1 to nExtraColors*2} procedure Dilate; var mark, data, bkg: pup; dataUL, markUL, bkgUL: Longint; {Upper Left corner pointers} RowBytes, offset, incr: LongInt; nc, lc, cc: integer; {num cols, line ctr, col ctr} mval, i, j: integer; SaveInfo: InfoPtr; table: LookupTable; begin if MarkupData16Info <> nil then begin Dilate16; exit(Dilate); end; ShowWatch; myHiliteControl(MarkupWindow, DilateCtrlid, 1); myHiliteControl(MarkupWindow, CancelCtrlid, 0); for i := 0 to 255 do table[i] := i; j := nExtraColors + 1; for i := 1 to nExtraColors do begin table[j] := i; j := j + 1; end; with MarkupMarkInfo^ do begin RowBytes := BytesPerRow; lc := nlines - 2; nc := PixelsPerLine - 2; markUL := Ord4(PicBaseAddr); end; offset := RowBytes + 1; incr := RowBytes - nc; mark := pup(markUL + offset); with MarkupBkgInfo^ do begin bkgUL := Ord4(PicBaseAddr); end; with MarkupDataInfo^ do begin dataUL := Ord4(PicBaseAddr); end; while lc > 0 do begin lc := lc - 1; cc := nc; while cc > 0 do begin cc := cc - 1; mval := mark^.u; if mval > 0 then if mval <= nExtraColors then begin mval := mval + nExtraColors; mark := pup(markUL); {scan surrounding marks} data := pup(dataUL); bkg := pup(bkgUL); i := 3; while i > 0 do begin j := 3; while j > 0 do begin if mark^.u = 0 then begin if gRidge then begin if data^.u > (bkg^.u * bkgCoefficient + 5000) div 10000 then mark^.u := mval; end else begin if data^.u < (bkg^.u * bkgCoefficient + 5000) div 10000 then mark^.u := mval; end; end; data := pup(Ord4(data) + 1); mark := pup(Ord4(mark) + 1); bkg := pup(Ord4(bkg) + 1); j := j - 1; end; {while j > 0} data := pup(Ord4(data) + rowBytes - 3); mark := pup(Ord4(mark) + rowBytes - 3); bkg := pup(Ord4(bkg) + rowBytes - 3); i := i - 1; end; {while i > 0} mark := pup(markUL + offset); {restore mark pointer} end; {if mval > 0 then if mval <= nExtraColors} dataUL := dataUL + 1; markUL := markUL + 1; bkgUL := bkgUL + 1; mark := pup(Ord4(mark) + 1); end; {while cc > 0 } dataUL := dataUL + incr; markUL := markUL + incr; bkgUL := bkgUL + incr; mark := pup(Ord4(mark) + incr); if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; cc := 0; lc := 0; end; end; {while lc > 0} with MarkupMarkInfo^ do begin markUL := Ord4(PicBaseAddr); for i := 1 to nlines do begin ApplyTableToLine(ptr(markUL), table, PixelsPerLine); markUL := markUL + BytesPerRow; end; changes := true; WhatToUndo := UndoEdit; gBkgUpdReqd := true; {redraw the profile plots} EnableKeepUndo; end; SaveInfo := Info; Info := MarkupMarkInfo; UpdatePicWindow; Info := SaveInfo; myHiliteControl(MarkupWindow, DilateCtrlid, 0); myHiliteControl(MarkupWindow, CancelCtrlid, 255); end; procedure Erode; var mark, data, bkg: pup; markUL: Longint; {Upper Left corner pointer} RowBytes, offset, incr, rbincr: LongInt; nl, nc, lc, cc: integer; {num cols, line ctr, col ctr} flag: integer; erodeable: Boolean; SaveInfo: InfoPtr; Savemark: pup; begin if MarkupData16Info <> nil then exit(Erode); ShowWatch; myHiliteControl(MarkupWindow, ErodeCtrlid, 1); myHiliteControl(MarkupWindow, CancelCtrlid, 0); with MarkupMarkInfo^ do begin RowBytes := BytesPerRow; nl := nlines - 2; nc := PixelsPerLine - 2; markUL := Ord4(PicBaseAddr); end; offset := RowBytes + 1; incr := RowBytes - nc; rbincr := RowBytes - 2; mark := pup(markUL + offset); bkg := pup(Ord4(MarkupBkgInfo^.PicBaseAddr) + offset); data := pup(Ord4(MarkupDataInfo^.PicBaseAddr) + offset); lc := nl; flag := nExtraColors + 1; while lc > 0 do begin lc := lc - 1; cc := nc; while cc > 0 do begin cc := cc - 1; if mark^.u <> 0 then if mark^.u <= nExtraColors then begin erodeable := false; if gRidge then begin if data^.u < (bkg^.u * bkgCoefficient + 5000) div 10000 then erodeable := true; end else begin if data^.u > (bkg^.u * bkgCoefficient + 5000) div 10000 then erodeable := true; end; Savemark := mark; mark := pup(markUL); if erodeable then if mark^.u <> 0 then begin mark := pup(Ord4(mark) + 1); if mark^.u <> 0 then begin mark := pup(Ord4(mark) + 1); if mark^.u <> 0 then begin mark := pup(Ord4(mark) + rbincr); if mark^.u <> 0 then begin mark := pup(Ord4(mark) + 2); if mark^.u <> 0 then begin mark := pup(Ord4(mark) + rbincr); if mark^.u <> 0 then begin mark := pup(Ord4(mark) + 1); if mark^.u <> 0 then begin mark := pup(Ord4(mark) + 1); if mark^.u <> 0 then begin erodeable := false; end; end; end; end; end; end; end; end; mark := Savemark; if erodeable then mark^.u := flag; end; {if mark^.u <> 0} data := pup(Ord4(data) + 1); markUL := markUL + 1; bkg := pup(Ord4(bkg) + 1); mark := pup(Ord4(mark) + 1); end; {while cc > 0} data := pup(Ord4(data) + incr); markUL := markUL + incr; bkg := pup(Ord4(bkg) + incr); mark := pup(Ord4(mark) + incr); if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; cc := 0; lc := 0; end; end; {while lc > 0} mark := pup(MarkupMarkInfo^.PicBaseAddr); lc := nl; while lc > 0 do begin lc := lc - 1; cc := nc; while cc > 0 do begin cc := cc - 1; if mark^.u = flag then begin mark^.u := 0; end; mark := pup(Ord4(mark) + 1); end; {while cc > 0} mark := pup(Ord4(mark) + incr); end; {while lc > 0} MarkupMarkInfo^.changes := true; WhatToUndo := UndoEdit; gBkgUpdReqd := true; {redraw the profile plots} EnableKeepUndo; SaveInfo := Info; Info := MarkupMarkInfo; UpdatePicWindow; Info := SaveInfo; myHiliteControl(MarkupWindow, ErodeCtrlid, 0); myHiliteControl(MarkupWindow, CancelCtrlid, 255); end; {Figure out which pixels need background values calculated. } {All pixels with a mark need background.} {All pixels adjacent to a mark need background.} procedure Plan8BkgCalc; type pp = ^p; p = packed record a, b, c: 0..255 end; var one, lc, cc: integer; prev, this, next: pp; mark: Ptr; RowBytes, incr: LongInt; nl, nc: integer; begin one := 1; {put this in a register } with MarkupMarkInfo^ do begin RowBytes := BytesPerRow; nl := nlines - 2; nc := PixelsPerLine - 2; mark := PicBaseAddr; end; incr := RowBytes - nc; prev := pp(MarkupBkgInfo^.PicBaseAddr); this := prev; next := pp(Ord4(this) + RowBytes); { Upper left corner } if mark^ <> 0 then begin this^.a := one; this^.b := one; next^.a := one; next^.b := one; end; mark := Ptr(Ord4(mark) + 1); {Top row } cc := nc; while cc > 0 do begin cc := cc - 1; if mark^ <> 0 then begin this^.a := one; this^.b := one; this^.c := one; next^.a := one; next^.b := one; next^.c := one; end; mark := Ptr(Ord4(mark) + 1); this := pp(Ord4(this) + 1); next := pp(Ord4(next) + 1); end; {Upper right corner } if mark^ <> 0 then begin this^.a := one; this^.b := one; next^.a := one; next^.b := one; end; mark := Ptr(Ord4(mark) + incr - 1); this := pp(Ord4(this) + incr); next := pp(Ord4(next) + incr); { Interior rows } lc := nl; while lc > 0 do begin lc := lc - 1; {Left edge } if mark^ <> 0 then begin prev^.a := one; prev^.b := one; this^.a := one; this^.b := one; next^.a := one; next^.b := one; end; mark := Ptr(Ord4(mark) + 1); cc := nc; while cc > 0 do begin cc := cc - 1; if mark^ <> 0 then begin prev^.a := one; prev^.b := one; prev^.c := one; this^.a := one; this^.b := one; this^.c := one; next^.a := one; next^.b := one; next^.c := one; end; mark := Ptr(Ord4(mark) + 1); prev := pp(Ord4(prev) + 1); this := pp(Ord4(this) + 1); next := pp(Ord4(next) + 1); end; {Right edge } if mark^ <> 0 then begin prev^.a := one; prev^.b := one; this^.a := one; this^.b := one; next^.a := one; next^.b := one; end; mark := Ptr(Ord4(mark) + incr - 1); prev := pp(Ord4(prev) + incr); this := pp(Ord4(this) + incr); next := pp(Ord4(next) + incr); if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; gCanceled := true; exit(Plan8BkgCalc); end; end; {Lower left corner} if mark^ <> 0 then begin prev^.a := one; prev^.b := one; this^.a := one; this^.b := one; end; mark := Ptr(Ord4(mark) + 1); {Bottom row} cc := nc; while cc > 0 do begin cc := cc - 1; if mark^ <> 0 then begin prev^.a := one; prev^.b := one; prev^.c := one; this^.a := one; this^.b := one; this^.c := one; end; mark := Ptr(Ord4(mark) + 1); prev := pp(Ord4(prev) + 1); this := pp(Ord4(this) + 1); end; {Lower right corner } if mark^ <> 0 then begin prev^.a := one; prev^.b := one; this^.a := one; this^.b := one; end; end; {Figure out which pixels need background values calculated. } {All pixels with a mark need background.} {All pixels adjacent to a mark need background.} procedure Plan16BkgCalc; type pp = ^p; p = packed record a, b, c: 0..65535 end; var one, lc, cc: integer; prev, this, next: pp; mark: Ptr; RowBytes, incr, RowBytes16, incr16: LongInt; nl, nc: integer; begin one := 1; {put this in a register } with MarkupMarkInfo^ do begin RowBytes := BytesPerRow; nl := nlines - 2; nc := PixelsPerLine - 2; mark := PicBaseAddr; end; with MarkupBkgInfo^ do begin RowBytes16 := BytesPerRow; end; incr := RowBytes - nc; incr16 := RowBytes16 - nc * 2; prev := pp(MarkupBkgInfo^.PicBaseAddr); this := prev; next := pp(Ord4(this) + RowBytes16); { Upper left corner } if mark^ <> 0 then begin this^.a := one; this^.b := one; next^.a := one; next^.b := one; end; mark := Ptr(Ord4(mark) + 1); {Top row } cc := nc; while cc > 0 do begin cc := cc - 1; if mark^ <> 0 then begin this^.a := one; this^.b := one; this^.c := one; next^.a := one; next^.b := one; next^.c := one; end; mark := Ptr(Ord4(mark) + 1); this := pp(Ord4(this) + 2); next := pp(Ord4(next) + 2); end; {Upper right corner } if mark^ <> 0 then begin this^.a := one; this^.b := one; next^.a := one; next^.b := one; end; mark := Ptr(Ord4(mark) + incr - 1); this := pp(Ord4(this) + incr16); next := pp(Ord4(next) + incr16); { Interior rows } lc := nl; while lc > 0 do begin lc := lc - 1; {Left edge } if mark^ <> 0 then begin prev^.a := one; prev^.b := one; this^.a := one; this^.b := one; next^.a := one; next^.b := one; end; mark := Ptr(Ord4(mark) + 1); cc := nc; while cc > 0 do begin cc := cc - 1; if mark^ <> 0 then begin prev^.a := one; prev^.b := one; prev^.c := one; this^.a := one; this^.b := one; this^.c := one; next^.a := one; next^.b := one; next^.c := one; end; mark := Ptr(Ord4(mark) + 1); prev := pp(Ord4(prev) + 2); this := pp(Ord4(this) + 2); next := pp(Ord4(next) + 2); end; {Right edge } if mark^ <> 0 then begin prev^.a := one; prev^.b := one; this^.a := one; this^.b := one; next^.a := one; next^.b := one; end; mark := Ptr(Ord4(mark) + incr - 1); prev := pp(Ord4(prev) + incr16); this := pp(Ord4(this) + incr16); next := pp(Ord4(next) + incr16); if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; gCanceled := true; exit(Plan16BkgCalc); end; end; {Lower left corner} if mark^ <> 0 then begin prev^.a := one; prev^.b := one; this^.a := one; this^.b := one; end; mark := Ptr(Ord4(mark) + 1); {Bottom row} cc := nc; while cc > 0 do begin cc := cc - 1; if mark^ <> 0 then begin prev^.a := one; prev^.b := one; prev^.c := one; this^.a := one; this^.b := one; this^.c := one; end; mark := Ptr(Ord4(mark) + 1); prev := pp(Ord4(prev) + 2); this := pp(Ord4(this) + 2); end; {Lower right corner } if mark^ <> 0 then begin prev^.a := one; prev^.b := one; this^.a := one; this^.b := one; end; end; procedure Calc8Bkg; var data, kernel, mark: LongInt;{pointers in D registers} RowBytes, offset, incr: LongInt; bkg: Ptr; {pointers in A registers} nl, nc, lc, cc, line, col: integer; {num lines, num cols, line ctr, col ctr} knr, knc, kincr, clip: LongInt; {kernel num rows, kernel num cols, kernel increment} r, d: integer; {radius, diameter} tryBiggerKernel: Boolean; SaveInfo: InfoPtr; kHandle: Handle; begin {given that the images all exist and are the same size} ShowWatch; myHiliteControl(MarkupWindow, CalcBackgroundCtrlid, 1); myHiliteControl(MarkupWindow, CancelCtrlid, 0); gCanceled := false; with MarkupMarkInfo^ do begin RowBytes := BytesPerRow; nl := nlines; nc := PixelsPerLine; end; {Clear background image to zero } bkg := MarkupBkgInfo^.PicBaseAddr; data := Ord4(bkg) + RowBytes * nl - 4; while Ord4(bkg) < data do begin lptr(bkg)^ := 0; bkg := Ptr(Ord4(bkg) + 4); end; data := data + 4; while Ord4(bkg) < data do begin bkg^ := 0; bkg := Ptr(Ord4(bkg) + 1); end; {done clearing to zero} Plan8BkgCalc; bkg := MarkupBkgInfo^.PicBaseAddr; data := Ord4(MarkupDataInfo^.PicBaseAddr); mark := Ord4(MarkupMarkInfo^.PicBaseAddr); incr := RowBytes - nc; lc := nl; line := 0; if gCanceled then lc := 0; while lc > 0 do begin lc := lc - 1; cc := nc; col := 0; while cc > 0 do begin cc := cc - 1; if bkg^ <> 0 then begin r := BkgKernelMinRadius; tryBiggerKernel := true; while tryBiggerKernel do begin d := r * 2 + 1; {find offset from center of data for kernel } {to upper left corner of data for kernel} offset := r * (RowBytes + 1); kHandle := BkgKernelHandle[r]; {last entry in BkgKernelHandle array is always nil} if kHandle = nil then begin bkg^ := Ptr(Ord4(bkg) - 1)^; beep; tryBiggerKernel := false; end else begin kernel := Ord4(kHandle^); kincr := 0; knc := d; knr := d; clip := r - line; if clip > 0 then begin knr := knr - clip; kernel := kernel + clip * d * 4; offset := offset - clip * RowBytes; end; clip := r - lc; if clip > 0 then knr := knr - clip; clip := r - col; if clip > 0 then begin kincr := clip; knc := knc - clip; kernel := kernel + clip * 4; offset := offset - clip; end; clip := r - cc; if clip > 0 then begin kincr := kincr + clip; knc := knc - clip; end; {onebkgpix (bkg, mark, data, kernel, incr, kincr, knc, knr: longint)} tryBiggerKernel := not onebkgpix(Ord4(bkg), mark - offset, data - offset, kernel, RowBytes - knc, kincr, knc, knr); end; {else kHandle <> nil} r := r + BkgKernelDeltaRadius; end; {while tryBiggerKernel} end; {if bkg^ <> 0} bkg := Ptr(Ord4(bkg) + 1); mark := mark + 1; data := data + 1; col := col + 1; end; {while cc > 0} if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; cc := 0; lc := 0; end; bkg := Ptr(Ord4(bkg) + incr); mark := mark + incr; data := data + incr; line := line + 1; end; {while lc > 0} gBkgUpdReqd := true; {redraw the profile plots} SaveInfo := Info; Info := MarkupBkgInfo; UpdatePicWindow; Info := SaveInfo; myHiliteControl(MarkupWindow, CalcBackgroundCtrlid, 0); myHiliteControl(MarkupWindow, CancelCtrlid, 255); end; procedure Calc16Bkg; var data, kernel, mark: LongInt;{pointers in D registers} RowBytes, offset, incr, dincr: LongInt; bkg: Ptr; {pointers in A registers} nl, nc, lc, cc, line, col: integer; {num lines, num cols, line ctr, col ctr} knr, knc, kincr, clip: LongInt; {kernel num rows, kernel num cols, kernel increment} r, d: integer; {radius, diameter} tryBiggerKernel: Boolean; SaveInfo: InfoPtr; kHandle: Handle; begin {given that the images all exist and are the proper size} {given that data and bkg are twice width of mark} {given that mark pixels per line is even} ShowWatch; myHiliteControl(MarkupWindow, CalcBackgroundCtrlid, 1); myHiliteControl(MarkupWindow, CancelCtrlid, 0); gCanceled := false; with MarkupMarkInfo^ do begin RowBytes := BytesPerRow; nl := nlines; nc := PixelsPerLine; end; {Clear background image to zero } bkg := MarkupBkgInfo^.PicBaseAddr; data := Ord4(bkg) + RowBytes * nl * 2 - 4; while Ord4(bkg) < data do begin lptr(bkg)^ := 0; bkg := Ptr(Ord4(bkg) + 4); end; data := data + 4; while Ord4(bkg) < data do begin bkg^ := 0; bkg := Ptr(Ord4(bkg) + 1); end; {done clearing to zero} Plan16BkgCalc; bkg := MarkupBkgInfo^.PicBaseAddr; data := Ord4(MarkupData16Info^.PicBaseAddr); mark := Ord4(MarkupMarkInfo^.PicBaseAddr); incr := RowBytes - nc; dincr := incr * 2; lc := nl; line := 0; if gCanceled then lc := 0; while lc > 0 do begin lc := lc - 1; cc := nc; col := 0; while cc > 0 do begin cc := cc - 1; if iptr(bkg)^ <> 0 then begin r := BkgKernelMinRadius; tryBiggerKernel := true; while tryBiggerKernel do begin d := r * 2 + 1; {find offset from center of data for kernel } {to upper left corner of data for kernel} offset := r * (RowBytes + 1); kHandle := BkgKernelHandle[r]; {last entry in BkgKernelHandle array is always nil} if kHandle = nil then begin bkg^ := Ptr(Ord4(bkg) - 2)^; beep; tryBiggerKernel := false; end else begin kernel := Ord4(kHandle^); kincr := 0; knc := d; knr := d; clip := r - line; if clip > 0 then begin knr := knr - clip; kernel := kernel + clip * d * 4; offset := offset - clip * RowBytes; end; clip := r - lc; if clip > 0 then knr := knr - clip; clip := r - col; if clip > 0 then begin kincr := clip; knc := knc - clip; kernel := kernel + clip * 4; offset := offset - clip; end; clip := r - cc; if clip > 0 then begin kincr := kincr + clip; knc := knc - clip; end; {onebkgp16 (bkg, mark, data, kernel, incr, kincr, knc, knr: longint)} tryBiggerKernel := not onebkgp16(Ord4(bkg), mark - offset, data - offset * 2, kernel, RowBytes - knc, kincr, knc, knr); end; {else kHandle <> nil} r := r + BkgKernelDeltaRadius; end; {while tryBiggerKernel} end; {if iptr(bkg)^ <> 0} bkg := Ptr(Ord4(bkg) + 2); mark := mark + 1; data := data + 2; col := col + 1; end; {while cc > 0} if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; cc := 0; lc := 0; end; bkg := Ptr(Ord4(bkg) + dincr); mark := mark + incr; data := data + dincr; line := line + 1; end; {while lc > 0} gBkgUpdReqd := true; {redraw the profile plots} SaveInfo := Info; Info := MarkupBkgInfo; UpdatePicWindow; Info := SaveInfo; myHiliteControl(MarkupWindow, CalcBackgroundCtrlid, 0); myHiliteControl(MarkupWindow, CancelCtrlid, 255); end; procedure CalculateBkg; begin if MarkupData16Info <> nil then Calc16Bkg else Calc8Bkg; end; procedure BkgSub16 (arg: extended); var data, kernel, mark: LongInt;{pointers in D registers} RowBytes, offset, incr, dincr: LongInt; bkg: Ptr; {pointers in A registers} nl, nc, lc, cc, line, col: integer; {num lines, num cols, line ctr, col ctr} SaveInfo: InfoPtr; begin {given that the images all exist and are the proper size} {given that data and bkg are twice width of mark} {given that mark pixels per line is even} {multiply bkg by arg prior to subtract} {when mark image is white (0) or > 127, use data as bkg} if arg = 0.0 then arg := 1.0; ShowWatch; myHiliteControl(MarkupWindow, CalcBackgroundCtrlid, 1); myHiliteControl(MarkupWindow, CancelCtrlid, 0); gCanceled := false; with MarkupMarkInfo^ do begin RowBytes := BytesPerRow; nl := nlines; nc := PixelsPerLine; end; bkg := MarkupBkgInfo^.PicBaseAddr; data := Ord4(MarkupData16Info^.PicBaseAddr); mark := Ord4(MarkupMarkInfo^.PicBaseAddr); incr := RowBytes - nc; dincr := incr * 2; lc := nl; line := 0; if gCanceled then lc := 0; while lc > 0 do begin lc := lc - 1; cc := nc; col := 0; while cc > 0 do begin cc := cc - 1; if ptr(mark)^ > 0 then puwp(data)^.u := puwp(data)^.u - round(arg * puwp(bkg)^.u) + 8192 else puwp(data)^.u := round((1.0 - arg) * puwp(data)^.u) + 8192; bkg := Ptr(Ord4(bkg) + 2); data := data + 2; col := col + 1; mark := mark + 1; end; {while cc > 0} if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; cc := 0; lc := 0; end; bkg := Ptr(Ord4(bkg) + dincr); data := data + dincr; line := line + 1; mark := mark + incr; end; {while lc > 0} gBkgUpdReqd := true; {redraw the profile plots} SaveInfo := Info; Info := MarkupBkgInfo; UpdatePicWindow; Info := SaveInfo; myHiliteControl(MarkupWindow, CalcBackgroundCtrlid, 0); myHiliteControl(MarkupWindow, CancelCtrlid, 255); end; procedure UpdateHistogram (oldmark, newmark, datav, h, v: integer); var SaveInfo: InfoPtr; dataUL, markUL: Longint; {Upper Left corner pointers} RowBytes, offset, incr, kernel: LongInt; mark, bkg: Ptr; k, c, nc, lc, cc: integer;{num cols, line ctr, col ctr} oldbkg, newbkg, markv: integer; scanRect: Rect; begin if MarkupData16Info <> nil then exit(UpdateHistogram); SaveInfo := Info; {Move the bkg value to another MarkedBkg slot before changing it } Info := MarkupBkgInfo; oldbkg := MyGetPixel(h, v); MarkedBkg[oldmark] := MarkedBkg[oldmark] - oldbkg; MarkedBkg[newmark] := MarkedBkg[newmark] + oldbkg; Histogram[oldmark] := Histogram[oldmark] - 1; Histogram[newmark] := Histogram[newmark] + 1; MarkedSum[oldmark] := MarkedSum[oldmark] - datav; MarkedSum[newmark] := MarkedSum[newmark] + datav; if gAutoBkgEnabled then begin {temporary disable auto bkg calc} beep; PutMessage('Automatic incremental background calculation is not implemented'); gAutoBkgEnabled := false; mySetCtlValue(MarkupWindow, AutoBkgCtrlid, ord(gAutoBkgEnabled)); end; if gAutoBkgEnabled then begin if (oldmark = 0) or (newmark = 0) then begin gBkgUpdReqd := true; {redraw the profile plots} {this pixel was a bkg pixel, is now a marked pixel, } {or this pixel was a marked pixel, is now a bkg pixel. } {Either way, the background has to be recalculated.} {MarkedBkg is updated for all bkg values which change, } {which might be more than one.} c := BkgKernelMinRadius;{???} k := c * 2 + 1; setRect(scanRect, h - c, v - c, h + c + 1, v + c + 1); with MarkupMarkInfo^, scanRect do begin RowBytes := BytesPerRow; if top < c then begin top := c; end; if left < c then begin left := c; end; if right > PixelsPerLine - c then begin right := PixelsPerLine - c; end; if bottom > nlines - c then begin bottom := nlines - c; end; nc := right - left; lc := bottom - top; {skip to (left,top)} offset := RowBytes * top + left; end; incr := RowBytes - nc; mark := MarkupMarkInfo^.PicBaseAddr; markUL := Ord4(mark); mark := Ptr(Ord4(mark) + offset); dataUL := Ord4(MarkupDataInfo^.PicBaseAddr); with MarkupBkgInfo^ do bkg := Ptr(Ord4(PicBaseAddr) + offset); {now adjust offset to upper left corner } offset := offset - RowBytes * c - c; markUL := markUL + offset; dataUL := dataUL + offset; kernel := Ord4(BkgKernelHandle[1]^);{???} while lc > 0 do begin cc := nc; while cc > 0 do begin markv := mark^; oldbkg := BAND(bkg^, 255); if markv > 0 then begin {if not onebkgpix(Ord4(@newbkg), markUL, dataUL, kernel, RowBytes, k) then} beep;{???} if newbkg <> oldbkg then begin bkg^ := newbkg; {MarkupBkgInfo^.Changes := true;--never want to save bkg image anyway...} {markv := BAND(markv, 255);--markv is > 0 already.} MarkedBkg[markv] := MarkedBkg[markv] - oldbkg + newbkg; end end else begin if oldbkg <> 0 then begin bkg^ := 0; {MarkupBkgInfo^.Changes := true;--never want to save bkg image anyway...} markv := BAND(markv, 255); MarkedBkg[markv] := MarkedBkg[markv] - oldbkg; end end; {markv <= 0} dataUL := dataUL + 1; markUL := markUL + 1; bkg := Ptr(Ord4(bkg) + 1); mark := Ptr(Ord4(mark) + 1); cc := cc - 1; end; {while cc > 0} dataUL := dataUL + incr; markUL := markUL + incr; bkg := Ptr(Ord4(bkg) + incr); mark := Ptr(Ord4(mark) + incr); lc := lc - 1; end; {while lc > 0} Info := MarkupBkgInfo; UpdateScreen(scanRect); end; {if (oldmark = 0) or (newmark = 0)} end;{if gAutoBkgEnabled} Info := SaveInfo; end; { Call this if changes are made directly in the original data or markup windows, } { or if SourceRect is changed to scroll the original image } procedure RefreshMarkupOffscreen; var SavePort: GrafPtr; rows, cols, r, c: integer; MarkRow, MarkPtr, PaneRow, PanePtr, PanePix: LongInt; MarkRowBytes, PaneRowBytes: LongInt; begin ShowWatch; getPort(SavePort); SetPort(GrafPtr(MarkupOsPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); { Use copybits to create the enlarged pixels in the offscreen pixmap } with MarkupDataInfo^ do begin hlock(handle(osPort^.portPixMap)); hlock(handle(MarkupOsPort^.PortPixMap)); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, BitMapHandle(MarkupOsPort^.PortPixMap)^^, SourceRect, MarkupPaneRect, SrcCopy, nil); hunlock(handle(osPort^.portPixMap)); hunlock(handle(MarkupOsPort^.PortPixMap)); end; { Directly access offscreen pixmaps to copy markup pixels. } { Safety: This will not store outside of the Markup offscreen pixmap, provided that } { Magnify, MagCenter, MarkupBytesPerRow, SourceHeight, SourceWidth, CenterOffset have not } { been changed without also reallocating the pixmap. } MarkRowBytes := MarkupMarkInfo^.BytesPerRow; MarkRow := Ord4(MarkupMarkInfo^.PicBaseAddr) + LongInt(SourceRect.top) * MarkRowBytes + SourceRect.left; PaneRowBytes := MarkupBytesPerRow * Magnify; PaneRow := Ord4(MarkupPicBaseHandle^) + CenterOffset; rows := SourceHeight; if DisplayMarks then begin if Magnify <= 3 then begin while rows > 0 do begin MarkPtr := MarkRow; PanePtr := PaneRow; cols := SourceWidth; while cols > 0 do begin if Ptr(MarkPtr)^ <> 0 then Ptr(PanePtr)^ := Ptr(MarkPtr)^; MarkPtr := MarkPtr + 1; PanePtr := PanePtr + Magnify; cols := cols - 1; end; MarkRow := MarkRow + MarkRowBytes; PaneRow := PaneRow + PaneRowBytes; rows := rows - 1; end; end else if Magnify <= 6 then begin {store 4 pixels in a square } while rows > 0 do begin MarkPtr := MarkRow; PanePtr := PaneRow; cols := SourceWidth; while cols > 0 do begin if Ptr(MarkPtr)^ <> 0 then begin Ptr(PanePtr)^ := Ptr(MarkPtr)^; PanePix := PanePtr + 1; Ptr(PanePix)^ := Ptr(MarkPtr)^; PanePix := PanePix + MarkupBytesPerRow; Ptr(PanePix)^ := Ptr(MarkPtr)^; PanePix := PanePix - 1; Ptr(PanePix)^ := Ptr(MarkPtr)^; end; PanePtr := PanePtr + Magnify; MarkPtr := MarkPtr + 1; cols := cols - 1; end; MarkRow := MarkRow + MarkRowBytes; PaneRow := PaneRow + PaneRowBytes; rows := rows - 1; end; end else begin { store 5 pixels in a plus sign array} PaneRow := PaneRow - MarkupBytesPerRow; while rows > 0 do begin MarkPtr := MarkRow; PanePtr := PaneRow; cols := SourceWidth; while cols > 0 do begin if Ptr(MarkPtr)^ <> 0 then begin Ptr(PanePtr)^ := Ptr(MarkPtr)^; PanePix := PanePtr + MarkupBytesPerRow; Ptr(PanePix)^ := Ptr(MarkPtr)^; PanePix := PanePix - 1; Ptr(PanePix)^ := Ptr(MarkPtr)^; PanePix := PanePix + 2; Ptr(PanePix)^ := Ptr(MarkPtr)^; PanePix := PanePix + MarkupBytesPerRow - 1; Ptr(PanePix)^ := Ptr(MarkPtr)^; end; PanePtr := PanePtr + Magnify; MarkPtr := MarkPtr + 1; cols := cols - 1; end; MarkRow := MarkRow + MarkRowBytes; PaneRow := PaneRow + PaneRowBytes; rows := rows - 1; end; end; end; UpdateRowDisplay; UpdateColDisplay; PenNormal; PaintRect(ProfileDragRect); FrameRoundRect(ScalePlotsButton, 8, 8); with ScalePlotsButton do begin MoveTo(left + 8, top + 20); DrawString('Scale Plots'); end; SetPort(MarkupWindow); UpdateMarkupRect(MarkupOsPort^.PortRect); SetPort(SavePort); end; {Scrolls the magnified image one pixel per pixel of unmagnified mouse motion} {so that you can drag across the whole image in one pass.} function ScrollMarkup (vect: point): Boolean; begin ScrollMarkup := false; with MarkupMarkInfo^, SourceRect, vect do begin if top + v < 0 then v := -top; if left + h < 0 then h := -left; if bottom + v > nlines then v := nlines - bottom; if right + h > PixelsPerLIne then h := PixelsPerLine - right; top := top + v; bottom := bottom + v; left := left + h; right := right + h; end; { Remember image center for grow box } {(ResizeMarkupWindow uses NewCenterPix regardless of whether the call came } { from magnifying glass click or from grow box).} with NewCenterPix do begin h := h + vect.h; v := v + vect.v; end; {These pixels must be on screen: } {??? Does this have something to do with that dead cursor bug? } AdjustPix(ThePixel); AdjustAutoPixel; AdjustPix(NewCenterPix); with vect do if (v <> 0) or (h <> 0) then begin RefreshMarkupOffScreen; ScrollMarkup := true; end; end; { Safety: This will not store outside of the Markup offscreen pixmap, provided that } { Magnify, MagCenter, MarkupBytesPerRow, SourceHeight, SourceWidth, CenterOffset have not } { been changed without also reallocating the pixmap. } procedure PutMarkupPixel (h, v, value: integer); {(h,v) in offscreen coordinates} var addr: LongInt; begin v := v - SourceRect.top; h := h - SourceRect.left; if (h >= 0) then if (v >= 0) then if (h < SourceWidth) then if (v < SourceHeight) then begin addr := Ord4(MarkupPicBaseHandle^) + (LongInt(v) * MarkupBytesPerRow + h) * Magnify + CenterOffset; if Magnify <= 3 then ptr(addr)^ := value else if Magnify <= 6 then begin {store 4 pixels in a square } ptr(addr)^ := value; addr := addr + 1; ptr(addr)^ := value; addr := addr + MarkupBytesPerRow; ptr(addr)^ := value; addr := addr - 1; ptr(addr)^ := value; end else begin {store 5 pixels in a plus sign array} Ptr(addr)^ := value; addr := addr - MarkupBytesPerRow; Ptr(addr)^ := value; addr := addr + MarkupBytesPerRow - 1; Ptr(addr)^ := value; addr := addr + 2; Ptr(addr)^ := value; addr := addr + MarkupBytesPerRow - 1; Ptr(addr)^ := value; end; end; end; procedure AllocateMarkupOffscreen; var SavePort: GrafPtr; neededSize: LongInt; PicRect: Rect; begin getPort(SavePort); if odd(MarkupWidth) then MarkupBytesPerRow := MarkupWidth + 1 else MarkupBytesPerRow := MarkupWidth; CenterOffset := MagCenter * MarkupBytesPerRow + MagCenter; { The markup control pane is not drawn in the offscreen Pixmap. } neededSize := LongInt(MarkupHeight - MarkupCtrlHeight) * MarkupBytesPerRow; SetRect(PicRect, 0, 0, MarkupWidth, MarkupHeight - MarkupCtrlHeight); if MarkupOsPort = nil then begin new(MarkupOsPort); OpenCPort(MarkupOsPort); end; SetPort(GrafPtr(MarkupOsPort)); if MarkupPicBaseHandle <> nil then DisposHandle(MarkupPicBaseHandle); MarkupPicBaseHandle := GetBigHandle(neededSize); if MarkupPicBaseHandle <> nil then begin HLock(MarkupPicBaseHandle); with MarkupOsPort^ do begin with PortPixMap^^ do begin BaseAddr := StripAddress(MarkupPicBaseHandle^); {StripAddress needed???} bounds := PicRect; RowBytes := BitOr(MarkupBytesPerRow, $8000); end; PortRect := PicRect; RectRgn(visRgn, PicRect); end; SetPalette(WindowPtr(MarkupOsPort), ExplicitPalette, false); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); EraseRect(MarkupOsPort^.PortRect); end; SetPort(SavePort); { Copy of the six critical variables, checked by MarkupReady } CheckSourceHeight := SourceHeight; CheckSourceWidth := SourceWidth; CheckMagnify := Magnify; CheckMagCenter := MagCenter; CheckMarkupBytesPerRow := MarkupBytesPerRow; CheckCenterOffset := CenterOffset; end; {interface function also used locally } procedure ResizeMarkupWindow (Width, Height: integer); begin ShowWatch; repeat MarkupWidth := Width; MarkupHeight := Height; AdjustMarkupSize; SizeWindow(MarkupWindow, MarkupWidth, MarkupHeight, true); AllocateMarkupOffscreen; if MarkupPicBaseHandle = nil then begin { Doesn't fit, try a smaller window. Leave the aspect ratio alone.} {??? test this, once got a possibly spurious heap warning...} Width := Width * 9 div 10; Height := Height * 9 div 10; end; until (MarkupPicBaseHandle <> nil) or (Width < 10) or (Height < 10); if MarkupPicBaseHandle = nil then begin PutMessage('Cannot allocate memory for Markup window'); CloseMarkupWindow; end else RefreshMarkupOffscreen; end; procedure DragMarkupWindow (userInfo: userInfoHandle); var trect: Rect; begin GetWindowRect(MarkupWindow, trect); MarkupTop := trect.top; MarkupLeft := trect.left; end; procedure keepChanges; forward; function NewInfoPtrsOK: Boolean; var markRowBytes, markRows, markCols: integer; r1: Boolean; begin r1 := false; NewInfoPtrsOK := false; if isAPic(newDataInfo) then if isAPic(newMarkInfo) then if isAPic(newBkgInfo) then if newDataInfo <> newMarkInfo then if newDataInfo <> newBkginfo then if newMarkInfo <> newBkgInfo then begin with newMarkInfo^ do begin markRowBytes := BytesPerRow; markRows := nlines; markCols := PixelsPerLine; end; with newDataInfo^ do if markRowBytes = BytesPerRow then if markRows = nlines then if markCols = PixelsPerLine then r1 := true; if r1 then if isAPic(newData16Info) then begin if newData16Info <> newMarkInfo then if newData16Info <> newBkgInfo then if newData16Info <> newDataInfo then begin r1 := false; with newData16Info^ do if markRowBytes * 2 = BytesPerRow then if markRows = nlines then if markCols * 2 = PixelsPerLine then r1 := true; if r1 then with newBkgInfo^ do if markRowBytes * 2 = BytesPerRow then if markRows = nlines then if markCols * 2 = PixelsPerLine then NewInfoPtrsOK := true; end end else begin newData16Info := nil; with newBkgInfo^ do if markRowBytes = BytesPerRow then if markRows = nlines then if markCols = PixelsPerLine then NewInfoPtrsOK := true; end; end; end; procedure SetKernelKind (kind: BkgKernelKindType); forward; procedure nilUserWindowProc (userInfo: userInfoHandle); begin end; procedure GrowMarkupWindow (userInfo: userInfoHandle); begin with userInfo^^ do ResizeMarkupWindow(LoWord(UserNewSize), hiWord(UserNewSize)); end; procedure UserCloseMarkupWindow (userInfo: userInfoHandle); begin CloseMarkupWindow; end; procedure unlockHandlesMarkup (userInfo: userInfoHandle); begin if MarkupPicBaseHandle <> nil then begin HUnlock(MarkupPicBaseHandle); end; end; procedure lockHandlesMarkup (userInfo: userInfoHandle); begin if MarkupPicBaseHandle <> nil then begin HLock(MarkupPicBaseHandle); MarkupOsPort^.PortPixMap^^.BaseAddr := StripAddress(MarkupPicBaseHandle^); end; end; procedure CreateMarkupWindow; var wrect: rect; SavePort: GrafPtr; SaveInfo: InfoPtr; begin SaveInfo := Info; if MarkupWindow <> nil then begin SelectWindow(MarkupWindow); exit(CreateMarkupWindow); end; CloseMarkupWindow; {if the data window has not been specified, try to use the front image } if not IsAPic(newDataInfo) then newDataInfo := Info; if not IsAPic(newDataInfo) then begin PutMessage('Please provide a data image for markup.'); exit(CreateMarkupWindow); end; if newBkgInfo = newDataInfo then newBkgInfo := nil; if newBkgInfo = newMarkInfo then newBkgInfo := nil; if newMarkInfo = newDataInfo then newMarkInfo := nil; {if either of the extra windows are missing, create them. } {Make bkg first so it is at the back.} if not IsAPic(newBkgInfo) then begin {create a new image window same size as front window for scratch storage of background} with newDataInfo^ do begin if not NewPicWindow(concat('Bkg for ', title), PixelsPerLine, nlines) then begin PutMessage('Please provide a background image for markup.'); exit(CreateMarkupWindow); end end; newBkgInfo := Info; end; if not IsAPic(newMarkInfo) then begin {create another new image window same size as front window} with newDataInfo^ do begin if not NewPicWindow(concat('Marks for ', title), PixelsPerLine, nlines) then begin PutMessage('Please provide a marks image for markup.'); exit(CreateMarkupWindow); end end; newMarkInfo := Info; end; if not NewInfoPtrsOK then begin PutMessage('All markup images must be the same size.'); CloseMarkupWindow; exit(CreateMarkupWindow); end; MarkupDataInfo := newDataInfo; MarkupData16Info := newData16Info; MarkupBkgInfo := newBkgInfo; MarkupMarkInfo := newMarkInfo; { Save the image size data for MarkupReady } CheckRowBytes := MarkupMarkInfo^.BytesPerRow; CheckRows := MarkupMarkInfo^.nlines; CheckCols := MarkupMarkInfo^.PixelsPerLine; { Create the window same size as last time } AdjustMarkupSize; SetRect(wrect, MarkupLeft, MarkupTop, MarkupLeft + MarkupWidth, MarkupTop + MarkupHeight); MarkupWindow := NewCWindow(nil, wrect, 'Markup', true, DocumentProc, Pointer(-1), true, 0); MarkupUserInfo := NewUserWindow; if (MarkupWindow <> nil) and (MarkupUserInfo <> nil) then begin with MarkupUserInfo^^ do begin UserWindowPtr := MarkupWindow; UKind := MarkupUKind; UserData := nil; InitUserWindow(MarkupUserInfo); UserUnlockHandles := @unlockHandlesMarkup; UserLockHandles := @lockHandlesMarkup; UserDispose := @nilUserWindowProc; UserActivate := @ActivateMarkupWindow; UserUpdate := @UpdateMarkupWindow; UserGrow := @GrowMarkupWindow; UserDrag := @DragMarkupWindow; UserClose := @UserCloseMarkupWindow; UserZoom := @nilUserWindowProc; UserMouseDown := @DoMouseDownInMarkup; UserCursor := @DoMarkupCursor; UserUndo := @nilUserWindowProc; UserCut := @nilUserWindowProc; UserCopy := @nilUserWindowProc; UserPaste := @nilUserWindowProc; UserClear := @nilUserWindowProc; UserCloseWarning := @MarkupCloseHook; end; GetPort(SavePort); SetPort(MarkupWindow); MyGetNewControls(MarkupWindow, MarkupCtrlDITL); SetPort(SavePort); { Now try to allocate the offscreen memory, and reduce size if necessary } ResizeMarkupWindow(MarkupWidth, MarkupHeight); if MarkupWindow <> nil then begin myHiliteControl(MarkupWindow, CancelCtrlid, 255); DoMarkupCtrl('U'); DoMarkupCtrl('W'); keepChanges; gRidge := false; mySetCtlValue(MarkupWindow, RidgeCtrlid, 0); mySetCtlValue(MarkupWindow, ValleyCtrlid, 1); gUndoButtonEnabled := false; myHiliteControl(MarkupWindow, KeepCtrlid, 255); myHiliteControl(MarkupWindow, UndoCtrlid, 255); gAutomatic := true; DoMarkupCtrl('A'); mySetCtlValue(MarkupWindow, ConeKernelCtrlid, 0); mySetCtlValue(MarkupWindow, ExponentialKernelCtrlid, 0); case BkgKernelKind of NoKernel: SetKernelKind(ConeKernel); ConeKernel: mySetCtlValue(MarkupWindow, ConeKernelCtrlid, 1); ExponentialKernel: mySetCtlValue(MarkupWindow, ExponentialKernelCtrlid, 1); end; end; end; if not MarkupReady then begin CloseMarkupWindow; PutMessage('Markup needs more memory. Close some windows or quit and give Image more memory.'); end; Info := SaveInfo; {To avoid a selectwindow call in runMacro in Macros1.p } end; procedure useNewPic; begin if MarkupReady then SelectWindow(MarkupWindow) else begin newDataInfo := MarkupDataInfo; newMarkInfo := MarkupMarkInfo; newBkgInfo := MarkupBkgInfo; newData16Info := MarkupData16Info; CloseMarkupWindow; PutMessage('All markup images must be the same size.'); end end; procedure SetMarkupDataPic (n: integer; var str: Str255); var thePic: InfoPtr; WhichWindow: WindowPtr; begin str := ''; if (n < 1) or (n > nPics) then str := InvalidPicNumber else begin WhichWindow := PicWindow[n]; thePic := pointer(WindowPeek(WhichWindow)^.RefCon); if MarkupReady then begin MarkupDataInfo := thePic; useNewPic end else newDataInfo := thePic end end; procedure SetMarkupData16Pic (n: integer; var str: Str255); var thePic: InfoPtr; WhichWindow: WindowPtr; begin str := ''; if (n < 1) or (n > nPics) then str := InvalidPicNumber else begin WhichWindow := PicWindow[n]; thePic := pointer(WindowPeek(WhichWindow)^.RefCon); if MarkupReady then begin MarkupData16Info := thePic; useNewPic end else newData16Info := thePic end end; procedure SetMarkupMarkPic (n: integer; var str: Str255); var thePic: InfoPtr; WhichWindow: WindowPtr; begin str := ''; if (n < 1) or (n > nPics) then str := InvalidPicNumber else begin WhichWindow := PicWindow[n]; thePic := pointer(WindowPeek(WhichWindow)^.RefCon); if MarkupReady then begin MarkupMarkInfo := thePic; useNewPic end else newMarkInfo := thePic end end; procedure SetMarkupBkgPic (n: integer; var str: Str255); var thePic: InfoPtr; WhichWindow: WindowPtr; begin str := ''; if (n < 1) or (n > nPics) then str := InvalidPicNumber else begin WhichWindow := PicWindow[n]; thePic := pointer(WindowPeek(WhichWindow)^.RefCon); if MarkupReady then begin MarkupBkgInfo := thePic; useNewPic end else newBkgInfo := thePic end end; { Called for an update event in the mark up window } { Copies the whole offscreen pixmap to the window } procedure UpdateMarkupWindow (userInfo: userInfoHandle); var SavePort: GrafPtr; begin if MarkupWindow <> nil then begin UpdateMarkupRect(MarkupOsPort^.PortRect); DrawControls(MarkupWindow); {Draw a line under the controls } GetPort(SavePort); SetPort(MarkupWindow); PenNormal; MoveTo(0, MarkupCtrlHeight - 1); LineTo(MarkupWidth, MarkupCtrlHeight - 1); SetPort(SavePort); end; end; { Called if markup window itself is closed } { Called via WarnUserWindows if subsidiary windows are closed.} procedure CloseMarkupWindow; begin if MarkupUserInfo <> nil then begin MarkupUserInfo^^.UserWindowPtr := nil; DisposeUserWindow(MarkupUserInfo); end; if MarkupWindow <> nil then DisposeWindow(MarkupWindow); MarkupWindow := nil; MarkupUserInfo := nil; MarkupDataInfo := nil; MarkupData16Info := nil; MarkupMarkInfo := nil; MarkupBkgInfo := nil; if MarkupOsPort <> nil then begin CloseCPort(MarkupOsPort); Dispose(MarkupOsPort); MarkupOsPort := nil; end; {This handle would be equal to theGDevice^^.GDPMap if it were an onscreen port.} {CloseCPort does not dispose of it.} if MarkupPicBaseHandle <> nil then begin DisposHandle(MarkupPicBaseHandle); MarkupPicBaseHandle := nil; end; CheckRowBytes := 0; CheckRows := 0; CheckCols := 0; end; procedure MarkupCloseHook (userInfo: userInfoHandle); {called from WarnUserWindows in files.p} begin if (Info = MarkupDataInfo) or (Info = MarkupMarkInfo) or (Info = MarkupBkgInfo) or (Info = MarkupData16Info) then CloseMarkupWindow; end; function MarkupReady: Boolean; var ready: Boolean; BkgRowBytes, BkgRows, BkgCols: Integer; begin ready := false; if MarkupWindow <> nil then if MarkupUserInfo <> nil then if MarkupPicBaseHandle <> nil then if MarkupOsPort <> nil then if MarkupDataInfo <> nil then if MarkupMarkInfo <> nil then if MarkupBkgInfo <> nil then if MarkupDataInfo <> NoInfo then if MarkupMarkInfo <> NoInfo then if MarkupBkgInfo <> NoInfo then if MarkupDataInfo <> MarkupMarkInfo then if MarkupDataInfo <> MarkupBkgInfo then if MarkupMarkInfo <> MarkupBkgInfo then with MarkupMarkInfo^ do if CheckRowBytes = BytesPerRow then if CheckRows = nlines then if CheckCols = PixelsPerLine then ready := true; if ready then begin ready := false; with MarkupDataInfo^ do if CheckRowBytes = BytesPerRow then if CheckRows = nlines then if CheckCols = PixelsPerLine then ready := true; end; if ready then begin ready := false; if MarkupData16Info = nil then begin BkgRowBytes := CheckRowBytes; BkgRows := CheckRows; BkgCols := CheckCols; ready := true; end else if MarkupData16Info <> NoInfo then if MarkupData16Info <> MarkupMarkInfo then if MarkupData16Info <> MarkupBkgInfo then if MarkupData16Info <> MarkupDataInfo then begin BkgRowBytes := CheckRowBytes * 2; BkgRows := CheckRows; BkgCols := CheckCols * 2; with MarkupData16Info^ do if BkgRowBytes = BytesPerRow then if BkgRows = nlines then if BkgCols = PixelsPerLine then ready := true; end; end; if ready then begin ready := false; with MarkupBkgInfo^ do if BkgRowBytes = BytesPerRow then if BkgRows = nlines then if BkgCols = PixelsPerLine then ready := true; end; if ready then begin ready := false; {The following checks would only fail due to faulty software modifications.} {The check is necessary because otherwise detection of the error would} {be rather difficult, and failure to detect the error would cause a crash.} if CheckSourceHeight = SourceHeight then if CheckSourceWidth = SourceWidth then if CheckMagnify = Magnify then if CheckMagCenter = MagCenter then if CheckMarkupBytesPerRow = MarkupBytesPerRow then if CheckCenterOffset = CenterOffset then ready := true; if not ready then PutMessage('Markup Bug: MarkupReady failure.'); end; if ready then if CheckRowBytes <> CheckCols then begin ready := false; PutMessage('Marks image must have even number of pixels per row'); {this requirement added for 16 bit processing to make coding easier.} end; MarkupReady := ready; end; procedure ToggleMarks (pix: point; toggle: Boolean); var SavePort: GrafPtr; SaveInfo: InfoPtr; DestLoc: point; DestRect, RowRect, ColRect, SqrRect: rect; oldMark, data, undoMark, newMark: integer; begin GetPort(SavePort); SaveInfo := Info; with pix do begin Info := MarkupDataInfo; data := MyGetPixel(h, v); Info := UndoInfo; undoMark := MyGetPixel(h, v); {requires SetupUndoInfoRec which was done} Info := MarkupMarkInfo; oldMark := MyGetPixel(h, v); if (currentTool = pencil) or (currentTool = Wand) then newMark := ForegroundIndex else newMark := BackgroundIndex; if toggle then gDragUndo := (oldMark <> undoMark) and (oldMark = newMark); if gDragUndo then newMark := undoMark; if oldMark <> newMark then begin PutPixel(h, v, newMark); if DisplayMarks then if newMark = 0 then {Unmarked pixels do not get a white center } PutMarkupPixel(h, v, data) else PutMarkupPixel(h, v, newMark); Info^.Changes := true; gDrawValues := true; if gAutoIntensityEnabled then UpdateHistogram(oldMark, newMark, data, h, v); WhatToUndo := UndoEdit; EnableKeepUndo; end; end; SetPort(GrafPtr(MarkupOsPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); { Use copybits to create the enlarged pixels in the row and column line offscreen pixmap } with pix do SetRect(SqrRect, h, v, h + 1, v + 1); DestLoc := pix; with DestLoc, SourceRect do begin v := (v - top) * Magnify; h := (h - left) * Magnify; SetRect(RowRect, h, PaneHeight + 1, h + Magnify, PaneHeight + 1 + Magnify); SetRect(ColRect, PaneWidth + 1, v, PaneWidth + 1 + Magnify, v + Magnify); end; with MarkupMarkInfo^ do begin hlock(handle(osPort^.portPixMap)); hlock(handle(MarkupOsPort^.PortPixMap)); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, BitMapHandle(MarkupOsPort^.PortPixMap)^^, SqrRect, RowRect, SrcCopy, nil); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, BitMapHandle(MarkupOsPort^.PortPixMap)^^, SqrRect, ColRect, SrcCopy, nil); hunlock(handle(osPort^.portPixMap)); hunlock(handle(MarkupOsPort^.PortPixMap)); end; SetPort(MarkupWindow); UpdateMarkupRect(RowRect); UpdateMarkupRect(ColRect); { Immediately update the modified pixel in Dest window} with pix, DestRect do begin top := v; left := h; bottom := v + 1; right := h + 1; end; UpdateScreen(DestRect); {force update of the modified pixel in Markup window.} PixToLoc(pix, DestLoc); with DestLoc do begin if Magnify <= 3 then SetRect(DestRect, h, v, h + 1, v + 1) else if Magnify <= 6 then SetRect(DestRect, h, v, h + 2, v + 2) else SetRect(DestRect, h - 1, v - 1, h + 2, v + 2) end; SetPort(MarkupWindow); UpdateMarkupRect(DestRect); Info := SaveInfo; SetPort(SavePort); end; function AutoMark (pix: point): Boolean; var SaveInfo: InfoPtr; data: integer; bkg: LongInt; begin SaveInfo := Info; gDragUndo := false; AutoMark := false; Info := MarkupMarkInfo; data := MyGetPixel(pix.h, pix.v); if (data = 0) or (data = ForegroundIndex) then begin ToggleMarks(pix, false); {Could speed this up by writing a special version of ToggleMarks... } with pix do begin Info := MarkupDataInfo; data := MyGetPixel(h, v); Info := MarkupBkgInfo; bkg := MyGetPixel(h, v); bkg := (bkg * BkgCoefficient + 5000) div 10000; if gRidge then begin AutoMark := data > bkg; end else begin AutoMark := data < bkg; end; if (v = 0) or (v + 1 = MarkupMarkInfo^.nLines) or (h = 0) or (h + 1 = MarkupMarkInfo^.PixelsPerLine) then AutoMark := false; end; end; Info := SaveInfo; end; procedure AutoAdjust (pix: point; narrow: Boolean); begin gDragUndo := narrow; ToggleMarks(pix, false); end; procedure ApplyConstraint (var loc: point); var x, y: integer; begin if gAutomatic and (MarkupTool = Wand) then begin PixToLoc(gAutoPixel, constraint); with constraint do begin gWorkSwap := false; if gWorkdh = 0 then begin if loc.v < v then begin if gWorkDown then begin loc.v := v; gWorkSwap := true; end else begin loc.v := v - Magnify end end else if loc.v > v then begin if gWorkUp then begin loc.v := v; gWorkSwap := true; end else begin loc.v := v + Magnify end end end else begin if loc.h < h then begin if gWorkRight then begin loc.h := h; gWorkSwap := true; end else begin loc.h := h - Magnify end end else if loc.h > h then begin if gWorkLeft then begin loc.h := h; gWorkSwap := true; end else begin loc.h := h + Magnify end end end end end else if not ShiftKeyDown then begin CursorMotion := FreeMotion; Constraint := loc; end else begin case CursorMotion of FreeMotion: begin Constraint := loc; CursorMotion := Deciding; end; Deciding: begin x := abs(loc.h - Constraint.h); y := abs(loc.v - Constraint.v); if x > y + 2 then begin CursorMotion := HorizontalOnly; loc.v := Constraint.v; end else if y > x + 2 then begin CursorMotion := VerticalOnly; loc.h := Constraint.h; end else begin { haven't decided yet, report no motion } loc := Constraint; end; end; HorizontalOnly: loc.v := Constraint.v; VerticalOnly: loc.h := Constraint.h; end; end; end; procedure NewMousePosition (pix: point); var SaveInfo: InfoPtr; data, mark, bkg: integer; begin SaveInfo := Info; Info := MarkupDataInfo; DrawLabels('X:', 'Y:', 'Value/Mark:'); if PtInRect(pix, SourceRect) then begin if (ThePixel.h <> pix.h) or gBkgUpdReqd then begin ThePixel.h := pix.h; UpdateColDisplay; DrawXCoord(pix.h); gDrawValues := true; end; if (ThePixel.v <> pix.v) or gBkgUpdReqd then begin ThePixel.v := pix.v; UpdateRowDisplay; DrawYCoord(pix.v); gDrawValues := true; end; gBkgUpdReqd := false; end; if gDrawValues then begin Info := MarkupMarkInfo; mark := MyGetPixel(ThePixel.h, ThePixel.v); Info := MarkupDataInfo; data := MyGetPixel(ThePixel.h, ThePixel.v); Info := MarkupBkgInfo; bkg := MyGetPixel(ThePixel.h, ThePixel.v); DrawMarkValues(data, mark, bkg); gDrawValues := false; end; Info := SaveInfo; end; {Report the area, uncorrected, and corrected intensity of each mark value} {from 1 to number of reserved colors in the values window.} {"Knows" that ShoMessage is really this:} {procedure ShowMessage (str: str255);} {begin} { ValuesMessage := str;} { ShowValues;} {end;} procedure ShowMarkupResults; var strs: array[FirstExtraColorsEntry..MaxExtraColors] of str255; str1, str2: str255; a, c, tota, totc: longInt; pct: extended; i: integer; begin for i := FirstExtraColorsEntry to MaxExtraColors do begin strs[i] := ''; end; totc := 0; tota := 0; for i := FirstExtraColorsEntry to nExtraColors do begin tota := tota + Histogram[i]; totc := totc + MarkedSum[i] - MarkedBkg[i]; end; for i := FirstExtraColorsEntry to nExtraColors do begin a := Histogram[i]; c := MarkedSum[i] - MarkedBkg[i]; pct := a * 100.0 / tota; RealToString(pct, 1, 2, str1); pct := c * 100.0 / totc; RealToString(pct, 1, 2, str2); strs[i] := concat(Long2str(i), ' A=', Long2str(a), ' ', str1, '% C=', Long2str(c), ' ', str2, '%', cr); end; if (FirstExtraColorsEntry = 1) and (MaxExtraColors = 6) then InfoMessage := concat(strs[1], strs[2], strs[3], strs[4], strs[5], strs[6]) else InfoMessage := 'ExtraColors constants have changed '; if not gAutoBkgEnabled then InfoMessage := concat(InfoMessage, cr, 'manual background'); if not gAutoIntensityEnabled then InfoMessage := concat(InfoMessage, cr, 'Not Recalculated'); ShowInfo; end; procedure DragProfilePlot; var loc: point; limits: rect; procedure restrictPosition; begin if loc.h < limits.left then loc.h := limits.left else if loc.h > limits.right then loc.h := limits.right; if loc.v < limits.top then loc.v := limits.top else if loc.v > limits.bottom then loc.v := limits.bottom; if ShiftKeyDown then begin if loc.h - limits.left > loc.v - limits.top then loc.v := loc.h - limits.left + limits.top else loc.h := loc.v - limits.top + limits.left; end; end; procedure DrawProfileOutline; begin MoveTo(0, loc.v); LineTo(loc.h, loc.v); LineTo(loc.h, 0); end; begin {Drag to resize the profile plots. } {Shift key down forces plots same size.} limits.left := MarkupWidth - MaxProfile - (ProfileColRect.left - PaneWidth); limits.right := limits.left + MaxProfile - MinProfile; limits.top := MarkupHeight - MaxProfile - (ProfileRowRect.top - PaneHeight); limits.bottom := limits.top + MaxProfile - MinProfile; PenNormal; PenMode(PatXor); PenPat(gray); getMouse(loc); RestrictPosition; DrawProfileOutline; while WaitMouseUp do begin DrawProfileOutline; getMouse(loc); RestrictPosition; DrawProfileOutline; end; DrawProfileOutline; PenNormal; ProfileHeight := limits.bottom - loc.v + MinProfile; ProfileWidth := limits.right - loc.h + MinProfile; ResizeMarkupWindow(MarkupWidth, MarkupHeight); end; procedure AutoValScroll (var pix: point); var vect: point; begin with pix do begin if v < 0 then v := 0; if v >= MarkupMarkInfo^.nLines then v := MarkupMarkInfo^.nLines - 1; if h < 0 then h := 0; if h >= MarkupMarkInfo^.PixelsPerLine then h := MarkupMarkInfo^.PixelsPerLine - 1; with SourceRect do begin if (v < top + 2) or (v > bottom - 2) or (h < left + 2) or (h > right - 2) then begin vect.h := h - (right + left) div 2; vect.v := v - (top + bottom) div 2; if ScrollMarkup(vect) then ; end; end; end; end; procedure AutoFindPlus (var pix: point); begin with pix do begin v := v + gWorkdh; h := h + gWorkdv; AutoValScroll(pix); end; end; procedure AutoFindMinus (var pix: point); begin with pix do begin v := v - gWorkdh; h := h - gWorkdv; AutoValScroll(pix); end; end; procedure FlipWorkDirection; begin if gWorkUp then doMarkupCtrl('D') else if gWorkDown then doMarkupCtrl('U') else if gWorkLeft then doMarkupCtrl('R') else if gWorkRight then doMarkupCtrl('L'); end; procedure DoMouseDownInSource (loc, pix: point); var oldMagnify: integer; vect, target: point; begin if MarkupCursor = nil then exit(DoMouseDownInSource); if MarkupTool = MagnifyingGlass then begin oldMagnify := Magnify; if MarkupCursor = @GlassMinusCursor then Magnify := Magnify - 2 else begin Magnify := Magnify + 2; {??? This calculation does not allow for the profile plots or controls,} { a minor bug because resize fixes it.} MarkupWidth := LongInt(MarkupWidth) * Magnify div oldMagnify + 1; MarkupHeight := LongInt(MarkupHeight) * Magnify div oldMagnify + 1; end; NewCenterPix := ThePixel; ResizeMarkupWindow(MarkupWidth, MarkupHeight); end else if MarkupTool = Pencil then begin ToggleMarks(pix, true); if gDragUndo then myHiliteControl(MarkupWindow, UndoCtrlid, 1); end else if MarkupTool = Wand then begin if not gAutomatic then begin mySetCtlValue(MarkupWindow, AutomaticCtrlid, 1); gAutomatic := true; end; if gWorkSwap then FlipWorkDirection; gWorkSwap := false; gAutoPixel := ThePixel; {constraint center for automatic mode} gAutoPlusEnd := ThePixel; gAutoMinusEnd := ThePixel; while AutoMark(gAutoPlusEnd) do AutoFindPlus(gAutoPlusEnd); while AutoMark(gAutoMinusEnd) do AutoFindMinus(gAutoMinusEnd); end; SetCursor(MarkupCursor^); while WaitMouseUp do begin GetMouse(loc); loc.v := loc.v - MarkupCtrlHeight; ApplyConstraint(loc); LocToPix(loc, pix); SetCursor(MarkupCursor^); if MarkupTool = Pencil then begin target := pix; pix := ThePixel; while not EqualPt(pix, target) do begin vect.h := target.h - pix.h; vect.v := target.v - pix.v; if abs(vect.h) > abs(vect.v) then vect.v := 0 else if abs(vect.h) < abs(vect.v) then vect.h := 0; if vect.h > 0 then vect.h := 1 else if vect.h < 0 then vect.h := -1; if vect.v > 0 then vect.v := 1 else if vect.v < 0 then vect.v := -1; pix.h := pix.h + vect.h; pix.v := pix.v + vect.v; if PtInRect(pix, SourceRect) then begin ToggleMarks(pix, false); end else begin pix.h := pix.h - vect.h; pix.v := pix.v - vect.v; target := pix; end; end; end else if MarkupTool = Grabber then begin vect.h := MouseDownLoc.h - loc.h; vect.v := MouseDownLoc.v - loc.v; if ScrollMarkup(vect) then begin MouseDownLoc := loc; end; end; NewMousePosition(pix); end; if gUndoButtonEnabled then myHiliteControl(MarkupWindow, UndoCtrlid, 0) else myHiliteControl(MarkupWindow, UndoCtrlid, 255); end; procedure keepChanges; var SaveInfo: InfoPtr; begin ShowWatch; myHiliteControl(MarkupWindow, KeepCtrlid, 1); SaveInfo := Info; Info := MarkupMarkInfo; SetupUndo; SetupUndoInfoRec; Info := SaveInfo; gUndoButtonEnabled := false; myHiliteControl(MarkupWindow, KeepCtrlid, 255); myHiliteControl(MarkupWindow, UndoCtrlid, 255); end; procedure undoMarkup; var SaveInfo: InfoPtr; begin if not MarkupReady then exit(undoMarkup); ShowWatch; myHiliteControl(MarkupWindow, UndoCtrlid, 1); SaveInfo := Info; Info := MarkupMarkInfo; OpPending := false; undo; WhatToUndo := NothingToUndo; UpdatePicWindow; Info := SaveInfo; RefreshMarkupOffscreen; if gAutoBkgEnabled then CalculateBkg; if gAutoIntensityEnabled then CalculateHistograms; ShowMarkupResults; gUndoButtonEnabled := false; myHiliteControl(MarkupWindow, KeepCtrlid, 255); myHiliteControl(MarkupWindow, UndoCtrlid, 255); end; procedure DoMarkupCtrl (c: char); begin case c of 'K', 'k': keepChanges; 'U', 'u': begin mySetCtlValue(MarkupWindow, WorkUpCtrlid, 1); if gWorkDown then mySetCtlValue(MarkupWindow, WorkDownCtrlid, 0); if gWorkLeft then mySetCtlValue(MarkupWindow, WorkLeftCtrlid, 0); if gWorkRight then mySetCtlValue(MarkupWindow, WorkRightCtrlid, 0); gWorkdh := 0; gWorkdv := -1; gWorkUp := true; gWorkDown := false; gWorkLeft := false; gWorkRight := false; end; 'D', 'd': begin if gWorkUp then mySetCtlValue(MarkupWindow, WorkUpCtrlid, 0); mySetCtlValue(MarkupWindow, WorkDownCtrlid, 1); if gWorkLeft then mySetCtlValue(MarkupWindow, WorkLeftCtrlid, 0); if gWorkRight then mySetCtlValue(MarkupWindow, WorkRightCtrlid, 0); gWorkdh := 0; gWorkdv := 1; gWorkUp := false; gWorkDown := true; gWorkLeft := false; gWorkRight := false; end; 'L', 'l': begin if gWorkUp then mySetCtlValue(MarkupWindow, WorkUpCtrlid, 0); if gWorkDown then mySetCtlValue(MarkupWindow, WorkDownCtrlid, 0); mySetCtlValue(MarkupWindow, WorkLeftCtrlid, 1); if gWorkRight then mySetCtlValue(MarkupWindow, WorkRightCtrlid, 0); gWorkdh := -1; gWorkdv := 0; gWorkUp := false; gWorkDown := false; gWorkLeft := true; gWorkRight := false; end; 'R', 'r': begin if gWorkUp then mySetCtlValue(MarkupWindow, WorkUpCtrlid, 0); if gWorkDown then mySetCtlValue(MarkupWindow, WorkDownCtrlid, 0); if gWorkLeft then mySetCtlValue(MarkupWindow, WorkLeftCtrlid, 0); mySetCtlValue(MarkupWindow, WorkRightCtrlid, 1); gWorkdh := 1; gWorkdv := 0; gWorkUp := false; gWorkDown := false; gWorkLeft := false; gWorkRight := true; end; 'H', 'h': begin DisplayMarks := not DisplayMarks; mySetCtlValue(MarkupWindow, HideMarksCtrlid, ord(not DisplayMarks)); RefreshMarkupOffscreen; end; 'A', 'a': begin {This unconventional check box does not go on when you click it, but } {only when you click the wand tool in the Markup window.} mySetCtlValue(MarkupWindow, AutomaticCtrlid, 0); if gAutomatic then begin SelectNewTool(Pencil); gAutomatic := false; end else begin SelectNewTool(Wand); gAutoPixel := ThePixel; end; end; 'W', 'w': begin mySetCtlValue(MarkupWindow, WidenCtrlid, 1); mySetCtlValue(MarkupWindow, NarrowCtrlid, 0); gWiden := true; end; 'N', 'n': begin mySetCtlValue(MarkupWindow, WidenCtrlid, 0); mySetCtlValue(MarkupWindow, NarrowCtrlid, 1); gWiden := false; end; end; end; procedure SetKernelKind (kind: BkgKernelKindType); begin case BkgKernelKind of NoKernel: ; ConeKernel: mySetCtlValue(MarkupWindow, ConeKernelCtrlid, 0); ExponentialKernel: mySetCtlValue(MarkupWindow, ExponentialKernelCtrlid, 0); end; BkgKernelKind := kind; case BkgKernelKind of NoKernel: ; ConeKernel: mySetCtlValue(MarkupWindow, ConeKernelCtrlid, 1); ExponentialKernel: mySetCtlValue(MarkupWindow, ExponentialKernelCtrlid, 1); end; MakeKernel; end; procedure DoMouseDownInMarkup (userInfo: userInfoHandle); var SavePort: GrafPtr; pix: point; whichControl: ControlHandle; ctrlPart: integer; radius, delta: integer; Coefficient: extended; wasCanceled: Boolean; saveInfo: InfoPtr; loc: point; begin loc := userInfo^^.UserLoc; if not MarkupReady then exit(DoMouseDownInMarkup); if not MarkupWindowActive then begin SelectWindow(MarkupWindow); exit(DoMouseDownInMarkup); end; saveInfo := Info; Info := MarkupDataInfo; GetPort(SavePort); SetPort(MarkupWindow); GlobalToLocal(loc); {Look for controls before applying cursor motion constraints} ctrlPart := FindControl(loc, MarkupWindow, whichControl); if (ctrlPart <> 0) and (whichControl <> nil) then begin ctrlPart := TrackControl(whichControl, loc, nil); if ctrlPart <> 0 then begin case whichControl^^.contrlRfCon of UndoCtrlid: UndoMarkup; KeepCtrlid: doMarkupCtrl('K'); RidgeCtrlid: begin gRidge := true; mySetCtlValue(MarkupWindow, RidgeCtrlid, 1); mySetCtlValue(MarkupWindow, ValleyCtrlid, 0); end; ValleyCtrlid: begin gRidge := false; mySetCtlValue(MarkupWindow, RidgeCtrlid, 0); mySetCtlValue(MarkupWindow, ValleyCtrlid, 1); end; WorkUpCtrlid: doMarkupCtrl('U'); WorkDownCtrlid: doMarkupCtrl('D'); WorkLeftCtrlid: doMarkupCtrl('L'); WorkRightCtrlid: doMarkupCtrl('R'); HideMarksCtrlid: doMarkupCtrl('H'); AutomaticCtrlid: doMarkupCtrl('A'); WidenCtrlid: doMarkupCtrl('W'); NarrowCtrlid: doMarkupCtrl('N'); ConeKernelCtrlid: begin Coefficient := GetReal('Enter slope for cone kernel', BkgKernelSlope, wasCanceled); if not wasCanceled then begin BkgKernelSlope := Coefficient; SetKernelKind(ConeKernel); if gAutoBkgEnabled then CalculateBkg; if gAutoIntensityEnabled then CalculateHistograms; ShowMarkupResults; end; end; ExponentialKernelCtrlid: begin Coefficient := GetReal('Enter base for exponential kernel', BkgKernelBase, wasCanceled); if not wasCanceled then begin BkgKernelBase := Coefficient; SetKernelKind(ExponentialKernel); if gAutoBkgEnabled then CalculateBkg; if gAutoIntensityEnabled then CalculateHistograms; ShowMarkupResults; end; end; KernelRadiusCtrlid: begin radius := GetInt('Enter minimum bkg kernel radius', BkgKernelMinRadius, wasCanceled); if not wasCanceled then begin delta := GetInt('Enter bkg kernel delta radius', BkgKernelDeltaRadius, wasCanceled); if not wasCanceled then begin case BkgKernelKind of NoKernel: wasCanceled := true; ConeKernel: begin Coefficient := GetReal('Enter slope for cone kernel', BkgKernelSlope, wasCanceled); if not wasCanceled then begin BkgKernelSlope := Coefficient; end; end; ExponentialKernel: begin Coefficient := GetReal('Enter base for exponential kernel', BkgKernelBase, wasCanceled); if not wasCanceled then begin BkgKernelBase := Coefficient; end; end; end; if not wasCanceled then begin if radius < 1 then radius := 1; if radius > BkgKernelMaxRadius then radius := BkgKernelMaxRadius; BkgKernelMinRadius := radius; if delta < 1 then delta := 1; if delta > BkgKernelMaxRadius then delta := BkgKernelMaxRadius; BkgKernelDeltaRadius := delta; MakeKernel; if gAutoBkgEnabled then CalculateBkg; if gAutoIntensityEnabled then CalculateHistograms; ShowMarkupResults; end; end; end; end; BkgCoefficientCtrlid: begin Coefficient := GetReal('Enter bkg coef * 10000', BkgCoefficient, wasCanceled); if not wasCanceled then begin BkgCoefficient := Round(Coefficient); end; end; AutoBkgCtrlid: begin gAutoBkgEnabled := not gAutoBkgEnabled; mySetCtlValue(MarkupWindow, AutoBkgCtrlid, ord(gAutoBkgEnabled)); if gAutoBkgEnabled then begin if not gAutoIntensityEnabled then begin gAutoIntensityEnabled := true; mySetCtlValue(MarkupWindow, AutoIntensityCtrlid, ord(gAutoIntensityEnabled)); end; CalculateBkg; CalculateHistograms; end; ShowMarkupResults; end; AutoIntensityCtrlid: begin gAutoIntensityEnabled := not gAutoIntensityEnabled; mySetCtlValue(MarkupWindow, AutoIntensityCtrlid, ord(gAutoIntensityEnabled)); if gAutoIntensityEnabled then CalculateHistograms; ShowMarkupResults; end; CalcBackgroundCtrlid: begin CalculateBkg; end; CalcIntensityCtrlid: begin CalculateHistograms; ShowMarkupResults; end; DataImageCtrlid: SelectWindow(MarkupDataInfo^.wptr); MarksImageCtrlid: SelectWindow(MarkupMarkInfo^.wptr); BkgImageCtrlid: SelectWindow(MarkupBkgInfo^.wptr); ErodeCtrlid: begin Erode; if gAutoBkgEnabled then CalculateBkg; if gAutoIntensityEnabled then CalculateHistograms; RefreshMarkupOffscreen; end; DilateCtrlid: begin Dilate; if gAutoBkgEnabled then CalculateBkg; if gAutoIntensityEnabled then CalculateHistograms; RefreshMarkupOffscreen; end; end; end; end else begin loc.v := loc.v - MarkupCtrlHeight; {Offscreen pixmap coordinates} ApplyConstraint(loc); MouseDownLoc := loc; LocToPix(loc, pix); if PtInRect(pix, SourceRect) then DoMouseDownInSource(loc, pix) else begin {these events do not wait for mouse up} if PtInRect(loc, ProfileDragRect) then DragProfilePlot else begin if PtInRect(loc, ScalePlotsButton) then ScalePlots := not ScalePlots; {This low budget buttons is scheduled for replacement soon... } RefreshMarkupOffscreen {click in profile plots to refresh } end end; end; ShowMarkupResults; SetPort(SavePort); Info := saveInfo; end; {This function is called from SelectCursor in Image.p, which is} {called every time through the main event loop, when the cursor} {is over the content area of a window with ^.WindowKind = UserKind.} procedure DoMarkupCursor (userInfo: userInfoHandle); var SavePort: GrafPtr; pix: point; SaveInfo: InfoPtr; loc: point; begin loc := userInfo^^.UserLoc; if not MarkupReady then exit(DoMarkupCursor); GetPort(SavePort); SetPort(MarkupWindow); GlobalToLocal(loc); loc.v := loc.v - MarkupCtrlHeight; {Do NOT call ApplyConstraint here...} LocToPix(loc, pix); MarkupCursor := nil; if MarkupWindowActive and PtInRect(pix, SourceRect) then begin if SpaceBarDown then tempToolSelect(Grabber) else if CommandKeyDown then tempToolSelect(MagnifyingGlass) else if OptionKeyDown then begin if not gTempToolSelected then begin if (currentTool = Pencil) then tempToolSelect(Eraser) else if (currentTool = Eraser) then tempToolSelect(Pencil) end end else tempToolRestore; if currentTool = Grabber then begin MarkupCursor := @ToolCursor[Grabber]; MarkupTool := Grabber; end else if currentTool = MagnifyingGlass then begin MarkupTool := MagnifyingGlass; if OptionKeyDown then MarkupCursor := @GlassMinusCursor else MarkupCursor := @ToolCursor[MagnifyingGlass] end else if (currentTool = Pencil) or (currentTool = Eraser) then begin MarkupTool := Pencil; MarkupCursor := @ToolCursor[Pencil]; end else if currentTool = Wand then begin MarkupTool := Wand; {This whole if should be one PtInRect call...} if not gAutomatic then MarkupCursor := @ToolCursor[Wand] else if gWorkUp or gWorkDown then begin if pix.v < gAutoPixel.v then MarkupCursor := @WandMinusCursor else if pix.v > gAutoPixel.v then MarkupCursor := @WandPlusCursor else MarkupCursor := @ToolCursor[Wand]; end else begin if pix.h < gAutoPixel.h then MarkupCursor := @WandMinusCursor else if pix.h > gAutoPixel.h then MarkupCursor := @WandPlusCursor else MarkupCursor := @ToolCursor[Wand]; end; end; end; if MarkupCursor = nil then begin initCursor; TempToolRestore; end else SetCursor(MarkupCursor^); ApplyConstraint(loc); LocToPix(loc, pix); NewMousePosition(pix); SetPort(SavePort); end; procedure ActivateMarkupWindow (userInfo: userInfoHandle); var Activating: Boolean; SaveInfo: InfoPtr; begin Activating := userInfo^^.UserActivating; KillRoi;{original image buffer tended to get trashed with marching ants} {anytime Roi was active in front window and click on Markup title bar} SaveInfo := Info; if MarkupWindowActive = Activating then begin if MarkupWindowActive then {PutMessage('Markup Bug: Activate event when already active')} {Get these events when an alert box was up} {??? maybe that means the refresh could be avoided in this case?} else {PutMessage('Markup Bug: Deactivate event when not active');} {Get this event when running macro "open a 16 bit stack"} end else if MarkupReady then begin Info := MarkupMarkInfo; KillRoi; {PutPixel into RoiRect would be overwritten by CopyBits from undo } Info := MarkupBkgInfo; KillRoi; Info := saveInfo; MarkupWindowActive := Activating; if MarkupWindowActive then begin RefreshMarkupOffscreen; keepChanges; if gAutoBkgEnabled then CalculateBkg; if gAutoIntensityEnabled then CalculateHistograms; ShowMarkupResults; end; end; end; procedure NudgeMarkUp (key: integer); var dh, dv: integer; loc: point; narrow: Boolean; begin case key of LeftArrow: begin dh := -1; dv := 0 end; RightArrow: begin dh := 1; dv := 0 end; UpArrow: begin dh := 0; dv := -1 end; DownArrow: begin dh := 0; dv := 1 end; end; if CurrentTool = wand then begin if OptionKeyDown then narrow := gWiden else narrow := not gWiden; if (dh = gWorkdh) and (dv = gWorkdv) then begin PixToLoc(thePixel, loc); DoMouseDownInSource(loc, thePixel); end else if (dh = -gWorkdh) and (dv = -gWorkdv) then {e.g. down arrow when working up} flipWorkDirection else if (dh = gWorkdv) and (dv = gWorkdh) then begin AutoAdjust(gAutoPlusEnd, narrow); if narrow then AutoFindMinus(gAutoPlusEnd) else AutoFindPlus(gAutoPlusEnd); end else begin AutoAdjust(gAutoMinusEnd, narrow); if narrow then AutoFindPlus(gAutoMinusEnd) else AutoFindMinus(gAutoMinusEnd); end; end; end; procedure DoMarkupKey (ch: char; KeyCode: Integer); var ich: integer; begin if markupReady then begin ich := ord(ch); if false then else if (ich >= LeftArrow) and (ich <= DownArrow) then NudgeMarkUp(ich) else DoMarkupCtrl(ch); end; end; {minmax(} {unsigned short *wp,} {unsigned long n,} {unsigned long *minp,} {unsigned long *maxp) [} { unsigned short minv, maxv, v;} {} { minv = 65535;} { maxv = 0;} { n++;} { while (--n != 0) [} { v = *wp++;} { if (v < minv) } { minv = v;} { if (v > maxv) } { maxv = v;} { ]} { *minp = minv;} { *maxp = maxv;} {]} { MACHINE MC68020} { PROC} { MOVEM.L D4-D7/A4,-(A7)} { MOVEA.L $14(A7),A4 ;wp} { MOVE.L $18(A7),D4 ;n} { MOVE.W #$FFFF,D5} { CLR.W D6} { MOVE.L D4,D0} { ADDQ.L #$1,D4} { BRA.S L3} {L1: MOVE.W (A4)+,D7} { CMP.W D7,D5} { BLS.S L2} { MOVE.W D7,D5} {L2: CMP.W D7,D6} { BCC.S L3} { MOVE.W D7,D6} {L3: SUBQ.L #$1,D4} { BNE.S L1} { MOVEQ #$00,D0} { MOVE.W D5,D0} { MOVEA.L $1C(A7),A0 ;minp} { MOVE.L D0,(A0)} { MOVEQ #$00,D0} { MOVE.W D6,D0} { MOVEA.L $20(A7),A0 ;maxp} { MOVE.L D0,(A0)} { MOVEM.L (A7)+,D4-D7/A4} { ADDA.L #$10,A7} { ENDPROC} procedure minmax (var maxp, minp: LongInt; n: LongInt; wp: Ptr); inline $48E7, $0F08, $286F, $0014, $282F, $0018, $3A3C, $FFFF, {} $4246, $2004, $5284, $600E, $3E1C, $BA47, $6302, $3A07, {} $BC47, $6402, $3C07, $5384, $66EE, $7000, $3005, $206F, {} $001C, $2080, $7000, $3006, $206F, $0020, $2080, $4CDF, {} $10F0, $DEFC, $0010; {minor bug: should have been (maxv + 1 - minv) and 65535} {and then n <= maxv} {scalexlate(} {unsigned long minv,} {unsigned long maxv,} {unsigned char *xlate) [} { unsigned long n = 0;} { unsigned long maxmin;} { unsigned long maxrnd;} { if (minv >= 65536)} { minv = 65536;} { if (maxv >= 65536)} { maxv = 65536;} { maxmin = (maxv - minv) * 256;} { maxrnd = maxmin >> 1;} { while (n < minv) [} { *xlate++ = 0;} { n++;} { ]} { while (n < maxv) [} { *xlate++ = ((n - minv) * (255*256) + maxrnd) / maxmin;} { n++;} { ]} { while (n < 65536) [} { *xlate++ = 255;} { n++;} { ]} {]} { MACHINE MC68020} { PROC} { MOVEM.L D3-D7/A4,-(A7)} { MOVE.L $1C(A7),D5 ;maxv} { MOVE.L $18(A7),D6 ;minv} { MOVEA.L $20(A7),A4 ;xlate} { MOVEQ #$00,D7} { CMPI.L #$00010000,D6} { BCS.S L1} { MOVE.L #$00010000,D6} {L1: CMPI.L #$00010000,D5} { BCS.S L2} { MOVE.L #$00010000,D5} {L2: MOVE.L D5,D0} { SUB.L D6,D0} { ASL.L #$8,D0} { MOVE.L D0,D4} { LSR.L #$1,D0} { MOVE.L D0,D3} { BRA.S L4} {L3: CLR.B (A4)+} { ADDQ.L #$1,D7} {L4: CMP.L D7,D6} { BHI.S L3} { BRA.S L6} {L5: MOVE.L D7,D0} { SUB.L D6,D0} { MULS.L #$0000FF00,D0} { MOVE.L D3,D1} { ADD.L D0,D1} { DIVU.L D4,D1} { MOVE.B D1,(A4)+} { MOVE.L D7,D0} { ADDQ.L #$1,D7} {L6: CMP.L D7,D5} { BHI.S L5} { BRA.S L8} {L7: MOVE.B #$FF,(A4)+} { ADDQ.L #$1,D7} {L8: CMPI.L #$00010000,D7} { BCS.S L7} { MOVEM.L (A7)+,D3-D7/A4} { ADDA.L #$0C,A7} { ENDPROC} procedure ScaleXlate (xlate: Ptr; maxv, minv: LongInt); inline $48E7, $1F08, $2A2F, $001C, $2C2F, $0018, $286F, $0020, {} $7E00, $0C86, $0001, $0000, $6506, $2C3C, $0001, $0000, {} $0C85, $0001, $0000, $6506, $2A3C, $0001, $0000, $2005, {} $9086, $E180, $2800, $E288, $2600, $6004, $421C, $5287, {} $BC87, $62F8, $601A, $2007, $9086, $4C3C, $0800, $0000, {} $FF00, $2203, $D280, $4C44, $1001, $18C1, $2007, $5287, {} $BA87, $62E2, $6006, $18FC, $00FF, $5287, $0C87, $0001, {} $0000, $65F2, $4CDF, $10F8, $DEFC, $000C; procedure MakeScale; begin if gScaleXlate = nil then gScaleXlate := NewHandle(65536); if gScaleXlate <> nil then ScaleXlate(gScaleXlate^, gScaleMax, gScaleMin); end; {scale16(} {unsigned short *wp,} {unsigned char *cp,} {unsigned long n,} {unsigned char *xlate) [} { n++;} { while (--n != 0) [} { *cp++ = xlate[*wp++];} { ]} {]} { MACHINE MC68020} { PROC} { MOVEM.L D7/A3/A4,-(A7)} { MOVEA.L $10(A7),A3 ;cp} { MOVEA.L $0C(A7),A4 ;wp} { MOVE.L $14(A7),D7 ;n} { ADDQ.L #$1,D7} { MOVEA.L $18(A7),A0 ;xlate} { MOVEQ.L #$00,D0} { BRA.S L2} {L1: MOVE.W (A4)+,D0} { MOVE.B $00(A0,D0.L),(A3)+} {L2: SUBQ.L #$1,D7} { BNE.S L1} { MOVEM.L (A7)+,D7/A3/A4} { ADDA.L #$10,A7} { ENDPROC} procedure doScale16 (xlate: Ptr; n: LongInt; cp, wp: Ptr); inline $48E7, $0118, $266F, $0010, $286F, $000C, $2E2F, $0014, {} $5287, $206F, $0018, $7000, $6006, $301C, $16F0, $0800, {} $5387, $66F6, $4CDF, $1880, $DEFC, $0010; procedure scale16b; var n: LongInt; cp, wp: Ptr; begin if MarkupReady then if MarkupData16Info <> nil then begin n := MarkupDataInfo^.BytesPerRow; n := n * MarkupDataInfo^.nlines; wp := MarkupData16Info^.PicBaseAddr; cp := MarkupDataInfo^.PicBaseAddr; if gScaleMin >= gScaleMax then begin minmax(gScaleMax, gScaleMin, n, wp); MakeScale; end; if gScaleXlate <> nil then begin doScale16(gScaleXlate^, n, cp, wp); end; end; end; {Constructs a 16 bit image by inserting a zero byte after each pixel of the} {associated 8 bit image, which in effect multiplies each value by 256 unsigned.} procedure make16b; type pp = ^p; p = packed record a, b: 0..255 end; var n: LongInt; cp: pp; wp: pp; begin if MarkupReady then if MarkupData16Info <> nil then begin n := MarkupDataInfo^.BytesPerRow; n := n * MarkupDataInfo^.nlines; wp := pp(MarkupData16Info^.PicBaseAddr); cp := pp(MarkupDataInfo^.PicBaseAddr); while n > 0 do begin n := n - 1; wp^.a := cp^.a; wp^.b := 0; cp := pp(ORD4(cp) + 1); wp := pp(ORD4(wp) + 2); end; end; end; procedure Avg16toBkg; var data, kernel, mark: LongInt;{pointers in D registers} RowBytes, offset, incr, dincr: LongInt; bkg: Ptr; {pointers in A registers} nl, nc, lc, cc, line, col: integer; {num lines, num cols, line ctr, col ctr} knr, knc, kincr, clip: LongInt; {kernel num rows, kernel num cols, kernel increment} r, d: integer; {radius, diameter} tryBiggerKernel: Boolean; SaveInfo: InfoPtr; kHandle: Handle; begin {given that the images all exist and are the proper size} {given that data and bkg are twice width of mark} {given that mark pixels per line is even} ShowWatch; myHiliteControl(MarkupWindow, CalcBackgroundCtrlid, 1); myHiliteControl(MarkupWindow, CancelCtrlid, 0); gCanceled := false; with MarkupMarkInfo^ do begin RowBytes := BytesPerRow; nl := nlines; nc := PixelsPerLine; end; bkg := MarkupBkgInfo^.PicBaseAddr; data := Ord4(MarkupData16Info^.PicBaseAddr); mark := Ord4(MarkupMarkInfo^.PicBaseAddr); incr := RowBytes - nc; dincr := incr * 2; lc := nl; line := 0; if gCanceled then lc := 0; while lc > 0 do begin lc := lc - 1; cc := nc; col := 0; while cc > 0 do begin cc := cc - 1; r := BkgKernelMinRadius; tryBiggerKernel := true; while tryBiggerKernel do begin d := r * 2 + 1; {find offset from center of data for kernel } {to upper left corner of data for kernel} offset := r * (RowBytes + 1); kHandle := BkgKernelHandle[r]; {last entry in BkgKernelHandle array is always nil} if kHandle = nil then begin bkg^ := Ptr(Ord4(bkg) - 2)^; beep; tryBiggerKernel := false; end else begin kernel := Ord4(kHandle^); kincr := 0; knc := d; knr := d; clip := r - line; if clip > 0 then begin knr := knr - clip; kernel := kernel + clip * d * 4; offset := offset - clip * RowBytes; end; clip := r - lc; if clip > 0 then knr := knr - clip; clip := r - col; if clip > 0 then begin kincr := clip; knc := knc - clip; kernel := kernel + clip * 4; offset := offset - clip; end; clip := r - cc; if clip > 0 then begin kincr := kincr + clip; knc := knc - clip; end; {onebkgp16 (bkg, mark, data, kernel, incr, kincr, knc, knr: longint)} tryBiggerKernel := not onebkgp16(Ord4(bkg), mark - offset, data - offset * 2, kernel, RowBytes - knc, kincr, knc, knr); end; {else kHandle <> nil} r := r + BkgKernelDeltaRadius; end; {while tryBiggerKernel} bkg := Ptr(Ord4(bkg) + 2); mark := mark + 1; data := data + 2; col := col + 1; end; {while cc > 0} if CommandPeriod then begin myHiliteControl(MarkupWindow, CancelCtrlid, 1); beep; cc := 0; lc := 0; end; bkg := Ptr(Ord4(bkg) + dincr); mark := mark + incr; data := data + dincr; line := line + 1; end; {while lc > 0} gBkgUpdReqd := true; {redraw the profile plots} SaveInfo := Info; Info := MarkupBkgInfo; UpdatePicWindow; Info := SaveInfo; myHiliteControl(MarkupWindow, CalcBackgroundCtrlid, 0); myHiliteControl(MarkupWindow, CancelCtrlid, 255); end; {$S} {Called from procedure InitUserMacros in UMacroRun.p, } {which is called from Image.p early in initialization.} {Do not start timers (see UMTimer.p) in this function.} procedure UMMarkupInit; begin locals := nil;{Do not allocate space unless needed} MarkupInitialize; end; {Called from procedure FinalUserMacros in UMacroRun,p.} {This is guaranteed to run prior to any exit which happens after a call} {to DoUserMacro, and is intended for things which MUST be done prior } {to exit, like removing timers from the system timer list.} {Note well that it is NOT guaranteed to be called prior to any exit} {which might happen after InitUserMacros but before DoUserMacro.} procedure UMMarkupFinal; begin end; {AddUMSym calls:} {Add one call for each macro command, function, or string function} {you wish to add to the macro language.} {First argument is a string, case is ignored, truncated to SymbolSize characters.} {Second argument must be one of UserCommandT, UserFuncT, or UserStrFuncT} {Third argument is the UserCommandType item associated with the name.} {Called from procedure AddUserMacros in UMacroRun.p.} {This runs once each time macros are loaded from a file or a text window.} procedure UMMarkupAdd; begin AddUMSym('Dilate8Circular', UserCommandT, Dilate8CircularUC); AddUMSym('Sum16uMark', UserCommandT, Sum16uMarkUC); AddUMSym('Sum16sMark', UserCommandT, Sum16sMarkUC); AddUMSym('MarkupPicNumber', UserFuncT, MarkupPicNumberUC); AddUMSym('MarkupData16', UserCommandT, MarkupData16UC); AddUMSym('MarkupData8', UserCommandT, MarkupData8UC); AddUMSym('MarkupMarks', UserCommandT, MarkupMarksUC); AddUMSym('MarkupBkg', UserCommandT, MarkupBkgUC); AddUMSym('MarkupShow', UserCommandT, MarkupShowUC); AddUMSym('MarkupHide', UserCommandT, MarkupHideUC); AddUMSym('MarkupPasteKernel', UserCommandT, MarkupPasteKernelUC); AddUMSym('MarkupValleys', UserCommandT, MarkupValleysUC); AddUMSym('MarkupRidges', UserCommandT, MarkupRidgesUC); AddUMSym('MarkupBkgCoef', UserCommandT, MarkupBkgCoefUC); AddUMSym('MarkupBkgMin', UserCommandT, MarkupBkgMinUC); AddUMSym('MarkupBkgDelta', UserCommandT, MarkupBkgDeltaUC); AddUMSym('MarkupBkgCone', UserCommandT, MarkupBkgConeUC); AddUMSym('MarkupBkgExponential', UserCommandT, MarkupBkgExponentialUC); AddUMSym('MarkupDilate', UserCommandT, MarkupDilateUC); AddUMSym('MarkupErode', UserCommandT, MarkupErodeUC); AddUMSym('MarkupCalcBkg', UserCommandT, MarkupCalcBkgUC); AddUMSym('MarkupCalcHist', UserCommandT, MarkupCalcHistUC); AddUMSym('MarkupScale16b', UserCommandT, MarkupScale16bUC); AddUMSym('MarkupScalMin', UserCommandT, MarkupScaleMinUC); AddUMSym('MarkupScalMax', UserCommandT, MarkupScaleMaxUC); AddUMSym('MarkupMake16b', UserCommandT, MarkupMake16bUC); AddUMSym('MarkupavgToBkg', UserCommandT, MarkupavgToBkgUC); AddUMSym('MarkupBkgSub', UserCommandT, MarkupBkgSubUC); AddUMSym('MarkedSum', UserFuncT, MarkedSumUC); AddUMSym('MarkedBkg', UserFuncT, MarkedBkgUC); end; {Called from procedure LookupUserMacro in UMMacroRun.p} {This runs every time the macro is executed, just prior to} {parsing the arguments.} procedure UMMarkupLookup (var uma: UserMacroArgs); begin with uma do case UserMacroCommand of Dilate8CircularUC: begin {in, out, radius} nArgs := 3; arg[1].atype := UMATpic; arg[2].atype := UMATpic; arg[3].atype := UMATreal; end; Sum16uMarkUC: begin {in, mark, out} nArgs := 3; arg[1].atype := UMATpic; arg[2].atype := UMATpic; arg[3].atype := UMATpic; end; Sum16sMarkUC: begin nArgs := 3; arg[1].atype := UMATpic; arg[2].atype := UMATpic; arg[3].atype := UMATpic; end; MarkupPicNumberUC: begin nArgs := 1; arg[1].atype := UMATstring; end; MarkupData16UC: begin nArgs := 1; arg[1].atype := UMATinteger; end; MarkupData8UC: begin nArgs := 1; arg[1].atype := UMATinteger; end; MarkupMarksUC: begin nArgs := 1; arg[1].atype := UMATinteger; end; MarkupBkgUC: begin nArgs := 1; arg[1].atype := UMATinteger; end; MarkupShowUC: nArgs := 0; MarkupHideUC: nArgs := 0; MarkupPasteKernelUC: ; MarkupValleysUC: ; MarkupRidgesUC: ; MarkupBkgCoefUC: ; MarkupBkgMinUC: ; MarkupBkgDeltaUC: ; MarkupBkgConeUC: ; MarkupBkgExponentialUC: ; MarkupDilateUC: ; MarkupErodeUC: ; MarkupCalcBkgUC: ; MarkupCalcHistUC: ; MarkupScale16bUC: ; MarkupScaleMinUC: ; MarkupScaleMaxUC: ; MarkupMake16bUC: ; MarkupavgToBkgUC: ; MarkupBkgSubUC: ; MarkedSumUC: begin nArgs := 1; arg[1].atype := UMATinteger; end; MarkedBkgUC: begin nArgs := 1; arg[1].atype := UMATinteger; end; otherwise begin ErrorOccurred := true; str := 'UMMarkup.p LookupUserMacro'; end; end; end; {;/* CircularDilate8.c */ } {;/* } {; } {;8 bit unsigned input and output images. } {; } {;The images must be the same size. The ROI's must be the same size. } {;There must be a border around the ROI's at least radius wide. } {;(If the images were not the same size, then two arrays of offsets } {;would be needed). } {; } {;The output image will be modified outside of the ROI but } {;the values there are not necessarily correct. In other words, } {;both images contain a scratch area outside the ROI that is } {;used to avoid the need for special cases near the edges of the ROI. } {; } {;In the input image, pixel values represent segmentation. } {;Value zero means the pixel is unassigned, values 1 to 254 } {;mean the pixel is assigned to the corresponding segment, } {;and value 255 should not be used. It is a temporary flag } {;in the output image meaning that the final value has not been } {;determined yet. } {; } {;This dilation operation takes a radius parameter. A single } {;pixel will dilate in one step to a circle of specified radius. } {;A line of pixels will dilate to a rod with rounded ends. The caller } {;provides an array of offsets that encode the circle. } {; } {;In contract, repeated dilation using the ordinary binary } {;algorithm produces artifacts. } {; } {;Also, when two separate segments are close enough that the dilated } {;segments would overlap, then a disputed pixel will be assigned to } {;the closer segment. (The caller provides the definition of } {;"closer"). } {; } {;Both images must have a border around the ROI which is large enough } {;so that no offset from a pixel inside the ROI will extend beyond } {;the image. Thus, the border must be radius pixels wide. } {; } {;A two pass algorithm is used. First, every nonzero pixel of the } {;input image is dilated into the output image, and when conflicts } {;are detected, the output pixel is set to 255. Second, every conflict } {;pixel of the output image is resolved by searching for the closest } {;nonzero intput pixel. } {; } {;It is assumed that the output image is a copy of the input image. } {; } {;A vector of offset and distance information is provided. Each entry } {;in the vector gives the offset to the corresponding input pixel. } {;The vector is sorted in order of increasing distance from the } {;center. Equal distance pixels are listed in an arbitrary order. } {;The offset vector encodes information about the number of bytes per } {;row of the input image. The end of the vector is denoted by an offset } {;of zero. } {; } {;Fast scan pass: } {; } {;For each nonzero pixel of the input image ("center input pixel"), } {;loop over each output pixel in range of the input pixel (loop } {;through the offset vector until a zero offset is seen). } {;Calculate the new value of the offset output pixel as follows: } {;If the offset output pixel is zero, use the center input value. } {;If it is equal to the center input pixel or it is equal to the } {;offset input pixel, then use the output pixel value (leave it } {;unchanged). Otherwise, the new value should be 255. Finally, } {;store the new value into the offset output pixel. } {; } {;Conflict resolution pass: } {; } {;For each conflict pixel in the output image, consider each entry } {;in the offset vector in order until a nonzero input pixel is found. } {;Replace the conflict flag value in the output image with this value. } {;If a zero offset is encountered, store a zero. This should not happen } {;if the input image was actually a copy of the output. } {; } {; } {;Inputs: input image, fast offset vector, conflict offset vector. } {;outputs: output image. } {; } {;*/ } {; } {;#define CONFLICT_PIXEL 255 } {;typedef unsigned char pixel_type; } {;/* offsets are in bytes. code referencing in[offset] */ } {;/* must be modified for 16 bit images */ } {; } {;typedef long offset_type; } {; } {;typedef struct [ } {; long wpix, height, skipIn, skipOut; } {; pixel_type *baseIn; } {; pixel_type *baseOut; } {; offset_type *offsets; } {;] CircDil8Arg; } {; } {;CircularDilate8( } {; register CircDil8Arg *a } {;) [ } {; register pixel_type *in; } {; register pixel_type *out; } {; } {; register long lines, cols; } {; register offset_type *off; } {; register offset_type offset; } {; register pixel_type p, q; } {; } {; in = a->baseIn; } {; out = a->baseOut; } {; lines = a->height; } {; do [ } {; cols = a->wpix; } {; do [ } {; p = *in; } {; if (p != 0) [ } {; off = a->offsets; } {; while ((offset = *off++) != 0) [ } {; q = out[offset]; } {; if (q == 0) [ } {; out[offset] = p; } {; ] else if (q != p && q != in[offset]) [ } {; out[offset] = CONFLICT_PIXEL; } {; ] } {; ] } {; ] } {; ++in; } {; ++out; } {; ] while (--cols > 0); } {; (char * )in += a->skipIn; } {; (char * )out += a->skipOut; } {; ] while (--lines > 0); } {; in = a->baseIn; } {; out = a->baseOut; } {; lines = a->height; } {; do [ } {; cols = a->wpix; } {; do [ } {; p = *out; } {; if (p == CONFLICT_PIXEL) [ } {; off = a->offsets; } {; while ((offset = *off++) != 0 && (p = in[offset]) == 0) } {; ; } {; *out = p; } {; ] } {; ++in; } {; ++out; } {; ] while (--cols > 0); } {; (char * )in += a->skipIn; } {; (char * )out += a->skipOut; } {; ] while (--lines > 0); } {;] } {; } {; } {; } { CASE YES } { MACHINE MC68020 } {decl PROC EXPORT } { LEA str,A0 } { MOVE.L A0,D0 } { RTS } { DATA } { STRING ASIS } {str DC.B 'CircDil8Arg = record wpix, height, skipIn, skipOut: LongInt;',13 } { DC.B 'baseIn, baseOut, offsets: Ptr;end;',13 } { DC.B 'procedure CircularDilate8(var a: CircDil8Arg); inline' } { DC.B 0 } { ENDPROC } { } {code PROC EXPORT } { EXPORT endcode } { MOVEA.L (A7)+,A1 } { MOVEM.L D3-D6/A2-A4,-(A7) } { MOVEA.L $0010(A1),A3 } { MOVEA.L $0014(A1),A4 } { MOVE.L $0004(A1),D3 } {L0018 MOVE.L (A1),D4 } {L001A MOVE.B (A3),D5 } { MOVEQ #$00,D0 } { MOVE.B D5,D0 } { TST.L D0 } { BEQ.S L0050 } { MOVEA.L $0018(A1),A2 } { BRA.S L004C } {L002A MOVE.B $00(A4,D1.L),D6 } { BNE.S L003C } { MOVE.B D5,$00(A4,D1.L) } { BRA.S L004C } {L003C CMP.B D6,D5 } { BEQ.S L004C } { CMP.B $00(A3,D1.L),D6 } { BEQ.S L004C } { MOVE.B #$FF,$00(A4,D1.L) } {L004C MOVE.L (A2)+,D1 } { BNE.S L002A } {L0050 ADDQ.W #$1,A3 } { ADDQ.W #$1,A4 } { SUBQ.L #$1,D4 } { BGT.S L001A } { ADDA.L $0008(A1),A3 } { ADDA.L $000C(A1),A4 } { SUBQ.L #$1,D3 } { BGT.S L0018 } { MOVEA.L $0010(A1),A3 } { MOVEA.L $0014(A1),A4 } { MOVE.L $0004(A1),D3 } {L0070 MOVE.L (A1),D4 } {L0072 MOVE.B (A4),D5 } { CMPI.B #$FF,D5 } { BNE.S L0094 } { MOVEA.L $0018(A1),A2 } {L0082 MOVE.L (A2)+,D1 } { BEQ.S L0092 } { MOVE.B $00(A3,D1.L),D5 } { BEQ.S L0082 } {L0092 MOVE.B D5,(A4) } {L0094 ADDQ.W #$1,A3 } { ADDQ.W #$1,A4 } { SUBQ.L #$1,D4 } { BGT.S L0072 } { ADDA.L $0008(A1),A3 } { ADDA.L $000C(A1),A4 } { SUBQ.L #$1,D3 } { BGT.S L0070 } { MOVEM.L (A7)+,D3-D6/A2-A4 } {endcode: } { ENDPROC } { END } {} type CircDil8Arg = record wpix, height, skipIn, skipOut: LongInt; baseIn, baseOut, offsets: Ptr; end; procedure CircularDilate8 (var a: CircDil8Arg); inline $225F, $48E7, $1E38, $2669, $0010, $2869, $0014, $2629,{} $0004, $2811, $1A13, $7000, $1005, $4A80, $6726, $2469,{} $0018, $601C, $1C34, $1800, $6606, $1985, $1800, $6010,{} $BA06, $670C, $BC33, $1800, $6706, $19BC, $00FF, $1800,{} $221A, $66E0, $524B, $524C, $5384, $6EC8, $D7E9, $0008,{} $D9E9, $000C, $5383, $6EBA, $2669, $0010, $2869, $0014,{} $2629, $0004, $2811, $1A14, $0C05, $00FF, $6610, $2469,{} $0018, $221A, $6706, $1A33, $1800, $67F6, $1885, $524B,{} $524C, $5384, $6EE0, $D7E9, $0008, $D9E9, $000C, $5383,{} $6ED2, $4CDF, $1C78; procedure doDil8C (var uma: UserMacroArgs; var cd8Arg: CircDil8Arg); const maxr = 20; {20 would take a long time anyway...} type lptr = ^LongInt; var lp: lptr; yx: array[0..maxr] of LongInt; h: handle; r, x, y, r2, x2y2, xmin, ymin, r2min, bpr, xbpr, ybpr: LongInt; begin h := nil; with uma do begin bpr := arg[1].infop^.BytesPerRow; r := trunc(arg[3].aval); if r > maxr then begin ErrorOccurred := true; str := 'radius too large'; exit(doDil8C); end; {r2 may be bigger than sqr(r)} r2 := trunc(sqr(arg[3].aval)); {overestimate size of offsets vector} h := newHandle(sqr(2 * r + 1) * sizeof(longint)); if h = nil then begin errorOccurred := true; str := 'Out of memory'; exit(doDil8C); end; end; HLock(h); cd8Arg.offsets := ptr(h^); lp := lptr(h^); yx[0] := 1; for x := 1 to r do yx[x] := 0; r2min := 0; while r2min <= r2 do begin xmin := r; ymin := r; r2min := r2 + 1; for x := 1 to r do begin y := yx[x]; if y <= x then begin x2y2 := sqr(x) + sqr(y); if x2y2 < r2min then begin r2min := x2y2; xmin := x; ymin := y; end; end; end; if r2min <= r2 then begin yx[xmin] := ymin + 1; xbpr := xmin * bpr; ybpr := ymin * bpr; lp^ := xmin + ybpr; lp := lptr(ord4(lp) + sizeof(longint)); if xmin = ymin then begin lp^ := xmin - ybpr; lp := lptr(ord4(lp) + sizeof(longint)); lp^ := -xmin - ybpr; lp := lptr(ord4(lp) + sizeof(longint)); lp^ := -xmin + ybpr; lp := lptr(ord4(lp) + sizeof(longint)); end {assert that xmin <> 0} else if ymin = 0 then begin lp^ := -xmin + ybpr; lp := lptr(ord4(lp) + sizeof(longint)); lp^ := ymin + xbpr; lp := lptr(ord4(lp) + sizeof(longint)); lp^ := ymin - xbpr; lp := lptr(ord4(lp) + sizeof(longint)); end else begin lp^ := xmin - ybpr; lp := lptr(ord4(lp) + sizeof(longint)); lp^ := -xmin - ybpr; lp := lptr(ord4(lp) + sizeof(longint)); lp^ := -xmin + ybpr; lp := lptr(ord4(lp) + sizeof(longint)); lp^ := ymin + xbpr; lp := lptr(ord4(lp) + sizeof(longint)); lp^ := ymin - xbpr; lp := lptr(ord4(lp) + sizeof(longint)); lp^ := -ymin - xbpr; lp := lptr(ord4(lp) + sizeof(longint)); lp^ := -ymin + xbpr; lp := lptr(ord4(lp) + sizeof(longint)); end; end; end; lp^ := 0; {end marker} CircularDilate8(cd8Arg); DisposHandle(h); end; {in, out, radius} procedure doDilate8Circular (var uma: UserMacroArgs); var cd8Arg: CircDil8Arg; r: LongInt; begin with uma do begin r := trunc(arg[3].aval); checkOutputConflict(uma, 2); if ErrorOccurred then exit(doDilate8Circular); with cd8Arg do begin with arg[1].roi do begin baseIn := Base; skipIn := Skip; end; height := arg[2].roi.Height; with arg[2].roi do begin wpix := Width; baseOut := Base; skipOut := Skip; end; with arg[1], infop^.RoiRect do begin if (wpix <> roi.Width) or (height <> roi.Height) then begin errorOccurred := true; str := 'input and output selections must be same size'; exit(doDilate8Circular); end; {roi top left must be at least trunc(radius) pixels from left edge and from top.} {roi bottom right must be at least trunc(radius) pixels from right edge and bottom.} if (top < r) or (left < r) or (infop^.nlines - bottom < r) or (infop^.PixelsPerLine - right < r) then begin errorOccurred := true; str := 'input image margins must match or exceed radius'; exit(doDilate8Circular); end; if infop^.BytesPerRow <> arg[2].infop^.BytesPerRow then ErrorOccurred := true; if infop^.PixelsPerLine <> arg[2].infop^.PixelsPerLine then ErrorOccurred := true; if infop^.nlines <> arg[2].infop^.nlines then ErrorOccurred := true; if ErrorOccurred then begin str := 'both images must be same size'; exit(doDilate8Circular); end; end; end; end; doDil8C(uma, cd8Arg); end; {;/* MarkSum16u16s.c */ } {; } {;/* } {; } {;Add each pixel value in the data image into the output vector } {;element selected by the corresponding marks pixel. } {; } {;The input image is a 16 bit signed image. } {; } {;The marks image is a 16 bit unsigned image. } {; } {;The ROI sizes of the input and marks images must match allowing for } {;pixel size. } {; } {;The output image is a 32 bit signed vector with 65536 elements. } {;It must not have an ROI, the image is required to be precisely } {;the correct size. } {; } {;The output image must contain exactly 4*65536 bytes, } {;for example 512w x 512h. } {; } {;*/ } {; } {;typedef long vect_type; } {;typedef short pixel_type; } {;typedef unsigned short mark_type; } {; } {;typedef struct [ } {; long wpix, height, skipData, skipMark; } {; vect_type *baseVect; } {; mark_type *baseMark; } {; pixel_type *baseData; } {;] markSum16u16sarg; } {; } {;markSum16u16s( } {; markSum16u16sarg *a } {;) [ } {; register mark_type *mark; } {; register pixel_type *data; } {; register vect_type *vect; } {; register long wpix; } {; register long rows; } {; register long skipData, skipMark; } {; register long cols; } {; } {; wpix = a->wpix; } {; rows = a->height; } {; skipData = a->skipData; } {; skipMark = a->skipMark; } {; vect = a->baseVect; } {; mark = a->baseMark; } {; data = a->baseData; } {; } {; do [ } {; cols = wpix; } {; do [ } {; vect[*mark++] += *data++; } {; ] while (--cols > 0); } {; (char * )mark += skipMark; } {; (char * )data += skipData; } {; ] while (--rows > 0); } {; } {;] } {; } { CASE YES } { MACHINE MC68020 } {decl PROC EXPORT } { LEA str,A0 } { MOVE.L A0,D0 } { RTS } { DATA } { STRING ASIS } {str DC.B 'type markSum16u16sarg = record ' } { DC.B 'wpix, height, skipData, skipMark: LongInt;' } { DC.B 'baseVect, baseMark, baseData: ptr;' } { DC.B 'end;' } { DC.B 'procedure markSum16u16s(a: markSum16u16sarg); inline' } { DC.B 0 } { ENDPROC } { } {code PROC EXPORT } { EXPORT endcode } { MOVEA.L (A7)+,A0 } { MOVEM.L D3-D7/A2-A4,-(A7) } { MOVEM.L (A0),D3-D6/A2-A4 } { MOVEQ #$00,D0 } {L26 MOVE.L D3,D7 } {L28 MOVE.W (A3)+,D0 } { MOVE.W (A4)+,D1 } { EXT.L D1 } { ADD.L D1,$00(A2,D0.L*4) } { SUBQ.L #$1,D7 } { BGT.S L28 } { ADDA.L D6,A3 } { ADDA.L D5,A4 } { SUBQ.L #$1,D4 } { BGT.S L26 } { MOVEM.L (A7)+,D3-D7/A2-A4 } {endcode: } { ENDPROC } { END } {} type markSumarg = record wpix, height, skipData, skipMark: LongInt; baseVect, baseMark, baseData: ptr; end; type markSum16u16sarg = record wpix, height, skipData, skipMark: LongInt; baseVect, baseMark, baseData: ptr; end; procedure markSum16u16s (a: markSumarg); inline $205F, $48E7, $1F38, $4CD0, $1C78, $7000, $2E03, $301B,{} $321C, $48C1, $D3B2, $0C00, $5387, $6EF2, $D7C6, $D9C5,{} $5384, $6EE8, $4CDF, $1CF8; {;/* MarkSum16u16u.c */ } {; } {;/* } {; } {;Add each pixel value in the data image into the output vector } {;element selected by the corresponding marks pixel. } {; } {;The input image is a 16 bit unsigned image. } {; } {;The marks image is a 16 bit unsigned image. } {; } {;The ROI sizes of the input and marks images must match allowing for } {;pixel size. } {; } {;The output image is a 32 bit unsigned vector with 65536 elements. } {;It must not have an ROI, the image is required to be precisely } {;the correct size. } {; } {;The output image must contain exactly 4*65536 bytes, } {;for example 512w x 512h. } {; } {;*/ } {; } {;typedef unsigned long vect_type; } {;typedef unsigned short pixel_type; } {;typedef unsigned short mark_type; } {; } {;typedef struct [ } {; long wpix, height, skipData, skipMark; } {; vect_type *baseVect; } {; mark_type *baseMark; } {; pixel_type *baseData; } {;] markSum16u16uarg; } {; } {;markSum16u16u( } {; markSum16u16uarg *a } {;) [ } {; register mark_type *mark; } {; register pixel_type *data; } {; register vect_type *vect; } {; register long wpix; } {; register long rows; } {; register long skipData, skipMark; } {; register long cols; } {; } {; wpix = a->wpix; } {; rows = a->height; } {; skipData = a->skipData; } {; skipMark = a->skipMark; } {; vect = a->baseVect; } {; mark = a->baseMark; } {; data = a->baseData; } {; } {; do [ } {; cols = wpix; } {; do [ } {; vect[*mark++] += *data++; } {; ] while (--cols > 0); } {; (char * )mark += skipMark; } {; (char * )data += skipData; } {; ] while (--rows > 0); } {; } {;] } {; } { CASE YES } { MACHINE MC68020 } {decl PROC EXPORT } { LEA str,A0 } { MOVE.L A0,D0 } { RTS } { DATA } { STRING ASIS } {str DC.B 'type markSum16u16uarg = record ' } { DC.B 'wpix, height, skipData, skipMark: LongInt;' } { DC.B 'baseVect, baseMark, baseData: ptr;' } { DC.B 'end;' } { DC.B 'procedure markSum16u16u(a: markSum16u16uarg); inline' } { DC.B 0 } { ENDPROC } { } {code PROC EXPORT } { EXPORT endcode } { MOVEA.L (A7)+,A0 } { MOVEM.L D3-D7/A2-A4,-(A7) } { MOVEM.L (A0),D3-D6/A2-A4 } { MOVEQ #$00,D0 } { MOVEQ #$00,D1 } {L26 MOVE.L D3,D7 } {L28 MOVE.W (A3)+,D0 } { MOVE.W (A4)+,D1 } { ADD.L D1,$00(A2,D0.L*4) } { SUBQ.L #$1,D7 } { BGT.S L28 } { ADDA.L D6,A3 } { ADDA.L D5,A4 } { SUBQ.L #$1,D4 } { BGT.S L26 } { MOVEM.L (A7)+,D3-D7/A2-A4 } {endcode: } { ENDPROC } { END } {} type markSum16u16uarg = record wpix, height, skipData, skipMark: LongInt; baseVect, baseMark, baseData: ptr; end; procedure markSum16u16u (a: markSumarg); inline $205F, $48E7, $1F38, $4CD0, $1C78, $7000, $7200, $2E03,{} $301B, $321C, $D3B2, $0C00, $5387, $6EF4, $D7C6, $D9C5,{} $5384, $6EEA, $4CDF, $1CF8; {;/* MarkSum8u16s.c */ } {; } {;/* } {; } {;Add each pixel value in the data image into the output vector } {;element selected by the corresponding marks pixel. } {; } {;The input image is a 16 bit signed image. } {; } {;The marks image is an 8 bit unsigned image. } {; } {;The ROI sizes of the input and marks images must match allowing for } {;pixel size. } {; } {;The output image is a 32 bit signed vector with 256 elements. } {;It must not have an ROI, the image is required to be precisely } {;the correct size. } {; } {;The output image must contain exactly 4*256 bytes, } {;for example 32w x 32h. 32 is the minimum width of an image. } {; } {;*/ } {; } {;typedef long vect_type; } {;typedef short pixel_type; } {;typedef unsigned char mark_type; } {; } {;typedef struct [ } {; long wpix, height, skipData, skipMark; } {; vect_type *baseVect; } {; mark_type *baseMark; } {; pixel_type *baseData; } {;] markSum8u16sarg; } {; } {;markSum8u16s( } {; markSum8u16sarg *a } {;) [ } {; register mark_type *mark; } {; register pixel_type *data; } {; register vect_type *vect; } {; register long wpix; } {; register long rows; } {; register long skipData, skipMark; } {; register long cols; } {; } {; wpix = a->wpix; } {; rows = a->height; } {; skipData = a->skipData; } {; skipMark = a->skipMark; } {; vect = a->baseVect; } {; mark = a->baseMark; } {; data = a->baseData; } {; } {; do [ } {; cols = wpix; } {; do [ } {; vect[*mark++] += *data++; } {; ] while (--cols > 0); } {; (char * )mark += skipMark; } {; (char * )data += skipData; } {; ] while (--rows > 0); } {; } {;] } {; } { CASE YES } { MACHINE MC68020 } {decl PROC EXPORT } { LEA str,A0 } { MOVE.L A0,D0 } { RTS } { DATA } { STRING ASIS } {str DC.B 'type markSum8u16sarg = record ' } { DC.B 'wpix, height, skipData, skipMark: LongInt;' } { DC.B 'baseVect, baseMark, baseData: ptr;' } { DC.B 'end;' } { DC.B 'procedure markSum8u16s(a: markSum8u16sarg); inline' } { DC.B 0 } { ENDPROC } { } {code PROC EXPORT } { EXPORT endcode } { MOVEA.L (A7)+,A0 } { MOVEM.L D3-D7/A2-A4,-(A7) } { MOVEM.L (A0),D3-D6/A2-A4 } { MOVEQ #$00,D0 } {L26 MOVE.L D3,D7 } {L28 MOVE.B (A3)+,D0 } { MOVE.W (A4)+,D1 } { EXT.L D1 } { ADD.L D1,$00(A2,D0.L*4) } { SUBQ.L #$1,D7 } { BGT.S L28 } { ADDA.L D6,A3 } { ADDA.L D5,A4 } { SUBQ.L #$1,D4 } { BGT.S L26 } { MOVEM.L (A7)+,D3-D7/A2-A4 } {endcode: } { ENDPROC } { END } {} type markSum8u16sarg = record wpix, height, skipData, skipMark: LongInt; baseVect, baseMark, baseData: ptr; end; procedure markSum8u16s (a: markSumarg); inline $205F, $48E7, $1F38, $4CD0, $1C78, $7000, $2E03, $101B,{} $321C, $48C1, $D3B2, $0C00, $5387, $6EF2, $D7C6, $D9C5,{} $5384, $6EE8, $4CDF, $1CF8; {;/* MarkSum8u16u.c */ } {; } {;/* } {; } {;Add each pixel value in the data image into the output vector } {;element selected by the corresponding marks pixel. } {; } {;The input image is a 16 bit unsigned image. } {; } {;The marks image is an 8 bit unsigned image. } {; } {;The ROI sizes of the input and marks images must match allowing for } {;pixel size. } {; } {;The output image is a 32 bit signed vector with 256 elements. } {;It must not have an ROI, the image is required to be precisely } {;the correct size. } {; } {;The output image must contain exactly 4*256 bytes, } {;for example 32w x 32h. 32 is the minimum width of an image. } {; } {;*/ } {; } {;typedef long vect_type; } {;typedef unsigned short pixel_type; } {;typedef unsigned char mark_type; } {; } {;typedef struct [ } {; long wpix, height, skipData, skipMark; } {; vect_type *baseVect; } {; mark_type *baseMark; } {; pixel_type *baseData; } {;] markSum8u16uarg; } {; } {;markSum8u16u( } {; markSum8u16uarg *a } {;) [ } {; register mark_type *mark; } {; register pixel_type *data; } {; register vect_type *vect; } {; register long wpix; } {; register long rows; } {; register long skipData, skipMark; } {; register long cols; } {; } {; wpix = a->wpix; } {; rows = a->height; } {; skipData = a->skipData; } {; skipMark = a->skipMark; } {; vect = a->baseVect; } {; mark = a->baseMark; } {; data = a->baseData; } {; } {; do [ } {; cols = wpix; } {; do [ } {; vect[*mark++] += *data++; } {; ] while (--cols > 0); } {; (char * )mark += skipMark; } {; (char * )data += skipData; } {; ] while (--rows > 0); } {; } {;] } {; } { CASE YES } { MACHINE MC68020 } {decl PROC EXPORT } { LEA str,A0 } { MOVE.L A0,D0 } { RTS } { DATA } { STRING ASIS } {str DC.B 'type markSum8u16uarg = record ' } { DC.B 'wpix, height, skipData, skipMark: LongInt;' } { DC.B 'baseVect, baseMark, baseData: ptr;' } { DC.B 'end;' } { DC.B 'procedure markSum8u16u(a: markSum8u16uarg); inline' } { DC.B 0 } { ENDPROC } { } {code PROC EXPORT } { EXPORT endcode } { MOVEA.L (A7)+,A0 } { MOVEM.L D3-D7/A2-A4,-(A7) } { MOVEM.L (A0),D3-D6/A2-A4 } { MOVEQ #$00,D0 } { MOVEQ #$00,D1 } {L26 MOVE.L D3,D7 } {L28 MOVE.B (A3)+,D0 } { MOVE.W (A4)+,D1 } { ADD.L D1,$00(A2,D0.L*4) } { SUBQ.L #$1,D7 } { BGT.S L28 } { ADDA.L D6,A3 } { ADDA.L D5,A4 } { SUBQ.L #$1,D4 } { BGT.S L26 } { MOVEM.L (A7)+,D3-D7/A2-A4 } {endcode: } { ENDPROC } { END } {} type markSum8u16uarg = record wpix, height, skipData, skipMark: LongInt; baseVect, baseMark, baseData: ptr; end; procedure markSum8u16u (a: markSumarg); inline $205F, $48E7, $1F38, $4CD0, $1C78, $7000, $7200, $2E03,{} $101B, $321C, $D3B2, $0C00, $5387, $6EF4, $D7C6, $D9C5,{} $5384, $6EEA, $4CDF, $1CF8; procedure doSum16 (var uma: UserMacroArgs; signed: Boolean); var a: markSumarg; mark8: Boolean; markpix: Integer; begin {in, mark, out} with uma do begin with a do begin checkPixelWidth(2, uma, 1); checkOutputConflict(uma, 3); with arg[3], infop^ do begin if PixMapSize = 4 * 256 then begin mark8 := true; markPix := arg[2].roi.Width; end else if PixMapSize = 4 * 65536 then begin mark8 := false; markPix := arg[2].roi.Width div 2; checkPixelWidth(2, uma, 2); end else begin errorOccurred := true; str := 'Output image must contain 256 or 65536 32 bit pixels'; end; end; if errorOccurred then exit(doSum16); height := arg[1].roi.Height; with arg[1].roi do begin wpix := Width div 2; baseData := Base; skipData := Skip; end; with arg[2].roi do begin baseMark := Base; skipMark := Skip; end; with arg[3].roi do begin baseVect := Base; end; if (height <> arg[2].roi.Height) or (wpix <> markPix) then begin errorOccurred := true; str := 'mark selection must be same size as input selection'; exit(doSum16); end; end; if signed then begin if mark8 then markSum8u16s(a) else markSum16u16s(a); end else if mark8 then markSum8u16u(a) else markSum16u16u(a); end; end; procedure doMarkedSum (var uma: UserMacroArgs); var i: LongInt; begin with uma do begin i := arg[1].ival; if (0 <= i) and (i <= 255) then funcResult := MarkedSum[i] else begin errorOccurred := true; str := 'subscript out of range'; end; end; end; procedure doMarkedBkg (var uma: UserMacroArgs); var i: LongInt; begin with uma do begin i := arg[1].ival; if (0 <= i) and (i <= 255) then funcResult := MarkedBkg[i] else begin errorOccurred := true; str := 'subscript out of range'; end; end; end; procedure doMarkupPicNumber (var uma: UserMacroArgs); begin with uma do begin funcResult := 0; if str = 'data' then begin if MarkupDataInfo <> nil then funcResult := MarkupDataInfo^.PicNum else if IsAPic(newDataInfo) then funcResult := newDataInfo^.PicNum; end else if str = 'mark' then begin if MarkupMarkInfo <> nil then funcResult := MarkupMarkInfo^.PicNum else if IsAPic(newMarkInfo) then funcResult := newMarkInfo^.PicNum; end else if str = 'bkg' then begin if MarkupBkgInfo <> nil then funcResult := MarkupBkgInfo^.PicNum else if IsAPic(newBkgInfo) then funcResult := newBkgInfo^.PicNum; end else if str = 'data16' then begin if MarkupData16Info <> nil then funcResult := MarkupData16Info^.PicNum else if IsAPic(newData16Info) then funcResult := newData16Info^.PicNum; end else begin str := 'MarkupPicNumber(''data'' or ''mark'' or ''bkg'' or ''data16'')'; errorOccurred := true; end; end; end; {Called from procedure DoUserMacro in UMacroRun.p .} {Do not change uma.nArgs or uma.arg[i].argt here.} {This runs once each time the macro is used, after parsing the arguments.} procedure UMMarkupRun (var uma: UserMacroArgs); var iarg: Longint; saveBkgCoef: Longint; begin if locals = nil then begin locals := localsH(getBigHandle(sizeof(localsR))); if locals = nil then with uma do begin ErrorOccurred := true; str := 'UMMarkup.p Out of memory'; Exit(UMMarkupRun); end; HLock(Handle(locals)); locals^^.saveString := ''; end; HLock(Handle(locals)); with uma do begin iarg := arg[1].ival; case UserMacroCommand of Dilate8CircularUC: doDilate8Circular(uma); Sum16uMarkUC: doSum16(uma, false); Sum16sMarkUC: doSum16(uma, true); MarkupPicNumberUC: doMarkupPicNumber(uma); MarkupData16UC: begin SetMarkupData16Pic(iarg, str); if str <> '' then ErrorOccurred := true; end; MarkupData8UC: begin SetMarkupDataPic(iarg, str); if str <> '' then ErrorOccurred := true; end; MarkupMarksUC: begin SetMarkupMarkPic(iarg, str); if str <> '' then ErrorOccurred := true; end; MarkupBkgUC: begin SetMarkupBkgPic(iarg, str); if str <> '' then ErrorOccurred := true; end; MarkupShowUC: begin CreateMarkupWindow; if (MarkupWindow = nil) or not MarkupReady then begin str := 'MarkupShow failed'; ErrorOccurred := true; end else begin RefreshMarkupOffscreen; ShowMarkupResults; end; end; MarkupHideUC: begin CloseMarkupWindow; end; MarkupPasteKernelUC: begin pasteKernel(arg[1].aval); end; MarkupValleysUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin gRidge := false; mySetCtlValue(MarkupWindow, RidgeCtrlid, 0); mySetCtlValue(MarkupWindow, ValleyCtrlid, 1); end; MarkupRidgesUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin gRidge := true; mySetCtlValue(MarkupWindow, RidgeCtrlid, 1); mySetCtlValue(MarkupWindow, ValleyCtrlid, 0); end; MarkupBkgCoefUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin BkgCoefficient := round(arg[1].aval * 10000.0); end; MarkupBkgMinUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin if iarg < 1 then iarg := 1; if iarg > BkgKernelMaxRadius then iarg := BkgKernelMaxRadius; BkgKernelMinRadius := iarg; MakeKernel; end; MarkupBkgDeltaUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin if iarg < 1 then iarg := 1; if iarg > BkgKernelMaxRadius then iarg := BkgKernelMaxRadius; BkgKernelDeltaRadius := iarg; MakeKernel; end; MarkupBkgConeUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin BkgKernelSlope := arg[1].aval; SetKernelKind(ConeKernel); end; MarkupBkgExponentialUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin BkgKernelBase := arg[1].aval; SetKernelKind(ExponentialKernel); end; MarkupDilateUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin saveBkgCoef := BkgCoefficient; if arg[1].aval <> 0.0 then BkgCoefficient := round(arg[1].aval * 10000.0); Dilate; BkgCoefficient := saveBkgCoef; end; MarkupErodeUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin saveBkgCoef := BkgCoefficient; if arg[1].aval <> 0.0 then BkgCoefficient := round(arg[1].aval * 10000.0); Erode; BkgCoefficient := saveBkgCoef; end; MarkupCalcBkgUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin CalculateBkg; end; MarkupCalcHistUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin CalculateHistograms; end; MarkupScale16bUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin if MarkupData16Info <> nil then scale16b else begin str := 'No 16 bit data window'; ErrorOccurred := true; end; end; MarkupScaleMinUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin gScaleMin := iarg; MakeScale; end; MarkupScaleMaxUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin gScaleMax := iarg; MakeScale; end; MarkupMake16bUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin if MarkupData16Info <> nil then make16b else begin str := 'No 16 bit data window'; ErrorOccurred := true; end; end; MarkupavgToBkgUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin if MarkupData16Info <> nil then Avg16toBkg else begin str := 'No 16 bit data window'; ErrorOccurred := true; end; end; MarkupBkgSubUC: if not MarkupReady then begin str := 'Markup window is not open'; ErrorOccurred := true; end else begin if MarkupData16Info <> nil then BkgSub16(arg[1].aval) else begin str := 'No 16 bit data window'; ErrorOccurred := true; end; end; MarkedSumUC: doMarkedSum(uma); MarkedBkgUC: doMarkedBkg(uma); otherwise begin ErrorOccurred := true; str := 'UMMarkup.p DoUserMacro'; end; end; end; HUnLock(Handle(locals)); end; end.