home *** CD-ROM | disk | FTP | other *** search
Text File | 1992-03-30 | 61.8 KB | 2,382 lines
unit Edit; {Editing routines used by the Image program} interface uses QuickDraw, Palettes, PrintTraps, globals, Utilities, Graphics, Camera, analysis, file1, functions, stacks, Lut; procedure FlipOrRotate (DoWhat: FlipRotateType); procedure RotateToNewWindow (DoWhat: FlipRotateType); procedure Rotate (DoWhat: FlipRotateType); procedure DoCopy; procedure DoCut; procedure DoPaste; procedure DoClear; procedure SetPasteMode (item: integer); procedure DoMouseDownInPasteControl (loc: point); procedure ShowPasteControl; procedure DrawPasteControl; procedure ShowClipboard; procedure DoObject (obj: ObjectType; event: EventRecord); procedure DoAirBrush; procedure DoBrush (event: EventRecord); procedure DoText (loc: point); procedure SetAirbrushSize; procedure SetBrushSize; procedure UpdateEditMenu; procedure ConvertClipboard; procedure ZoomOut; procedure ZoomIn (event: EventRecord); procedure Scroll (event: EventRecord); procedure DoFill (event: EventRecord); procedure DoGrow (WhichWindow: WindowPtr; event: EventRecord); procedure DrawCharacter (ch: char); procedure ConvertSystemClipboard; procedure SetupOperation (item: integer); procedure PastePicture; procedure DoUndo; procedure FindWhatToCopy; procedure DoMath; procedure CopyResults; implementation procedure PivotSelection (var SelectionRect: rect; WindowRect: rect); var OldWidth, NewWidth, OldHeight, NewHeight, hCenter, vCenter, NewLeft, NewTop: integer; begin with SelectionRect do begin OldWidth := right - left; OldHeight := bottom - top; hCenter := left + OldWidth div 2; vCenter := top + OldHeight div 2; end; NewWidth := OldHeight; NewHeight := OldWidth; NewLeft := hCenter - NewWidth div 2; NewTop := vCenter - NewHeight div 2; with WindowRect do begin if (NewLeft + NewWidth) > right then NewLeft := right - NewWidth; if (NewTop + NewHeight) > bottom then NewTop := bottom - NewHeight; if NewLeft < 0 then NewLeft := 0; if NewTop < 0 then NewTop := 0; end; with SelectionRect do begin left := NewLeft; top := NewTop; right := NewLeft + NewWidth; bottom := NewTop + NewHeight; end; end; procedure FlipLine (var LineBuf: LineType; width: integer); var TempLine: LineType; i, WidthLessOne: integer; begin TempLine := LineBuf; WidthLessOne := width - 1; for i := 0 to width - 1 do LineBuf[i] := TempLine[WidthLessOne - i]; end; procedure ScreenToOffscreenRect (var r: rect); var p1, p2: point; begin with r do begin p1.h := left; p1.v := top; p2.h := right; p2.v := bottom; ScreenToOffscreen(p1); ScreenToOffscreen(p2); Pt2Rect(p1, p2, r); end; end; procedure FlipOrRotate; {(DoWhat: FlipRotateType)} var SaveInfo: InfoPtr; width, height, hDst, vSrc, vDst, hSrc, i, inc: integer; LineBuf: LineType; srect, drect, MaskRect: rect; PixelCount: LongInt; AutoSelectAll: boolean; begin if NotRectangular or NotInBounds or NoUndo then exit(FlipOrRotate); AutoSelectAll := not Info^.RoiShowing; if AutoSelectAll then SelectAll(true); if TooWide then exit(FlipOrRotate); ShowWatch; SetupUndoFromClip; SetupUndo; if (DoWhat = RotateLeft) or (DoWhat = RotateRight) then WhatToUndo := UndoRotate else WhatToUndo := UndoFlip; SetupUndoInfoRec; SaveInfo := Info; srect := info^.RoiRect; PixelCount := 0; case DoWhat of RotateLeft, RotateRight: with srect do begin if OptionKeyWasDown then DoOperation(EraseOp); drect := srect; with info^ do begin PivotSelection(drect, PicRect); MaskRect := drect; RoiRect := drect; RectRgn(roiRgn, RoiRect); end; width := right - left; if DoWhat = RotateLeft then begin hDst := drect.left; inc := 1 end else begin hDst := drect.right - 1; inc := -1 end; for vSrc := top to bottom - 1 do begin Info := UndoInfo; GetLine(left, vSrc, width, LineBuf); if DoWhat = RotateLeft then FlipLine(LineBuf, width); Info := SaveInfo; PutColumn(hDst, drect.top, width, LineBuf); hDst := hDst + inc; PixelCount := PixelCount + width; if PixelCount > 10000 then begin UpdateScreen(MaskRect); PixelCount := 0; end; end; end; FlipVertical: with srect do begin MaskRect := srect; width := right - left; vDst := bottom; for vSrc := top to bottom - 1 do begin Info := UndoInfo; GetLine(left, vSrc, width, LineBuf); Info := SaveInfo; vDst := vDst - 1; PutLine(left, vDst, width, LineBuf); end; end; FlipHorizontal: with srect do begin MaskRect := srect; width := right - left; for vSrc := top to bottom - 1 do begin Info := UndoInfo; GetLine(left, vSrc, width, LineBuf); FlipLine(LineBuf, width); Info := SaveInfo; PutLine(left, vSrc, width, LineBuf); PixelCount := PixelCount + width; if PixelCount > 10000 then begin UpdateScreen(MaskRect); PixelCount := 0; end; end; end; end; {case} Info := SaveInfo; with info^ do begin UpdatePicWindow; changes := true; end; SetupRoiRect; if AutoSelectAll then KillRoi; end; procedure RotateToNewWindow (DoWhat: FlipRotateType); var SrcInfo, DstInfo: InfoPtr; Srcwidth, DstWidth, DstHeight, hDst, vSrc, vDst, hSrc, i, inc, ignore: integer; LineBuf: LineType; SourceRect, DstRect: rect; PixelCount: LongInt; AutoSelectAll: boolean; begin if NotRectangular or NotInBounds then exit(RotateToNewWindow); AutoSelectAll := not Info^.RoiShowing; if AutoSelectAll then SelectAll(true); if TooWide then exit(RotateToNewWindow); ShowWatch; SrcInfo := info; with info^, info^.RoiRect do begin SourceRect := RoiRect; SrcWidth := right - left; DstWidth := bottom - top; DstHeight := right - left; if not NewPicWindow(title, DstWidth, DstHeight) then begin KillRoi; if macro then macro := false; exit(RotateToNewWindow) end; DstInfo := info; DstRect := info^.PicRect; end; PixelCount := 0; if DoWhat = RotateLeft then begin hDst := 0; inc := 1 end else begin hDst := DstWidth - 1; inc := -1 end; with SourceRect do for vSrc := top to bottom - 1 do begin Info := SrcInfo; GetLine(left, vSrc, SrcWidth, LineBuf); if DoWhat = RotateLeft then FlipLine(LineBuf, SrcWidth); Info := DstInfo; PutColumn(hDst, 0, SrcWidth, LineBuf); hDst := hDst + inc; PixelCount := PixelCount + SrcWidth; if PixelCount > 20000 then begin UpdatePicWindow; PixelCount := 0; end; end; UpdatePicWindow; info^.changes := true; if AutoSelectAll then with SrcInfo^ do begin Changes := false; ignore := CloseAWindow(wptr); info := DstInfo; end; end; procedure Rotate; {(DoWhat: FlipRotateType)} const NewWindowID = 3; var mylog: DialogPtr; item: integer; NewWindow: boolean; begin with info^, info^.RoiRect do if RoiShowing then NewWindow := ((right - left) > PicRect.bottom) or ((bottom - top) > PicRect.right) else begin RotateToNewWindow(DoWhat); exit(Rotate); end; InitCursor; mylog := GetNewDialog(120, nil, pointer(-1)); SetDialogItem(mylog, NewWindowID, ord(NewWindow)); OutlineButton(MyLog, ok, 16); repeat if item = NewWindowID then begin NewWindow := not NewWindow; SetDialogItem(mylog, NewWindowID, ord(NewWindow)); end; ModalDialog(nil, item); until (item = ok) or (item = cancel); DisposDialog(mylog); if NewWindow then RotateToNewWindow(DoWhat) else FlipOrRotate(DoWhat); end; procedure CopyImage; var err: LongInt; line: integer; begin with info^ do begin if NoUndo then begin WhatsOnClip := Nothing; exit(CopyImage) end; SetupUndo; BlockMove(PicBaseAddr, ClipBuf, PixMapSize); end; with ClipBufInfo^ do begin PixelsPerLine := info^.PixelsPerLine; BytesPerRow := info^.BytesPerRow; nLines := Info^.nLines; RoiRect := info^.RoiRect; roiType := Info^.roiType; PicRect := Info^.PicRect; with osPort^.portPixMap^^ do begin RowBytes := BitOr(BytesPerRow, $8000); bounds := PicRect; end; with osPort^ do begin PortRect := PicRect; RectRgn(visRgn, PicRect); end; if RoiType = RectRoi then begin if info^.PictureType = QuickCaptureType then WhatsOnClip := CameraPic else WhatsOnClip := RectPic end else WhatsOnClip := NonRectPic; CopyRgn(info^.roiRgn, roiRgn); ctable := info^.ctable; end; end; procedure CopyWindow; var tPort: GrafPtr; WindowSize: LongInt; WindowRect: rect; WhichWindow: WindowPtr; kind, ignore: integer; HidingPasteControl: boolean; begin WhichWindow := FrontWindow; WindowRect := WhichWindow^.PortRect; kind := WindowPeek(WhichWindow)^.WindowKind; HidingPasteControl := false; with WindowRect do WindowSize := LongInt(right) * bottom; if kind = LUTKind then WindowRect.bottom := 256; case kind of ProfilePlotKind: begin ConvertPlotToText; ClipTextInBuffer := true; end; CalibrationPlotKind: begin ConvertCalibrationCurveToText; ClipTextInBuffer := true; end; HistoKind, LUTKind, MapKind, ToolKind: begin if PasteControl <> nil then begin ignore := CloseAWindow(PasteControl); HidingPasteControl := true; end; case kind of HistoKind: begin ConvertHistoToText; ClipTextInBuffer := true; DrawHistogram; end; MapKind: DrawMap; LUTKind: DrawLUT; ToolKind: DrawTools; end; {case} end; otherwise end; {case} if NoUndo then begin WhatsOnClip := Nothing; exit(CopyWindow) end; ClipboardConverted := false; with ClipBufInfo^ do begin RoiType := RectRoi; RoiRect := WindowRect; RectRgn(roiRgn, RoiRect); PicRect := WindowRect; PixelsPerLine := WindowRect.right; BytesPerRow := PixelsPerLine; if odd(BytesPerRow) then BytesPerRow := BytesPerRow + 1; nLines := WindowRect.bottom; with osPort^.portPixMap^^ do begin RowBytes := BitOr(BytesPerRow, $8000); bounds := WindowRect; end; with osPort^ do begin PortRect := PicRect; RectRgn(visRgn, PicRect); SetRectRgn(ClipRgn, 0, 0, 30000, 30000); end; WhatsOnClip := RectPic; GetPort(tPort); SetPort(GrafPtr(osPort)); RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); if (kind = ProfilePlotKind) or (kind = CalibrationPlotKind) then begin EraseRect(osPort^.portRect); DrawPlot end else begin hlock(handle(osPort^.portPixMap)); CopyBits(WhichWindow^.PortBits, BitMapHandle(osPort^.portPixMap)^^, WindowRect, WindowRect, SrcCopy, nil); hunlock(handle(osPort^.portPixMap)); end; SetPort(tPort); end; {with} if HidingPasteControl then ShowPasteControl; end; procedure CopyResults; begin CopyResultsToBuffer(1, mCount, ShowHeadings); ClipTextInBuffer := true; WhatsOnClip := TextOnClip; UnsavedResults := false; end; procedure DoCopy; var err: OSErr; begin err := ZeroScrap; OldScrapCount := GetScrapCount; case WhatToCopy of CopyColor: DoCopyColor; CopySelection: begin CopyImage; ClipTextInBuffer := false; ClipboardConverted := false; end; CopyHistogram, CopyPlot, CopyCalibrationPlot, CopyCLUT, CopyGrayMap, CopyTools: CopyWindow; CopyMeasurements: CopyResults; otherwise beep; end; end; procedure DoCut; begin WhatToCopy := CopySelection; DoCopy; DoClear; end; procedure CenterRect (inRect, outRect: rect; var ResultRect: rect); {Creates a new rectangle(ResultsRect) that is the same size as inRect, but centered within outRect.} var width, height, hcenter, vcenter: integer; begin with inRect do begin width := right - left; height := bottom - top; end; with outRect do begin hcenter := left + (right - left) div 2; vcenter := top + (bottom - top) div 2; end; with ResultRect do begin left := hcenter - width div 2; top := vcenter - height div 2; right := left + width; bottom := top + height; end; end; procedure PastePicture; var loc: point; SrcWidth, SrcHeight, DstHeight, DstWidth, dh, dv: integer; DestRect: rect; WindowNotResized: boolean; begin if LivePasteMode or (PasteTransferMode <> SrcCopy) then begin LivePasteMode := false; PasteTransferMode := SrcCopy; if PasteControl <> nil then DrawPasteControl end; with info^ do begin SetupUndo; WhatToUndo := UndoPaste; if RoiShowing then with RoiRect do {Pasting back into selection of same size?} if ((right - left) = (ClipBufInfo^.RoiRect.right - ClipBufInfo^.RoiRect.left)) and ((bottom - top) = (ClipBufInfo^.RoiRect.bottom - ClipBufInfo^.RoiRect.top)) and (ClipBufInfo^.RoiType = RoiType) then begin OpPending := true; CurrentOp := PasteOp; exit(PastePicture) end; with ClipBufInfo^.RoiRect do {Pasting into same size window?} if (PicRect.right = right - left) and (PicRect.bottom = (bottom - top)) and (ClipBufInfo^.RoiType = RectRoi) then begin SelectAll(true); WhatToUndo := UndoPaste; OpPending := true; CurrentOp := PasteOp; exit(PastePicture) end; if RoiShowing or (roiType <> NoRoi) then KillRoi; with ClipBufInfo^.RoiRect do begin SrcWidth := right - left; SrcHeight := bottom - top; end; with SrcRect do begin DstWidth := right - left; DstHeight := bottom - top; end; with initwrect do WindowNotResized := (DstWidth = (right - left)) and (DstHeight = (bottom - top)); if ((SrcWidth > DstWidth) or (SrcHeight > DstHeight)) and WindowNotResized then DestRect := PicRect else DestRect := SrcRect; CenterRect(ClipBufInfo^.RoiRect, DestRect, RoiRect); roiType := ClipBufInfo^.roiType; CopyRgn(ClipBufInfo^.roiRgn, roiRgn); dh := RoiRect.left - roiRgn^^.rgnbbox.left; dv := RoiRect.top - roiRgn^^.rgnbbox.top; OffsetRgn(roiRgn, dh, dv); RoiShowing := true; OpPending := true; CurrentOp := PasteOp; BinaryPic := false; end;{with} end; procedure ConvertSystemClipboard; {Converts system scrape to local scrape.} var phandle: handle; offset, length, size: LongInt; pframe: rect; width, height: integer; tPort: GrafPtr; ScrapInfo: PScrapStuff; begin ScrapInfo := InfoScrap; if ScrapInfo^.ScrapSize <= 0 then exit(ConvertSystemClipboard); phandle := NewHandle(0); length := GetScrap(phandle, 'PICT', offset); if length > 0 then begin ShowWatch; pframe := PicHandle(phandle)^^.PicFrame; with pframe do begin width := right - left; height := bottom - top; size := LongInt(width) * height; if size > ClipBufSize then begin PutMessage('Sorry, but this image is too large to paste.'); DisposHandle(phandle); exit(ConvertSystemClipboard) end; end; with ClipBufInfo^ do begin PixelsPerLine := width; nlines := height; SetRect(PicRect, 0, 0, width, height); RoiRect := PicRect; RectRgn(roiRgn, RoiRect); RoiType := Rectroi; GetPort(tPort); SetPort(GrafPtr(osPort)); BytesPerRow := PixelsPerLine; if odd(BytesPerRow) then BytesPerRow := BytesPerRow + 1; with osPort^.portPixMap^^ do begin RowBytes := BitOr(BytesPerRow, $8000); bounds := PicRect; end; with CGrafPort(osPort^) do begin PortRect := PicRect; RectRgn(visRgn, PicRect); SetRectRgn(ClipRgn, 0, 0, 30000, 30000); end; RGBForecolor(WhiteRGB); PaintRect(PicRect); DrawPicture(PicHandle(phandle), PicRect); SetPort(tPort); end; {with} WhatsOnClip := ImportedPic; end else begin length := GetScrap(phandle, 'TEXT', offset); if (length > 0) and (length < MaxTextBufSize) then begin hlock(phandle); BlockMove(phandle^, ptr(TextBufP), length); hunlock(phandle); TextBufSize := length; WhatsOnClip := TextOnClip; end; end; DisposHandle(phandle); end; procedure PasteText; var nTextLines, LineWidth, MaxLineWidth, MaxRectWidth, MaxRectHeight: integer; LineStart, LineEnd, height: integer; begin if TextBufSize > 5000 then begin PutMessage('The maximum number of characters that can be pasted is 5000.'); exit(PasteText); end; if NoUndo then exit(PasteText); with ClipBufInfo^ do begin SetPort(GrafPtr(osPort)); RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); TextFont(CurrentFontID); TextFace(CurrentStyle); TextSize(CurrentSize); end; with info^ do begin if (not RoiShowing) or (RoiShowing and (RoiType <> RectRoi)) then begin KillRoi; nTextLines := 1; MaxLineWidth := 10; LineStart := 1; LineEnd := 0; repeat LineEnd := LineEnd + 1; if TextBufP^[LineEnd] = CR then begin nTextLines := nTextLines + 1; LineWidth := TextWidth(ptr(TextBufP), LineStart - 1, LineEnd - LineStart); if LineWidth > MaxLineWidth then MaxLineWidth := LineWidth; LineStart := LineEnd; end; until LineEnd >= TextBufSize; if LineEnd > LineStart then begin LineWidth := TextWidth(ptr(TextBufP), LineStart - 1, LineEnd - LineStart); if LineWidth > MaxLineWidth then MaxLineWidth := LineWidth; end; height := nTextLines * CurrentSize + CurrentSize div 4; MaxRectHeight := (PicRect.bottom * 2) div 3; if height > MaxRectHeight then height := MaxRectHeight; MaxLineWidth := MaxLineWidth + CurrentSize div 2; MaxRectWidth := (PicRect.right * 2) div 3; if MaxLineWidth > MaxRectWidth then begin MaxLineWidth := MaxRectWidth; height := MaxRectHeight; end; with RoiRect do begin left := 0; top := 0; right := MaxLineWidth; bottom := height; end; RoiType := RectRoi; MakeRegion; end; CopyImage; WhatsOnClip := TextOnClip; end; SetRectRgn(ClipBufInfo^.osPort^.ClipRgn, 0, 0, 30000, 30000); {Why is this needed?} TextBox(ptr(TextBufP), TextBufSize, ClipBufInfo^.RoiRect, TextJust); PastePicture; end; procedure DoPaste; var NewScrapCount: integer; begin if (info = NoInfo) and (WhatsOnClip <> aColor) then begin PutMessage('You must have an image window open in order to paste.'); exit(DoPaste); end; RoiUpdateTime := 0; NewScrapCount := GetScrapCount; if NewScrapCount <> OldScrapCount then begin WhatsOnClip := Nothing; OldScrapCount := NewScrapCount; end; case WhatsOnClip of AColor: PasteColor; RectPic, NonRectPic, ImportedPic, CameraPic: PastePicture; TextOnClip: PasteText; Nothing: begin ConvertSystemClipboard; if WhatsOnClip = ImportedPic then PastePicture else if WhatsOnClip = textOnClip then PasteText else beep; end; end; end; procedure DoClear; begin if not NoSelection then begin SetupUndo; WhatToUndo := UndoClear; CurrentOp := EraseOp; OpPending := true; RoiUpdateTime := 0; end; end; procedure DoMath; const PixelsPerUpdate = 15000; var nrows, ncols, hSrcStart, vSrcStart, hDstStart, vDstStart: integer; SaveInfo: InfoPtr; h, v, vDst, PixelCount, offset: integer; Src, Dst: LineType; tmp, range, min, max, StartTicks: LongInt; x, xmax, xmin, xrange, xscale: extended; begin if TooWide then exit(DoMath); ShowWatch; OpPending := false; WhatToUndo := UndoPaste; KillRoi; with info^.RoiRect do begin ncols := right - left; nrows := bottom - top; hDstStart := left; vDstStart := top; end; with ClipBufInfo^.RoiRect do begin hSrcStart := left; vSrcStart := top; end; if hDstStart < 0 then begin offset := -hDstStart; hDstStart := 0; hSrcStart := hSrcStart + offset; ncols := ncols - offset; end; if vDstStart < 0 then begin offset := -vDstStart; vDstStart := 0; vSrcStart := vSrcStart + offset; nrows := nrows - offset; end; with info^.PicRect do begin if hDstStart + ncols > right then ncols := right - hDstStart; if vDstStart + nrows > bottom then nrows := bottom - vDstStart; end; SaveInfo := info; vDst := vDstStart; min := 999999; max := -999999; xmin := 999999.0; xmax := -999999.0; StartTicks := TickCount; {First pass to find result range} if ScaleArithmetic then begin for v := vSrcStart to vSrcStart + nRows - 1 do begin Info := ClipBufInfo; GetLine(hSrcStart, v, nCols, Src); Info := SaveInfo; GetLine(hDstStart, vDst, nCols, Dst); case CurrentOp of AddOp: begin for h := 0 to nCols - 1 do begin tmp := Src[h] + Dst[h]; if tmp > max then max := tmp; if tmp < Min then min := tmp; end; end; SubtractOp: begin for h := 0 to nCols - 1 do begin tmp := Dst[h] - Src[h]; if tmp > max then max := tmp; if tmp < Min then min := tmp; end; end; MultiplyOp: begin for h := 0 to nCols - 1 do begin tmp := LongInt(Dst[h]) * Src[h]; if tmp > max then max := tmp; if tmp < min then min := tmp; end; end; DivideOp: begin for h := 0 to nCols - 1 do begin tmp := Src[h]; if tmp = 0 then tmp := 1; x := Dst[h] / tmp; if x > xmax then begin xmax := x; end; if x < xmin then xmin := x; end; end; end; vDst := vDst + 1; end; vDst := vDstStart; if CurrentOp = DivideOp then begin xrange := xmax - xmin; if xrange <> 0.0 then xscale := 256.0 / xrange else xscale := 1; end else range := max - min; end; {if ScaleArithmetic=true} PixelCount := 0; {Second pass to do arithmetic and scaling} for v := vSrcStart to vSrcStart + nRows - 1 do begin Info := ClipBufInfo; GetLine(hSrcStart, v, nCols, Src); Info := SaveInfo; GetLine(hDstStart, vDst, nCols, Dst); case CurrentOp of AddOp: if ScaleArithmetic then for h := 0 to nCols - 1 do begin tmp := Dst[h] + Src[h] - min; if range <> 0 then tmp := tmp * 256 div range else tmp := BackgroundIndex; if tmp > 255 then dst[h] := 255 else dst[h] := tmp; end else for h := 0 to nCols - 1 do begin tmp := Dst[h] + Src[h]; if tmp > 255 then dst[h] := 255 else dst[h] := tmp; end; SubtractOp: if ScaleArithmetic then for h := 0 to nCols - 1 do begin tmp := Dst[h] - Src[h] - min; if range <> 0 then tmp := tmp * 256 div range else tmp := BackgroundIndex; if tmp > 255 then dst[h] := 255 else dst[h] := tmp; end else for h := 0 to nCols - 1 do begin tmp := Dst[h] - Src[h]; if tmp < 0 then dst[h] := 0 else dst[h] := tmp; end; MultiplyOp: if ScaleArithmetic then for h := 0 to nCols - 1 do begin tmp := LongInt(Dst[h]) * Src[h] - min; if range <> 0 then tmp := tmp * 256 div range else tmp := BackgroundIndex; if tmp > 255 then dst[h] := 255 else dst[h] := tmp; end else for h := 0 to nCols - 1 do begin tmp := LongInt(Dst[h]) * Src[h]; if tmp > 255 then dst[h] := 255 else dst[h] := tmp; end; DivideOp: if ScaleArithmetic then for h := 0 to nCols - 1 do begin tmp := Src[h]; if tmp = 0 then tmp := 1; x := Dst[h] / tmp - xmin; if xrange <> 0.0 then tmp := trunc(x * xscale) else tmp := BackgroundIndex; if tmp > 255 then tmp := 255; if tmp < 0 then tmp := 0; dst[h] := tmp; end else for h := 0 to nCols - 1 do begin tmp := Src[h]; if tmp = 0 then tmp := 1; dst[h] := Dst[h] div tmp; end; end; PutLine(hDstStart, vDst, nCols, Dst); vDst := vDst + 1; PixelCount := PixelCount + ncols; if PixelCount > PixelsPerUpdate then begin UpdateScreen(info^.RoiRect); if CommandPeriod then begin UpdateScreen(info^.RoiRect); beep; exit(DoMath) end; PixelCount := 0; end; end; with info^ do begin ShowTime(StartTicks, RoiRect, ''); UpdateScreen(RoiRect); end; end; procedure SetPasteMode (item: integer); var SavePort: GrafPtr; BlendColor: rgbColor; begin if not macro then begin SetForegroundColor(BlackIndex); SetBackGroundColor(WhiteIndex); end; case Item of CopyModeItem: PasteTransferMode := SrcCopy; AndItem: PasteTransferMode := NotSrcBic; {And} OrItem: PasteTransferMode := SrcOr; XorItem: PasteTransferMode := SrcXor; ReplaceItem: PasteTransferMode := Transparent; BlendItem: begin GetPort(SavePort); with BlendColor do begin red := 32767; blue := 32767; green := 32767; end; SetPort(GrafPtr(info^.osPort)); OpColor(BlendColor); SetPort(SavePort); PasteTransferMode := Blend; end; end; {case} end; function GetTransferModeItem: integer; begin case PasteTransferMode of SrcCopy: GetTransferModeItem := CopyModeItem; NotSrcBic: GetTransferModeItem := AndItem; SrcOr: GetTransferModeItem := OrItem; SrcXor: GetTransferModeItem := XorItem; Transparent: GetTransferModeItem := ReplaceItem; Blend: GetTransferModeItem := BlendItem; end; end; procedure DrawPasteControl; const bWidth = 64; bHeight = 14; vinc = 18; bhloc = 114; bvloc = 6; var tPort: GrafPtr; i, hloc, vloc, item: integer; tType: pcItemType; tRect: rect; ItemStr: str255; begin GetPort(tPort); SetPort(PasteControl); with PcItem[1] do begin SetRect(r, 15, 22, 87, 40); itype := pcPopupMenu; str := 'Transfer Mode'; end; with pcItem[2] do begin SetRect(r, 88, 50, 100, 62); itype := pcCheckBox; str := 'Scale Math'; end; with pcItem[3] do begin SetRect(r, 88, 65, 100, 77); itype := pcCheckBox; str := 'Live Paste'; end; hloc := bhloc; vloc := bvloc; tType := pcButton; with pcItem[4] do begin SetRect(r, hloc, vloc, hloc + bWidth, vloc + bHeight); itype := tType; str := 'Add'; end; vloc := vloc + vinc; with pcItem[5] do begin SetRect(r, hloc, vloc, hloc + bWidth, vloc + bHeight); itype := tType; str := 'Subtract'; end; vloc := vloc + vinc; with pcItem[6] do begin SetRect(r, hloc, vloc, hloc + bWidth, vloc + bHeight); itype := tType; str := 'Multiply'; end; vloc := vloc + vinc; with pcItem[7] do begin SetRect(r, hloc, vloc, hloc + bWidth, vloc + bHeight); itype := tType; str := 'Divide'; end; TextFont(SystemFont); TextSize(12); for i := 1 to npcItems do with pcItem[i] do case iType of pcPopupMenu: with r do begin MoveTo(r.left - 10, r.top - 4); DrawString(str); EraseRect(r); FrameRect(r); MoveTo(left + 2, bottom); LineTo(right, bottom); MoveTo(right, top + 2); LineTo(right, bottom); item := GetTransferModeItem; GetItem(TransferModeMenuH, item, ItemStr); MoveTo(left + 13, bottom - 5); DrawString(ItemStr); end; pcCheckBox: with r do begin MoveTo(left - StringWidth(str) - 4, bottom - 2); DrawString(str); EraseRect(r); FrameRect(r); if ((i = 2) and ScaleArithmetic) or ((i = 3) and LivePasteMode) then begin MoveTo(left, top); LineTo(right - 1, bottom - 1); MoveTo(left, bottom - 1); LineTo(right - 1, top); end; end; pcButton: begin FrameRoundRect(r, 6, 6); with r do MoveTo(left + ((right - left) - StringWidth(str)) div 2, bottom - 3); DrawString(str); end; end; {case} SetPort(tPort); end; procedure DoMouseDownInPasteControl; {(loc:point)} var nItem, i, MenuItem: integer; PopupResult: LongInt; MenuLoc: point; tr: rect; begin if not (OpPending and (CurrentOp = PasteOp)) then begin PutMessage('Paste Control is only available during paste operations.'); exit(DoMouseDownInPasteControl); end; SetPort(PasteControl); GlobalToLocal(loc); nItem := 0; for i := 1 to npcItems do if PtInRect(loc, pcItem[i].r) then nitem := i; if nItem > 0 then begin case pcItem[nItem].itype of pcPopUpMenu: with pcItem[1].r, MenuLoc do begin MenuLoc.h := left; MenuLoc.v := top; LocalToGlobal(MenuLoc); PopUpResult := PopupMenuSelect(TransferModeMenuH, v, h, GetTransferModeItem); MenuItem := LoWord(PopUpResult); SetPasteMode(MenuItem); end; pcCheckBox: begin tr := pcItem[nItem].r; InsetRect(tr, 1, 1); FrameRect(tr); if nitem = 2 then ScaleArithmetic := not ScaleArithmetic; if nitem = 3 then LivePasteMode := not LivePasteMode; end; pcButton: begin InvertRoundRect(pcItem[nitem].r, 6, 6); while Button and (nitem > 0) do begin GetMouse(loc); if not PtInRect(loc, pcItem[nitem].r) then begin InvertRoundRect(pcItem[nitem].r, 6, 6); nItem := 0; end; end; end; end; {case} repeat until not button; if nItem > 0 then with pcItem[nitem] do begin case itype of pcPopupMenu: ; pcCheckBox: begin end; pcButton: begin InvertRoundRect(pcItem[nitem].r, 6, 6); if info^.RoiType = RectRoi then begin case nitem of 4: CurrentOp := AddOp; 5: CurrentOp := SubtractOp; 6: CurrentOp := MultiplyOp; 7: CurrentOp := DivideOp; end; DoMath; end; {if} end; {pcButton} end; {case} end; {with} end; {if nitem>0} if LivePasteMode and ((WhatsOnClip <> CameraPic) or (QuickCaptureInfo = nil)) then begin PutMessage('"Live Paste" requires that a rectangular selection be first copied from the Camera window to the Clipboard.'); LivePasteMode := false; end; if LivePasteMode and (info^.PictureType = QuickCaptureType) then begin PutMessage('Live pasting into the Camera window is not supported.'); LivePasteMode := false; end; DrawPasteControl; end; procedure ShowPasteControl; var tPort: GrafPtr; trect: rect; wp: ^WindowPtr; begin SetRect(trect, PasteControlLeft, PasteControlTop, PasteControlLeft + pcwidth, PasteControlTop + pcheight); PasteControl := NewWindow(nil, trect, 'Paste Control', true, rDocProc, nil, true, 0); WindowPeek(PasteControl)^.WindowKind := PasteControlKind; wp := pointer(GhostWindow); wp^ := PasteControl; PasteTransferMode := SrcCopy; LivePasteMode := false; end; procedure ShowClipboard; var width, height, hstart, vstart, i, NewScrapCount: integer; begin NewScrapCount := GetScrapCount; if NewScrapCount <> OldScrapCount then begin WhatsOnClip := Nothing; OldScrapCount := NewScrapCount; end; if WhatsOnClip = Nothing then ConvertSystemClipboard; if (WhatsOnClip = RectPic) or (WhatsOnClip = NonRectPic) or (WhatsOnClip = ImportedPic) or (WhatsOnClip = CameraPic) then with ClipBufinfo^.RoiRect do begin width := right - left; if odd(width) then width := Width - 1; height := bottom - top; if NewPicWindow('Clipboard', width, height) then begin PastePicture; KillRoi; SetupUndo; info^.changes := false; end; end; end; procedure DoSelection (obj: ObjectType; start, finish: point); var tRect: rect; temp: integer; TempRgn: RgnHandle; begin WhatToUndo := NothingToUndo; Info^.RoiShowing := false; RoiUpdateTime := 0; if (start.h = finish.h) or (start.v = finish.v) then exit(DoSelection); if start.h > finish.h then begin temp := start.h; start.h := finish.h; finish.h := temp; end; if start.v > finish.v then begin temp := start.v; start.v := finish.v; finish.v := temp; end; Pt2Rect(start, finish, tRect); ScreenToOffscreenRect(tRect); with info^ do begin RoiShowing := true; if SelectionMode <> NewSelection then TempRgn := NewRgn; OpenRgn; case obj of SelectionOval: begin FrameOval(tRect); roiType := OvalRoi; end; SelectionRect: begin FrameRect(tRect); roiType := RectRoi; end; end; if SelectionMode = NewSelection then CloseRgn(roiRgn) else begin CloseRgn(TempRgn); if RgnNotTooBig(roiRgn, TempRgn) then begin if SelectionMode = AddSelection then UnionRgn(roiRgn, TempRgn, roiRgn) else begin DiffRgn(roiRgn, TempRgn, roiRgn); UpdatePicWindow; end; end; DisposeRgn(TempRgn); if GetHandleSize(handle(roiRgn)) = 10 then roiType := RectRoi else roiType := RgnRoi; end; RoiRect := roiRgn^^.rgnBBox; uLength := 0.0; cLength := 0.0; end;{with} measuring := false; end; function ScreenToPixmapH (hloc: integer): real; begin with info^ do ScreenToPixmapH := SrcRect.left + hloc / magnification; end; function ScreenToPixmapV (vloc: integer): real; begin with info^ do ScreenToPixmapV := SrcRect.top + vloc / magnification; end; procedure DoObject; {(obj: ObjectType; event: EventRecord)} var Start, Finish, ScreenStart, ScreenFinish, osStart, osFinish: point; r: rect; ff, DeltaX, DeltaY, switch, imag: integer; Constrain: boolean; StartH, StartV: real; begin SetPort(info^.wptr); if (obj = PlotLine) or (obj = LineObj) then DrawLabels('DX:', 'DY:', 'Length:') else DrawLabels('Width:', 'Height:', ''); start := event.where; StartH := ScreenToPixmapH(start.h); StartV := ScreenToPixmapV(start.v); osStart := start; ScreenToOffscreen(osStart); finish := start; osFinish := finish; ScreenToOffscreen(osFinish); PenNormal; PenMode(PatXor); with info^ do begin imag := trunc(magnification + 0.5); ff := imag div 2; if (obj = SelectionRect) or (obj = SelectionOval) then PenSize(imag, imag) else PenSize(imag * LineWidth, imag * LineWidth); if (CurrentTool = LineTool) and (LineWidth = 1) then begin PenSize(1, 1); ff := 0; end; end; while button do begin GetMouse(finish); with finish, Info^ do begin if h > wrect.right then h := wrect.right; if v > wrect.bottom then v := wrect.bottom; if h < 0 then h := 0; if v < 0 then v := 0; end; if ShiftKeyDown then begin DeltaX := finish.h - start.h; DeltaY := finish.v - start.v; if (obj = lineObj) or (obj = PlotLine) then begin if abs(DeltaX) > abs(DeltaY) then finish.v := start.v else finish.h := start.h end else begin if ((DeltaX > 0) and (DeltaY < 0)) or ((DeltaX < 0) and (DeltaY > 0)) then switch := -1 else switch := 1; if abs(DeltaX) > abs(DeltaY) then finish.h := start.h + switch * DeltaY else finish.v := start.v + switch * DeltaX; end; end; osFinish := finish; ScreenToOffscreen(osfinish); case obj of LineObj, PlotLine: begin MoveTo(start.h - ff, start.v - ff); LineTo(finish.h - ff, finish.v - ff); ShowDxDy(abs(ScreenToPixMapH(finish.h) - StartH), abs(ScreenToPixMapV(finish.v) - StartV)); MoveTo(start.h - ff, start.v - ff); LineTo(finish.h - ff, finish.v - ff); end; Rectangle, SelectionRect: begin if obj = SelectionRect then begin PatIndex := (PatIndex + 1) mod 8; PenPat(pat[PatIndex]); end; Pt2Rect(start, finish, r); OffsetRect(r, -ff, -ff); FrameRect(r); Show3Values(osfinish.h - osstart.h, osfinish.v - osstart.v, -1); Pt2Rect(start, finish, r); OffsetRect(r, -ff, -ff); FrameRect(r); end; SelectionOval: begin PatIndex := (PatIndex + 1) mod 8; PenPat(pat[PatIndex]); Pt2Rect(start, finish, r); OffsetRect(r, -ff, -ff); FrameOval(r); Show3Values(osfinish.h - osstart.h, osfinish.v - osstart.v, -1); Pt2Rect(start, finish, r); OffsetRect(r, -ff, -ff); FrameOval(r); end; end; {case} end; {while button} if (obj = SelectionRect) or (obj = SelectionOval) then begin DoSelection(obj, start, finish); exit(DoObject); end; if (obj = LineObj) and (CurrentTool = LineTool) then begin MoveTo(start.h - ff, start.v - ff); LineTo(finish.h - ff, finish.v - ff); with info^ do begin LX1 := StartH; LY1 := StartV; LX2 := ScreenToPixmapH(finish.h); LY2 := ScreenToPixmapV(finish.v); end; exit(DoObject); end; if obj = PlotLine then begin DoProfilePlot(osStart, osFinish); exit(DoObject) end; DrawObject(obj, start, finish); end; procedure DrawAirBrush (xcenter, ycenter: integer); var i, xoffset, yoffset, nDots: integer; begin nDots := AirBrushDiameter div 4; if nDots < 15 then nDots := 15; for i := 1 to nDots do begin repeat xoffset := random mod AirBrushRadius; yoffset := random mod AirBrushRadius; until xoffset * xoffset + yoffset * yoffset <= AirBrushRadius2; PutPixel(xcenter + xoffset, ycenter + yoffset, ForegroundIndex); end; end; procedure DoAirBrush; {Reference: "Spaying and Smudging", Dick Pountain, Byte, November 1987} var xcenter, ycenter, off: integer; MaskRect: rect; pt: point; begin info^.changes := true; off := AirbrushRadius; repeat GetMouse(pt); ScreenToOffscreen(pt); with MaskRect, pt do begin left := h - off; top := v - off; right := h + off; bottom := v + off; end; with pt do begin xcenter := h; ycenter := v end; DrawAirbrush(xcenter, ycenter); UpdateScreen(MaskRect); until not button; WhatToUndo := UndoEdit; end; procedure DoBrush; {(event: EventRecord)} var r, ScreenRect: rect; p1, p2, p2x, start: point; WhichWindow: WindowPtr; SaveLineWidth, SaveForegroundColor: integer; Constrained, MoreHorizontal, FirstTime: boolean; offset, width: integer; begin SaveLineWidth := LineWidth; p1 := event.where; start := p1; if OptionKeyDown then begin case CurrentTool of Brush, Pencil: GetForegroundColor(event); Eraser: GetBackgroundColor(event); end; if (CurrentTool = Brush) or (CurrentTool = Eraser) then exit(DoBrush); end; case CurrentTool of Pencil: LineWidth := 1; Brush, Eraser: begin if CurrentTool = Brush then width := BrushWidth else width := 16; LineWidth := round(width / info^.magnification); if LineWidth < 1 then LineWidth := 1; end; end; with info^ do offset := round((LineWidth - 1) * info^.magnification / 2.0); if CurrentTool <> Pencil then with p1 do begin h := h - offset; v := v - offset end; Constrained := ShiftKeyDown; FirstTime := true; if CurrentTool = eraser then begin SaveForegroundColor := ForegroundIndex; SetForegroundColor(BackgroundIndex) end; repeat GetMouse(p2); if CurrentTool <> Pencil then with p2 do begin h := h - offset; v := v - offset end; if FirstTime then if not EqualPt(p1, p2) then begin MoreHorizontal := abs(p2.h - p1.h) >= abs(p2.v - p1.v); FirstTime := false; end; if Constrained then if MoreHorizontal then p2.v := p1.v else p2.h := p1.h; if CurrentTool = brush then DrawObject(BrushObj, p1, p2) else DrawObject(LineObj, p1, p2); p1 := p2; until not button; if CurrentTool = Eraser then SetForegroundColor(SaveForegroundColor); LineWidth := SaveLineWidth; WhatToUndo := UndoEdit; end; procedure DrawCharacter; {(ch: char)} var str: str255; begin if Info = NoInfo then begin beep; exit(DrawCharacter) end; if ch = cr then with InsertionPoint do begin h := TextStart.h; v := v + CurrentSize; SetupUndo; TextStr := ''; TextStart := InsertionPoint; exit(DrawCharacter) end; if ch = BackSpace then with InsertionPoint do begin if length(TextStr) > 0 then begin delete(TextStr, length(TextStr), 1); DisplayText(true); end; exit(DrawCharacter) end; str := ' '; {Needed for MPW} str[1] := ch; TextStr := Concat(TextStr, str); DisplayText(true); end; procedure DoText; {(loc: point)} {Handles text tool mouse clicks.} var value: extended; str: str255; isValue: boolean; begin ScreenToOffscreen(loc); with loc do begin InsertionPoint.h := h; InsertionPoint.v := v + 4; end; IsInsertionPoint := true; TextStart := InsertionPoint; TextStr := ''; if OptionKeyDown then with info^ do begin isValue := true; if (PreviousTool = LineTool) and (nLengths > 0) then value := plength^[mCount2] else if (PreviousTool = AngleTool) and (nAngles > 0) then value := orientation^[mCount2] else if mCount > 0 then if AreaM in Measurements then value := mArea^[mCount2] else if MeanM in Measurements then value := mean^[mCount2] else isValue := false; if isValue then begin RealToString(value, 1, precision, str); if mCount2 > 0 then mCount2 := mCount2 - 1; DrawTextString(str, TextStart, TextJust); end; end; WhatToUndo := UndoEdit; end; procedure DoFill (event: EventRecord); var loc: point; MaskBits: BitMap; BitMapSize: LongInt; tPort: GrafPtr; trect: rect; begin ShowWatch; loc := event.where; ScreenToOffscreen(loc); with info^ do begin tRect := PicRect; with tRect do if (right mod 16 <> 0) and not Has32BitQuickDraw then right := (right div 16) * 16 + 16; {Workaround for SeedCFill bug that results in garbage along right edge.} with MaskBits do begin RowBytes := PixelsPerLine div 8 + 1; if odd(RowBytes) then RowBytes := RowBytes + 1; bounds := tRect; BitMapSize := LongInt(rowBytes) * nLines; baseAddr := NewPtr(BitMapSize); if baseAddr = nil then begin beep; exit(DoFill) end; end; GetPort(tPort); SetPort(GrafPtr(osPort)); SeedCFill(BitMapHandle(osPort^.PortPixMap)^^, MaskBits, tRect, tRect, loc.h, loc.v, nil, 0); CopyBits(MaskBits, BitMapHandle(osPort^.PortPixMap)^^, tRect, tRect, SrcOr, nil); DisposPtr(MaskBits.baseAddr); changes := true; end; {with} SetPort(tPort); UpdatePicWindow; WhatToUndo := UndoEdit; end; procedure SetAirbrushSize; var TempSize: integer; Canceled: boolean; begin TempSize := GetInt('Airbrush diameter in pixels(2-362):', AirbrushDiameter, Canceled); if Canceled then exit(SetAirBrushSize); if (TempSize > 1) and (TempSize <= 362) then begin AirbrushDiameter := TempSize; AirbrushRadius := AirbrushDiameter div 2; AirbrushRadius2 := AirbrushRadius * AirBrushRadius end else beep; end; procedure SetBrushSize; var TempSize: integer; Canceled: boolean; begin TempSize := GetInt('Brush Size in pixels(1..99):', BrushWidth, Canceled); if Canceled then exit(SetBrushSize); if (TempSize > 0) and (TempSize < 100) then begin BrushWidth := TempSize; BrushHeight := BrushWidth end else beep; end; procedure FindWhatToCopy; var kind: integer; WhichWindow: WindowPtr; begin WhatToCopy := NothingToCopy; if CurrentTool = PickerTool then WhatToCopy := CopyColor else begin WhichWindow := FrontWindow; kind := WindowPeek(WhichWindow)^.WindowKind; if (kind = PicKind) and measuring then kind := ValuesKind; case kind of PicKind: with info^, info^.RoiRect do if RoiShowing and (left >= 0) and (top >= 0) and (right <= PicRect.right) and (bottom <= PicRect.bottom) then WhatToCopy := CopySelection; HistoKind: WhatToCopy := CopyHistogram; ProfilePlotKind: WhatToCopy := CopyPlot; CalibrationPlotKind: WhatToCopy := CopyCalibrationPlot; LUTKind: if info <> NoInfo then WhatToCopy := CopyCLUT; MapKind: if info <> NoInfo then WhatToCopy := CopyGrayMap; ToolKind: WhatToCopy := CopyTools; ValuesKind, ResultsKind: WhatToCopy := CopyMeasurements; otherwise end; end; end; procedure UpdateEditMenu; var DimUndo, ShowItems: boolean; str: str255; kind, i: integer; WhichWindow: WindowPtr; begin with info^ do begin WhichWindow := FrontWindow; kind := WindowPeek(WhichWindow)^.WindowKind; if kind < 0 then begin {DA is active, so activate Edit menu.} SetItem(EditMenuH, UndoItem, 'Undo'); SetItem(EditMenuH, CutItem, 'Cut'); SetItem(EditMenuH, CopyItem, 'Copy'); SetMenuItem(EditMenuH, UndoItem, true); for i := CutItem to ClearItem do SetMenuItem(EditMenuH, i, true); exit(UpdateEditMenu); end; if (info = NoInfo) and (WhatToUndo <> UndoLUT) then WhatToUndo := NothingToUndo; DimUndo := WhatToUndo = NothingToUndo; SetMenuItem(EditMenuH, UndoItem, not DimUndo); if DimUndo then SetItem(EditMenuH, UndoItem, 'Undo'); case WhatToUndo of UndoEdit: str := 'Editing'; UndoFlip: str := 'Flip'; UndoRotate: str := 'Rotate'; UndoFilter: str := 'Filtering'; UndoPaste: str := 'Paste'; UndoMeasurement, UndoPoint: str := 'Measurement'; UndoTransform: str := 'Transformation'; UndoClear: str := 'Clear'; UndoZoom: str := 'Zoom'; UndoOutline: str := 'Outline'; UndoSliceDelete, UndoFirstSliceDelete: str := 'Delete Slice'; UndoLUT: str := 'LUT Change'; otherwise str := ''; end; SetItem(EditMenuH, UndoItem, concat('Undo ', str)); FindWhatToCopy; if WhatToCopy = CopySelection then str := 'Cut Selection' else str := 'Cut'; SetItem(EditMenuH, CutItem, str); SetMenuItem(EditMenuH, CutItem, RoiShowing); case WhatToCopy of NothingToCopy: str := ''; CopySelection: str := 'Selection'; CopyCLUT: str := 'LUT'; CopyGrayMap: str := 'Gray Map'; CopyTools: str := 'Tools'; CopyPlot: str := 'Plot'; CopyCalibrationPlot: str := 'Calibration Plot'; CopyHistogram: str := 'Histogram'; CopyMeasurements: str := 'Measurements'; CopyColor: str := 'Color'; end; SetItem(EditMenuH, CopyItem, concat('Copy ', str)); SetMenuItem(EditMenuH, CopyItem, WhatToCopy <> NothingToCopy); SetMenuItem(EditMenuH, ClearItem, RoiShowing); ShowItems := (WhatsOnClip <> nothing) or (OldScrapCount <> GetScrapCount); SetMenuItem(EditMenuH, PasteItem, ShowItems); SetMenuItem(EditMenuH, ShowClipboardItem, ShowItems and (WhatsOnClip <> TextOnClip)); ShowItems := info <> NoInfo; for i := FillItem to DrawScaleItem do SetMenuItem(EditMenuH, i, ShowItems); if RoiShowing and EqualRect(RoiRect, PicRect) then SetItem(EditMenuH, SelectAllItem, 'Deselect All') else SetItem(EditMenuH, SelectAllItem, 'Select All'); for i := SelectAllItem to ScaleAndRotateItem do SetMenuItem(EditMenuH, i, ShowItems); for i := RotateLeftItem to FlipHorizontalItem do SetMenuItem(EditMenuH, i, ShowItems); SetMenuItem(EditMenuH, UnZoomItem, ShowItems and ((magnification <> 1.0) or ScaleToFitWindow)); end; {with} end; procedure ZoomOut; var Width, Height, divisor, NewWidth, NewHeight: integer; OldMagnification, xratio, yratio: extended; begin with Info^ do begin if magnification < 2.0 then begin beep; exit(ZoomOut) end; OldMagnification := magnification; if magnification = 2.0 then begin magnification := 1.0; divisor := 4 end else if magnification = 3.0 then begin magnification := 2.0; divisor := 6 end else if magnification = 4.0 then begin magnification := 3.0; divisor := 8 end else begin magnification := magnification / 2.0; divisor := 4 end; if EqualRect(SrcRect, PicRect) then begin {Make window smaller} NewWidth := trunc(PicRect.right * magnification); NewHeight := trunc(PicRect.bottom * magnification); SizeWindow(wptr, NewWidth, NewHeight, true); wrect.right := NewWidth; wrect.bottom := NewHeight; SrcRect := PicRect; UpdateTitleBar; UpdatePicWindow; DrawMyGrowIcon(wptr); exit(ZoomOut); end; if ((wrect.right > PicRect.right) or (wrect.bottom > PicRect.bottom)) then begin xratio := wrect.right / PicRect.right; yratio := wrect.bottom / PicRect.bottom; if (xratio <> yratio) or ((xratio - trunc(xratio)) <> 0.0) then begin UnZoom; Exit(ZoomOut) end; SrcRect := PicRect; Magnification := xratio; UpdateTitleBar; UpdatePicWindow; DrawMyGrowIcon(wptr); Exit(ZoomOut) end; end; {with} with Info^.SrcRect, info^ do begin if magnification = 1.0 then begin width := wrect.right; height := wrect.bottom; end else begin width := round((right - left) * OldMagnification / Magnification); height := round((bottom - top) * OldMagnification / Magnification); end; left := left - (width div divisor); if left < 0 then left := 0; if (left + width) > Info^.PicRect.right then left := Info^.PicRect.right - round(width); top := top - (height div divisor); if top < 0 then top := 0; if (top + height) > Info^.PicRect.bottom then top := Info^.picRect.bottom - round(height); right := left + width; bottom := top + height; RoiShowing := false; UpdatePicWindow; DrawMyGrowIcon(wptr); UpdateTitleBar; end; ShowRoi; end; procedure DoGrow; {(WhichWindow: WindowPtr; event: EventRecord)} var NewSize: LongInt; trect, WinRect: rect; kind: integer; WasDigitizing: boolean; ZoomCenterH, ZoomCenterV, width, height: extended; begin kind := WindowPeek(WhichWindow)^.WindowKind; if (kind = PicKind) and (info^.PictureType = ScionType) then exit(DoGrow); NewSize := GrowWindow(WhichWindow, event.where, ScreenBits.bounds); if newSize = 0 then exit(DoGrow); if WindowPeek(WhichWindow)^.WindowKind = PicKind then with Info^ do begin SetPort(wptr); WasDigitizing := digitizing; StopDigitizing; InvalRect(wrect); with trect do begin top := 0; left := 0; right := LoWord(NewSize); bottom := HiWord(NewSize); end; if ScaleToFitWindow then begin ScaleImageWindow(trect); wrect := trect; end else begin if trect.right > PicRect.right * magnification then trect.right := trunc(PicRect.right * magnification); if trect.bottom > PicRect.bottom * magnification then trect.bottom := trunc(PicRect.bottom * magnification); wrect := trect; with SrcRect do begin ZoomCenterH := left + (wrect.right / 2.0) / magnification; ZoomCenterV := top + (wrect.bottom / 2.0) / magnification; width := wrect.right / magnification; height := wrect.bottom / magnification; left := round(ZoomCenterH - width / 2.0); if left < 0 then left := 0; if (left + width) > PicRect.right then left := round(PicRect.right - width); top := round(ZoomCenterV - height / 2.0); if top < 0 then top := 0; if (top + height) > PicRect.bottom then top := round(picRect.bottom - height); right := round(left + width); bottom := round(top + height); wrect.right := trunc((right - left) * magnification); wrect.bottom := trunc((bottom - top) * magnification); end; savewrect := wrect; end; SizeWindow(WhichWindow, wrect.right, wrect.bottom, true); WindowState := NormalWindow; if WasDigitizing then StartDigitizing; exit(DoGrow) end; {with info^} if WhichWindow = PlotWindow then begin PlotWidth := LoWord(NewSize); PlotHeight := hiWord(NewSize); SetPort(PlotWindow); SizeWindow(PlotWindow, PlotWidth, Plotheight, true); InvalRect(PlotWindow^.PortRect); exit(DoGrow) end; if WhichWindow = ResultsWindow then begin ResultsWidth := LoWord(NewSize); ResultsHeight := hiWord(NewSize); SetPort(ResultsWindow); with ResultsWindow^.PortRect do SetRect(tRect, right - 12, bottom - 12, right, bottom); EraseRect(trect); {Erase Grow Box} SizeWindow(ResultsWindow, ResultsWidth, ResultsHeight, true); MoveControl(hScrollBar, -1, ResultsHeight - ScrollBarWidth); MoveControl(vScrollBar, ResultsWidth - ScrollBarWidth, -1); SizeControl(hScrollBar, ResultsWidth - 13, ScrollBarWidth + 1); SizeControl(vScrollBar, ScrollBarWidth + 1, ResultsHeight - 13); InvalRect(ResultsWindow^.PortRect); with ListTE^^.viewRect do begin right := left + ResultsWidth - ScrollBarWidth - 4; bottom := top + ResultsHeight - ScrollBarWidth; end; UpdateScrollBars; ScrollText; end; end; procedure ZoomIn; {(event: EventRecord)} var width, height, OldMagnification: extended; PicCenterH, PicCenterV, NewWidth, NewHeight: integer; trect: rect; begin if Info = NoInfo then begin beep; exit(ZoomIn) end; if Info^.ScaleToFitWindow then begin PutMessage('The magnifying glass does not work in "Scale to Fit Window" mode.'); exit(ZoomIn) end; if BitAnd(Event.modifiers, OptionKey) = OptionKey then begin ZoomOut; WhatToUndo := NothingToUndo; exit(ZoomIn) end; with Info^ do begin OldMagnification := magnification; if magnification = 1.0 then magnification := 2.0 else if magnification = 2.0 then magnification := 3.0 else if magnification = 3.0 then magnification := 4.0 else begin magnification := magnification * 2.0; if magnification > 64.0 then begin magnification := 64.0; exit(ZoomIn) end; end; if (WindowState = NormalWindow) and EqualRect(SrcRect, PicRect) then {Make window bigger?} with trect do begin NewWidth := trunc(PicRect.right * magnification); NewHeight := trunc(PicRect.bottom * magnification); if NewWidth <= 640 then begin GetWindowRect(wptr, trect); if ((left + NewWidth) <= ScreenWidth) and ((top + NewHeight) <= ScreenHeight) then begin SizeWindow(wptr, NewWidth, NewHeight, true); wrect.right := NewWidth; wrect.bottom := NewHeight; end; end; end; end; {with} with Info^.SrcRect, Info^ do begin PicCenterH := left + round(event.where.h / OldMagnification); PicCenterV := top + round(event.where.v / OldMagnification); width := wrect.right / magnification; height := wrect.bottom / magnification; left := PicCenterH - round(width / 2); if left < 0 then left := 0; if (left + width) > PicRect.right then left := PicRect.right - round(width); top := PicCenterV - round(height / 2); if top < 0 then top := 0; if (top + height) > PicRect.bottom then top := picRect.bottom - round(height); right := left + round(width); bottom := top + round(height); wrect.right := trunc((right - left) * magnification); wrect.bottom := trunc((bottom - top) * magnification); SizeWindow(wptr, wrect.right, wrect.bottom, true); RoiShowing := false; UpdatePicWindow; DrawMyGrowIcon(wptr); UpdateTitleBar; WhatToUndo := UndoZoom; ShowRoi; end; {with} end; procedure SynchScroll; var n: integer; TempInfo, SaveInfo: InfoPtr; begin SaveInfo := info; if allsamesize then for n := 1 to nPics do begin TempInfo := pointer(WindowPeek(PicWindow[n])^.RefCon); TempInfo^.SrcRect := info^.SrcRect; TempInfo^.magnification := Info^.magnification; info := TempInfo; UpdatePicWindow; Info := SaveInfo; end else PutMessage('Synchronized scrolling requires all images and all windows to be the same size.'); end; procedure Scroll; {(event: EventRecord)} var hstart, vstart, DeltaH, DeltaV, width, height: integer; loc: point; SaveSR: rect; WasDigitizing: boolean; begin with info^ do begin if ScaleToFitWindow then begin PutMessage('Scrolling does not work in "Scale to Fit Window" mode.'); exit(Scroll) end; WasDigitizing := digitizing; StopDigitizing; with event.where do begin hstart := h; vstart := v end; with SrcRect do begin width := right - left; height := bottom - top end; SaveSR := SrcRect; while StillDown do begin GetMouse(loc); DeltaH := hstart - loc.h; DeltaV := vstart - loc.v; with SrcRect do begin left := SaveSR.left + DeltaH; if left < 0 then left := 0; if (left + width) > PicRect.right then left := PicRect.right - width; right := left + width; top := SaveSR.top + DeltaV; if top < 0 then top := 0; if (top + height) > PicRect.bottom then top := PicRect.bottom - height; bottom := top + height; end; UpdatePicWindow; DrawMyGrowIcon(wptr); end; WhatToUndo := NothingToUndo; ShowRoi; if OptionKeyDown and (nPics > 1) then SynchScroll; if WasDigitizing then StartDigitizing; end; {with info^} end; procedure ConvertClipboard; {Converts local scrape to system scrape when quitting or} {switching to other programs or DAs . } var PicH: PicHandle; frect: rect; err: LongInt; begin PicH := nil; if ((WhatsOnClip = RectPic) or (WhatsOnClip = CameraPic)) and (ClipBuf <> nil) and not ClipboardConverted then with ClipBufInfo^ do begin ShowWatch; SetPort(GrafPtr(osPort)); with RoiRect do SetRect(frect, 0, 0, right - left, bottom - top); ClipRect(frect); LoadLUT(ctable); {Switch to original LUT} RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); PicH := OpenPicture(frect); with osPort^ do begin hlock(handle(portPixMap)); CopyBits(BitMapHandle(portPixMap)^^, BitMapHandle(portPixMap)^^, RoiRect, frect, SrcCopy, nil); hunlock(handle(portPixMap)); end; ClosePicture; if info <> NoInfo then LoadLUT(info^.ctable); {Restore LUT} end; if (PicH <> nil) and (GetHandleSize(handle(PicH)) <= 10) then beep; if (PicH <> nil) or ClipTextInBuffer then begin err := ZeroScrap; if err = NoErr then begin if PicH <> nil then begin hlock(handle(PicH)); err := PutScrap(GetHandleSize(handle(PicH)), 'PICT', handle(PicH)^); hunlock(handle(PicH)); DisposHandle(handle(PicH)); end; if ClipTextInBuffer and (err = noErr) then err := PutScrap(TextBufSize, 'TEXT', ptr(TextBufP)); end; end; ClipboardConverted := true; end; procedure SetupOperation; {(item: integer)} var AutoSelectAll: boolean; begin if NotinBounds then exit(SetupOperation); if (item = 10) then if NoSelection then exit(SetupOperation); StopDigitizing; AutoSelectAll := not Info^.RoiShowing; if AutoSelectAll then SelectAll(true); SetupUndo; WhatToUndo := UndoEdit; case Item of 8: begin CurrentOp := PaintOp; OpPending := true end; 9: begin CurrentOp := InvertOp; OpPending := true end; 10: begin CurrentOp := FrameOp; OpPending := true end; end; if AutoSelectAll then KillRoi; RoiUpdateTime := 0; {Forces outline to be redrawn in scale-to-fit mode.} end; procedure DoUndo; var aok: boolean; begin case WhatToUndo of UndoMeasurement: UndoLastMeasurement(true); UndoPoint: begin Undo; UpdatePicWindow; UndoLastMeasurement(true); WhatToUndo := NothingToUndo; end; UndoZoom: begin ZoomOut; if info^.magnification < 2 then WhatToUndo := NothingToUndo; end; UndoOutLine: begin undo; if WandAutoMeasure then UndoLastMeasurement(true); WhatToUndo := NothingToUndo; UpdatePicWindow; end; UndoSliceDelete, UndoFirstSliceDelete: if info^.StackInfo <> nil then with info^.StackInfo^ do begin if WhatToUndo = UndoFirstSliceDelete then CurrentSlice := 0; aok := AddSlice(false); if aok then begin Undo; UpdatePicWindow; end else if CurrentSlice = 0 then CurrentSlice := 1; end; UndoLUT: begin UndoLutChange; DrawMap; DensitySlicing := false; end; otherwise begin if UndoFromClip then OpPending := false; if not OpPending then undo; WhatToUndo := NothingToUndo; if IsInsertionPoint then begin InsertionPoint := TextStart; TextStr := ''; end; UpdatePicWindow; if OpPending and (CurrentOp = PasteOp) then begin OpPending := false; KillRoi; end; OpPending := false; end; end; {case} end; end. 
