Celestin Apprentice 2

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Pascal / Applications / NIH Image 1.55 / Source / Edit.p < prev next >

Wrap

Text File | 1994-04-20 | 52.4 KB | 1,841 lines | [TEXT/PJMM]

re DoSprayCan; procedure DoBrush (event: EventRecord); procedure DoText (loc: point); procedure SetSprayCanSize; procedure SetBrushSize; procedure SetLineWidth; 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 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 > 40000 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, isStack: boolean; begin if NotRectangular or NotInBounds then exit(RotateToNewWindow); AutoSelectAll := not Info^.RoiShowing; isStack := info^.StackInfo <> nil; 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 and not isStack 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 item = cancel then exit(Rotate); 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 := NothingOnClip; 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 = FrameGrabberType 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; if WhichWindow = nil then exit(CopyWindow); 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 := NothingOnClip; 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; var err: OSErr; begin CopyResultsToBuffer(1, mCount, ShowHeadings); UnsavedResults := false; err := ZeroScrap; if err = NoErr then begin err := PutScrap(TextBufSize, 'TEXT', ptr(TextBufP)); WhatsOnClip := NothingOnClip; {The text is on the System Scrap} end; 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; CopyText: DoTextCopy; otherwise beep; end; end; procedure DoCut; begin 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; en DisposHandle(phandle); end; procedure PasteText; var nTextLines, LineWidth, MaxLineWidth, MaxRectWidth, MaxRectHeight: integer; LineStart, LineEnd, height, kind: integer; fwptr: WindowPtr; SaveGDevice: GDHandle; begin fwptr := FrontWindow; if fwptr = nil then exit(PasteText); kind := WindowPeek(fwptr)^.WindowKind; if Kind = TextKind then begin DoTextPaste; exit(PasteText); end; if TextBufSize > 5000 then begin PutMessage('The maximum number of characters that can be pasted is 5000.'); exit(PasteText); end; if (Info = NoInfo) or NoUndo then exit(PasteText); with ClipBufInfo^ do begin SaveGDevice := GetGDevice; SetGDevice(osGDevice); 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); SetGDevice(SaveGDevice); PastePicture; end; procedure DoPaste; var NewScrapCount: integer; begin if ((info = NoInfo) and (WhatsOnClip in [RectPic, NonRectPic, ImportedPic, CameraPic])) then begin if CurrentWindow <> TextKind then begin PutMessage('You must have an image window open to paste.'); exit(DoPaste); end else WhatsOnClip := NothingOnClip; end; RoiUpdateTime := 0; NewScrapCount := GetScrapCount; if NewScrapCount <> OldScrapCount then begin WhatsOnClip := NothingOnClip; OldScrapCount := NewScrapCount; end; case WhatsOnClip of aColor: PasteColor; RectPic, NonRectPic, ImportedPic, CameraPic: PastePicture; TextOnClip: PasteText; LivePic: WhatsOnClip := NothingOnClip; NothingOnClip: begin ConvertSystemClipboard; if (WhatsOnClip = ImportedPic) and (info <> NoInfo) then PastePicture else if WhatsOnClip = textOnClip then PasteText else beep; end; end; end; procedure DoClear; var fwptr: WindowPtr; kind: integer; begin fwptr := FrontWindow; if fwptr = nil then exit(DoClear); kind := WindowPeek(fwptr)^.WindowKind; if Kind = TextKind then begin DoTextClear; exit(DoClear); end; if not NoSelection then begin SetupUndo; WhatToUndo := UndoClear; CurrentOp := EraseOp; OpPending := true; RoiUpdateTime := 0; end; end; procedure ShowClipboard; var width, height, hstart, vstart, i, NewScrapCount: integer; begin NewScrapCount := GetScrapCount; if NewScrapCount <> OldScrapCount then begin WhatsOnClip := NothingOnClip; OldScrapCount := NewScrapCount; end; if WhatsOnClip = NothingOnClip then ConvertSystemClipboard; if (WhatsOnClip = RectPic) or (WhatsOnClip = NonRectPic) or (WhatsOnClip = ImportedPic) or (WhatsOnClip = CameraPic) then with ClipBufinfo^.RoiRect do begin width := right - left; height := bottom - top; if NewPicWindow('Clipboard', width, height) then begin PastePicture; KillRoi; SetupUndo; info^.changes := false; end; end; 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 DoSelection (obj: ObjectType; start, finish: point); var tRect: rect; temp, StartH, StartV, FinishH, FinishV: 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; StartH := round(ScreenToPixmapH(start.h)); StartV := round(ScreenToPixmapV(start.v)); FinishH := round(ScreenToPixmapH(finish.h)); FinishV := round(ScreenToPixmapV(finish.v)); SetRect(tRect, StartH, StartV, FinishH, FinishV); 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 := FreehandRoi; nCoordinates := 0; end; RoiRect := roiRgn^^.rgnBBox; end;{with} measuring := false; end; procedure DoObject; {(obj: ObjectType; event: EventRecord)} var Start, Finish, ScreenStart, ScreenFinish, osStart, osFinish: point; r: rect; DeltaX, DeltaY, switch: integer; Constrain: boolean; StartH, StartV: real; begin SetPort(info^.wptr); if 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); PenSize(1, 1); 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 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: begin MoveTo(start.h, start.v); LineTo(finish.h, finish.v); ShowDxDy(abs(ScreenToPixMapH(finish.h) - StartH), abs(ScreenToPixMapV(finish.v) - StartV)); MoveTo(start.h, start.v); LineTo(finish.h, finish.v); end; Rectangle, SelectionRect: begin if obj = SelectionRect then begin PatIndex := (PatIndex + 1) mod 8; PenPat(pat[PatIndex]); end; Pt2Rect(start, finish, r); FrameRect(r); Show3Values(osfinish.h - osstart.h, osfinish.v - osstart.v, -1); Pt2Rect(start, finish, r); FrameRect(r); end; SelectionOval: begin PatIndex := (PatIndex + 1) mod 8; PenPat(pat[PatIndex]); Pt2Rect(start, finish, r); FrameOval(r); Show3Values(osfinish.h - osstart.h, osfinish.v - osstart.v, -1); Pt2Rect(start, finish, r); 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) or (CurrentTool = PlotTool)) then begin MoveTo(start.h, start.v); LineTo(finish.h, finish.v); with info^ do begin LX1 := StartH; LY1 := StartV; LX2 := ScreenToPixmapH(finish.h); LY2 := ScreenToPixmapV(finish.v); if LX1 > (PicRect.right - 1) then LX1 := PicRect.right - 1; if LY1 > (PicRect.bottom - 1) then LY1 := PicRect.bottom - 1; if LX1 < 0 then LX1 := 0; if LY1 < 0 then LY1 := 0; if LX2 > (PicRect.right - 1) then LX2 := PicRect.right - 1; if LY2 > (PicRect.bottom - 1) then LY2 := PicRect.bottom - 1; if LX2 < 0 then LX2 := 0; if LY2 < 0 then LY2 := 0; end; exit(DoObject); end; DrawObject(obj, start, finish); end; procedure DrawSprayCan (xcenter, ycenter: integer); var i, xoffset, yoffset, nDots: integer; begin nDots := SprayCanDiameter div 4; if nDots < 15 then nDots := 15; for i := 1 to nDots do begin repeat xoffset := random mod SprayCanRadius; yoffset := random mod SprayCanRadius; until xoffset * xoffset + yoffset * yoffset <= SprayCanRadius2; PutPixel(xcenter + xoffset, ycenter + yoffset, ForegroundIndex); end; end; procedure DoSprayCan; {Reference: "Spaying and Smudging", Dick Pountain, Byte, November 1987} var xcenter, ycenter, off: integer; MaskRect: rect; pt: point; begin info^.changes := true; off := SprayCanRadius; 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; DrawSprayCan(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; SaveGDevice: GDHandle; 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; SaveGDevice := GetGDevice; SetGDevice(osGDevice); GetPort(tPort); SetPort(GrafPtr(osPort)); pmForeColor(ForegroundIndex); 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); SetGDevice(SaveGDevice); UpdatePicWindow; WhatToUndo := UndoEdit; end; procedure SetSprayCanSize; var TempSize: integer; Canceled: boolean; begin TempSize := GetInt('Spray can diameter in pixels(2-250):', SprayCanDiameter, Canceled); if Canceled then exit(SetSprayCanSize); if (TempSize > 1) and (TempSize <= 250) then begin SprayCanDiameter := TempSize; SprayCanRadius := SprayCanDiameter div 2; SprayCanRadius2 := SprayCanRadius * SprayCanRadius end else beep; end; procedure SetBrushSize; var TempSize: integer; Canceled: boolean; i, ticks: LongInt; 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; exit(SetBrushSize); ticks := TickCount; for i := 1 to 10000 do PutPixel(100, 100, 50); ShowMessage(concat('ticks=', long2str(TickCount - ticks))); end; procedure SetLineWidth; var TempSize: integer; Canceled: boolean; begin TempSize := GetInt('Line Width in pixels(1..100):', LineWidth, Canceled); if Canceled then exit(SetLineWidth); if (TempSize > 0) and (TempSize <= 100) then begin LineWidth := TempSize; ShowLineWidth; end else beep; end; procedure FindWhatToCopy; var kind: integer; WhichWindow: WindowPtr; begin WhatToCopy := NothingToCopy; WhichWindow := FrontWindow; if WhichWindow = nil then exit(FindWhatToCopy); kind := WindowPeek(WhichWindow)^.WindowKind; if (CurrentTool = PickerTool) and (kind <> TextKind) then WhatToCopy := CopyColor else begin if (kind = PicKind) and measuring and (not macro) then kind := ResultsKind; 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; TextKind: begin TextInfo := TextInfoPtr(WindowPeek(WhichWindow)^.RefCon); if TextInfo <> nil then with TextInfo^.TextTE^^ do if selEnd > selStart then WhatToCopy := CopyText; end; InfoKind, ResultsKind: if mCount > 0 then WhatToCopy := CopyMeasurements; otherwise end; end; end; procedure UpdateEditMenu; var DimUndo, ShowItems: boolean; str: str255; i: integer; begin with info^ do begin if CurrentKind < 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 not (WhatToUndo in [UndoLUT, UndoMeasurement, UndoPoint]) and ((info = NoInfo) or (PixMapSize <> CurrentUndoSize)) 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, (WhatToCopy = CopySelection) or (WhatToCopy = CopyText)); case WhatToCopy of NothingToCopy, CopyText: 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, (WhatToCopy = CopySelection) or (WhatToCopy = CopyText)); ShowItems := (WhatsOnClip <> NothingOnClip) or (OldScrapCount <> GetScrapCount); SetMenuItem(EditMenuH, PasteItem, ShowItems); SetMenuItem(EditMenuH, ShowClipboardItem, ShowItems and (WhatsOnClip <> TextOnClip)); ShowItems := info <> NoInfo; if CurrentKind = TextKind then SetItem(EditMenuH, FillItem, 'Find…') else SetItem(EditMenuH, FillItem, 'Fill'); SetMenuItem(EditMenuH, FillItem, ShowItems or (CurrentKind = TextKind)); SetMenuItem(EditMenuH, InvertItem, ShowItems); SetMenuItem(EditMenuH, DrawBoundaryItem, ShowItems); SetMenuItem(EditMenuH, DrawScaleItem, 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 - width; top := top - (height div divisor); if top < 0 then top := 0; if (top + height) > Info^.PicRect.bottom then top := Info^.picRect.bottom - 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, SizeRect: 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); if kind = PicKind then with info^, SizeRect do begin if ScaleToFitWindow then SizeRect := ScreenBits.bounds else begin right := PicRect.right + 1; bottom := PicRect.bottom + 1; if magnification > 1.0 then begin right := round(right * magnification); bottom := round(bottom * magnification); end; left := 32; top := 32; if left > right then left := right; if top > bottom then top := bottom; end end else SetRect(SizeRect, 64, 48, 2048, 2048); NewSize := GrowWindow(WhichWindow, event.where, SizeRect); if newSize = 0 then exit(DoGrow); if kind = 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 (kind = TextKind) then begin TextInfo := TextInfoPtr(WindowPeek(WhichWindow)^.RefCon); GrowTextWindow(NewSize); 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; UpdateResultsScrollBars; ScrollResultsText; 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} 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 (err = noErr) and ClipTextInBuffer then err := PutScrap(TextBufSize, 'TEXT', ptr(TextBufP)); end; {if err=NoErr} end; ClipboardConverted := true; end; {with} 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.