home *** CD-ROM | disk | FTP | other *** search
Text File | 1994-04-26 | 71.1 KB | 1,318 lines | [ TEXT/PJMM]
unit Utilities; {Miscellaneous utility routines used by NIH Image} interface uses QuickDraw, Palettes, Picker, PrintTraps, globals, SANE; procedure SetDialogItem (TheDialog: DialogPtr; item, value: integer); procedure OutlineButton (theDialog: DialogPtr; itemNo, CornerRad: integer); function GetDNum (TheDialog: DialogPtr; item: integer): LongInt; function GetDString (TheDialog: DialogPtr; item: integer): str255; procedure SetDNum (TheDialog: DialogPtr; item: integer; n: LongInt); procedure Ge String('Back.', fwidth); PutTabDelimeter; end; if MinMaxM in measurements then begin PutFString('Min', fwidth); PutTabDelimeter; PutFString('Max', fwidth); PutTabDelimeter; end; if User1M in measurements then begin PutFString(User1Label, fwidth); PutTabDelimeter; end; if User2M in measurements then begin PutFString(User2Label, fwidth); PutTabDelimeter; end; PutChar(cr); PutChar(cr); end; for i := FirstCount to LastCount do begin column := 0; if Headings then PutSequenceNumber; if AreaM in measurements then begin PutReal(mArea^[i], fwidth, precision); PutTabDelimeter; end; if MeanM in measurements then begin PutReal(mean^[i], fwidth, precision); PutTabDelimeter; end; if StdDevM in measurements then begin PutReal(sd^[i], fwidth, precision); PutTabDelimeter; end; if (xyLocM in measurements) or (nPoints > 0) then begin PutReal(xcenter^[i], fwidth, precision); PutTab; PutReal(ycenter^[i], fwidth, precision); PutTabDelimeter; end; if ModeM in measurements then begin PutReal(mode^[i], fwidth, precision); PutTabDelimeter; end; if (LengthM in measurements) or (nLengths > 0) then begin PutReal(plength^[i], fwidth, precision); PutTabDelimeter; end; if MajorAxisM in measurements then begin PutReal(MajorAxis^[i], fwidth, precision); PutTabDelimeter; end; if MinorAxisM in measurements then begin PutReal(MinorAxis^[i], fwidth, precision); PutTabDelimeter; end; if (AngleM in measurements) or (nAngles > 0) then begin PutReal(orientation^[i], fwidth, precision); PutTabDelimeter; end; if IntDenM in measurements then begin PutReal(IntegratedDensity^[i], fwidth + 2, precision); PutTabDelimeter; PutReal(idBackground^[i], fwidth, precision); PutTabDelimeter; end; if MinMaxM in measurements then begin PutReal(mMin^[i], fwidth, precision); PutTabDelimeter; PutReal(mMax^[i], fwidth, precision); PutTabDelimeter; end; if User1M in measurements then begin PutReal(User1^[i], fwidth, precision); PutTabDelimeter; end; if User2M in measurements then begin PutReal(User2^[i], fwidth, precision); PutTabDelimeter; end; PutChar(cr); end; {for} end; {with} end; procedure ShowWatch; begin SetCursor(watch); end; procedure ShowAnimatedWatch; begin SetCursor(AnimatedWatch[WatchIndex]); WatchIndex := WatchIndex + 1; if WatchIndex > 8 then WatchIndex := 1; end; procedure DoOperation;{(Operation:OpType)} var tPort: GrafPtr; loc: point; width, height, SaveWidth: integer; tRect: rect; SaveGDevice: GDHandle; begin SaveGDevice := GetGDevice; GetPort(tPort); with Info^ do begin changes := true; SetGDevice(osGDevice); SetPort(GrafPtr(osPort)); pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); PenNormal; case Operation of InvertOp: InvertRgn(roiRgn); PaintOp: PaintRgn(roiRgn); FrameOp: begin if (RoiType = LineRoi) or (RoiType = FreeLineRoi) or (RoiTYpe = SegLineRoi) then PenSize(1, 1) else PenSize(LineWidth, LineWidth); FrameRgn(roiRgn); end; EraseOp: EraseRgn(roiRgn); PasteOp: Paste; otherwise end; if not RoiShowing then UpdateScreen(RoiRect); if PixMapSize > UndoBufSize then OpPending := false; end; SetPort(tPort); SetGDevice(SaveGDevice); end; procedure SaveRoi; begin with info^ do if RoiType <> noRoi then begin NoInfo^.roiType := roiType; NoInfo^.RoiRect := RoiRect; CopyRgn(roiRgn, NoInfo^.roiRgn); NoInfo^.LX1 := LX1; NoInfo^.LY1 := LY1; NoInfo^.LX2 := LX2; NoInfo^.LY2 := LY2; NoInfo^.LAngle := LAngle; end; end; procedure KillRoi; var trect: rect; begin with info^ do begin if RoiShowing then begin if OpPending then begin OpPending := false; DoOperation(CurrentOp); end; SaveRoi; RoiShowing := false; trect := RoiRect; if RoiType = LineRoi then InsetRect(trect, -RoiHandleSize, -RoiHandleSize); UpdateScreen(trect); end; RoiType := NoRoi; RoiUpdateTime := 0; end; end; procedure CaptureImage; var Timeout: LongInt; begin case FrameGrabber of QuickCapture: begin ControlReg^ := BitAnd($80, 255); {Start frame capture} while ControlReg^ < 0 do ; {Wait for it to complete} end; ScionLG3: begin TimeOut := TickCount + 30; {1/2sec. timeout} ControlReg^ := $80; {Start frame capture} while BitAnd(ControlReg^, $80) = $00 do begin {Wait for it to complete} if TickCount > TimeOut then begin ControlReg^ := $00; leave end; end; ControlReg^ := $00; end; end; {case} end; procedure Paste; var srcPort: cGrafPtr; begin if info = NoInfo then begin beep; exit(Paste) end; with Info^ do begin if not RoiShowing then exit(Paste); if PasteTransferMode = SrcCopy then begin pmForeColor(BlackIndex); pmBackColor(WhiteIndex); end; srcPort := ClipBufInfo^.osPort; if LivePasteMode then if ((WhatsOnClip = CameraPic) or (WhatsOnClip = LivePic)) and (PictureType <> FrameGrabberType) then begin CaptureImage; srcPort := fgPort; end; hlock(handle(srcPort^.portPixMap)); hlock(handle(osPort^.portPixMap)); CopyBits(BitMapHandle(srcPort^.portPixMap)^^, BitMapHandle(osPort^.PortPixMap)^^, ClipBufInfo^.RoiRect, RoiRect, PasteTransferMode, roiRgn); hunlock(handle(srcPort^.portPixMap)); hunlock(handle(osPort^.PortPixMap)); if PasteTransferMode = SrcCopy then begin pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); end; end; end; procedure ShowRoi; begin with info^ do if RoiType <> NoRoi then begin SetupUndo; RoiShowing := true; end; end; procedure SetupUndo; var line: integer; begin WhatToUndo := NothingToUndo; if info = NoInfo then begin CurrentUndoSize := 0; exit(SetupUndo) end; with info^ do begin if PixMapSize > UndoBufSize then begin CurrentUndoSize := 0; exit(SetupUndo) end; if OpPending then begin DoOperation(CurrentOp); OpPending := false; end; CurrentUndoSize := PixMapSize; BlockMove(PicBaseAddr, UndoBuf, PixMapSize); UndoFromClip := false; RedoSelection := false; end; end; procedure SetupUndoFromClip; var line: integer; begin WhatToUndo := NothingToUndo; if info = NoInfo then begin CurrentUndoSize := 0; exit(SetupUndoFromClip) end; with info^ do begin if PixMapSize > ClipBufSize then begin CurrentUndoSize := 0; exit(SetupUndoFromClip) end; if OpPending then begin DoOperation(CurrentOp); OpPending := false; end; CurrentUndoSize := PixMapSize; BlockMove(PicBaseAddr, ClipBuf, PixMapSize); end; WhatsOnClip := NothingOnClip; UndofromClip := true; RedoSelection := false; end; function NoSelection;{:boolean} begin if Info = NoInfo then begin beep; NoSelection := true; exit(NoSelection); end; if not Info^.RoiShowing then begin PutMessage('Please use a selection tool to make a selection or use the Select All command.'); macro := false; end; NoSelection := not Info^.RoiShowing; end; function NotRectangular;{:boolean} begin with info^ do if RoiShowing and (RoiType <> RectRoi) then begin PutMessage('This operation requires a rectangular selection.'); NotRectangular := true; macro := false; end else NotRectangular := false; end; procedure GetLoi (var x1, y1, x2, y2: real); begin with info^, info^.RoiRect do begin x1 := left + LX1; y1 := top + LY1; x2 := left + LX2; y2 := top + LY2; end; end; function NotInBounds;{:boolean} var x1, y1, x2, y2: real; begin NotInBounds := false; with info^, info^.RoiRect do if RoiShowing then begin if RoiType = LineRoi then begin GetLoi(x1, y1, x2, y2); if (x1 >= 0.0) and (y1 >= 0.0) and (x2 <= right) and (y2 <= bottom) then exit(NotInBounds); end; if (left < 0) or (top < 0) or (right > PicRect.right) or (bottom > PicRect.bottom) then begin PutMessage('This operation requires the selection to be entirely within the image.'); NotInBounds := true; macro := false; end; end; end; function NoUndo: boolean; var ImageTooLarge: boolean; begin with info^ do ImageTooLarge := (PixMapSize > ClipBufSize) or (PixMapSize > UndoBufSize); if ImageTooLarge then PutMessage('This operation requires that the Undo and Clipboard buffers be at least as large as the image.'); NoUndo := ImageTooLarge; end; {$POP} procedure PutMemoryAlert; begin PutMessage('There is not enough free memory to open this image. Try closing some windows or allocating more memory to NIH Image.'); macro := false; end; procedure CompactMemory; var size: LongInt; TempInfo: InfoPtr; i: integer; begin for i := 1 to nPics do begin TempInfo := pointer(WindowPeek(PicWindow[i])^.RefCon); hunlock(TempInfo^.PicBaseHandle) end; size := MaxSize; size := MaxMem(size); for i := 1 to nPics do begin TempInfo := pointer(WindowPeek(PicWindow[i])^.RefCon); with TempInfo^ do begin hlock(PicBaseHandle); PicBaseAddr := StripAddress(PicBaseHandle^); osPort^.PortPixMap^^.BaseAddr := PicBaseAddr; end; end; end; function GetBigHandle (NeededSize: LongInt): handle; {Allocates a handle and guarantees MinFree contiguous free bytes after allocation . } {Does NOT arrange for the new handle to be unlocked during CompactMemory. } {GetBigHandle returns nil if CompactMemory fails to obtain enough contiguous free space . } var h: handle; FreeMem: LongInt; begin h := NewHandle(NeededSize); FreeMem := MaxBlock; if (h = nil) or (FreeMem < MinFree) then begin if h <> nil then DisposHandle(h); if FreeMem > 0 then {Why does FreeMem get set to 0 sometimes and MaxMem} CompactMemory {crash, but only when using the Modern Memory Manager?} else beep; h := NewHandle(NeededSize); FreeMem := MaxBlock; end; if (h = nil) or (FreeMem < MinFree) then begin if h <> nil then DisposHandle(h); h := nil; end; GetBigHandle := h; end; function GetImageMemory (SaveInfo: infoPtr): ptr; {Allocates memory for the PixMap of new image windows. SaveInfo points to the InfoRec of the previous window.} {A handle is used, rather than a pointer, since NewPtr(particularly on the ci and fx) is rediculously slow.} var h: handle; NeededSize: LongInt; begin with info^ do begin if odd(PixelsPerLine) then BytesPerRow := PixelsPerLine + 1 else BytesPerRow := PixelsPerLine; PixMapSize := LongInt(nlines) * BytesPerRow; ImageSize := LongInt(nlines) * PixelsPerLine; NeededSize := PixMapSize; end; h := GetBigHandle(NeededSize); if h = nil then begin DisposPtr(pointer(Info)); PutMemoryAlert; Info := SaveInfo; GetImageMemory := nil; exit(GetImageMemory); end; with info^ do begin PicBaseHandle := h; hlock(PicBaseHandle); GetImageMemory := StripAddress(PicBaseHandle^); end; end; {$PUSH} {$D-} procedure UpdateAnalysisMenu; var ShowItems: boolean; i: integer; begin ShowItems := Info <> NoInfo; SetMenuItem(AnalyzemenuH, MeasureItem, ShowItems); SetMenuItem(AnalyzemenuH, AnalyzeItem, ShowItems); SetMenuItem(AnalyzemenuH, HistogramItem, ShowItems); SetMenuItem(AnalyzemenuH, PlotItem, ShowItems); SetMenuItem(AnalyzemenuH, PlotSurfaceItem, ShowItems); SetMenuItem(AnalyzemenuH, SetScaleItem, ShowItems); SetMenuItem(AnalyzemenuH, CalibrateItem, ShowItems); SetMenuItem(AnalyzemenuH, RedoItem, mCount > 0); SetMenuItem(AnalyzemenuH, DeleteItem, mCount > 0); SetMenuItem(AnalyzemenuH, RestoreItem, ShowItems and (NoInfo^.RoiType <> NoRoi)); SetMenuItem(AnalyzemenuH, MarkItem, info^.RoiShowing); end; procedure ExtendWindowsMenu;{(fname:str255; size:LongInt; wptr:WindowPtr)} var str, SizeStr: str255; begin if nPics < MaxPics then begin nPics := nPics + 1; PicWindow[nPics] := wptr; NumToString((size + 511) div 1024, SizeStr); str := concat(fname, ' ', SizeStr, 'K'); AppendMenu(WindowsMenuH, ' '); SetItem(WindowsMenuH, nPics + WindowsMenuItems + nTextWindows, str); InsertMenu(WindowsMenuH, 0); end; end; procedure InvertGrayLevels; begin with info^ do begin DensityCalibrated := true; nCoefficients := 2; fit := StraightLine; Coefficient[1] := 255.0; Coefficient[2] := -1.0; ZeroClip := false; UpdateTitleBar; GenerateValues; end; end; procedure GetAngle (dx, dy: real; var angle: real); var quadrant: (q1, q2orq3, q4); begin if dx <> 0.0 then angle := arctan(dy / dx) else begin if dy >= 0.0 then angle := pi / 2.0 else angle := -pi / 2.0 end; angle := (180.0 / pi) * angle; if (dx >= 0.0) and (dy >= 0.0) then quadrant := q1 else if dx < 0.0 then quadrant := q2orq3 else quadrant := q4; case quadrant of q1: ; q2orq3: angle := angle + 180.0; q4: angle := angle + 360.0; end; end; procedure MakeRegion; var deltax, deltay, x1, y1, x2, y2, xt, yt: integer; dx, dy, pAngle: real; add: boolean; tPort: GrafPtr; begin with info^ do begin GetPort(tPort); SetPort(wptr); OpenRgn; case RoiType of LineRoi: begin GetAngle(LX2 - LX1, LY1 - LY2, LAngle); x1 := round(LX1); y1 := round(LY1); x2 := round(LX2); y2 := round(LY2); if (x1 = x2) and (y1 = y2) then begin MoveTo(x1, y1); LineTo(x1 + 1, y1); LineTo(x1 + 1, y1 + 1); LineTo(x1, y1 + 1); LineTo(x1, y1); end else begin add := (LAngle > 90.0) and (LAngle <= 270.0); pAngle := (LAngle / 180.0) * pi; if add then pAngle := pAngle + pi / 2.0 else pAngle := pAngle - pi / 2.0; dx := cos(pAngle) * LineWidth; dy := -sin(pAngle) * LineWidth; MoveTo(x1, y1); LineTo(round(x1 + dx), round(y1 + dy)); LineTo(round(x2 + dx), round(y2 + dy)); LineTo(x2, y2); LineTo(x1, y1); end; end; OvalRoi: FrameOval(RoiRect); RectRoi: FrameRect(RoiRect); otherwise end; CloseRgn(roiRgn); if RoiType = LineRoi then begin RoiRect := roiRgn^^.rgnBBox; with RoiRect do begin LX1 := LX1 - left; LY1 := LY1 - top; LX2 := LX2 - left; LY2 := LY2 - top; end; end; end; SetPort(tPort); end; procedure SelectAll;{(visible:boolean)} var loc: point; tPort: GrafPtr; begin if info <> NoInfo then with Info^ do begin KillRoi; RoiType := RectRoi; RoiRect := PicRect; MakeRegion; if visible then begin SetupUndo; RoiShowing := true; if (magnification > 1.0) and not ScaleToFitWindow then Unzoom; if not macro then begin PreviousTool := CurrentTool; CurrentTool := SelectionTool; isSelectionTool := true; GetPort(tPort); SetPort(ToolWindow); EraseRect(ToolRect[PreviousTool]); EraseRect(ToolRect[CurrentTool]); InvalRect(ToolRect[PreviousTool]); InvalRect(ToolRect[CurrentTool]); SetPort(tPort); end; end; IsInsertionPoint := false; measuring := false; end; {with} end; procedure KillOperation; begin if OpPending then with info^ do if info <> NoInfo then begin DoOperation(CurrentOp); RoiShowing := false; UpdateScreen(RoiRect); OpPending := false; end; end; procedure CloneInfo (var OldInfo, NewInfo: PicInfo); begin NewInfo := OldInfo; with NewInfo do begin PicBaseAddr := nil; PicBaseHandle := nil; osPort := nil; roiRgn := nil; RoiType := NoRoi; RoiShowing := false; Magnification := 1.0; vref := 0; wPtr := nil; ScaleToFitWindow := false; WindowState := NormalWindow; StackInfo := nil; iversion := 0; PictureType := NewPicture; DataType := EightBits; changes := false; DataH := nil; LittleEndian := false; end; end; function NewPicWindow (name: str255; width, height: integer): boolean; var iptr, p: ptr; lptr: ^LongInt; SaveInfo: InfoPtr; NeededSize: LongInt; trect: rect; begin NewPicWindow := false; PicLeft := PicLeftBase; PicTop := PicTopBase; if (info <> noInfo) then begin with info^ do begin GetWindowRect(wptr, trect); if trect.left = PicLeftBase then if pos('Camera', name) = 0 then begin PicLeft := trect.left + hPicOffset; PicTop := trect.top + vPicOffset; end; end; end; if nPics = MaxPics then exit(NewPicWindow); KillOperation; DisableDensitySlice; SaveInfo := Info; iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; macro := false; exit(NewPicWindow); end; Info := pointer(iptr); CloneInfo(SaveInfo^, Info^); with Info^ do begin nlines := height; PixelsPerLine := width; p := GetImageMemory(SaveInfo); if p = nil then exit(NewPicWindow); PicBaseAddr := p; MakeNewWindow(name); SelectAll(false); DoOperation(EraseOp); KillRoi; Changes := false; BinaryPic := false; end; NewPicWindow := true; end; procedure EraseScreen; begin SetPort(GrafPtr(CScreenPort)); with CScreenPort^ do begin HideCursor; pmBackColor(BackgroundIndex); EraseRect(portPixMap^^.Bounds); pmBackColor(WhiteIndex); end; end; procedure RestoreScreen; var GrayRgn: RgnHandle; rptr: rhptr; wp: ^WindowPtr; begin rptr := rhptr(GrayRgnGlobal); GrayRgn := rptr^; wp := pointer(GhostWindow); wp^ := WindowPtr(nil); PaintBehind(WindowPeek(FrontWindow), GrayRgn); wp^ := PasteControl; DrawMenuBar; end; procedure UpdateTitleBar; {Updates the window title bar to show the current magnification or the current frame within a stack.} var str, str2, str3: str255; begin with info^ do begin str := title; if SpatiallyCalibrated then str := concat(str, chr($13)); {Black Diamond} if DensityCalibrated then str := concat(str, 'â—Š'); if StackInfo <> nil then with StackInfo^ do begin NumToString(CurrentSlice, str2); NumToString(nSlices, str3); str := concat(str, '(', str2, '/', str3, ')'); end else if (magnification <> 1.0) or ScaleToFitWindow then begin if ScaleToFitWindow then begin RealToString(magnification, 1, 2, str2); str := concat(str, '(', str2, ')'); end else begin RealToString(magnification, 1, 0, str2); str := concat(str, '(', str2, ':1)'); end; end; if Digitizing then begin if ExternalTrigger then str := concat(str, '(Waiting for Trigger)') else str := concat(str, '(Live)'); end; if wptr <> nil then SetWTitle(wptr, str); end; {with} end; procedure ScaleToFit; var trect: rect; begin if digitizing then exit(ScaleToFit); if info <> NoInfo then with info^ do begin ScaleToFitWindow := not ScaleToFitWindow; KillRoi; if ScaleToFitWindow then begin savewrect := wrect; SaveSrcRect := SrcRect; SaveMagnification := magnification; GetWindowRect(wptr, trect); savehloc := trect.left; savevloc := trect.top; wrect := wptr^.PortRect; SrcRect := PicRect; ScaleImageWindow(wrect); SizeWindow(wptr, wrect.right, wrect.bottom, true); end else begin if WindowState = TiledBigScaled then begin wrect := initwrect; SrcRect := wrect; magnification := 1.0; WindowState := NormalWindow; end else begin wrect := savewrect; SrcRect := SaveSrcRect; magnification := SaveMagnification; end; HideWindow(wptr); SizeWindow(wptr, wrect.right, wrect.bottom, true); MoveWindow(wptr, savehloc, savevloc, true); ShowWindow(wptr); UpdateTitleBar; end; SetPort(wptr); InvalRect(wrect); WindowState := NormalWindow; end; end; procedure DrawMyGrowIcon;{(w:WindowPtr)} var tPort: GrafPtr; tRect: rect; begin GetPort(tPort); SetPort(w); PenNormal; with w^.PortRect do begin SetRect(tRect, right - 12, bottom - 12, right - 5, bottom - 5); FrameRect(tRect); MoveTo(right - 6, bottom - 10); LineTo(right - 2, bottom - 10); LineTo(right - 2, bottom - 2); LineTo(right - 10, bottom - 2); LineTo(right - 10, bottom - 6); end; SetPort(tPort); end; procedure Unzoom; begin if Info <> NoInfo then with Info^ do begin if ScaleToFitWindow then ScaleToFit else begin wrect := initwrect; SrcRect := wrect; end; SizeWindow(wptr, wrect.right, wrect.bottom, true); LoadLUT(info^.cTable); UpdatePicWindow; magnification := 1.0; DrawMyGrowIcon(wptr); UpdateTitleBar; if WhatToUndo = UndoZoom then WhatToUndo := NothingToUndo; ShowRoi; end; end; procedure DrawBString;{(str:string)} begin TextFace([bold]); DrawString(str); TextFace([]); end; function long2str (num: LongInt): str255; var str: str255; begin NumToString(num, str); long2str := str; end; procedure PutWarning; begin PutMessage(concat('This ', long2str((info^.PixmapSize + 511) div 1024), 'K image is larger than the ', long2str(UndoBufSize div 1024), 'K Undo buffer. Many operations may fail or be Undoable.')); end; procedure SetupRoiRect; {Copies the current image to Undo buffer so it can be used for drawing} {the "marching ants". The copy of the previous image in the Clipboard buffer} { buffer will be used for Undo.} var SaveWhatToUndo: WhatToUndoType; begin SaveWhatToUndo := WhatToUndo; SetupUndo; UndoFromClip := true; info^.RoiShowing := true; WhatToUndo := SaveWhatToUndo; end; procedure SetForegroundColor (color: integer); var tPort: GrafPtr; SaveGDevice: GDHandle; begin if (color >= 0) and (color <= 255) then with info^ do begin ForegroundIndex := color; GetPort(tPort); SetPort(ToolWindow); InvalRect(ToolRect[brush]); SaveGDevice := GetGDevice; SetGDevice(osGDevice); if osPort <> nil then begin SetPort(GrafPtr(osPort)); pmForeColor(ForegroundIndex); end; SetPort(tPort); SetGDevice(SaveGDevice); if isInsertionPoint then DisplayText(true); end; end; procedure SetBackgroundColor (color: integer); var tPort: GrafPtr; SaveGDevice: GDHandle; begin if (color >= 0) and (color <= 255) then with info^ do begin BackgroundIndex := color; GetPort(tPort); SetPort(ToolWindow); InvalRect(ToolRect[eraser]); SaveGDevice := GetGDevice; SetGDevice(osGDevice); if osPort <> nil then begin SetPort(GrafPtr(osPort)); pmBackColor(BackgroundIndex); end; SetPort(tPort); SetGDevice(SaveGDevice); if isInsertionPoint then DisplayText(true); end; end; procedure GetForegroundColor;{(event: EventRecord)} var loc: point; color: integer; begin loc := event.where; ScreenToOffScreen(loc); Color := MyGetPixel(loc.h, loc.v); SetForegroundColor(color); end; procedure GetBackgroundColor; {(event: EventRecord)} var loc: point; color: integer; begin loc := event.where; ScreenToOffScreen(loc); Color := MyGetPixel(loc.h, loc.v); SetBackgroundColor(color); end; procedure GenerateValues; var a, b, c, d, e, f, x, y: extended; i: integer; begin with info^ do begin if not DensityCalibrated then begin for i := 0 to 255 do cvalue[i] := i; MinValue := 0.0; MaxValue := 255.0; exit(GenerateValues); end; a := Coefficient[1]; b := Coefficient[2]; c := Coefficient[3]; d := Coefficient[4]; e := Coefficient[5]; f := Coefficient[6]; MinValue := 10e+12; MaxValue := -MinValue; for i := 0 to 255 do begin x := i; case fit of StraightLine: y := a + b * x; Poly2: y := a + b * x + c * x * x; Poly3: y := a + b * x + c * x * x + d * x * x * x; Poly4: y := a + b * x + c * x * x + d * x * x * x + e * x * x * x * x; Poly5: y := a + b * x + c * x * x + d * x * x * x + e * x * x * x * x + f * x * x * x * x * x; ExpoFit: y := a * exp(b * x); PowerFit: if x = 0.0 then y := 0.0 else y := a * exp(b * ln(x)); {y=ax^b} LogFit: begin if x = 0.0 then x := 0.5; y := a * ln(b * x) end; RodbardFit: begin if x <= a then y := 0 else begin y := (a - x) / (x - d); y := exp(ln(y) * (1 / b)); {y:=y**(1/b)} y := y * c; end; end; UncalibratedOD: begin if x = 255.0 then x := 254.5; y := 0.434294481 * ln(255 / (255 - x)) {log10} end; otherwise y := x; end; {case} cvalue[i] := y; if y > MaxValue then MaxValue := y; if y < MinValue then MinValue := y; end; {for} if MinValue >= 0.0 then ZeroClip := false; if ZeroClip then begin for i := 0 to 255 do if cvalue[i] < 0.0 then cvalue[i] := 0.0; MinValue := 0.0; end; end; end; procedure ScaleImageWindow (var trect: rect); var WindowLeft, WindowTop: integer; PicAspectRatio, TempMagnification: extended; begin with info^ do begin SrcRect := PicRect; with CGrafPort(wptr^).PortPixMap^^.bounds do begin WindowLeft := -left; WindowTop := -top; end; with PicRect do PicAspectRatio := right / bottom; with trect do begin if (WindowLeft + right) > (ScreenWidth - 5) then right := ScreenWidth - 5 - WindowLeft; bottom := round(right / PicAspectRatio); if (WindowTop + bottom) > (ScreenHeight - 5) then bottom := ScreenHeight - 5 - WindowTop; right := round(bottom * PicAspectRatio); magnification := right / PicRect.right; end; UpdateTitleBar; end; {with} end; function TooWide: boolean; var SelectionTooWide: boolean; MaxWidth: str255; begin with info^.RoiRect do SelectionTooWide := (right - left) > MaxLine; if SelectionTooWide then begin NumToString(MaxLine, MaxWidth); PutMessage(concat('This operation does not support selections wider than ', MaxWidth, ' pixels.')); macro := false; end; TooWide := SelectionTooWide; end; procedure DrawTextString (str: str255; loc: point; just: integer); var SaveJust: integer; begin TextStr := str; IsInsertionPoint := true; TextStart := loc; SaveJust := TextJust; TextJust := just; DisplayText(false); TextJust := SaveJust; IsInsertionPoint := false; end; procedure IncrementCounter; begin if mCount < MaxMeasurements then begin mCount := mCount + 1; UnsavedResults := true; end else beep; end; procedure ClearResults (i: integer); begin mean^[i] := 0.0; sd^[i] := 0.0; PixelCount^[i] := 0; mArea^[i] := 0.0; mode^[i] := 0.0; IntegratedDensity^[i] := 0.0; idBackground^[i] := 0.0; xcenter^[i] := 0.0; ycenter^[i] := 0.0; MajorAxis^[i] := 0.0; MinorAxis^[i] := 0.0; orientation^[i] := 0.0; mMin^[i] := 0.0; mMax^[i] := 0.0; plength^[i] := 0.0; end; procedure UpdateFitEllipse; begin FitEllipse := (xyLocM in measurements) or (MajorAxisM in measurements) or (MinorAxisM in measurements) or (AngleM in measurements); end; ; savewrect := wrect; SaveSrcRect := SrcRect; SaveMagnification := magnification; savehloc := wleft; savevloc := wtop; roiRgn := NewRgn; NewPic := true; ScaleToFitWindow := false; OpPending := false; Changes := false; WindowState := NormalWindow; if not DensityCalibrated and InvertPixelValues then InvertGrayLevels; Revertable := false; end; WhatToUndo := NothingToUndo; end; procedure MakeLowerCase (var str: str255); var i: integer; c: char; begin for i := 1 to length(str) do begin c := str[i]; if (c >= 'A') and (c <= 'Z') then str[i] := chr(ord(c) + 32); end; end; function PutMessageWithCancel (str: str255): integer; begin InitCursor; ParamText(str, '', '', ''); PutMessageWithCancel := Alert(800, nil); end; function CurrentWindow: integer; begin CurrentWPtr := FrontWindow; if CurrentWPtr <> nil then begin CurrentKind := WindowPeek(CurrentWPtr)^.WindowKind; if CurrentKind = TextKind then TextInfo := TextInfoPtr(WindowPeek(CurrentWPtr)^.RefCon); CurrentWindow := CurrentKind; end else begin CurrentWindow := 0; CurrentKind := 0; end; end; procedure FindMonitors (NewScreenDepth: integer); {Generate a list of 8-bit monitors so we can update their LUTs.} {This wouldn't be necessary if we were using the Palette Manager.} var nextDevice: GDHandle; begin nMonitors := 0; nextDevice := GetDeviceList; while nextDevice <> nil do begin if TestDeviceAttribute(nextDevice, screenDevice) and TestDeviceAttribute(nextDevice, screenActive) then if nextDevice^^.gdPmap^^.PixelSize = 8 then begin nMonitors := nMonitors + 1; Monitors[nMonitors] := nextDevice; end; nextDevice := GetNextDevice(nextDevice); end; {while} if NewScreenDepth < 4 then gCopyMode := DitherCopy else gCopyMode := SrcCopy; SaveScreenDepth := NewScreenDepth; end; function ScreenDepth: integer; var depth: integer; begin depth := ScreenPixMap^^.PixelSize; if depth <> SaveScreenDepth then FindMonitors(depth); ScreenDepth := depth; end; procedure SetFColor (index: integer); {Sets the screen foreground color. Use pmForeColor to set the offscreen color.} begin if ScreenDepth = 8 then pmForeColor(index) else RGBForeColor(osGDevice^^.gdPMap^^.pmTable^^.ctTable[index].rgb); end; procedure SetBColor (index: integer); {Sets the screen background color.} begin if ScreenDepth = 8 then pmBackColor(index) else RGBBackColor(osGDevice^^.gdPMap^^.pmTable^^.ctTable[index].rgb); end; end. 
