unit Utilities; {Miscellaneous utility routines used by Image program} 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 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): real; 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 DrawLong (i: LongInt); function GetInt (message: str255; default: integer): integer; function GetReal (message: str255; default: extended): 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 UpdateTextMenu; procedure RedrawLUTWindow; procedure Load256ColorCLUT; function LoadCLUTResource (id: integer): boolean; procedure UnprotectLUT; procedure LoadLUT (table: MyCSpecArray); procedure DrawDensitySlice (OptionKey: boolean); procedure SelectLutTool; procedure EnableDensitySlice; procedure DisableDensitySlice; procedure UpdateColors; procedure LoadInputLookupTable (address: ptr); procedure ResetQuickCapture; procedure GetLookupTable (var table: LookupTable); procedure wait (ticks: LongInt); procedure SetGrayScaleLUT; procedure CheckColorWidth; procedure GetDefaultPalette; procedure GetPaletteFromFile (fname: str255; vnum: integer); procedure InitColor (fname: str255; vnum: integer); function GetScrapCount: integer; procedure DisplayText (update: boolean); procedure SetForegroundColor (color: integer); procedure SetBackgroundColor (color: integer); procedure ScreenToOffscreen (var loc: point); procedure OffscreenToScreen (var loc: point); procedure OffScreenToScreenRect (var r: rect); procedure UpdateScreen (MaskRect: rect); function GetColorIndex: integer; 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: integer): integer; procedure PutPixel (h, v, value: integer); procedure GetLine (h, v, count: integer; var line: LineType); procedure GetColumn (hstart, vstart, count: integer; var data: LineType); procedure PutColumn (hstart, vstart, count: integer; var data: LineType); procedure PutLine (h, v, count: integer; var line: LineType); procedure Show1Value (rvalue, CalibratedValue: extended); procedure Show2CalibratedValues (x, y: LongInt; ShowUncalibrated: boolean); procedure Show2Values (current, total: LongInt); procedure DrawDimension (x: integer); procedure Show3Values (hloc, vloc, ivalue: LongInt); procedure Show3RealValues (X, Y: LongInt; Z: 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 UpdatePicWindow; procedure DoOperation (Operation: OpType); procedure SaveRoi; procedure KillRoi; procedure Paste; procedure ShowRoi; procedure SetupUndo; procedure SetupUndoFromClip; function NotRectangular: boolean; function NotInBounds: boolean; function NoSelection: boolean; function NoUndo: boolean; function NewPicWindow (name: str255; width, height: integer): boolean; procedure MakeRegion; procedure SelectAll (visible: boolean); procedure EraseScreen; procedure RestoreScreen; procedure ShowMagnification; procedure Unzoom; function FindMedian (var a: SortArray): integer; procedure DrawBString (str: string); procedure DrawMyGrowIcon (w: WindowPtr); procedure PutMemoryAlert; function GetImageMemory (SaveInfo: infoPtr; var PicBaseHandle: handle; double: boolean): ptr; procedure UpdateAnalysisMenu; procedure ExtendWindowsMenu (fname: str255; size: LongInt; wptr: WindowPtr); procedure MakeNewWindow (name: str255); procedure PutWarning; procedure ScaleToFit; procedure SetupRoiRect; procedure GetForegroundColor (event: EventRecord); procedure GetBackgroundColor (event: EventRecord); procedure GenerateValues; procedure KillOperation; procedure ScaleImageWindow (var trect: rect); procedure InvertGrayLevels; function TooWide: boolean; procedure DrawText (str: str255; loc: point; just: integer); procedure IncrementCounter; procedure ClearResults (i: integer); procedure UpdateFitEllipse; implementation type KeyPtrType = ^KeyMap; procedure MacsBug (str: str255); inline $abff; procedure SetDialogItem;{(TheDialog:DialogPtr; item,value:integer)} var ItemType: integer; ItemBox: rect; ItemHdl: handle; begin GetDItem(TheDialog, item, ItemType, ItemHdl, ItemBox); SetCtlValue(ControlHandle(ItemHdl), value) end; procedure OutlineButton;{(theDialog: DialogPtr; itemNo, CornerRad: integer)} { Draws a border around a button. 16 is the normal} { cornerRad for small buttons } var itemType: Integer; itemBox: Rect; itemHdl: Handle; tempPort: GrafPtr; begin GetPort(tempPort); SetPort(theDialog); GetDItem(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 GetDItem(TheDialog, item, ItemType, ItemHdl, ItemBox); GetIText(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 GetDItem(TheDialog, item, ItemType, ItemHdl, ItemBox); GetIText(ItemHdl, str); GetDString := str; end; procedure SetDNum;{(TheDialog:DialogPtr; item:integer; n:LongInt)} var ItemType: integer; ItemBox: rect; ItemHdl: handle; str: str255; begin GetDItem(TheDialog, item, ItemType, ItemHdl, ItemBox); NumToString(n, str); SetIText(ItemHdl, str) end; procedure GetWindowRect;{(w:WindowPtr; VAR wrect:rect)} {Returns global coordinates of specified window.} begin wrect := WindowPeek(w)^.contRgn^^.rgnBBox; end; procedure SetDReal;{(TheDialog:DialogPtr; item:integer; n:extended; fwidth:integer)} var ItemType: integer; ItemBox: rect; ItemHdl: handle; str: str255; begin GetDItem(TheDialog, item, ItemType, ItemHdl, ItemBox); RealToString(n, 1, fwidth, str); SetIText(ItemHdl, str) end; procedure SetDString;{(TheDialog:DialogPtr; item:integer; str:str255)} var ItemType: integer; ItemBox: rect; ItemHdl: handle; begin GetDItem(TheDialog, item, ItemType, ItemHdl, ItemBox); SetIText(ItemHdl, str) end; function StringToReal (str: str255): real; var i, ndigits, StringLength: integer; c: char; n, m: real; negative, LeftOfPoint: boolean; 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 ndigits = 0 then n := BadReal else if negative then n := -n; StringToReal := n; 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} {form: DecForm;} begin if fwidth < 0 then begin if val < 1.0 then fwidth := 4 else if trunc(val) = val then fwidth := 0 else fwidth := 2; end; str := StringOf(val : width : fwidth); {Use LSP StringOf function because SANE Num2Str bombs out under A/UX} {form.digits := fwidth;} {form.style := FixedDecimal;} {Num2Str(form, val, DecStr(str));} {while length(Str) < width do begin} {str := concat(' ', Str)} {end;} 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; function GetInt;{(message:str255; default:integer):integer} const NumberID = 3; var mylog: DialogPtr; item: integer; temp: LongInt; begin ParamText(message, '', '', ''); mylog := GetNewDialog(3000, nil, pointer(-1)); SetDNum(MyLog, NumberID, default); SelIText(MyLog, NumberID, 0, 32767); OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); until (item = ok) or (item = cancel); if item = ok then begin temp := GetDNum(MyLog, NumberID); if (temp > -MaxInt) and (temp <= MaxInt) then GetInt := temp else begin SysBeep(1); temp := -MaxInt end; end else GetInt := -MaxInt; DisposDialog(mylog); end; function GetReal (message: str255; default: extended): extended; const NumberID = 3; var mylog: DialogPtr; item: integer; begin InitCursor; ParamText(message, '', '', ''); mylog := GetNewDialog(3000, nil, pointer(-1)); SetDReal(MyLog, NumberID, default, 2); SelIText(MyLog, NumberID, 0, 32767); OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); until (item = ok) or (item = cancel); if item = ok then GetReal := GetDReal(MyLog, NumberID) else GetReal := BadReal; DisposDialog(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 getditem(d, itemnum, itype, ignore, r); textfont(fontrqst); textsize(sizerqst); textbox(pointer(ord(@s) + 1), length(s), r, TEJustRight); end; procedure SysResume; begin FlushEvents(EveryEvent, 0); ExitToShell; end; procedure beep; begin SysBeep(1) end; procedure PutMessage;{(str:str255)} var ignore: integer; begin InitCursor; ParamText(str, '', '', ''); Ignore := Alert(300, nil); end; function GetFontSize;{(item:integer):integer} var TempSize: integer; 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); if TempSize < 1 then TempSize := 1; if TempSize > 1000 then TempSize := 1000; GetFontSize := TempSize; 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 UpdateTextMenu; var size, i, MenuItem, FontID, item: integer; FontName: str255; FontFound, FoundIt: boolean; str: str255; begin FontFound := false; for item := 1 to NumFontItems do begin GetItem(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 GetItem(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, ']ة'); SetItem(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(TextMenuH, MenuItem, LeftItem, RightItem); if TextBack = NoBack then MenuItem := NoBackgroundItem else MenuItem := WithBackgroundItem; CheckOnOffItem(TextMenuH, 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; 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]; 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; procedure RedrawLUTWindow; begin LoadLUT(info^.cTable); cheight := 256 + (2 + nExtraColors) * ExtraColorsHeight; SizeWindow(LUTWindow, cwidth, cheight, true); end; procedure Load256ColorCLUT; const Sat = -1; Val = -1; var i: integer; color: HSVColor; begin DisableDensitySlice; with info^ do begin for i := 0 to 255 do begin color.hue := i * 256; color.saturation := sat; color.value := val; HSV2RGB(color, ctable[i].rgb); end; LoadLUT(ctable); LUTMode := spectrum; end; IdentityFunction := false; end; function LoadPP2Palette: boolean; {Loads COLR resource from PixelPaint 2.0 palette file.} var i: integer; size: LongInt; h: Handle; PPColorTable: record ctSize: INTEGER; table: array[0..255] of RGBColor; end; begin h := GetResource('COLR', 999); size := GetHandleSize(handle(h)); if (ResError = NoErr) and (size = 1538) then with info^ do begin BlockMove(handle(h)^, @PPColorTable, SizeOf(PPColorTable)); with PPColorTable do begin for i := 0 to 255 do cTable[i].rgb := table[i]; end; LoadLUT(cTable); LUTMode := Custom; IdentityFunction := false; LoadPP2Palette := true; end else LoadPP2Palette := false; if h <> nil then DisposHandle(h); end; function LoadCLUTResource;{(id:integer):boolean} const ExpectedSize = 2056; var Size: LongInt; h: cTabHandle; MyColorTable: record ctSeed: LONGINT; transIndex: INTEGER; ctSize: INTEGER; ctTable: MyCSpecArray; end; begin DisableDensitySlice; h := GetCTable(id); size := GetHandleSize(handle(h)); if (ResError <> NoErr) or (size < ExpectedSize) then begin LoadCLUTResource := false; if id = PixelpaintID then begin if LoadPP2Palette then LoadCLUTResource := true; end; if h <> nil then DisposCTable(h); exit(LoadCLUTResource) end; if size > ExpectedSize then size := ExpectedSize; BlockMove(handle(h)^, @MyColorTable, size); DisposCTable(h); LoadLUT(MyColorTable.ctTable); with info^ do begin cTable := MyColorTable.ctTable; if id = AppleDefaultCLUT then LUTMode := AppleDefault else LUTMode := Custom; end; IdentityFunction := false; LoadCLUTResource := true; end; procedure DrawDensitySlice (OptionKey: boolean); var i, tRed: integer; begin with info^ do begin if OptionKey then begin ctable := SaveCTable^; end else for i := 0 to 255 do if (i >= SliceStart) and (i <= SliceEnd) then cTable[i].rgb := SliceColor else ctable[i].rgb := SaveCTable^[i].rgb; LoadLUT(cTable); end; end; procedure SelectLutTool; var tPort: GrafPtr; begin if (CurrentTool <> LutTool) and (CurrentTool <> Wand) then begin GetPort(tPort); SetPort(ToolWindow); InvalRect(ToolRect[CurrentTool]); InvalRect(ToolRect[LutTool]); CurrentTool := LutTool; isSelectionTool := false; SetPort(tPort); end; end; procedure EnableDensitySlice; begin if not DensitySlicing then begin new(SaveCTable); if SaveCTable <> nil then begin SaveCTable^ := info^.ctable; DrawDensitySlice(false); DensitySlicing := true; end; SelectLUTTool; end; end; procedure DisableDensitySlice; begin if DensitySlicing then begin DensitySlicing := false; with info^ do if lutMode = GrayScale then SetGrayScaleLUT else ctable := SaveCTable^; dispose(SaveCTable); LoadLUT(info^.cTable); end; end; procedure UpdateColors; var MaxStart, LastColor, i, v: integer; index: 0..MaxPseudoColorsLessOne; OptionKey: boolean; begin OptionKey := OptionKeyDown; DisableDensitySlice; with info^ do begin LastColor := ColorStart + nColors * ColorWidth - 1; for i := 0 to 255 do with cTable[255 - i].rgb do begin if (i < ColorStart) or (i > LastColor) then begin if OptionKey then begin v := bsl(i, 8); Red := v; Green := v; Blue := v; end else begin Red := 0; Green := 0; Blue := 0; end end else begin index := (i - ColorStart) div ColorWidth; if index < 0 then index := 0; if index > nColors - 1 then index := nColors - 1; Red := RedX[index]; Green := GreenX[index]; Blue := BlueX[index]; end; end; {for} LoadLUT(cTable); LUTMode := PseudoColor32; end; IdentityFunction := false; end; procedure LoadInputLoouupTable;{(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 ControlReg^ < 0 do ; ChannelReg^ := VideoChannel * 64; while ControlReg^ < 0 do ; LoadInputLookupTable(Ptr(DTSlotBase + ilutOffset)); end; procedure GetLookupTable;{(VAR table:LookupTable)} var i, r, g, b: integer; GrayscaleImage: boolean; begin with info^ do begin if DensitySlicing then begin for i := 0 to 255 do if (i >= SliceStart) and (i <= SliceEnd) then begin if ThresholdToForeground then table[i] := ForegroundIndex else table[i] := i end else begin if NonThresholdToBackground then table[i] := BackgroundIndex else table[i] := i end; DisableDensitySlice; exit(GetLookupTable); end; if (LutMode = GrayScale) or (LutMode = CustomGrayscale) then for i := 0 to 255 do table[i] := 255 - BSR(cTable[i].RGB.red, 8) else begin table[0] := 0; for i := 1 to 254 do with cTable[i].RGB do table[i] := 255 - trunc(band(bsr(red, 8), 255) * 0.3 + band(bsr(green, 8), 255) * 0.59 + band(bsr(blue, 8), 255) * 0.11); table[255] := 255; end; end; {with} end; procedure wait;{(ticks:LongInt)} var SaveTicks: LongInt; begin SaveTicks := TickCount + ticks; repeat until TickCount > SaveTicks; end; procedure MakeLine (X1, Y1, X2, Y2: integer); var x: integer; v, temp: integer; begin with info^ do begin if not gmFixedSlope then begin DeltaX := X2 - X1; DeltaY := y2 - y1; end; if Deltax <> 0 then for X := X1 to X2 do with info^.cTable[255 - x].rgb do begin temp := (LongInt(DeltaY) * (x - x1)) div DeltaX + Y1; {Temporary variable needed to avoid range check} v := temp * 256; red := v; green := v; blue := v; end; end; end; procedure MakeHorizontalLine (X1, X2, Y: integer); var x: integer; v: integer; begin for X := X1 to X2 do with info^.cTable[255 - x].rgb do begin v := y * 256; red := v; green := v; blue := v; end; end; procedure SetGrayScaleLUT; begin with info^ do begin MakeHorizontalLine(0, p1x, 0); MakeLine(p1x, p1y, p2x, p2y); MakeHorizontalLine(p2x, 255, 255); LoadLUT(cTable); LUTMode := GrayScale; end; end; procedure CheckColorWidth; begin with info^ do if (ColorStart + ncolors * ColorWidth) > 256 then begin ColorWidth := (256 - ColorStart) div ncolors; if ColorWidth < 1 then ColorWidth := 1; end; end; procedure GetPaletteFromFile;{(fname:str255; vnum:integer)} var PaletteHeader: ColorArray; err, f: integer; size: LongInt; begin err := FSOpen(fname, vnum, f); with info^ do begin size := SizeOf(ColorArray); err := FSRead(f, size, @PaletteHeader); nColors := PaletteHeader[0]; if nColors > MaxPseudocolors then nColors := MaxPseudoColors; ColorStart := PaletteHeader[1]; ColorWidth := PaletteHeader[2]; CheckColorWidth; with PaletteRec do begin err := FSRead(f, size, @RedData); err := FSRead(f, size, @GreenData); err := FSRead(f, size, @BlueData); end; end; err := fsclose(f); PaletteName := fname; end; procedure GetDefaultPalette; var Size: LongInt; pHandle: handle; i: integer; begin with info^ do begin ncolors := 0; pHandle := GetResource('CPAL', 1000); if (ResError <> noErr) or (pHandle = nil) then begin beep; if pHandle <> nil then ReleaseResource(pHandle); exit(GetDefaultPalette) end; Size := GetHandleSize(pHandle); if size = SizeOF(PaletteRec) then begin BlockMove(pHandle^, @PaletteRec, size); ncolors := PaletteRec.NumberOfColors; end; for i := 0 to MaxPseudoColorsLessOne do with PaletteRec do begin RedX[i] := RedData[i] * 255; GreenX[i] := GreenData[i] * 255; BlueX[i] := BlueData[i] * 255; end; LUTMode := PseudoColor32; end; ReleaseResource(pHandle); end; procedure InitColor;{(fname:str255; vnum:integer)} var i: integer; begin with info^ do begin if fname = 'Default' then GetDefaultPalette else begin GetPaletteFromFile(fname, vnum); LUTMode := PseudoColor32; end; for i := 0 to ncolors - 1 do with PaletteRec do begin RedX[i] := RedData[i] * 255; GreenX[i] := GreenData[i] * 255; BlueX[i] := BlueData[i] * 255; end; end; end; function GetScrapCount;{:integer} var ScrapInfo: PScrapStuff; begin ScrapInfo := InfoScrap; GetScrapCount := ScrapInfo^.ScrapCount; end; procedure DisplayText (update: boolean); var tPort: GrafPtr; i, hstart, width, ff: integer; MaskRect: rect; p1, p2: point; begin if (info = NoInfo) or (not IsInsertionPoint) then exit(DisplayText); if update then Undo; GetPort(tPort); SetPort(GrafPtr(Info^.osPort)); 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); Info^.changes := true; end; procedure SetForegroundColor;{(color:integer)} var tPort: GrafPtr; begin if (color >= 0) and (color <= 255) then with info^ do begin ForegroundIndex := color; GetPort(tPort); SetPort(ToolWindow); InvalRect(ToolRect[brush]); if LUTMode = PseudoColor32 then CurrentColorIndex := GetColorIndex; if osPort <> nil then begin SetPort(GrafPtr(osPort)); pmForeColor(ForegroundIndex); end; SetPort(tPort); if isInsertionPoint then DisplayText(true); end; end; procedure SetBackgroundColor;{(color:integer)} var tPort: GrafPtr; begin if (color >= 0) and (color <= 255) then with info^ do begin BackgroundIndex := color; GetPort(tPort); SetPort(ToolWindow); InvalRect(ToolRect[eraser]); if osPort <> nil then begin SetPort(GrafPtr(osPort)); pmBackColor(BackgroundIndex); end; SetPort(tPort); if isInsertionPoint then DisplayText(true); end; end; function GetColorIndex;{:integer} var CLUTIndex: LongInt; begin CLUTIndex := 255 - ForegroundIndex; with info^ do if (CLUTIndex < ColorStart) or (CLUTIndex > (ColorStart + nColors * ColorWidth)) then begin GetColorIndex := NoColor end else GetColorIndex := (CLUTIndex - ColorStart) div ColorWidth; 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; begin OffScreenToScreenRect(MaskRect); with Info^ do if info <> NoInfo then begin getPort(tPort); SetPort(wptr); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); imag := trunc(magnification); InsetRect(MaskRect, -imag * 2 * LineWidth, -imag * 2 * LineWidth); InsetRect(MaskRect, 0, 0); RectRgn(MaskRgn, MaskRect); hlock(handle(osPort^.portPixMap)); hlock(handle(CGrafPort(wptr^).PortPixMap)); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, BitMapHandle(CGrafPort(wptr^).PortPixMap)^^, SrcRect, wrect, SrcCopy, MaskRgn); hunlock(handle(osPort^.portPixMap)); hunlock(handle(CGrafPort(wptr^).PortPixMap)); SetPort(tPort); 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); RoiShowing := true; measuring := false; WhatToUndo := NothingToUndo; 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:integer):integer} var offset: LongInt; p: ptr; begin with Info^ do begin if (h < 0) or (v < 0) or (h >= PixelsPerLine) or (v >= nlines) then begin MyGetPixel := WhiteIndex; exit(MyGetPixel); end; offset := LongInt(v) * BytesPerRow + h; if offset >= PixMapSize then exit(MyGetPixel); p := ptr(ord4(PicBaseAddr) + offset); MyGetPixel := BAND(p^, 255); end; end; procedure PutPixel;{(h,v,value:integer)} type uptr = ^UnsignedByte; var offset: LongInt; p: ptr; begin with Info^ do begin if (h < 0) or (v < 0) or (h >= PixelsPerLine) or (v >= nlines) then exit(PutPixel); offset := LongInt(v) * BytesPerRow + h; p := ptr(ord4(PicBaseAddr) + offset); p^ := BAND(value, 255); end; end; procedure GetLine;{(h,v,count:integer; VAR line:LineType)} var offset: LongInt; p: ptr; begin with Info^ do begin if (h < 0) or (v < 0) or ((h + count) > PixelsPerLine) or (v >= nlines) then begin line := BlankLine; exit(GetLine); end; offset := LongInt(v) * BytesPerRow + h; p := ptr(ord4(PicBaseAddr) + offset); BlockMove(p, @line, count); end; end; procedure GetColumn;{(hstart,vstart,count:integer; VAR data:LineType)} var i, v: integer; begin if count > MaxPixelsPerLine then count := MaxPixelsPerLine; v := vstart; for i := 0 to count - 1 do begin data[i] := MyGetPixel(hstart, v); v := v + 1; end; end; procedure PutColumn;{(hstart,vstart,count:integer; VAR data:LineType)} var i, v: integer; begin if count > MaxPixelsPerLine then count := MaxPixelsPerLine; v := vstart; for i := 0 to count - 1 do begin PutPixel(hstart, v, data[i]); v := v + 1; end; end; procedure PutLine;{(h,v,count:integer; 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 := LongInt(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 := ValuesHStart; vstart := ValuesVStart; GetPort(tPort); SetPort(ResultsWindow); 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 Show2CalibratedValues; {(x, y: LongInt; ShowUncalibrated: boolean)} var tPort: GrafPtr; hstart, vstart, ivalue: integer; begin hstart := ValuesHStart; vstart := ValuesVStart; GetPort(tPort); SetPort(ResultsWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); MoveTo(xValueLoc, vstart); DrawLong(x); DrawString(' '); MoveTo(yValueLoc, vstart + 10); if info^.Calibrated then begin DrawReal(cvalue[y], 5, 2); if ShowUncalibrated then begin DrawString(' ('); DrawLong(y); DrawString(')'); end; end else DrawLong(y); DrawString(' '); SetPort(tPort); end; procedure Show2Values (current, total: LongInt); var tPort: GrafPtr; hstart, vstart, ivalue: integer; begin hstart := ValuesHStart; vstart := ValuesVStart; GetPort(tPort); SetPort(ResultsWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); MoveTo(xValueLoc, vstart); DrawLong(current); DrawString(' '); MoveTo(yValueLoc, vstart + 10); DrawLong(total); DrawString(' '); SetPort(tPort); end; procedure DrawDimension (x: integer); begin with info^ do begin if SpatialScale <> 0.0 then begin DrawReal(x / SpatialScale, 5, 2); DrawString(units); DrawString(' ('); DrawReal(x, 3, 0); DrawString(')') end else DrawLong(x); DrawString(' '); end; end; procedure Show3Values;{(hloc,vloc,ivalue:LongInt)} var tPort: GrafPtr; hstart, vstart: integer; begin with info^ do begin hstart := ValuesHStart; vstart := ValuesVStart; GetPort(tPort); SetPort(ResultsWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); if hloc < 0 then hloc := -hloc; MoveTo(xValueLoc, vstart); DrawDimension(hloc); if InvertYCoordinates and (ivalue >= 0) then vloc := PicRect.bottom - vloc - 1; if vloc < 0 then vloc := -vloc; MoveTo(yValueLoc, vstart + 10); DrawDimension(vloc); DrawString(' '); if ivalue >= 0 then begin MoveTo(zValueLoc, vstart + 20); if Calibrated then begin DrawReal(cvalue[ivalue], 5, 2); DrawString(' ('); DrawLong(ivalue); DrawString(')'); end else DrawLong(ivalue); end; DrawString(' '); SetPort(tPort); end; end; procedure Show3RealValues;{(X,Y:LongInt; Z:extended)} var tPort: GrafPtr; hstart, vstart, ivalue: integer; begin with info^ do begin hstart := ValuesHStart; vstart := ValuesVStart; GetPort(tPort); SetPort(ResultsWindow); TextSize(9); TextFont(Monaco); TextMode(SrcCopy); MoveTo(xValueLoc, vstart); DrawDimension(x); MoveTo(yValueLoc, vstart + 10); DrawDimension(y); MoveTo(zValueLoc, vstart + 20); if SpatialScale <> 0.0 then begin DrawReal(z / SpatialScale, 5, 2); DrawString(units); DrawString(' ('); DrawReal(z, 1, 2); DrawString(')') end else DrawReal(z, 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^.SpatialScale <> 0.0 then begin PutString(' ('); PutString(info^.Units); 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; 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; 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; PutChar(cr); end; {for} end; {with} end; procedure ShowWatch; begin SetCursor(watch); end; procedure UpdatePicWindow; var tPort: GrafPtr; begin if info <> NoInfo then with Info^ do begin getPort(tPort); SetPort(wptr); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); hlock(handle(osPort^.portPixMap)); hlock(handle(CGrafPort(wptr^).PortPixMap)); CopyBits(BitMapHandle(osPort^.portPixMap)^^, BitMapHandle(CGrafPort(wptr^).PortPixMap)^^, SrcRect, wrect, SrcCopy, nil); hunlock(handle(osPort^.portPixMap)); hunlock(handle(CGrafPort(wptr^).PortPixMap)); SetPort(tPort); RoiUpdateTime := 0; end; end; procedure DoOperation;{(Operation:OpType)} var tPort: GrafPtr; loc: point; width, height: integer; tRect: rect; begin GetPort(tPort); with Info^ do begin changes := true; SetPort(GrafPtr(osPort)); PenNormal; PenSize(LineWidth, LineWidth); case Operation of InvertOp: InvertRgn(roiRgn); PaintOp: PaintRgn(roiRgn); FrameOp: FrameRgn(roiRgn); EraseOp: EraseRgn(roiRgn); PasteOp: Paste; otherwise end; if not RoiShowing then UpdateScreen(RoiRect); if PixMapSize > UndoBufSize then OpPending := false; end; SetPort(tPort); end; procedure SaveRoi; begin with info^ do if RoiType <> noRoi then begin NoInfo^.roiType := roiType; NoInfo^.RoiRect := RoiRect; CopyRgn(roiRgn, NoInfo^.roiRgn); end; end; procedure KillRoi; begin with info^ do begin if RoiShowing then begin if OpPending then begin OpPending := false; DoOperation(CurrentOp); end; SaveRoi; RoiShowing := false; UpdateScreen(RoiRect); end; RoiType := NoRoi; RoiUpdateTime := 0; end; 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) and (QuickCaptureInfo <> nil) and (PictureType <> QuickCaptureType) then begin ControlReg^ := BitAnd($80, 255); {Start frame capture} while ControlReg^ < 0 do ; {Wait for it to complete} srcPort := qcPort; 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 if info = NoInfo then begin CurrentUndoSize := 0; exit(SetupUndo) end; if info^.PixMapSize > UndoBufSize then begin CurrentUndoSize := 0; WhatToUndo := NothingToUndo; exit(SetupUndo) end; with info^ do begin 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 if info = NoInfo then begin CurrentUndoSize := 0; WhatToUndo := NothingToUndo; exit(SetupUndoFromClip) end; if info^.PixMapSize > ClipBufSize then begin CurrentUndoSize := 0; WhatToUndo := NothingToUndo; exit(SetupUndoFromClip) end; with info^ do begin if OpPending then begin DoOperation(CurrentOp); OpPending := false; end; CurrentUndoSize := PixMapSize; BlockMove(PicBaseAddr, ClipBuf, PixMapSize); end; WhatsOnClip := nothing; 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 the 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; function NotInBounds;{:boolean} begin NotInBounds := false; with info^, info^.RoiRect do if RoiShowing then 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; 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; procedure PutMemoryAlert; begin PutMessage('Sorry, but there is not enough memory available to open this image. Try closing some windows.'); 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 := 4000000; PurgeMem(size); size := CompactMem(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 GetImageMemory (SaveInfo: infoPtr; var PicBaseHandle: handle; double: boolean): 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.} {Would you believe up to 10 seconds when many windows are open?} const MinFree = 100000; var h: handle; FreeMem, 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; if double then NeededSize := NeededSize * 2; h := NewHandle(NeededSize); end; FreeMem := MaxBlock; if (h = nil) or (FreeMem < MinFree) then begin if h <> nil then DisposHandle(h); CompactMemory; h := NewHandle(NeededSize); FreeMem := MaxBlock; end; if (h = nil) or (FreeMem < MinFree) then begin if h <> nil then DisposHandle(h); PutMemoryAlert; DisposPtr(pointer(Info)); Info := SaveInfo; GetImageMemory := nil; exit(GetImageMemory); end; PicBaseHandle := h; hlock(PicBaseHandle); GetImageMemory := StripAddress(PicBaseHandle^); end; function OldGetMemory (Size: LongInt; SaveInfo: infoPtr; var PicBaseHandle: handle): ptr; const MinFree = 100000; var h1, h2: handle; begin h1 := NewHandle(size); h2 := NewHandle(MinFree); if (h1 = nil) or (h2 = nil) then begin if h1 <> nil then DisposHandle(h1); if h2 <> nil then DisposHandle(h2); CompactMemory; h1 := NewHandle(size); h2 := NewHandle(MinFree); end; if (h1 = nil) or (h2 = nil) then begin if h1 <> nil then DisposHandle(h1); if h2 <> nil then DisposHandle(h2); PutMemoryAlert; DisposPtr(pointer(Info)); Info := SaveInfo; OldGetMemory := nil; exit(OldGetMemory); end; DisposHandle(h2); PicBaseHandle := h1; hlock(PicBaseHandle); OldGetMemory := PicBaseHandle^; 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, Plot3DItem, 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 div 1024, SizeStr); str := concat(fname, ' ', SizeStr, 'K'); AppendMenu(WindowsMenuH, ' '); SetItem(WindowsMenuH, nPics + WindowsMenuItems, str); InsertMenu(WindowsMenuH, 0); end; end; procedure InvertGrayLevels; begin with info^ do begin calibrated := true; nCoefficients := 2; fit := StraightLine; Coefficient[1] := 255.0; Coefficient[2] := -1.0 end; end; procedure MakeNewWindow;{(name:str255)} var wwidth, wheight, wleft, wtop, i: integer; tPort: GrafPtr; rgb: RGBColor; err: OSErr; begin with Info^ do begin 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 - 5; wheight := nlines; if (wtop + wheight) > ScreenHeight then wheight := ScreenHeight - wtop - 5; SetRect(wrect, wleft, wtop, wleft + wwidth, wtop + wheight); wptr := NewCWindow(nil, wrect, name, true, DocumentProc + ZoomDocProc, nil, true, 0); GetPort(tPort); SetPort(wptr); SetPalette(wptr, ExplicitPalette, false); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); SetRect(wrect, 0, 0, wwidth, wheight); SetRect(PicRect, 0, 0, PixelsPerLine, nlines); SelectWindow(wptr); WindowPeek(wptr)^.WindowKind := PicKind; WindowPeek(wptr)^.RefCon := ord4(Info); title := name; ExtendWindowsMenu(name, ImageSize, wptr); PicNum := nPics; new(osPort); OpenCPort(osPort); with osPort^ do begin with PortPixMap^^ do begin BaseAddr := PicBaseAddr; bounds := PicRect; end; PortRect := PicRect; RectRgn(visRgn, PicRect); PortPixMap^^.RowBytes := BitOr(BytesPerRow, $8000); end; SetPalette(WindowPtr(osPort), ExplicitPalette, false); pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); 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 not Calibrated and UseZeroForBlack then InvertGrayLevels; Revertable := false; end; WhatToUndo := NothingToUndo; end; procedure MakeRegion; begin with info^ do begin OpenRgn; case RoiType of OvalRoi: FrameOval(RoiRect); RoundRectRoi: FrameRoundRect(RoiRect, OvalSize, OvalSize); RectRoi: FrameRect(RoiRect); otherwise end; CloseRgn(roiRgn) end; end; procedure SelectAll;{(visible:boolean)} var loc: point; tPort: GrafPtr; begin KillRoi; with Info^ do begin RoiType := RectRoi; RoiRect := PicRect; MakeRegion; if visible then begin SetupUndo; WhatToUndo := NothingToUndo; RoiShowing := true; if (magnification > 1.0) and not ScaleToFitWindow then Unzoom; 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; 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; function NewPicWindow;{(name:str255; width,height:integer):boolean} var iptr: ptr; lptr: ^LongInt; SaveInfo: InfoPtr; NeededSize: LongInt; begin NewPicWindow := false; KillOperation; DisableDensitySlice; SaveInfo := Info; iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin DisposPtr(iptr); PutMemoryAlert; exit(NewPicWindow); end; Info := pointer(iptr); info^ := SaveInfo^; with Info^ do begin nlines := height; PixelsPerLine := width; if name = 'Camera' then begin PictureType := QuickCaptureType; QuickCaptureInfo := info; end; PicBaseAddr := GetImageMemory(SaveInfo, PicBaseHandle, false); if PicBaseAddr = nil then exit(NewPicWindow); PicLeft := PicLeftBase; PicTop := PicTopBase; MakeNewWindow(name); if name <> 'Camera' then PictureType := NewPicture; SelectAll(false); DoOperation(EraseOp); RoiType := NoRoi; 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 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); ShowMagnification; 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 ShowMagnification; {Updates the window title bar to show the current magnification.} var str: str255; begin with info^ do begin if (magnification = 1.0) and not ScaleToFitWindow then str := title else begin if ScaleToFitWindow then begin RealToString(magnification, 1, 2, str); str := concat(title, ' (', str, ')'); end else begin RealToString(magnification, 1, 0, str); str := concat(title, ' (', str, ':1)'); end; end; SetWTitle(wptr, str); end; 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); ShowMagnification; if WhatToUndo = UndoZoom then WhatToUndo := NothingToUndo; ShowRoi; end; end; function FindMedian;{(VAR a:SortArray):integer} {Finds the 5th largest of 9 values} var i, j, mj, max: integer; begin for i := 1 to 4 do begin max := 0; mj := 1; for j := 1 to 9 do if a[j] > max then begin max := a[j]; mj := j; end; a[mj] := 0; end; max := 0; for j := 1 to 9 do if a[j] > max then max := a[j]; FindMedian := max; end; procedure DrawBString;{(str:string)} begin TextFace([bold]); DrawString(str); TextFace([]); end; procedure PutWarning; var BufSizeStr: str255; begin NumToString(UndoBufSize div 1024, BufSizeStr); PutMessage(concat('This image is larger than the ', BufSizeStr, '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.} begin SetupUndo; UndoFromClip := true; info^.RoiShowing := true; 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 calibrated 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.000001; 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; end; cvalue[i] := y; if y > MaxValue then MaxValue := y; if y < MinValue then MinValue := y; 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; ShowMagnification; end; {with} end; function TooWide: boolean; var SelectionTooWide: boolean; MaxWidth: str255; begin with info^.RoiRect do SelectionTooWide := (right - left) > MaxPixelsPerLine; if SelectionTooWide then begin NumToString(MaxPixelsPerLine, MaxWidth); PutMessage(concat('This operation does not support selections wider than ', MaxWidth, ' pixels.')); end; TooWide := SelectionTooWide; end; procedure DrawText (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 < MaxRegions 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; end.