unit Utilities; {Miscellaneous utility routines used by NIH Image} interface uses Types, Memory, QuickDraw, Packages, Devices, Menus, Events, Fonts, Scrap, TextEdit, ToolUtils, Dialogs, Controls, Palettes, ColorPicker, Printing, SegLoad, Processes, QuickDrawText, TextUtils, Windows, OSUtils, QDOffscreen, Components, QuickTimeComponents, DriverServices, globals; procedure SetDlogItem (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 GetWindowRect (w: WindowPtr; var wrect: rect); procedure SetDReal (TheDialog: DialogPtr; item: integer; n: extended; fwidth: integer); procedure SetDString (TheDialog: DialogPtr; item: integer; str: str255); procedure DrawSItem (itemnum, fontrqst, sizerqst: integer; d: dialogptr; s: str255); function StringToReal (str: str255): extended; function GetDReal (TheDialog: DialogPtr; item: integer): extended; procedure RealToString (Val: extended; width, fwidth: integer; var Str: Str255); procedure DrawReal (Val: extended; width, fwidth: integer); procedure DrawJReal (hloc, vloc: integer; Val: extended; fwidth: integer); procedure DrawLong (i: LongInt); function GetInt (message: str255; default: integer; var Canceled: boolean): integer; function GetReal (message: str255; default: extended; precision: integer; var Canceled: boolean): extended; function OptionKeyDown: boolean; function ShiftKeyDown: boolean; function ControlKeyDown: boolean; function CommandPeriod: boolean; function SpaceBarDown: boolean; procedure SysResume; procedure beep; procedure PutMessage (str: str255); procedure PutError (str: str255); procedure UnprotectLUT; procedure LoadLUT (table: MyCSpecArray); procedure SetupLutUndo; procedure UndoLutChange; procedure DisableDensitySlice; procedure LoadInputLUT (address: ptr); procedure ResetQuickCapture; procedure ResetScionLG3; procedure ResetScionAG5; procedure ResetScionVG5f; procedure ResetFrameGrabber; procedure CopyOffscreen (src, dst: PixMapHandle; sRect, dRect: rect); procedure wait (ticks: LongInt); function GetScrapCount: integer; procedure DisplayText (update: boolean); procedure ScreenToOffscreen (var loc: point); procedure OffscreenToScreen (var loc: point); procedure OffScreenToScreenRect (var r: rect); procedure UpdateScreen (MaskRect: rect); procedure RestoreRoi; procedure Undo; procedure CheckOnOffItem (MenuH: MenuHandle; item, fst, lst: Integer); procedure SetMenuItem (menuh: menuhandle; itemnum: integer; on: boolean); function GetFontSize (item: integer): integer; function MyGetPixel (h, v: LongInt): integer; procedure PutPixel (h, v: LongInt; value: integer); procedure GetLine (h, v, count: LongInt; var line: LineType); procedure GetColumn (h, v, count: LongInt; var data: LineType); procedure PutColumn (hstart, vstart, count: LongInt; var data: LineType); procedure PutLine (h, v, count: LongInt; var line: LineType); procedure Show1Value (rvalue, CalibratedValue: extended); procedure Show2PlotValues (x, y: extended); procedure Show2Values (current, total: LongInt); procedure DrawXDimension (x: extended; digits: integer); procedure DrawYDimension (y: extended; digits: integer); procedure DrawRGB (index: integer); procedure Show3Values (hloc, vloc, ivalue: LongInt); procedure ShowDxDy (X, Y: extended); procedure PutChar (c: char); procedure PutTab; procedure PutString (str: str255); procedure PutReal (n: extended; width, fwidth: integer); procedure PutLong (n: LongInt; FieldWidth: integer); procedure CopyResultsToBuffer (FirstCount, LastCount: integer; Headings: boolean); procedure ShowWatch; procedure ShowAnimatedWatch; procedure UpdatePicWindow; procedure DoOperation (Operation: OpType); procedure SaveRoi; procedure KillRoi; procedure ShowRoi; procedure SetupUndo; procedure SetupUndoFromClip; procedure GetLoi (var x1, y1, x2, y2: extended); function NotRectangular: boolean; function NotInBounds: boolean; function NoSelection: boolean; function NoUndo: boolean; procedure CloneInfo (var OldInfo, NewInfo: PicInfo); function NewPicWindow (name: str255; width, height: integer): boolean; function GetAngle (dx, dy: extended):extended; procedure MakeRegion; procedure SelectAll (visible: boolean); procedure EraseScreen; procedure RestoreScreen; procedure UpdateTitleBar; procedure Unzoom; procedure DrawBString (str: string); procedure DrawMyGrowIcon (w: WindowPtr); procedure PutMemoryAlert; function GetBigHandle (NeededSize: LongInt): handle; function GetImageMemory (SaveInfo: infoPtr): ptr; procedure UpdateAnalysisMenu; procedure ExtendWindowsMenu (fname: str255; size: LongInt; wptr: WindowPtr); procedure MakeNewWindow (name: str255); function long2str (num: LongInt): str255; procedure PutWarning; procedure ScaleToFit; procedure SetupRoiRect; procedure SetForegroundColor (color: integer); procedure SetBackgroundColor (color: integer); procedure GetForegroundColor (event: EventRecord); procedure GetBackgroundColor (event: EventRecord); procedure GenerateValues; procedure KillOperation; procedure ScaleImageWindow (var trect: rect); procedure InvertGrayLevels; function TooWide: boolean; procedure DrawTextString (str: str255; loc: point; just: integer); procedure IncrementCounter; procedure ClearResults (i: integer); procedure UpdateFitEllipse; procedure UpdateTextItems; procedure MakeLowerCase (var str: str255); function PutMessageWithCancel (str: str255): integer; function CurrentWindow: integer; procedure FindMonitors (NewScreenDepth: integer); function ScreenDepth: integer; procedure SetFColor (index: integer); procedure SetBColor (index: integer); function DoubleToReal(d:FakeDouble):extended; {68k-bug} procedure RealToDouble(rr: extended; var d:FakeDouble); function MakeStackFromWindow: boolean; procedure SelectSlice (i: integer); procedure UpdateWindowsMenuItem; function AddSlice (update: boolean): boolean; procedure AbortMacro; procedure TruncateString(var str: str255; length: integer); procedure RemovePath(var str: str255); procedure CloseVdig; procedure FlushCache; procedure IndexToRgbForeColor(index: integer);{18.11.2002 replaces pmForeColor} procedure IndexToRgbBackColor(index: integer);{18.11.2002 replaces pmBackColor} implementation type KeyPtrType = ^KeyMap; {procedure MacsBug (str: str255); inline $abff;} procedure ShowMessage (str: str255); var vloc, hloc: integer; tPort: GrafPtr; trect: rect; SaveGDevice: GDHandle; font: integer; begin SaveGDevice := GetGDevice; SetGDevice(GetMainDevice); InfoMessage := str; GetPort(tPort); vloc := 35; hloc := 4; SetPort(InfoWindow); {TextFont(Geneva);} GetFNum ('Geneva', font); TextFont(font); TextSize(9); Setrect(trect, hloc, vloc + 15, rwidth - 10, rheight); TETextBox(pointer(ord(@InfoMessage) + 1), length(InfoMessage), trect, teJustLeft); SetPort(tPort); SetGDevice(SaveGDevice); wait(120); end; procedure SetDlogItem (TheDialog: DialogPtr; item, value: integer); var ItemType: integer; ItemBox: rect; ItemHdl: handle; begin GetDialogItem(TheDialog, item, ItemType, ItemHdl, ItemBox); SetControlValue(ControlHandle(ItemHdl),value) end; procedure OutlineButton (theDialog: DialogPtr; itemNo, CornerRad: integer); {Draws a border around a button. 16 is the normal} {corner radius for small buttons } var itemType: Integer; itemBox: Rect; itemHdl: Handle; tempPort: GrafPtr; begin GetPort(tempPort); SetPort(GrafPtr(theDialog)); GetDialogItem(theDialog, itemNo, itemType, itemHdl, itemBox); PenSize(3, 3); InSetRect(itemBox, -4, -4); FrameRoundRect(itemBox, cornerRad, cornerRad); PenSize(1, 1); SetPort(tempPort); end; function GetDNum (TheDialog: DialogPtr; item: integer): LongInt; var ItemType: integer; ItemBox: rect; ItemHdl: handle; str: str255; n: LongInt; begin GetDialogItem(TheDialog, item, ItemType, ItemHdl, ItemBox); GetDialogItemText(ItemHdl, str); StringToNum(str, n); GetDNum := n; end; function GetDString (TheDialog: DialogPtr; item: integer): str255; var ItemType: integer; ItemBox: rect; ItemHdl: handle; str: str255; begin GetDialogItem(TheDialog, item, ItemType, ItemHdl, ItemBox); GetDialogItemText(ItemHdl, str); GetDString := str; end; procedure SetDNum (TheDialog: DialogPtr; item: integer; n: LongInt); var ItemType: integer; ItemBox: rect; ItemHdl: handle; str: str255; begin GetDialogItem(TheDialog, item, ItemType, ItemHdl, ItemBox); NumToString(n, str); SetDialogItemText(ItemHdl, str) end; procedure GetWindowRect (w: WindowPtr; var wrect: rect); {Returns global coordinates of specified window.} begin if w <> nil then wrect := WindowPeek(w)^.contRgn^^.rgnBBox else SetRect(wrect, 0, 0, 0, 0); end; procedure SetDReal (TheDialog: DialogPtr; item: integer; n: extended; fwidth: integer); var ItemType: integer; ItemBox: rect; ItemHdl: handle; str: str255; begin GetDialogItem(TheDialog, item, ItemType, ItemHdl, ItemBox); RealToString(n, 1, fwidth, str); SetDialogItemText(ItemHdl, str) end; procedure SetDString (TheDialog: DialogPtr; item: integer; str: str255); var ItemType: integer; ItemBox: rect; ItemHdl: handle; begin GetDialogItem(TheDialog, item, ItemType, ItemHdl, ItemBox); SetDialogItemText(ItemHdl, str) end; function GetDReal (TheDialog: DialogPtr; item: integer): extended; var str: str255; begin str := GetDString(TheDialog, item); GetDReal := StringToReal(str); end; procedure DrawLong (i: LongInt); var str: str255; begin NumToString(i, str); DrawString(str); end; procedure RealToString (Val: extended; width, fwidth: integer; var Str: Str255); {Does number to string conversion equivalent to write(val:width:fwidth).} var i:integer; begin if width<1 then width:=1; if (fwidth<0) or (fwidth>8) then fwidth:=0; str:=StringOf(val:width:fwidth); end; procedure DrawReal (Val: extended; width, fwidth: integer); {Displays a real(or integer) number at the current location in} {a form equivalent to write(val:width:fwidth) } var str: str255; begin RealToString(val, width, fwidth, str); DrawString(str); end; procedure DrawJReal (hloc, vloc: integer; val: extended; fwidth: integer); {Draws right justified real number.} var str: str255; begin if (val >= 1000.0) or (val <= -1000.0) then fwidth := 0; RealToString(val, 1, fwidth, str); MoveTo(hloc - StringWidth(str) - 2, vloc); DrawString(str); end; function GetInt (message: str255; default: integer; var Canceled: boolean): integer; const NumberID = 3; var mylog: DialogPtr; item: integer; temp: LongInt; begin ParamText(message, '', '', ''); mylog := GetNewDialog(3000, nil, pointer(-1)); SetDNum(MyLog, NumberID, default); SelectdialogItemText(MyLog, NumberID, 0, 32767); OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); until (item = ok) or (item = cancel); if item = ok then begin Canceled := false; temp := GetDNum(MyLog, NumberID); if (temp > -MaxInt) and (temp <= MaxInt) then GetInt := temp else begin beep; GetInt := default end; end {item=ok} else begin Canceled := true; GetInt := default; end; DisposeDialog(mylog); end; function GetReal (message: str255; default: extended; precision: integer; var Canceled: boolean): extended; const NumberID = 3; var mylog: DialogPtr; item: integer; begin InitCursor; ParamText(message, '', '', ''); mylog := GetNewDialog(3000, nil, pointer(-1)); SetDReal(MyLog, NumberID, default, precision); SelectdialogItemText(MyLog, NumberID, 0, 32767); OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); until (item = ok) or (item = cancel); if item = ok then begin GetReal := GetDReal(MyLog, NumberID); Canceled := false; end else begin GetReal := default; Canceled := true; end; DisposeDialog(mylog); end; function OptionKeyDown: boolean; var KeyPtr: KeyPtrType; keys: array[0..3] of LongInt; begin KeyPtr := KeyPtrType(@keys); GetKeys(KeyPtr^); OptionKeyDown := (BAND(keys[1], 4)) <> 0; end; function ShiftKeyDown: boolean; var KeyPtr: KeyPtrType; keys: array[0..3] of LongInt; begin KeyPtr := KeyPtrType(@keys); GetKeys(KeyPtr^); ShiftKeyDown := (BAND(keys[1], 1)) <> 0; end; function ControlKeyDown: boolean; type KeyPtrType = ^KeyMap; var KeyPtr: KeyPtrType; keys: array[0..3] of LongInt; begin KeyPtr := KeyPtrType(@keys); GetKeys(KeyPtr^); ControlKeyDown := (BAND(keys[1], 8)) <> 0; end; function CommandPeriod: boolean; type KeyPtrType = ^KeyMap; var KeyPtr: KeyPtrType; keys: array[0..3] of LongInt; begin KeyPtr := KeyPtrType(@keys); GetKeys(KeyPtr^); CommandPeriod := (BAND(keys[1], $808000)) = $808000; end; function SpaceBarDown: boolean; var KeyPtr: KeyPtrType; keys: array[0..3] of LongInt; begin KeyPtr := KeyPtrType(@keys); GetKeys(KeyPtr^); SpaceBarDown := (BAND(keys[1], 512)) <> 0; end; procedure DrawSItem (itemnum, fontrqst, sizerqst: integer; d: dialogptr; s: str255); {Draw a string item in a dialog box.} var r: rect; iType: integer; ignore: handle; begin GetDialogItem(d, ItemNum, iType, ignore, r); TextFont(fontrqst); TextSize(sizerqst); TETextBox(pointer(ord(@s) + 1), length(s), r, TEJustRight); end; procedure SysResume; begin FlushEvents(EveryEvent, 0); ExitToShell; end; procedure beep; {Sets the current gdevice to the screen because SysBeep flashes the menu bar if the sound level is zero and this is reported to sometimes cause a crash on older Macs when using an offscreen gdevice.} var SaveGDevice: GDHandle; begin SaveGDevice := GetGDevice; SetGDevice(GetMainDevice); SysBeep(1); SetGDevice(SaveGDevice); end; procedure PutMessage (str: str255); var ignore: integer; SaveGDevice: GDHandle; begin SaveGDevice := GetGDevice; SetGDevice(GetMainDevice); InitCursor; ParamText(str, '', '', ''); Ignore := Alert(300, nil); SetGDevice(SaveGDevice); end; procedure PutError (str: str255); var ignore: integer; SaveGDevice: GDHandle; begin SaveGDevice := GetGDevice; SetGDevice(GetMainDevice); InitCursor; ParamText(str, '', '', ''); Ignore := Alert(310, nil); SetGDevice(SaveGDevice); end; function GetFontSize (item: integer): integer; var TempSize: integer; Canceled: boolean; begin case item of 1: GetFontSize := 9; 2: GetFontSize := 10; 3: GetFontSize := 12; 4: GetFontSize := 14; 5: GetFontSize := 18; 6: GetFontSize := 24; 7: GetFontSize := 36; 8: GetFontSize := 48; 9: GetFontSize := 56; 10: GetFontSize := 72; 12: begin TempSize := GetInt('Font Size:', CurrentSize, Canceled); if TempSize < 1 then TempSize := 1; if TempSize > 1000 then TempSize := 1000; if not canceled then GetFontSize := TempSize else GetFontSize := CurrentSize; end; end; end; procedure SetMenuItem (menuh: menuhandle; itemnum: integer; on: boolean); {Enable or disable menuh's itemnum. } begin if on then EnableItem(menuh, itemnum) else DisableItem(menuh, itemnum); if ItemNum = 0 then DrawMenuBar; end; procedure CheckOnOffItem (MenuH: MenuHandle; item, fst, lst: Integer); var i: integer; begin for i := fst to lst do if i = item then CheckItem(MenuH, i, true) else CheckItem(MenuH, i, false); end; procedure UpdateTextItems; var size, i, MenuItem, FontID, item: integer; FontName: str255; FontFound, FoundIt: boolean; str: str255; begin FontFound := false; for item := 1 to NumFontItems do begin GetMenuItemText(FontMenuH, Item, FontName); GetFNum(FontName, FontID); if FontID = CurrentFontID then begin FontFound := true; CheckItem(FontMenuH, Item, True) end else CheckItem(FontMenuH, Item, false); end; if not FontFound then begin FoundIt := False; Item := 1; repeat GetMenuItemText(FontMenuH, Item, FontName); GetFNum(FontName, FontID); if FontID = Geneva then begin CheckItem(FontMenuH, Item, True); CurrentFontID := FontID; FoundIt := true; end; Item := Item + 1; until (Item > NumFontItems) or FoundIt; end; for i := 1 to 10 do begin size := GetFontSize(i); if RealFont(CurrentFontID, size) then SetItemStyle(SizeMenuH, i, [outline]) else SetItemStyle(SizeMenuH, i, []) end; NumToString(CurrentSize, str); str := concat('Other[', str, ']ة'); SetMenuItemText(SizeMenuH, 12, str); for i := TxPlain to TxShadow do CheckItem(StyleMenuH, i, false); if CurrentStyle = [] then CheckItem(StyleMenuH, TxPlain, true) else begin if Bold in CurrentStyle then CheckItem(StyleMenuH, TxBold, true); if Italic in CurrentStyle then CheckItem(StyleMenuH, TxItalic, true); if Underline in CurrentStyle then CheckItem(StyleMenuH, TxUnderline, true); if Outline in CurrentStyle then CheckItem(StyleMenuH, TxOutline, true); if Shadow in CurrentStyle then CheckItem(StyleMenuH, Txshadow, true); end; case CurrentSize of 9: MenuItem := 1; 10: MenuItem := 2; 12: MenuItem := 3; 14: MenuItem := 4; 18: MenuItem := 5; 24: MenuItem := 6; 36: MenuItem := 7; 48: MenuItem := 8; 56: MenuItem := 9; 72: MenuItem := 10; otherwise MenuItem := 12; end; CheckOnOffItem(SizeMenuH, MenuItem, 1, 12); case TextJust of teJustLeft: MenuItem := LeftItem; teJustCenter: MenuItem := CenterItem; teJustRight: MenuItem := RightItem; end; CheckOnOffItem(StyleMenuH, MenuItem, LeftItem, RightItem); if TextBack = NoBack then MenuItem := NoBackgroundItem else MenuItem := WithBackgroundItem; CheckOnOffItem(StyleMenuH, MenuItem, NoBackgroundItem, WithBackgroundItem); end; procedure LoadLUT (table: MyCSpecArray); var i, entry, screen: integer; cPtr: ^cSpecArray; SaveDevice: GDHandle; begin if nExtraColors > 0 then begin entry := FirstExtraColorsEntry; for i := 1 to nExtraColors do begin table[entry].rgb := ExtraColors[i]; entry := entry + 1; end; end; if HighLightMode then begin table[1].rgb := Highlight1; table[254].rgb := Highlight254; end; for i := 1 to 254 do {Work around needed for 32-bit QuickDraw} with table[i].rgb do if (red = 0) and (green = 0) and (blue = 0) then begin red := 256; green := 256; blue := 256; end; cPtr := @table[1]; if ScreenDepth = 8 then begin SaveDevice := GetGDevice; for screen := 1 to nMonitors do begin SetGDevice(Monitors[screen]); for i := 1 to 254 do begin ProtectEntry(i, false); ReserveEntry(i, false); end; SetEntries(1, 253, cPtr^); end; SetGDevice(SaveDevice); end; table[0].rgb := WhiteRGB; table[255].rgb := BlackRGB; BlockMove(@table, @osGDevice^^.gdPMap^^.pmTable^^.ctTable, SizeOf(table)); with osGDevice^^.gdPMap^^.pmTable^^ do if ScreenDepth = 8 then ctSeed := ScreenPixMap^^.pmTable^^.ctSeed else ctSeed := GetCtSeed; end; procedure SetupLutUndo; begin with info^ do begin UndoInfo^.RedLut := RedLut; UndoInfo^.GreenLut := GreenLut; UndoInfo^.BlueLut := BlueLut; UndoInfo^.nColors := nColors; UndoInfo^.ColorStart := ColorStart; UndoInfo^.ColorEnd := ColorEnd; UndoInfo^.FillColor1 := FillColor1; UndoInfo^.FillColor2 := FillColor2; UndoInfo^.LutMode := LutMode; UndoInfo^.ColorTable := ColorTable; UndoInfo^.IdentityFunction := IdentityFunction; UndoInfo^.cTable := cTable; WhatToUndo := UndoLUT; end; end; procedure UndoLutChange; begin with info^ do begin RedLut := UndoInfo^.RedLut; GreenLut := UndoInfo^.GreenLut; BlueLut := UndoInfo^.BlueLut; nColors := UndoInfo^.nColors; ColorStart := UndoInfo^.ColorStart; ColorEnd := UndoInfo^.ColorEnd; FillColor1 := UndoInfo^.FillColor1; FillColor2 := UndoInfo^.FillColor2; LutMode := UndoInfo^.LutMode; LutMode := UndoInfo^.LutMode; ColorTable := UndoInfo^.ColorTable; cTable := UndoInfo^.cTable; LoadLut(cTable); Thresholding := false; WhatToUndo := NothingToUndo; end; end; procedure UpdatePicWindow; var tPort: GrafPtr; SaveGDevice: GDHandle; begin if (info <> NoInfo) and (info^.wptr <> nil) then with Info^ do begin SaveGDevice := GetGDevice; SetGDevice(GetMainDevice); getPort(tPort); SetPort(wptr); SetFColor(BlackIndex); SetBColor(WhiteIndex); CopyBits(BitMapHandle(osPort^.portPixMap)^^, BitMapHandle(CGrafPtr(wptr)^.PortPixMap)^^, SrcRect, wrect, gCopyMode, nil); SetPort(tPort); SetGDevice(SaveGDevice); RoiUpdateTime := 0; end; end; procedure DisableDensitySlice; var tPort: GrafPtr; begin if DensitySlicing then begin DensitySlicing := false; UndoLutChange; if ScreenDepth <> 8 then begin UpdatePicWindow; GetPort(tPort); SetPort(LUTWindow); InvalRect(LutWindow^.PortRect); SetPort(tPort); end; end; end; procedure LoadInputLUT (address: ptr); type ilutType = packed array[0..1023] of byte; ilutPtr = ^ilutType; var ilut: ilutPtr; i: integer; begin ilut := ilutPtr(address); if InvertVideo then begin for i := 0 to 255 do ilut^[i * 4] := i; ilut^[0] := 1; ilut^[255 * 4] := 254 end else begin for i := 0 to 255 do ilut^[i * 4] := 255 - i; ilut^[0] := 254; ilut^[255 * 4] := 1 end; end; procedure ResetQuickCapture; const ilutOffset = $90000; begin ControlReg^ := 1; {reset} while BitAnd(ControlReg^, $80) = $80 do ; ChannelReg^ := VideoChannel * 64; while BitAnd(ControlReg^, $80) = $80 do ; LoadInputLUT(Ptr(fgSlotBase + ilutOffset)); end; procedure ResetScionLG3; const ilutOffset = $80000; var SyncChannel, t: integer; begin ControlReg^ := 0; BufferReg^ := 0; if SyncMode = SeparateSync then SyncChannel := 3 else SyncChannel := VideoChannel; t := band(bsl(VideoChannel, 4), bsl(SyncChannel, 6)); ChannelReg^ := bor(LG3DataOut, bor(bsl(VideoChannel, 4), bsl(SyncChannel, 6))); DacHighReg^ := DacHigh; DacLowReg^ := DacLow; DacAReg^ := LG3DacA; DacBReg^ := LG3DacB; LoadInputLUT(Ptr(fgSlotBase + ilutOffset)); end; procedure ResetScionAG5; const ilutOffset = $E0000; var SyncChannel: integer; begin ControlReg^ := 0; if SyncMode = SeparateSync then SyncChannel := 3 else SyncChannel := VideoChannel; ChannelReg^ := bor(ord(AG5BufferMode), bor(bsl(VideoChannel, 4), bsl(SyncChannel, 6))); DacHighReg^ := DacHigh; DacLowReg^ := DacLow; LoadInputLUT(Ptr(fgSlotBase + ilutOffset)); end; procedure ResetScionVG5f; const ilutOffset = $80000; var SyncChannel, t: integer; begin ControlReg^ := 0; if SyncMode = SeparateSync then SyncChannel := 3 else SyncChannel := VideoChannel; t := band(bsl(VideoChannel, 4), bsl(SyncChannel, 6)); ChannelReg^ := bor(bsl(VideoChannel, 4), bsl(SyncChannel, 6)); DacHighReg^ := DacHigh; DacLowReg^ := DacLow; LoadInputLUT(Ptr(fgSlotBase + ilutOffset)); end; procedure ResetFrameGrabber; begin case FrameGrabber of QuickCapture: ResetQuickCapture; ScionLG3: ResetScionLG3; ScionAG5: ResetScionAG5; ScionVG5f: ResetScionVG5f; otherwise ; end; end; procedure CopyOffscreen (src, dst: PixMapHandle; sRect, dRect: rect); var SaveGDevice: GDHandle; begin SaveGDevice := GetGDevice; SetGDevice(osGDevice); IndexToRgbForeColor(BlackIndex); IndexToRgbBackColor(WhiteIndex); CopyBits(BitMapHandle(fgPixMap)^^, BitMapHandle(dst)^^, sRect, dRect, DitherCopy, nil); IndexToRgbForeColor(ForegroundIndex); IndexToRgbBackColor(BackgroundIndex); SetGDevice(SaveGDevice); end; procedure wait (ticks: LongInt); var SaveTicks: LongInt; begin SaveTicks := TickCount + ticks; repeat until TickCount > SaveTicks; end; function GetScrapCount: integer; var ScrapInfo: ScrapStuffPtr; begin ScrapInfo := InfoScrap; GetScrapCount := ScrapInfo^.ScrapCount; end; procedure DisplayText (update: boolean); var tPort: GrafPtr; i, hstart, width, ff: integer; MaskRect: rect; p1, p2: point; SaveGDevice: GDHandle; begin if (info = NoInfo) or (not IsInsertionPoint) then exit(DisplayText); if update then Undo; SaveGDevice := GetGDevice; SetGDevice(osGDevice); GetPort(tPort); SetPort(GrafPtr(Info^.osPort)); IndexToRgbForeColor(ForegroundIndex); IndexToRgbBackColor(BackgroundIndex); TextFont(CurrentFontID); TextFace(CurrentStyle); TextSize(CurrentSize); if TextBack = NoBack then TextMode(SrcOr) else TextMode(SrcCopy); width := StringWidth(TextStr); case TextJust of teJustLeft: hstart := TextStart.h; teJustCenter: hstart := TextStart.h - width div 2; teJustRight: hstart := TextStart.h - width; end; if hstart < 0 then hstart := 0; MoveTo(hstart, TextStart.v); DrawString(TextStr); GetPen(InsertionPoint); ff := CurrentSize * 2; p1.h := hstart - ff; p1.v := TextStart.v - CurrentSize; p2.h := TextStart.h + width + ff; p2.v := TextStart.v + CurrentSize div 3; Pt2Rect(p1, p2, MaskRect); UpdateScreen(MaskRect); SetPort(tPort); SetGDevice(SaveGDevice); Info^.changes := true; end; procedure OffScreenToScreenRect (var r: rect); var p1, p2: point; begin with r do begin p1.h := left; p1.v := top; p2.h := right; p2.v := bottom; OffScreenToScreen(p1); OffScreenToScreen(p2); Pt2Rect(p1, p2, r); end; end; procedure ScreenToOffscreen (var loc: point); begin with loc, Info^ do begin h := SrcRect.left + trunc(h / magnification); v := SrcRect.top + trunc(v / magnification); end; end; procedure OffscreenToScreen (var loc: point); begin with loc, Info^ do begin h := trunc((h - SrcRect.left) * magnification); v := trunc((v - SrcRect.top) * magnification); end; end; procedure UpdateScreen (MaskRect: rect); {Refreshes the portion of the screen defined by} {MaskRect, where MaskRect is defined in offscreen coordinates.} var tPort: GrafPtr; imag: integer; SaveGDevice: GDHandle; begin OffScreenToScreenRect(MaskRect); with Info^ do if info <> NoInfo then begin SaveGDevice := GetGDevice; SetGDevice(GetMainDevice); getPort(tPort); SetPort(wptr); SetFColor(BlackIndex); SetBColor(WhiteIndex); imag := trunc(magnification); InsetRect(MaskRect, -imag * 2 * LineWidth, -imag * 2 * LineWidth); InsetRect(MaskRect, 0, 0); RectRgn(MaskRgn, MaskRect); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, BitMapHandle(CGrafPtr(wptr)^.PortPixMap)^^, SrcRect, wrect, gCopyMode, MaskRgn); SetPort(tPort); SetGDevice(SaveGDevice); end; end; procedure RestoreRoi; begin with Info^ do begin SetupUndo; if RoiShowing then UpdateScreen(RoiRect); roiType := NoInfo^.roiType; RoiRect := NoInfo^.RoiRect; CopyRgn(NoInfo^.roiRgn, roiRgn); LX1 := NoInfo^.LX1; LY1 := NoInfo^.LY1; LX2 := NoInfo^.LX2; LY2 := NoInfo^.LY2; LAngle := NoInfo^.LAngle; RoiShowing := true; measuring := false; end; end; procedure Undo; var SrcPtr: ptr; line: integer; begin if info^.PixMapSize <> CurrentUndoSize then exit(Undo); if UndoFromClip then begin if info^.PixMapSize > ClipBufSize then exit(Undo); SrcPtr := ClipBuf; end else SrcPtr := UndoBuf; with info^ do BlockMove(SrcPtr, PicBaseAddr, PixMapSize); if UndoFromClip and RestoreUndoBuf then with info^ do BlockMove(SrcPtr, UndoBuf, PixMapSize); if RedoSelection then RestoreRoi; end; function MyGetPixel (h, v: LongInt): integer; begin MyGetPixel := BackgroundIndex; with Info^ do if h >= 0 then if v >= 0 then if h < PixelsPerLine then if v < nlines then MyGetPixel := ImageP(PicBaseAddr)^[v * BytesPerRow + h]; {MyGetPixel := band(ptr(Ord4(PicBaseAddr) + v * BytesPerRow + h)^, 255);} end; procedure PutPixel (h, v: LongInt; value: integer); var addr: Ptr; begin with Info^ do if h >= 0 then if v >= 0 then if h < PixelsPerLine then if v < nlines then begin addr := Ptr(Ord4(PicBaseAddr) + v * BytesPerRow + h); addr^ := value; end; end; procedure GetLine (h, v, count: LongInt; var line: LineType); var offset: LongInt; p: ptr; i: integer; begin if count > MaxLine then count := MaxLine; with Info^ do begin if (h < 0) or (v < 0) or ((h + count) > PixelsPerLine) or (v >= nlines) then begin for i := 0 to count - 1 do line[i] := MyGetPixel(h + i, v); exit(GetLine); end; offset := v * BytesPerRow + h; p := ptr(ord4(PicBaseAddr) + offset); BlockMove(p, @line, count); end; end; procedure GetColumn (h, v, count: LongInt; var data: LineType); var col, pic, bpr: LongInt; i: integer; begin if count > MaxLine then count := MaxLine; with Info^ do begin if (h < 0) or (v < 0) or (h >= PixelsPerLine) or ((v + count) > nlines) then begin for i := 0 to count - 1 do data[i] := MyGetPixel(h, v + i); exit(GetColumn); end; col := Ord4(@data); bpr := BytesPerRow; pic := Ord4(PicBaseAddr) + v * bpr + h; while count > 0 do begin Ptr(col)^ := Ptr(pic)^; pic := pic + bpr; col := col + 1; count := count - 1; end; end; end; procedure PutColumn (hstart, vstart, count: LongInt; var data: LineType); var col, pic, bpr: LongInt; begin col := Ord4(@data); with Info^ do begin bpr := BytesPerRow; if count > 0 then if hstart >= 0 then if vstart >= 0 then if hstart < PixelsPerLine then begin if vstart > nlines - count then count := nlines - vstart; pic := Ord4(PicBaseAddr) + vstart * bpr + hstart; while count > 0 do begin Ptr(pic)^ := Ptr(col)^; pic := pic + bpr; col := col + 1; count := count - 1; end; end; end; end; procedure PutLine (h, v, count: LongInt; var line: LineType); var offset: LongInt; p: ptr; begin with Info^ do begin if (h < 0) or (v < 0) or (v >= nlines) then exit(PutLine); if (h + count) > PixelsPerLine then count := PixelsPerLine - h; offset := v * BytesPerRow + h; p := ptr(ord4(PicBaseAddr) + offset); BlocKMove(@line, p, count); end; end; procedure Show1Value (rvalue, CalibratedValue: extended); var tPort: GrafPtr; hstart, vstart, ivalue: integer; begin hstart := InfoHStart; vstart := InfoVStart; GetPort(tPort); SetPort(InfoWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); MoveTo(xValueLoc, vstart); if CalibratedValue <> NoValue then begin DrawReal(CalibratedValue, 5, 2); DrawString(' ('); DrawReal(rvalue, 3, 0); DrawString(')'); end else DrawReal(rvalue, 6, 2); DrawString(' '); SetPort(tPort); end; procedure Show2PlotValues (x, y: extended); var tPort: GrafPtr; hstart, vstart, ivalue: integer; begin with info^ do begin hstart := InfoHStart; vstart := InfoVStart; GetPort(tPort); SetPort(InfoWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); MoveTo(xValueLoc, vstart); DrawXDimension(round(x), 0); MoveTo(yValueLoc, vstart + 10); DrawReal(y, 6, 2); SetPort(tPort); end; end; procedure Show2Values (current, total: LongInt); var tPort: GrafPtr; hstart, vstart, ivalue: integer; begin hstart := InfoHStart; vstart := InfoVStart; GetPort(tPort); SetPort(InfoWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); MoveTo(xValueLoc, vstart); DrawLong(current); DrawString(' '); MoveTo(yValueLoc, vstart + 10); DrawLong(total); DrawString(' '); SetPort(tPort); end; procedure DrawXDimension (x: extended; digits: integer); begin with info^ do begin if SpatiallyCalibrated then begin DrawReal(x / xScale, 5, 2); DrawChar(xUnit[1]); DrawChar(xUnit[2]); DrawString(' ('); DrawReal(x, 3, digits); DrawString(')') end else DrawReal(x, 1, digits); DrawString(' '); end; end; procedure DrawYDimension (y: extended; digits: integer); begin with info^ do begin if SpatiallyCalibrated then begin DrawReal(y / yScale, 5, 2); DrawChar(xUnit[1]); DrawChar(xUnit[2]); DrawString(' ('); DrawReal(y, 3, digits); DrawString(')') end else DrawReal(y, 1, digits); DrawString(' '); end; end; procedure DrawRGB (index: integer); var rStr, gStr, bStr: str255; TempRGB: rgbColor; i, entry: integer; procedure Convert (n: integer; var str: str255); var i: integer; begin RealToString(n, 3, 0, str); for i := 1 to 3 do if str[i] = ' ' then str[i] := '0'; end; begin if ScreenDepth = 8 then TempRGB := cScreenPort^.portPixMap^^.pmTable^^.ctTable[index].rgb else TempRGB := info^.cTable[index].rgb; with TempRGB do begin Convert(band(bsr(red, 8), 255), rStr); Convert(band(bsr(green, 8), 255), gStr); Convert(band(bsr(blue, 8), 255), bStr); DrawString(concat(rStr, ' ', gStr, ' ', bStr)); end; end; procedure Show3Values (hloc, vloc, ivalue: LongInt); var tPort: GrafPtr; hstart, vstart: integer; begin with info^ do begin hstart := InfoHStart; vstart := InfoVStart; GetPort(tPort); SetPort(InfoWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); if hloc < 0 then hloc := -hloc; MoveTo(xValueLoc, vstart); DrawXDimension(hloc, 0); if InvertYCoordinates and (ivalue >= 0) then vloc := PicRect.bottom - vloc - 1; if vloc < 0 then vloc := -vloc; MoveTo(yValueLoc, vstart + 10); DrawYDimension(vloc, 0); DrawString(' '); if ivalue >= 0 then begin MoveTo(zValueLoc, vstart + 20); if (fit <> uncalibrated) or (CurrentTool = PickerTool) then begin if CurrentTool = PickerTool then DrawRGB(ivalue) else DrawReal(cvalue[ivalue], 5, precision); DrawString(' ('); DrawLong(ivalue); DrawString(')'); end else DrawLong(ivalue); end; DrawString(' '); SetPort(tPort); end; end; procedure ShowDxDy (X, Y: extended); var tPort: GrafPtr; hstart, vstart, ivalue: integer; begin with info^ do begin hstart := InfoHStart; vstart := InfoVStart; GetPort(tPort); SetPort(InfoWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); MoveTo(xValueLoc, vstart); DrawXDimension(x, 2); MoveTo(yValueLoc, vstart + 10); DrawYDimension(y, 2); MoveTo(zValueLoc, vstart + 20); if SpatiallyCalibrated then begin DrawReal(sqrt(sqr(x / xScale) + sqr(y / yScale)), 5, 2); DrawChar(xUnit[1]); DrawChar(xUnit[2]); DrawString(' ('); DrawReal(sqrt(sqr(x) + sqr(y)), 1, 2); DrawString(')') end else DrawReal(sqrt(sqr(x) + sqr(y)), 1, 2); DrawString(' '); SetPort(tPort); end; end; procedure PutChar (c: char); begin if TextBufSize < MaxTextBufSize then begin TextBufSize := TextBufSize + 1; TextBufP^[TextBufSize] := c; if c = cr then begin TextBufColumn := 0; TextBufLineCount := TextBufLineCount + 1 end else TextBufColumn := TextBufColumn + 1; end; end; procedure PutTab; begin if not printing then PutChar(tab) end; procedure PutString (str: str255); var i: integer; begin for i := 1 to length(str) do begin if TextBufSize < MaxTextBufSize then TextBufSize := TextBufSize + 1; TextBufP^[TextBufSize] := str[i]; TextBufColumn := TextBufColumn + 1; end; end; procedure PutFString (str: str255; FieldWidth: integer); var LeadingSpaces: integer; begin LeadingSpaces := FieldWidth - length(str); if LeadingSpaces > 0 then str := concat(copy(' ', 1, LeadingSpaces), str); PutString(str); end; procedure PutReal (n: extended; width, fwidth: integer); var str: str255; begin RealToString(n, width, fwidth, str); PutString(str); end; procedure PutLong (n: LongInt; FieldWidth: integer); var str: str255; LeadingSpaces: integer; begin NumToString(n, str); LeadingSpaces := FieldWidth - length(str); if LeadingSpaces > 0 then str := concat(copy(' ', 1, LeadingSpaces), str); PutString(str); end; procedure CopyResultsToBuffer (FirstCount, LastCount: integer; Headings: boolean); var i, column, fwidth: integer; m: MeasurementTypes; procedure PutSequenceNumber; begin PutLong(i, 4); PutChar('.'); PutTab; end; procedure PutUnits; begin if info^.SpatiallyCalibrated then begin PutString(' ('); DrawChar(info^.xUnit[1]); DrawChar(info^.xUnit[2]); PutString(')') end else PutString('(Pixels)'); PutChar(cr); PutChar(cr); end; procedure PutTabDelimeter; begin Column := Column + 1; if Column <> nListColumns then PutTab; end; begin if mCount < 1 then begin TextBufSize := 0; TextBufLineCount := 0; exit(CopyResultsToBuffer); end; ShowWatch; Headings := Headings or OptionKeyWasDown; TextBufSize := 0; TextBufColumn := 0; TextBufLineCount := 0; nListColumns := 0; for m := AreaM to StdDevM do if m in Measurements then nListColumns := nListColumns + 1; if (xyLocM in measurements) or (nPoints > 0) then nListColumns := nListColumns + 2; if ModeM in measurements then nListColumns := nListColumns + 1; if (LengthM in measurements) or (nLengths > 0) then nListColumns := nListColumns + 1; if MajorAxisM in measurements then nListColumns := nListColumns + 1; if MinorAxisM in measurements then nListColumns := nListColumns + 1; if (AngleM in measurements) or (nAngles > 0) then nListColumns := nListColumns + 1; if IntDenM in measurements then nListColumns := nListColumns + 2; if MinMaxM in measurements then nListColumns := nListColumns + 2; if User1M in measurements then nListColumns := nListColumns + 1; if User2M in measurements then nListColumns := nListColumns + 1; with info^ do begin fwidth := FieldWidth; if Headings and (FirstCount = 1) then begin PutFString(' ', 5); PutTabDelimeter; if AreaM in measurements then begin PutFString('Area', fwidth); PutTabDelimeter; end; if MeanM in measurements then begin PutFString('Mean', fwidth); PutTabDelimeter; end; if StdDevM in measurements then begin PutFString('S.D.', fwidth); PutTabDelimeter; end; if (xyLocM in measurements) or (nPoints > 0) then begin PutFString('X', fwidth); PutTabDelimeter; PutFString('Y', fwidth); PutTabDelimeter; end; if ModeM in measurements then begin PutFString('Mode', fwidth); PutTabDelimeter; end; if (LengthM in measurements) or (nLengths > 0) then begin PutFString('Length', fwidth); PutTabDelimeter; end; if MajorAxisM in measurements then begin PutFString(MajorLabel, fwidth); PutTabDelimeter; end; if MinorAxisM in measurements then begin PutFString(MinorLabel, fwidth); PutTabDelimeter; end; if (AngleM in measurements) or (nAngles > 0) then begin PutFString('Angle', fwidth); PutTabDelimeter; end; if IntDenM in measurements then begin PutFString('Int.Den.', fwidth + 2); PutTabDelimeter; PutFString('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 FlushCache; var address: LogicalAddress; length: ByteCount; ignore: OSStatus; begin {$ifc PowerPC} if not PCIFrameGrabber then exit(FlushCache); if info = NoInfo then exit(FlushCache); if (FrameGrabber = ScionAG5) and (AG5GrabMode = GrabSum) then exit(FlushCache); if GrabbingToScreen then exit(FlushCache); address := LogicalAddress(fgPort^.PortPixMap^^.BaseAddr); length := ByteCount(longint(fgRowBytes) * longint(fgHeight)); ignore := FlushProcessorCache(AddressSpaceID(-1), address, length); {$endc} end; procedure CaptureImage; var Timeout: LongInt; vdigErr: ComponentResult; begin case FrameGrabber of QuickCapture: begin ControlReg^ := BitAnd($80, 255); {Start frame capture} while BitAnd(ControlReg^, $80) = $80 do ; {Wait for it to complete} end; ScionLG3, ScionAG5, ScionVG5f: 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; QTvdig: if vdig <> nil then vdigErr := VDGrabOneFrame(vdig); end; {case} FlushCache end; procedure Paste; var srcPixMap: PixMapHandle; PCILivePaste: boolean; 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 IndexToRgbForeColor(BlackIndex); IndexToRgbBackColor(WhiteIndex); end; srcPixMap := ClipBufInfo^.osPort^.PortPixMap; PCILivePaste := false; if LivePasteMode then if ((WhatsOnClip = CameraPic) or (WhatsOnClip = LivePic)) and (PictureType <> FrameGrabberType) then begin if PCIFrameGrabber then with fgPort^.PortPixMap^^ do begin BaseAddr := ptr(fgSlotBase); PCILivePaste := true; end; CaptureImage; srcPixMap := fgPixMap; end; CopyBits(BitMapHandle(srcPixMap)^^, BitMapHandle(osPort^.PortPixMap)^^, ClipBufInfo^.RoiRect, RoiRect, PasteTransferMode, roiRgn); if PCILivePaste then with fgPort^.PortPixMap^^ do BaseAddr := ptr(fgSuperSlotBase0); if PasteTransferMode = SrcCopy then begin IndexToRgbForeColor(ForegroundIndex); IndexToRgbBackColor(BackgroundIndex); end; end; 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)); IndexToRgbForeColor(ForegroundIndex); IndexToRgbBackColor(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:begin EraseRgn(roiRgn); end; PasteOp: Paste; otherwise end; if not RoiShowing then begin UpdateScreen(RoiRect); end; 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 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 PutError('Please use a selection tool to make a selection or use the Select All command.'); AbortMacro; end; NoSelection := not Info^.RoiShowing; end; function NotRectangular;{:boolean} begin with info^ do if RoiShowing and (RoiType <> RectRoi) then begin PutError('This operation requires a rectangular selection.'); NotRectangular := true; AbortMacro; end else NotRectangular := false; end; procedure GetLoi (var x1, y1, x2, y2: extended); 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: extended; 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 PutError('This operation requires the selection to be entirely within the image.'); NotInBounds := true; AbortMacro; end; end; end; function NoUndo: boolean; var ImageTooLarge: boolean; begin with info^ do ImageTooLarge := (PixMapSize > ClipBufSize) or (PixMapSize > UndoBufSize); if ImageTooLarge then PutError('This operation requires that the Undo and Clipboard buffers be at least as large as the image.'); NoUndo := ImageTooLarge; end; procedure PutMemoryAlert; begin if not OpeningFinderFiles then PutError('There is not enough free memory to open this image. Try closing some windows or allocating more memory to NIH Image.'); AbortMacro; 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); {$ifc PowerPC} PicBaseAddr := PicBaseHandle^; {$elsec} PicBaseAddr := StripAddress(PicBaseHandle^); {$endc} 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 DisposeHandle(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 DisposeHandle(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 := nlines * BytesPerRow; ImageSize := nlines * PixelsPerLine; NeededSize := PixMapSize; end; h := GetBigHandle(NeededSize); if h = nil then begin DisposePtr(pointer(Info)); PutMemoryAlert; Info := SaveInfo; GetImageMemory := nil; exit(GetImageMemory); end; with info^ do begin PicBaseHandle := h; hlock(PicBaseHandle); {$ifc PowerPC} GetImageMemory := PicBaseHandle^; {$elsec} GetImageMemory := StripAddress(PicBaseHandle^); {$endc} end; end; 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, ' '); SetMenuItemText(WindowsMenuH, nPics + WindowsMenuItems + nTextWindows, str); InsertMenu(WindowsMenuH, 0); end; end; procedure InvertGrayLevels; begin with info^ do begin fit := StraightLine; nCoefficients := 2; Coefficient[1] := 255.0; Coefficient[2] := -1.0; ZeroClip := false; UnitOfMeasure := ''; nKnownValues := 0; NoInfo^.fit := StraightLine; NoInfo^.nCoefficients := 2; NoInfo^.Coefficient := Coefficient; NoInfo^.ZeroClip := false; NoInfo^.UnitOfMeasure := ''; GenerateValues; UpdateTitleBar; end; end; function GetAngle (dx, dy: extended):extended; var angle:extended; 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; GetAngle:=angle; {ppc-bug} end; procedure MakeRegion; var deltax, deltay, x1, y1, x2, y2, xt, yt: integer; dx, dy, pAngle: extended; add: boolean; tPort: GrafPtr; begin with info^ do begin GetPort(tPort); SetPort(wptr); OpenRgn; case RoiType of LineRoi: begin LAngle:=GetAngle(LX2 - LX1, LY1 - LY2); 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; fileVersion := 0; PictureType := NewPicture; DataType := EightBits; changes := false; DataH := nil; LittleEndian := false; InvertedImage := false; if OldInfo.DataH <> nil then {real image} fit := uncalibrated; if (not SpatiallyCalibrated and (fit=uncalibrated)) or (nPics=0) then begin if NoInfo^.SpatiallyCalibrated then begin SpatiallyCalibrated:=true; xUnit := NoInfo^.xUnit; xScale := NoInfo^.xScale; PixelAspectRatio := NoInfo^.PixelAspectRatio; yScale := xScale / PixelAspectRatio; end; if NoInfo^.fit<>uncalibrated then begin fit := NoInfo^.fit; nCoefficients := NoInfo^.nCoefficients; Coefficient := NoInfo^.Coefficient; ZeroClip := NoInfo^.ZeroClip; UnitOfMeasure := NoInfo^.UnitOfMeasure; end; end; 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; AbortMacro; 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); if not OptionKeyDown then DoOperation(EraseOp); KillRoi; Changes := false; BinaryPic := false; end; UpdateTitleBar; NewPicWindow := true; end; procedure EraseScreen; begin SetPort(GrafPtr(CScreenPort)); with CScreenPort^ do begin HideCursor; IndexToRgbBackColor(BackgroundIndex); EraseRect(portPixMap^^.Bounds); IndexToRgbBackColor(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(WindowRef(FrontWindow), GrayRgn); wp^ := PasteControl; DrawMenuBar; InitCursor; 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; SaveGDevice: GDHandle; begin if info = NoInfo then exit(UpdateTitleBar); with info^ do begin str := title; if info^.DataH <> nil then str := concat('<<',str, '>>'); if SpatiallyCalibrated then str := concat(str, chr($13)); {Black Diamond} if fit <> uncalibrated then str := concat(str, '×'); if StackInfo <> nil then with StackInfo^ do if (nSlices = 3) and (StackType = rgbStack) then begin case CurrentSlice of 1: str2 := 'Red'; 2: str2 := 'Green'; 3: str2 := 'Blue'; end; str := concat(str, ' (', str2, ')'); end else 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 begin SaveGDevice := GetGDevice; SetGDevice(GetMainDevice); SetWTitle(wptr, str); SetGDevice(SaveGDevice); end; 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 ScaleToFitWindow:=false; wrect := initwrect; SrcRect := wrect; SizeWindow(wptr, wrect.right, wrect.bottom, true); LoadLUT(info^.cTable); UpdatePicWindow; magnification := 1.0; DrawMyGrowIcon(wptr); UpdateTitleBar; WindowState:=NormalWindow; if WhatToUndo = UndoZoom then WhatToUndo := NothingToUndo; ShowRoi; end; end; procedure DrawBString(str:string); var s:style; begin TextFace([bold]); DrawString(str); s:=[]; {ppc-bug} TextFace(s); end; function long2str (num: LongInt): str255; var str: str255; begin NumToString(num, str); long2str := str; end; procedure PutWarning; begin PutError(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 may not 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)); IndexToRgbForeColor(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)); IndexToRgbBackColor(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 fit = uncalibrated then begin for i := 0 to 255 do cvalue[i] := i; minCValue := 0.0; maxCValue := 255.0; exit(GenerateValues); end; a := Coefficient[1]; b := Coefficient[2]; c := Coefficient[3]; d := Coefficient[4]; e := Coefficient[5]; f := Coefficient[6]; minCValue := 10e+12; maxCValue := -minCValue; 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.0 / (255.0 - x)) {log10} end; otherwise y := x; end; {case} cvalue[i] := y; if y > maxCValue then maxCValue := y; if y < minCValue then minCValue := y; end; {for} if minCValue >= 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; minCValue := 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 CGrafPtr(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); PutError(concat('This operation does not support selections wider than ', MaxWidth, ' pixels.')); AbortMacro; 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; function StringToReal (str: str255): extended; var i, ndigits, StringLength: integer; c: char; n, m: extended; negative, LeftOfPoint, NegExp: boolean; exponent: LongInt; begin negative := false; n := 0.0; LeftOfPoint := true; m := 0.1; ndigits := 0; StringLength := length(str); i := 0; repeat i := i + 1; until (str[i] in ['0'..'9', '-', '.']) or (i >= StringLength); c := str[i]; repeat if c = '-' then negative := true else if c = '.' then LeftOfPoint := false else if (c >= '0') and (c <= '9') then begin ndigits := ndigits + 1; if LeftOfPoint then n := n * 10.0 + ord(c) - ord('0') else begin n := n + (ord(c) - ord('0')) * m; m := m * 0.1; end; end; i := i + 1; if i <= StringLength then c := str[i]; until not (c in ['0'..'9', '-', '.']) or (i > StringLength); if (c = 'e') or (c = 'E') then begin NegExp := false; exponent := 0; i := i + 1; if i <= StringLength then c := str[i]; if (c = '+') or (c = '-') then begin if c = '-' then NegExp := true; i := i + 1; if i <= StringLength then c := str[i]; end; repeat if (c >= '0') and (c <= '9') then exponent := exponent * 10 + ord(c) - ord('0'); i := i + 1; if i <= StringLength then c := str[i]; until not (c in ['0'..'9']) or (i > StringLength); if negExp then exponent := -exponent; if exponent <> 0 then n := n * exp(exponent * ln(10)); end; {if c='e'} if ndigits = 0 then n := BadReal else if negative then n := -n; StringToReal := n; end; procedure RemovePath(var str: str255); var loc: integer; begin repeat loc := pos(':', str); if loc > 0 then delete(str, 1, loc); until loc = 0; end; procedure MakeNewWindow (name: str255); var wwidth, wheight, wleft, wtop, i: integer; tPort: GrafPtr; rgb: RGBColor; err: OSErr; str: str255; SaveGDevice: GDHandle; begin with Info^ do begin RemovePath(name); wleft := PicLeft; wtop := PicTop; PicLeft := PicLeft + hPicOffset; PicTop := PicTop + vPicOffset; if ((PicLeft + round(0.75 * PixelsPerLine)) > ScreenWidth) or ((PicTop + round(0.75 * nlines)) > ScreenHeight) then begin PicLeft := PicLeftBase; PicTop := PicTopBase; end; wwidth := PixelsPerLine; if (wleft + wwidth) > ScreenWidth then wwidth := ScreenWidth - wleft - 4; wheight := nlines; if (wtop + wheight) > ScreenHeight then wheight := ScreenHeight - wtop - 4; if OpeningPlugInWindow then SetRect(wrect, -10000, wtop, -10000 + wwidth, wtop + wheight) else SetRect(wrect, wleft, wtop, wleft + wwidth, wtop + wheight); str := name; if SpatiallyCalibrated then str := concat(str, chr($13)); {Black Diamond} if fit <> uncalibrated then str := concat(str, '×'); wptr := NewCWindow(nil, wrect, str, true, DocumentProc + ZoomDocProc, nil, true, 0); GetPort(tPort); SetPort(wptr); SetPalette(wptr, ExplicitPalette, false); IndexToRgbForeColor(BlackIndex); IndexToRgbBackColor(WhiteIndex); SetRect(wrect, 0, 0, wwidth, wheight); SetRect(PicRect, 0, 0, PixelsPerLine, nlines); SelectWindow(wptr); WindowPeek(wptr)^.WindowKind := PicKind; WindowPeek(wptr)^.RefCon := ord4(Info); TruncateString(name, maxTitle); title := name; ExtendWindowsMenu(name, PixMapSize, wptr); PicNum := nPics; PidNum := nextPid; nextPid := nextPid - 1; osPort := CGrafPtr(NewPtr(SizeOf(CGrafPort))); SaveGDevice := GetGDevice; SetGDevice(osGDevice); OpenCPort(osPort); with osPort^ do begin with PortPixMap^^ do begin BaseAddr := PicBaseAddr; bounds := PicRect; pixelType := 0; if PixelSize > 8 then PixelSize := 8; cmpCount := 1; end; PortRect := PicRect; RectRgn(visRgn, PicRect); PortPixMap^^.RowBytes := BitOr(BytesPerRow, $8000); end; SetPalette(WindowPtr(osPort), ExplicitPalette, false); IndexToRgbForeColor(ForegroundIndex); IndexToRgbBackColor(BackgroundIndex); SetGDevice(SaveGDevice); SetPort(tPort); SrcRect := wrect; magnification := 1.0; RoiShowing := false; roiType := NoRoi; initwrect := wrect; savewrect := wrect; SaveSrcRect := SrcRect; SaveMagnification := magnification; savehloc := wleft; savevloc := wtop; roiRgn := NewRgn; NewPic := true; ScaleToFitWindow := false; OpPending := false; Changes := false; WindowState := NormalWindow; if (fit = uncalibrated) 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 = 8) and LUTFriendlyMode then depth := 6; if depth <> SaveScreenDepth then FindMonitors(depth); ScreenDepth := depth; end; procedure IndexToRgbForeColor(index: integer);{18.11.2002 replaces pmForeColor} begin RGBForeColor(osGDevice^^.gdPMap^^.pmTable^^.ctTable[index].rgb); end; procedure IndexToRgbBackColor(index: integer);{18.11.2002 replaces pmBackColor} begin RGBBackColor(osGDevice^^.gdPMap^^.pmTable^^.ctTable[index].rgb); 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 18.11.2002} RGBForeColor(osGDevice^^.gdPMap^^.pmTable^^.ctTable[index].rgb); end; procedure SetBColor (index: integer); {Sets the screen background color.} begin {if ScreenDepth = 8 then IndexToRgbBackColor(index) else 18.11.2002} RGBBackColor(osGDevice^^.gdPMap^^.pmTable^^.ctTable[index].rgb); end; function DoubleToReal(d:FakeDouble):extended; {Converts an IEEE double to an IEEE float. Will not be needed when "8 Byte Doubles" work in the Metrowerks 68k compiler.} var s, f, r:extended; e:LongInt; dd:double; begin {$ifc PowerPC} dd:=double(d); r:=dd; {$elsec PowerPC} if band(d[1],$80000000)=0 then s:=1 else s:=-1; e:=band(d[1],$7ff00000); e:=bsr(e,20); f:=band(d[1],$fffff); f:=f / 1048576.0; f:=f + bsr(d[2],24)/268435456.0; {ShowMessage(StringOf('s=',s , ' e=', e, ' f=', f));} if (e > 0) and (e < 2047) then r:=s * exp((e-1023)*ln(2.0)) * (1.0 + f) else if (e = 0) and (f <> 0) then r:=s * f * exp(-1022.0*ln(2.0)) * f else if (e = 0) and (e = 0) then r:=0.0 else if (e = 255) and (f = 0) then r:=0.0 {inf} else {if e=255 and f<>0} r:=0.0; {nan} {$endc PowerPC} DoubleToReal:=r; end; procedure RealToDouble(rr: extended; var d:FakeDouble); {Converts an IEEE float to an IEEE double. Will not be needed when "8 Byte Doubles" work in the Metrowerks 68k compiler.} var i, s, e, f:LongInt; r:real; dd:double; begin {$ifc PowerPC} dd:=rr; d:=FakeDouble(dd); {$elsec PowerPC} r:=rr; i:=LongInt(r); s:=band(i,$80000000); e:=band(i,$7f800000); e:=bsr(e, 23); if e>255 then e:=255; e:=e-127+1023; e:=bsl(e, 20); f:=band(i, $7fffff); f:=bsr(f, 3); d[1]:=bor(s,bor(e,f)); d[2]:=0; {if r<>0.0 then begin ShowMessage(StringOf(' e=', e,' f=', f)); wait(60); end;} {$endc PowerPC} end; {$S Utilities2} {Routines from here to the end of the file go in the Utilities2 segment} function MakeStackFromWindow: boolean; begin with info^ do begin StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then begin MakeStackFromWindow := false; exit(MakeStackFromWindow); end; with StackInfo^ do begin nSlices := 1; CurrentSlice := 1; PicBaseH[1] := PicBaseHandle; SliceSpacing := 0.0; FrameInterval := 0.0; StackType := VolumeStack; end; PictureType := NewPicture; MakeStackFromWindow := true; end; end; procedure SelectSlice (i: integer); begin with info^, info^.StackInfo^ do if i <= nSlices then begin hunlock(PicBaseHandle); PicBaseHandle := PicBaseH[i]; hlock(PicBaseHandle); {$ifc PowerPC} PicBaseAddr := PicBaseHandle^; {$elsec} PicBaseAddr := StripAddress(PicBaseHandle^); {$endc} osPort^.PortPixMap^^.BaseAddr := PicBaseAddr; end; end; procedure UpdateWindowsMenuItem; var str: str255; picSize: LongInt; begin with info^ do begin PicSize := PixMapSize; if StackInfo <> nil then PicSize := PicSize * StackInfo^.nSlices; if DataH <> nil then PicSize := PicSize + PicSize * SizeOf(real); NumToString((PicSize + 511) div 1024, str); str := concat(title, ' ', str, 'K'); SetMenuItemText(WindowsMenuH, PicNum + WindowsMenuItems + nTextWindows, str); end; end; function AddSlice (update: boolean): boolean; var i: integer; h: handle; isRoi: boolean; begin with info^, info^.StackInfo^ do begin AddSlice := false; if nSlices = MaxSlices then exit(AddSlice); isRoi := RoiShowing; if isRoi then KillRoi; h := GetBigHandle(PixMapSize); if h = nil then begin PutError('Not enough memory available to add a slice to this stack.'); AbortMacro; exit(AddSlice); end; for i := nSlices downto CurrentSlice + 1 do PicBaseH[i + 1] := PicBaseH[i]; nSlices := nSlices + 1; CurrentSlice := CurrentSlice + 1; PicBaseH[CurrentSlice] := h; SelectSlice(CurrentSlice); if Update then begin SelectAll(false); DoOperation(EraseOp); UpdatePicWindow; end; if (StackType = rgbStack) and (nSlices <> 3) then StackType := VolumeStack; UpdateTitleBar; if isRoi then RestoreRoi; WhatToUndo := NothingToUndo; AddSlice := true; changes := true; PictureType := NewPicture; UpdateWindowsMenuItem; end; end; procedure AbortMacro; {If a macro is running, abort it.} begin macro := false; end; procedure TruncateString(var str: str255; len: integer); begin {if length(str) > len then beep;} if length(str) > len then delete(str, len + 1, length(str) - len); end; procedure CloseVdig; {Closes the current video digitizer component and its associated offscreen graphics world.} var err: osErr; begin if fgPixMap <> nil then begin if osGWorld<>nil then DisposeGWorld(osGWorld); osGWorld := nil; GWorldLUT := nil; fgPixMap := nil; end; if vdig <> nil then begin err := CloseComponent(vdig); vdig := nil; end; FrameGrabber := noFrameGrabber; GrabbingToScreen := false; end; end.