Celestin Apprentice 4

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

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / Pascal / Applications / NIH Image 1.59 / 1.59 Source / File2.p < prev next >

Wrap

Text File | 1995-10-26 | 72.3 KB | 2,571 lines | [TEXT/PJMM]

unit File2; {Routines used by NIH Image for printing plus a few additional File Menu routines.} interface uses Memory, QuickDraw, Packages, Menus, Events, Fonts, Scrap, ToolUtils, Resources, Errors, Palettes, Printing, StandardFile, Folders, globals, Utilities, Graphics, Lut; procedure GetInfo; procedure DoPageSetup; procedure Print (ShowDialog: boolean); procedure SetHalftone; function OpenMacPaint (fname: str255; vnum: integer): boolean; procedure TypeMismatch (fname: str255); procedure SaveAsMacPaint (fname: str255; RefNum: integer); function GetTextFile (var name: str255; var RefNum: integer): boolean; procedure InitTextInput (name: str255; RefNum: integer); procedure GetLineFromText (var rLine: RealLine; var count: integer); function ImportTextFile (name: str255; RefNum: integer): boolean; procedure PlotXYZ; procedure SaveSettings; procedure ExportAsText (fname: str255; RefNum: integer); procedure ExportMeasurements (fname: str255; RefNum: integer); function OpenTiffHeader (f: integer; var DirOffset: LongInt): boolean; function OpenTiffDirectory (f: integer; DirOffset: LongInt; var TiffInfo: TiffInfoRec; Importing: boolean): boolean; procedure SaveTiffColorMap (f: integer; ImageDataSize: LongInt); procedure GetTiffColorMap (f: integer); function SaveTiffDir (f, slines, sPixelsPerLine: integer; SavingSelection: boolean; ctabSize, ImageDataSize: LongInt): OSErr; function RoomForFile (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean; function WriteExtraTiffIFDs (f: integer; ImageDataSize, cTabSize: LongInt): integer; procedure SaveLUT (fname: str255; RefNum: integer); procedure SaveColorTable (fname: str255; RefNum: integer); procedure ExportCoordinates (fname: str255; RefNum: integer); procedure SaveOutline (fname: str255; RefNum: integer); procedure OpenOutline (fname: str255; RefNum: integer); function CheckIO (err: OSerr): integer; function GetTIFFParameters (name: str255; RefNum: integer; var HasColorMap: boolean): boolean; procedure GetXUnits (UnitsKind: UnitsType); procedure GetUnitsKInd (var UnitsKind: UnitsType; var UnitsPerCM: extended); procedure Swap2Bytes (var i: integer); implementation var gstr: str255; {$PUSH} {$D-} procedure PrintErrCheck; var err: integer; ticks: LongInt; begin err := PrError; if err < 0 then beep; end; procedure DoPageSetup; var result: boolean; begin PrOpen; if PrintRecord = nil then begin PrintRecord := THPrint(NewHandle(SizeOF(TPrint))); PrintDefault(PrintRecord); end; if PrError = NoErr then begin result := PrValidate(PrintRecord); result := PrStlDialog(PrintRecord); end; PrClose; end; procedure PrintHalftone; const PostScriptBegin = 190; PostScriptEnd = 191; PostScriptHandle = 192; TextIsPostScript = 194; var HexBufH: handle; hloc, vloc, HexCount, iheight, iwidth, hstart, vstart: integer; Height, Width, eofStr, angle, freq: str255; aLine: LineType; HexBuf: packed array[0..4200] of char; err: OSErr; table: LookupTable; procedure PutHEX (byt: integer); var i, LowByte, HighByte, tmp: integer; h: char; begin if not info^.IdentityFunction then byt := table[byt]; byt := 255 - byt; LowByte := byt mod 16; byt := byt div 16; HighByte := byt mod 16; for i := 1 to 2 do begin if i = 1 then tmp := HighByte else tmp := LowByte; case tmp of 0: h := '0'; 1: h := '1'; 2: h := '2'; 3: h := '3'; 4: h := '4'; 5: h := '5'; 6: h := '6'; 7: h := '7'; 8: h := '8'; 9: h := '9'; 10: h := 'a'; 11: h := 'b'; 12: h := 'c'; 13: h := 'd'; 14: h := 'e'; 15: h := 'f'; end; hexbuf[HexCount] := h; HexCount := HexCount + 1; if HexCount mod 80 = 0 then begin HexBuf[HexCount] := cr; HexCount := HexCount + 1 end; end; end; begin with info^ do begin if not IdentityFunction then GetLookupTable(table); MoveTo(-1, -1); LineTo(-1, -1); {Nothing prints without this dummy dot!} PicComment(PostScriptBegin, 0, nil); {See Tech Note #91} PicComment(TextIsPostScript, 0, nil); NumToString(HalftoneFrequency, freq); NumToString(HalftoneAngle, angle); if HalftoneDotFunction then DrawString(concat(freq, ' ', angle, ' {dup mul exch dup mul add 1 exch sub} setscreen')) else DrawString(concat(freq, ' ', angle, ' {pop} setscreen')); DrawString('0 0 translate'); with RoiRect do begin iwidth := right - left; if iwidth > MaxLine then iwidth := MaxLine; iheight := bottom - top; hstart := left; vstart := top; end; NumToString(iwidth, width); NumToString(iheight, height); DrawString(concat(width, ' ', height, ' scale')); DrawString(concat('/PicStr ', width, ' string def')); DrawString(concat(width, ' ', height, ' 8 [', width, ' 0 0 ', height, ' 0 0]')); DrawString('{currentfile PicStr readhexstring pop} image'); for vloc := vstart to vstart + iheight - 1 do begin GetLine(hstart, vloc, iwidth, aline); HexCount := 0; for hloc := 0 to iwidth - 1 do PutHex(aline[hloc]); HexBuf[HexCount] := cr; HexCount := HexCount + 1; err := PtrToHand(@HexBuf, HexBufH, HexCount); if err <> noErr then exit(PrintHalftone); PicComment(PostScriptHandle, HexCount, HexBufH); DisposeHandle(HexBufH); Show2Values(vloc - vstart, iheight); if CommandPeriod then begin beep; eofStr := chr(4); DrawString(eofStr); exit(PrintHalftone) end; end; end; end; procedure PrintTheImage (PageWidth, PageHeight: integer); var PrintRect: rect; Width, Height: integer; procedure ScaleToFitPage; var hscale, vscale, scale: extended; begin hscale := PageWidth / width; vscale := PageHeight / height; if hscale <= vscale then scale := hscale else scale := vscale; width := trunc(scale * width); height := trunc(scale * height); end; procedure CenterOnPage; begin with PrintRect do begin left := 0; top := 0; if width < PageWidth then left := (PageWidth - width) div 2; if height < PageHeight then top := (Pageheight - height) div 2; right := left + width; bottom := top + height; end; end; begin if isLaserWriter and (not DriverHalftoning) then PrintHalftone else with info^ do begin LoadLUT(cTable); hlock(handle(osPort^.portPixMap)); with RoiRect do begin width := right - left; height := bottom - top; end; if (width > PageWidth) or (height > PageHeight) then ScaleToFitPage; CenterOnPage; if BitAnd(qd.thePort^.portBits.rowBytes, $8000) = $8000 then begin {Assume driver understands Color QD} CopyBits(BitMapHandle(osPort^.portPixMap)^^, BitMapHandle(CGrafPtr(qd.thePort)^.PortPixMap)^^, RoiRect, PrintRect, SrcCopy, nil); end else CopyBits(BitMapHandle(osPort^.portPixMap)^^, qd.thePort^.PortBits, RoiRect, PrintRect, SrcCopy, nil); end; end; procedure PrintTextBuffer (PageHeight: integer; var PrintPort: TPPrPort); const LineInc = 13; var vloc, i, LineCount, CharCount, LinesPerPage, MaxCount: integer; aLine: str255; begin ClipTextInBuffer := false; LinesPerPage := PageHeight div LineInc; vloc := LineInc; LineCount := 0; CharCount := 0; TextFont(Monaco); TextSize(9); if WhatToPrint = PrintText then MaxCount := 85 else MaxCount := 255; i := 1; repeat CharCount := 0; while (TextBufP^[i] <> cr) and (CharCount < MaxCount) and (i <= TextBufSize) do begin CharCount := CharCount + 1; aLine[CharCount] := TextBufP^[i]; i := i + 1; end; if TextBufP^[i] = cr then i := i + 1 else if CharCount = MaxCount then begin while (aLine[CharCount] <> ' ') and (CharCount > (MaxCount - 15)) do begin CharCount := CharCount - 1; i := i - 1; end; if TextBufP^[i] = ' ' then i := i + 1; end; aLine[0] := chr(CharCount); MoveTo(0, vloc); DrawString(aLine); vLoc := vLoc + LineInc; LineCount := LineCount + 1; if LineCount >= LinesPerPage then begin LineCount := 0; if i < TextBufSize then begin PrClosePage(PrintPort); PrintErrCheck; PrOpenPage(PrintPort, nil); vloc := LineInc end; end; until i > TextBufSize; end; procedure DoPrintText (PageHeight: integer; var PrintPort: TPPrPort); var ByteCount: LongInt; begin if TextInfo <> nil then with TextInfo^.TextTE^^ do begin ByteCount := TELength; BlockMove(hText^, ptr(TextBufP), ByteCount); TextBufSize := ByteCount; PrintTextBuffer(PageHeight, PrintPort); end; end; procedure Print (ShowDialog: boolean); var err, i, LinesToPrint: Integer; tPort: GrafPtr; PrintPort: TPPrPort; PrintStatusRec: TPrStatus; prect: rect; result: boolean; begin if WhatToPrint = PrintImage then SelectAll(false); if (WhatToPrint = PrintImage) or (WhatToPrint = PrintSelection) then begin if OpPending then KillRoi; with info^.RoiRect do LinesToPrint := bottom - top; if not DriverHalftoning then begin DrawLabels('Line:', 'Total:', ''); Show2Values(0, LinesToPrint); end; end; GetPort(tPort); PrOpen; if PrintRecord = nil then begin PrintRecord := THPrint(NewHandle(SizeOF(TPrint))); PrintDefault(PrintRecord); end; if PrError = NoErr then begin InitCursor; result := PrValidate(PrintRecord); isLaserWriter := BSR(PrintRecord^^.prStl.wDev, 8) = 3; prect := PrintRecord^^.prInfo.rPage; if ShowDialog then result := PrJobDialog(PrintRecord) else result := true; if not DriverHalftoning then ShowMessage(CmdPeriodToStop); ShowWatch; if result then for i := 1 to PrintRecord^^.PrJob.icopies do begin PrintPort := PrOpenDoc(PrintRecord, nil, nil); PrintErrCheck; Printing := true; PrOpenPage(PrintPort, nil); if PrError = NoErr then case WhatToPrint of PrintImage, PrintSelection: PrintTheImage(prect.right, prect.bottom); PrintMeasurements: begin CopyResultsToBuffer(1, mCount, true); PrintTextBuffer(prect.Bottom, PrintPort); UnsavedResults := false; end; PrintPlot: DrawPlot; PrintHistogram: DrawHistogram; PrintText: DoPrintText(prect.Bottom, PrintPort); end; Printing := false; PrClosePage(PrintPort); PrintErrCheck; PrCloseDoc(PrintPort); PrintErrCheck; if PrintRecord^^.prJob.bJDocLoop = bSpoolLoop then PrPicFile(PrintRecord, nil, nil, nil, PrintStatusRec); end; end; PrClose; SetPort(tPort); if WhatToPrint = PrintImage then KillRoi; ShowMessage(' '); end; procedure SetHalftone; const FrequencyID = 8; AngleID = 10; DotID = 4; LineID = 5; CustomID = 13; var mylog: DialogPtr; item, i, ignore, SaveFrequency, SaveAngle: integer; SaveFunction, SaveCustom: boolean; str: str255; begin SaveFrequency := HalftoneFrequency; SaveAngle := HalftoneAngle; SaveFunction := HalftoneDotFunction; SaveCustom := DriverHalftoning; mylog := GetNewDialog(30, nil, pointer(-1)); SetDNum(MyLog, FrequencyID, HalftoneFrequency); SelectdialogItemText(MyLog, FrequencyID, 0, 32767); SetDNum(MyLog, AngleID, HalftoneAngle); SetDlogItem(mylog, CustomID, ord(not DriverHalftoning)); OutlineButton(MyLog, ok, 16); if HalftoneDotFunction then SetDlogItem(mylog, DotID, 1) else SetDlogItem(mylog, LineID, 1); repeat ModalDialog(nil, item); if item = FrequencyID then begin HalftoneFrequency := GetDNum(MyLog, FrequencyID); DriverHalftoning := false; SetDlogItem(mylog, CustomID, ord(not DriverHalftoning)); end; if item = AngleID then begin HalftoneAngle := GetDNum(MyLog, AngleID); if (HalftoneAngle < 0) or (HalftoneAngle > 180) then begin beep; HalftoneAngle := SaveAngle; end; DriverHalftoning := false; SetDlogItem(mylog, CustomID, ord(not DriverHalftoning)); end; if (item >= DotID) and (item <= LineID) then begin for i := DotID to LineID do SetDlogItem(mylog, i, 0); SetDlogItem(mylog, item, 1); HalftoneDotFunction := item = DotID; DriverHalftoning := false; SetDlogItem(mylog, CustomID, ord(not DriverHalftoning)); end; if item = CustomID then begin DriverHalftoning := not DriverHalftoning; SetDlogItem(mylog, CustomID, ord(not DriverHalftoning)); end; until (item = ok) or (item = cancel); DisposeDialog(mylog); if item = cancel then begin HalftoneFrequency := SaveFrequency; HalftoneAngle := SaveAngle; HalftoneDotFunction := SaveFunction; DriverHalftoning := SaveCustom; end; end; {$POP} procedure GetFileInfo (name: str255; vnum: integer; var DateCreated, LastModified: str255); var FileParmBlock: CInfoPBRec; theErr: OSErr; DateVar, TimeVar: str255; Secs: LongInt; begin DateCreated := ''; with FileParmBlock do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := vnum; ioFVersNum := 0; ioFDirIndex := 0; theErr := PBGetCatInfoSync(@FileParmBlock); {ppc-bug} if theErr = NoErr then begin Secs := ioFlCrDat; IUDateString(Secs, abbrevDate, DateVar); IUTimeString(Secs, true, TimeVar); DateCreated := concat(DateVar, ' ', TimeVar); Secs := ioFlMDDat; IUDateString(Secs, abbrevDate, DateVar); IUTimeString(Secs, true, TimeVar); LastModified := concat(DateVar, ' ', TimeVar); end; end; end; procedure GetVolumnInfo (vnum: integer; var VolumnName: str255; var FreeSpace: LongInt); var theErr: OSErr; str: str255; VolParmBlock: ParamBlockRec; begin VolumnName := ''; with VolParmBlock do begin str := ''; ioVRefNum := vnum; ioNamePtr := @str; ioCompletion := nil; ioVolIndex := -1; theErr := PBGetVInfoSync(@VolParmBlock); {ppc-bug} VolumnName := ioNamePtr^; FreeSpace := ioVAlBlkSiz * ioVFrBlk; end; end; function RoomForFile (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean; var err: OSErr; f: integer; VolumnName: str255; FreeSpace, ExistingFileSize, NeededSize: LongInt; begin with info^ do begin ExistingFileSize := 0; RoomForFile := true; err := fsopen(fname, RefNum, f); if err = 0 then begin err := GetEOF(f, ExistingFileSize); err := fsClose(f); end; if ExistingFileSize <> 0 then begin if SavingSelection then begin NeededSize := sLines; NeededSize := NeededSize * sPixelsPerLine end else NeededSize := ImageSize; if StackInfo <> nil then with StackInfo^ do NeededSize := NeededSize * nSlices + nSlices * SizeOf(StackIFDType); GetVolumnInfo(RefNum, VolumnName, FreeSpace); if (NeededSize - ExistingFileSize + 8192) > FreeSpace then begin PutError('There is not enough free space on this disk to save this image.'); RoomForFile := false; end; end; end; end; procedure GetInfo; var name, str, DateCreated, LastModified, VolumnName, str2: str255; hloc, vloc, InfoWidth, InfoHeight: integer; SaveRoiShowing: boolean; FreeSpace, DataSize: LongInt; SaveForeIndex, SaveBackIndex: integer; ImageInfo, InfoWindowInfo: InfoPtr; x1, y1, x2, y2, ulength, clength: extended; SaveGDevice: GDHandle; procedure NewLine; begin vloc := vloc + 13; MoveTo(hloc, vloc); end; procedure NewParagraph; begin vloc := vloc + 18; MoveTo(hloc, vloc); end; begin InfoWidth := 260; InfoHeight := 260; with info^ do begin if RoiShowing then InfoHeight := InfoHeight + 50; if RoiShowing and (RoiType = LineRoi) then InfoHeight := InfoHeight + 20; if vref <> 0 then InfoHeight := InfoHeight + 60; name := concat('Info About ', title); SaveRoiShowing := RoiShowing; end; SaveForeIndex := ForegroundIndex; SaveBackIndex := BackgroundIndex; SetForegroundColor(BlackIndex); SetBackgroundColor(WhiteIndex); ImageInfo := info; if NewPicWindow(name, InfoWidth, InfoHeight) then with ImageInfo^ do begin InfoWindowInfo := Info; SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(info^.osPort)); TextFont(Geneva); TextSize(9); hloc := 15; vloc := 10; NewLine; DrawBString('Name: '); DrawString(title); NewParagraph; DrawBString('Width: '); DrawXDimension(PixelsPerLine, 0); NewLine; DrawBString('Height: '); DrawYDimension(nlines, 0); if StackInfo <> nil then begin NewLine; DrawBString('Depth: '); DrawLong(StackInfo^.nSlices); end; NewLine; DrawBString('Size: '); if StackInfo <> nil then DataSize := PixMapSize * StackInfo^.nSlices else if DataH <> nil then DataSize := PixMapSize + PixMapSize * SizeOf(real) else DataSize := PixMapSize; DrawLong((DataSize + 511) div 1024); DrawString('K'); NewParagraph; GetFileInfo(title, vref, DateCreated, LastModified); {DateCreated:='';} if DateCreated <> '' then begin DrawBString('Creation Date: '); DrawString(DateCreated); NewLine; DrawBString('Last Modified: '); DrawString(LastModified); NewLine; end; if fileVersion > 0 then begin DrawBString('Version: '); DrawString('Created by NIH Image '); DrawReal(fileVersion / 100.0, 1, 2); NewParagraph; end; DrawBString('Type: '); if StackInfo <> nil then case StackInfo^.StackType of VolumeStack, MovieStack: str := concat('Stack (', long2str(StackInfo^.nSlices), ' slices)'); rgbStack: str := 'RGB color stack'; else ; end else begin case PictureType of NewPicture: str := 'New'; Normal: str := 'Normal'; PictFile: str := 'PICT'; TiffFile: str := 'TIFF'; Leftover: str := 'Left Over'; Imported: begin if DataType = EightBits then str := 'Imported 8-bit image' else str := 'Imported 16-bit image'; end; FrameGrabberType: str := 'Camera'; BlankField: str := 'Blank Field'; otherwise ; end; if BinaryPic then str := concat(str, ' (Binary)'); end; DrawString(str); if StackInfo <> nil then with StackInfo^ do if SliceSpacing <> 0.0 then begin NewLine; DrawBString('Slice Spacing: '); if SpatiallyCalibrated then DrawString(StringOf(SliceSpacing / xScale:1:2, ' ', xunit, ' (', SliceSpacing:1:2, ' pixels)')) else DrawString(StringOf(SliceSpacing:1:2, ' pixels')); end; NewLine; DrawBString('Lookup Table: '); case LutMode of PseudoColor: str := concat('Pseudocolor (', long2str(ncolors), ', ', long2str(ColorStart), '-', long2str(ColorEnd), ')'); GrayScale: str := concat('Grayscale (', long2str(ncolors), ', ', long2str(ColorStart), '-', long2str(ColorEnd), ')'); ColorLut: str := 'Color'; CustomGrayscale: str := 'Custom Grayscale'; otherwise end; DrawString(str); NewLine; DrawBString('Magnification: '); if ScaleToFitWindow then begin DrawReal(magnification, 1, 2); DrawString(' (Scale to Window Mode)') end else begin DrawReal(magnification, 1, 0); DrawString(':1') end; NewLine; DrawBString('Scale: '); if SpatiallyCalibrated then begin DrawReal(xScale, 1, 3); DrawString(' pixels per '); DrawString(xUnit); if PixelAspectRatio <> 1.0 then begin NewLine; DrawBString('Pixel Aspect Ratio: '); DrawReal(PixelAspectRatio, 1, 4); end; end else DrawString('None'); if fit <> uncalibrated then begin NewLine; DrawBString('Unit of Measure: '); if UnitOfMEasure = '' then DrawString('None') else DrawString(UnitOfMeasure) end; NewParagraph; DrawBString('Free RAM: '); DrawLong(FreeMem div 1024); DrawString('K'); NewLine; DrawBString('Largest Free Block: '); DrawLong(MaxBlock div 1024); DrawString('K'); if FrameGrabber <> NoFrameGrabber then begin NewLine; DrawBString('Frame Grabber: '); case FrameGrabber of QuickCapture: begin if fgWidth = 768 then DrawString('50Hz') else DrawString('60Hz'); DrawString(' Data Translation QuickCapture'); end; ScionLG3: begin if fgWidth = 768 then DrawString('50Hz') else DrawString('60Hz'); DrawString(' Scion LG-3 ('); DrawLong(MaxLG3Frames div 2); DrawString(' MB)'); end; ScionAG5: begin if fgWidth = 768 then DrawString('50Hz') else DrawString('60Hz'); DrawString(' Scion AG-5'); end; ScionVG5f: begin if fgWidth = 768 then DrawString('50Hz') else DrawString('60Hz'); DrawString(' Scion VG-5'); end QTvdig: DrawString('QuickTime Video Digitizer'); end; end; NewParagraph; if RoiType <> NoRoi then begin DrawBString('Selection Type: '); case RoiType of PolygonRoi: DrawString('Polygon'); FreehandRoi: DrawString('Freehand'); RectRoi: DrawString('Rectangle'); OvalRoi: DrawString('Oval'); LineRoi: DrawString('Straight Line'); FreeLineOF(f, srcSize); srcSize := srcSize - 512; srcPtr := NewPtr(srcSize); if srcPtr = nil then begin abort; exit(OpenMacPaint); end; err := SetFPos(f, fsFromStart, 512); err := fsRead(f, srcSize, srcPtr); if CheckIO(err) <> noErr then exit(OpenMacPaint); err := fsClose(f); dstPtr := NewPtrClear(MaxUnPackedSize); if dstPtr = nil then begin abort; exit(OpenMacPaint); end; src := srcPtr; dst := dstPtr; for scanLine := 1 to 720 do UnPackBits(src, dst, 72); {bumps both ptrs} DisposePtr(srcPtr); mpArray := mpArrayP(dstPtr); LastLine := 720; BlankLine := true; repeat for i := 1 to 18 do blankLine := BlankLine and (mpArray^[LastLine, i] = 0); if BlankLine then LastLine := LastLine - 1; until (not BlankLine) or (LastLine = 1); LastWord := 18; BlankColumn := true; repeat for i := 1 to LastLine do blankColumn := BlankColumn and (mpArray^[i, LastWord] = 0); if BlankColumn then LastWord := LastWord - 1; until (not BlankColumn) or (LastWord = 1); LastColumn := LastWord * 32; LastColumn := LastColumn + 8; if LastColumn > 576 then LastColumn := 576; LastLine := LastLine + 8; if LastLine > 720 then LastLine := 720; SetRect(frect, 0, 0, LastColumn, LastLine); with theBitMap do begin baseAddr := dstPtr; rowBytes := 72; bounds := frect; end; if not NewPicWindow(fname, LastColumn, LastLine) then begin abort; exit(OpenMacPaint); end; SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetForegroundColor(BlackIndex); SetBackgroundColor(WhiteIndex); with info^ do begin CopyBits(theBitMap, BitMapHandle(osPort^.PortPixMap)^^, frect, frect, SrcCopy, nil); DisposePtr(dstPtr); PictureType := imported; BinaryPic := true; SetGDevice(SaveGDevice); if PixMapSize > UndoBufSize then PutWarning; end; OpenMacPaint := true; end; procedure TypeMismatch (fname: str255); begin PutError(concat('The file "', fname, '" is a different type, and therefore cannot be replaced')); end; procedure SaveAsMacPaint (fname: str255; RefNum: integer); const MaxFileSize = 53072; { maximum MacPaint file size. } var TheInfo: FInfo; dstPtr, srcPtr, mpBufPtr: Ptr; i, f, scanLine, err, width, height: integer; dstBuffer: array[1..128] of LongInt; size, dstSize: LongInt; theBitMap: BitMap; mprect, srect, drect: rect; procedure abort; begin beep; if mpBufPtr <> nil then DisposePtr(mpBufPtr); if f <> -1 then err := fsclose(f); {exit(SaveAsMacPaint);} {ppc-bug} end; begin f := -1; err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: with TheInfo do begin if fdType <> 'PNTG' then begin TypeMismatch(fname); exit(SaveAsMacPaint) end; end; FNFerr: begin err := create(fname, RefNum, 'MPNT', 'PNTG'); if CheckIO(err) <> 0 then exit(SaveAsMacPaint); end; otherwise if CheckIO(err) <> 0 then exit(SaveAsMacPaint); end; mpBufPtr := NewPtrClear(MaxFileSize); if mpBufPtr = nil then begin abort; exit(SaveAsMacPaint); end; ShowWatch; SetRect(mprect, 0, 0, 576, 720); with theBitMap do begin baseAddr := mpBufPtr; rowBytes := 72; bounds := mprect; end; with info^ do begin if roiShowing then srect := RoiRect else srect := PicRect; with srect do begin width := right - left; height := bottom - top; if width > 576 then width := 576; if height > 720 then height := 720; right := left + width; bottom := top + height; end; SetRect(drect, 0, 0, width, height); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, theBitMap, srect, drect, srcCopy, nil); end; err := fsOpen(fname, RefNum, f); if CheckIO(err) <> noErr then begin abort; exit(SaveAsMacPaint); end; for I := 1 to 128 do dstBuffer[I] := 0; Size := 512; err := FSWrite(f, Size, @dstBuffer); if CheckIO(err) <> noErr then begin abort; exit(SaveAsMacPaint); end; srcPtr := theBitMap.baseAddr; for scanLine := 1 to 720 do begin dstPtr := @dstBuffer; { reset the pointer to bottom } PackBits(srcPtr, dstPtr, 72); { bumps both ptrs} dstSize := ord(dstPtr) - ord(@dstBuffer);{calc packed size} err := fsWrite(f, dstSize, @dstBuffer); if CheckIO(err) <> noErr then begin abort; exit(SaveAsMacPaint); end; end; err := fsclose(f); DisposePtr(mpBufPtr); if not info^.RoiShowing then info^.changes := false; end; function GetTextFile (var name: str255; var RefNum: integer): boolean; var where: Point; typeList: SFTypeList; reply: SFReply; err: OSErr; pBlock: WDPBRec; begin where.v := 120; where.h := 120; typeList[0] := 'TEXT'; SFGetFile(Where, '', nil, 1, @typeList, nil, reply); if reply.good then with reply do begin name := fname; RefNum := vRefNum; GetTextFile := true; end else GetTextFile := false; end; procedure GetBuffer; var err: OSErr; count, FilePos: LongInt; begin count := MaxTextBufSize; err := fsread(Textf, count, ptr(TextBufP)); TextBufSize := count; err := GetFPos(Textf, FilePos); if FilePos = TextFileSize then begin TextBufSize := TextBufSize + 1; if TextBufSize > MaxTextBufSize then TextBufSize := MaxTextBufSize; TextBufP^[TextBufSize] := eofChr; err := fsclose(Textf); end; TextIndex := 1; end; function GetByte: char; begin GetByte := TextBufP^[TextIndex]; TextIndex := TextIndex + 1; if TextIndex > MaxTextBufSize then GetBuffer; end; function GetNumber: extended; var c: char; str: str255; begin repeat c := GetByte; if c = tab then begin GetNumber := 0.0; {Assume 0 zero for missing value.} exit(GetNumber); end; if (c = cr) or (c = eofChr) then begin TextEol := true; TextEof := c = eofChr; GetNumber := NoValue; exit(GetNumber); end; until c in ['0'..'9', '-', '.']; Str := ''; while c in ['0'..'9', '+', '-', '.', 'e', 'E'] do begin Str := concat(str, c); c := GetByte; if (c = cr) or (c = eofChr) then begin TextEol := true; TextEof := c = eofChr; end; end; GetNumber := StringToReal(str); end; procedure GetLineFromText (var rLine: RealLine; var count: integer); var n: extended; begin count := 0; if TextEof then exit(GetLineFromText); repeat n := GetNumber; if n <> NoValue then begin count := count + 1; rLine[count] := n; end; until TextEol or (count = MaxLine); TextEol := false; end; procedure InitTextInput (name: str255; RefNum: integer); var err: OSErr; begin err := FSOpen(name, RefNum, Textf); err := GetEof(Textf, TextFileSize); err := SetFPos(Textf, fsFromStart, 0); ShowWatch; if WhatsOnClip = TextOnClip then WhatsOnClip := NothingOnClip; GetBuffer; TextEol := false; TextEof := false; end; function ImportTextFile (name: str255; RefNum: integer): boolean; var nRows, nColumns, count, i, vloc, BlankPixel, nPixelsPerLine: integer; rLine: RealLine; pvalue: extended; min, max, ScaleFactor, DefaultValue, tvalue: extended; err: OSErr; line, BlankLine: LineType; TheInfo: FInfo; noScaling:boolean; begin ImportTextFile := false; err := GetFInfo(name, RefNum, TheInfo); if TheInfo.fdType <> 'TEXT' then begin PutError('File is not of type ''TEXT''.'); exit(ImportTextFile); end; InitTextInput(name, RefNum); nRows := 0; nColumns := 0; max := -10e-10; min := 10e10; ShowMessage(concat('First pass used to find ', crStr, 'width, height,min, and max.', crStr, crStr, CmdPeriodToStop)); DrawLabels('Line:', '', ''); while not TextEof do begin GetLineFromText(rLine, count); if not (TextEof and (count = 0)) then nRows := nRows + 1; if count > nColumns then nColumns := count; for i := 1 to count do begin pvalue := rLine[i]; if pvalue > max then max := pvalue; if pvalue < min then min := pvalue; end; if nRows mod 10 = 0 then begin Show1Value(nRows, NoValue); ShowAnimatedWatch; if CommandPeriod then begin beep; err := fsclose(Textf); Exit(ImportTextFile); end; end; end; ShowMessage(concat('rows= ', long2str(nRows), crStr, 'columns= ', long2str(ncolumns), crStr, 'min= ', long2str(round(min)), crStr, 'max= ', long2str(round(max)))); if nColumns > MaxLine then begin PutError(concat('More than ',long2str(MaxLine),' pixels per line.')); Exit(ImportTextFile); end; nPixelsPerLine := nColumns; if NewPicWindow(name, nPixelsPerLine, nrows) then with info^ do begin if (not ImportAutoScale) and (max > min) then begin min := ImportMin; max := ImportMax; end; ScaleFactor := 253.0 / (max - min); InitTextInput(name, RefNum); vloc := 0; DefaultValue := 0.0; if DefaultValue < min then DefaultValue := min; if DefaultValue > max then DefaultValue := max; BlankPixel := round((DefaultValue - min) * ScaleFactor + 1); for i := 0 to nColumns - 1 do BlankLine[i] := BlankPixel; NoScaling:=not ImportAutoScale and ((min=0) and (max=255)); DrawLabels('Line:', 'Total:', ''); while not TextEof do begin GetLineFromText(rLine, count); if not (TextEof and (count = 0)) then begin line := BlankLine; if ImportAutoScale then {Map values into the range 1-254} for i := 1 to count do line[i - 1] := round((rLine[i] - min) * ScaleFactor + 1) else for i := 1 to count do begin tvalue := rLine[i]; if tvalue < min then tvalue := min; if tvalue > max then tvalue := max; if noScaling then line[i - 1]:=round(tvalue) else line[i - 1] := round((tvalue - min) * ScaleFactor + 1); end; PutLine(0, vloc, PixelsPerLine, line); vloc := vloc + 1; end; if vloc mod 10 = 0 then begin Show2Values(vloc, nRows); ShowAnimatedWatch; if CommandPeriod then begin beep; err := fsclose(Textf); Exit(ImportTextFile); end; end; end; if noScaling then ImportCalibrate:=false else begin fit := StraightLine; nCoefficients := 2; coefficient[2] := (max - min) / 253.0; coefficient[1] := min - coefficient[2]; nKnownValues := 0; UpdateTitleBar; if macro then GenerateValues; ZeroClip := false; end; changes := true; PictureType := imported; end; {with} ImportTextFile := true; end; procedure PlotXYZ; {Reads X-Y coordinate pairs and optional intensiy(Z) values from a} {two or three column tab-delimited text file and plots them in the current window.} var fname, str: str255; RefNum, i, nColumns, nValues, index, wheight: integer; rLine: RealLine; begin RefNum := 0; if not GetTextFile(fname, RefNum) then exit(PlotXYZ); InitTextInput(fname, RefNum); GetLineFromText(rLine, nValues); nColumns := nValues; if not ((nColumns = 2) or (nColumns = 3)) then begin PutError('File must have two or three columns.'); exit(PlotXYZ); end; wheight := info^.nLines; index := ForegroundIndex; repeat if nColumns = 3 then begin index := round(rLine[3]); if index > 255 then index := 255; if index < 0 then index := 0; end; PutPixel(round(rLine[1]), wheight - round(rLine[2] + 1), index); GetLineFromText(rLine, nValues); until nValues = 0; InitCursor; end; procedure SaveSettings; var TheInfo: FInfo; ByteCount: LongInt; f, i: integer; err: OSErr; settings: SettingsType; PrefsVRef: integer; PrefsDirID: LongInt; PrefsSpec: FSSpec; PrefsError:boolean; begin with settings, info^ do begin sID := 'IMAG'; sVersion := version; sForegroundIndex := ForegroundIndex; sBackgroundIndex := BackgroundIndex; sBrushHeight := BrushHeight; sBrushWidth := BrushWidth; sSprayCanDiameter := SprayCanDiameter; sLUTMode := LUTMode; sOldColorStart := 30; sOldColorWidth := 10; sCurrentFontID := CurrentFontID; sCurrentStyle := CurrentStyle; sCurrentSize := CurrentSize; sTextJust := TextJust; sTextBack := TextBack; sNExtraColors := nExtraColors; sExtraColors := ExtraColors; sInvertVideo := InvertVideo; sMeasurements := Measurements; sInvertPlots := InvertPlots; sAutoScalePlots := AutoScalePlots; sLinePlot := LinePlot; sDrawPlotLabels := DrawPlotLabels; for i := 1 to 12 do sUnused1[i] := 0; sFixedSizePlot := FixedSizePlot; sProfilePlotWidth := ProfilePlotWidth; sProfilePlotHeight := ProfilePlotHeight; sFramesToAverage := FramesToAverage; sNewPicWidth := NewPicWidth; sNewPicHeight := NewPicHeight; sBufferSize := BufferSize; sMaxScionWidth := MaxScionWidth; sThresholdToForeground := ThresholdToForeground; sNonThresholdToBackground := NonThresholdToBackground; sVideoChannel := VideoChannel; sWhatToImport := WhatToImport; sImportCustomWidth := ImportCustomWidth; sImportCustomHeight := ImportCustomHeight; sImportCustomOffset := ImportCustomOffset; sWandAutoMeasure := WandAutoMeasure; sWandAdjustAreas := WandAdjustAreas; sBinaryIterations := BinaryIterations; sScaleArithmetic := ScaleArithmetic; sInvertPixelValues := InvertPixelValues; sInvertYCoordinates := InvertYCoordinates; sFieldWidth := FieldWidth; sPrecision := precision; sMinParticleSize := MinParticleSize; sMaxParticleSize := MaxParticleSize; sIgnoreParticlesTouchingEdge := IgnoreParticlesTouchingEdge; sLabelParticles := LabelParticles; sOutlineParticles := OutlineParticles; sIncludeHoles := IncludeHoles; sOscillatingMovies := OscillatingMovies; sDriverHalftoning := DriverHalftoning; sMaxMeasurements := MaxMeasurements; sImportCustomDepth := ImportCustomDepth; sImportSwapBytes := ImportSwapBytes; sImportCalibrate := ImportCalibrate; sImportAutoscale := ImportAutoscale; for i := 1 to 12 do sUnused2[i] := 0; sShowHeadings := ShowHeadings; sDefaultVRefNum := 0; sDefaultDirID := 0; sKernelsVRefNum := 0; sKernelsDirID := 0; {***} sProfilePlotMin := ProfilePlotMin; sProfilePlotMax := ProfilePlotMax; sImportMin := ImportMin; sImportMax := ImportMax; sHighlightPixels := HighlightSaturatedPixels; {***} sBallRadius := BallRadius; sFasterBackgroundSubtraction := FasterBackgroundSubtraction; sScaleConvolutions := ScaleConvolutions; {V1.42} sBinaryCount := BinaryCount; sColorTable := ColorTable; sColorStart := ColorStart; sColorEnd := ColorEnd; sInvertedTable := InvertedColorTable; {V1.44} sHalftoneFrequency := HalftoneFrequency; sHalftoneAngle := HalftoneAngle; sHalftoneDotFunction := HalftoneDotFunction; sDacLow := DacLow; sDacHigh := DacHigh; sSyncMode := SyncMode; sSwitchLUTOnSuspend := SwitchLUTOnSuspend; sVideoRateAveraging := VideoRateAveraging; sImportInvert := ImportInvert; sTextCreator := TextCreator; sMathSubGain:=MathSubGain; sMathSubOffset:=round(MathSubOffset); for i := 1 to 10 do sUnused[i] := 0; end; {with} if System7 then begin {Save in Preferences folder} PrefsError:=true; err:=FindFolder(kOnSystemDisk, kPreferencesFolderType, kDontCreateFolder, PrefsVRef, PrefsDirID); if err=noErr then err:=FSMakeFSSpec(PrefsVRef, PrefsDirID, PrefsName, PrefsSpec); if err=noErr then err:=FSpDelete(PrefsSpec); if (err=noErr) or (err=fnfErr) then begin err:=FSpCreate(PrefsSpec, 'Imag', 'pref', smSystemScript); if err=noErr then err:=FSpOpenDF(PrefsSpec, fsCurPerm, f); if err=noErr then PrefsError:=false; end; if PrefsError then begin PutError('Error saving settings file'); exit(SaveSettings); end; end else begin {Save in System folder} err := GetFInfo(PrefsName, SystemRefNum, TheInfo); if err = FNFerr then begin err := create(PrefsName, SystemRefNum, 'Imag', 'pref'); if CheckIO(err) <> 0 then exit(SaveSettings); end; err := fsopen(PrefsName, SystemRefNum, f); end; if CheckIO(err) <> 0 then exit(SaveSettings); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(settings); err := fswrite(f, ByteCount, @settings); if CheckIO(err) <> 0 then begin err := fsclose(f); exit(SaveSettings) end; err := SetEof(f, ByteCount); err := fsclose(f); err := FlushVol(nil, SystemRefNum); end; procedure ExportAsText (fname: str255; RefNum: integer); var err, f, width, hloc, vloc: integer; TheInfo: FInfo; ByteCount, FileSize: LongInt; AutoSelectAll, InvertValues: boolean; tLine: LineType; begin if info = NoInfo then exit(ExportAsText); err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(ExportAsText) end; FNFerr: begin err := create(fname, RefNum, FourCharCode(TextCreator), 'TEXT'); if CheckIO(err) <> 0 then exit(ExportAsText); end; otherwise if CheckIO(err) <> 0 then exit(ExportAsText) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(ExportAsText); AutoSelectAll := not info^.RoiShowing; if AutoSelectAll then SelectAll(true); if TooWide then exit(ExportAsText); FileSize := 0; with info^, info^.RoiRect do begin InvertValues := isInvertingFunction; width := right - left; for vloc := top to bottom - 1 do begin GetLine(left, vloc, width, tLine); TextBufSize := 0; for hloc := 0 to width - 1 do begin if fit = uncalibrated then PutLong(tLine[hloc], 0) else if InvertValues then PutLong(255 - tLine[hloc], 0) else PutString(StringOf(cValue[tLine[hloc]]:1:precision)); if hloc <> (width - 1) then PutTab; end; PutChar(cr); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); FIleSize := FileSize + ByteCount; if (CheckIO(err) <> 0) or CommandPeriod then leave; if (vloc mod 10) = 0 then ShowAnimatedWatch; end; err := SetEof(f, FileSize); err := fsclose(f); err := FlushVol(nil, RefNum); end; if AutoSelectAll then KillRoi; end; procedure ExportCoordinates (fname: str255; RefNum: integer); var err, f, i, y: integer; TheInfo: FInfo; ByteCount, FileSize: LongInt; InvertY: boolean; begin if not CoordinatesAvailableMsg then begin exit(ExportCoordinates) end; err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(ExportCoordinates) end; FNFerr: begin err := create(fname, RefNum, FourCharCode(TextCreator), 'TEXT'); if CheckIO(err) <> 0 then exit(ExportCoordinates); end; otherwise if CheckIO(err) <> 0 then exit(ExportCoordinates) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(ExportCoordinates); FileSize := 0; InvertY := InvertYCoordinates and (Info <> NoInfo); with info^ do for i := 1 to nCoordinates do begin TextBufSize := 0; PutLong(xCoordinates^[i] + RoiRect.left, 0); PutTab; y := yCoordinates^[i] + RoiRect.top; if InvertY then y := PicRect.bottom - y - 1; PutLong(y, 0); PutChar(cr); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); FIleSize := FileSize + ByteCount; if (CheckIO(err) <> 0) or CommandPeriod then leave; end; err := SetEof(f, FileSize); err := fsclose(f); err := FlushVol(nil, RefNum); end; procedure ExportMeasurements (fname: str255; RefNum: integer); const LinesPerPass = 25; var err, f, i, first, last: integer; TheInfo: FInfo; ByteCount, FileSize: LongInt; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(ExportMeasurements) end; FNFerr: begin err := create(fname, RefNum, FourCharCode(TextCreator), 'TEXT'); if CheckIO(err) <> 0 then exit(ExportMeasurements); end; otherwise if CheckIO(err) <> 0 then exit(ExportMeasurements) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(ExportMeasurements); FileSize := 0; first := 1; last := LinesPerPass; repeat if last > mCount then last := mCount; CopyResultsToBuffer(first, last, ShowHeadings or OptionKeyWasDown); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); FIleSize := FileSize + ByteCount; if (CheckIO(err) <> 0) or CommandPeriod or (last = mCount) then leave; first := first + LinesPerPass; last := last + LinesPerPass; until false; err := SetEof(f, FileSize); err := fsclose(f); err := FlushVol(nil, RefNum); UnsavedResults := false; end; procedure Swap2Bytes (var i: integer); type atype = packed array[1..2] of char; var a: atype; c: char; begin a := atype(i); c := a[1]; a[1] := a[2]; a[2] := c; i := integer(a) end; procedure Swap4Bytes (var i: LongInt); var a: ostype; c: char; begin a := ostype(i); c := a[1]; a[1] := a[4]; a[4] := c; c := a[2]; a[2] := a[3]; a[3] := c; i := LongInt(a) end; function OpenTiffHeader (f: integer; var DirOffset: LongInt): boolean; var TiffHeader: TiffHdr; ByteCount: LongInt; err: OSErr; begin ByteCount := 8; err := SetFPos(f, fsFromStart, 0); err := fsread(f, ByteCount, @TiffHeader); if CheckIO(err) <> NoErr then begin OpenTiffHeader := false; exit(OpenTiffHeader); end; with TiffHeader do begin IntelByteOrder := ByteOrder = 'II'; if (ByteOrder <> 'MM') and (ByteOrder <> 'II') then begin PutError('Invalid TIFF header.'); OpenTiffHeader := false; exit(OpenTiffHeader) end; DirOffset := FirstIFDOffset; if IntelByteOrder then Swap4Bytes(DirOffset); OpenTiffHeader := true; end; end; procedure GetTiffEntry (f: integer; var tag: integer; var N, value: LongInt); var IFDEntry: TiffEntry; ByteCount: LongInt; IntValue: integer; err: OSErr; str: str255; begin ByteCount := 12; err := FSRead(f, ByteCount, @IFDEntry); with IFDEntry do begin tag := TagField; N := length; if IntelByteOrder then begin Swap2Bytes(tag); Swap2Bytes(ftype); Swap4Bytes(N); end; value := offset; if (ftype = short) and (N = 1) then begin value := bsr(value, 16); if IntelByteOrder then begin IntValue := value; Swap2Bytes(IntValue); value := IntValue end end else if IntelByteOrder then Swap4Bytes(value); if OptionKeyWasDown then begin gstr := concat(gstr, long2str(tag), ' ', long2str(ftype), ' ', long2str(N), ' ', long2str(value), crStr); ShowMessage(gstr); end; end; end; function OpenTiffDirectory (f: integer; DirOffset: LongInt; var TiffInfo: TiffInfoRec; Importing: boolean): boolean; const NoUnit = 1; inch = 2; centimeter = 3; var ByteCount, length, ftype, N, value, BytesPerStrip, SaveFPos: LongInt; err: OSErr; nEntries, i, tag, entry: integer; StripOffsetsArray: array[1..2] of LongInt; xRes, yRes: extended; function GetResolution: extended; var resolution: array[1..2] of LongInt; begin err := GetFPos(f, SaveFPos); err := SetFPos(f, fsFromStart, value); ByteCount := 8; err := fsread(f, ByteCount, @Resolution); if IntelByteOrder then begin Swap4Bytes(Resolution[1]); Swap4Bytes(Resolution[2]); end; err := SetFPos(f, fsFromStart, SaveFPos); if resolution[2] <> 0 then GetResolution := resolution[1] / resolution[2] else GetResolution := 0.0; end; begin if OptionKeyWasDown then gstr := ''; xRes := 0.0; err := SetFPos(f, fsFromStart, DirOffset); ByteCount := 2; err := FSRead(f, ByteCount, @nEntries); if CheckIO(err) <> NoErr then begin OpenTiffDirectory := false; exit(OpenTiffDirectory); end; if IntelByteOrder then Swap2Bytes(nEntries); with TiffInfo do begin width := 0; height := 0; BitsPerPixel := 8; SamplesPerPixel:=1; PlanarConfig := 1; OffsetToData := 0; Resolution := 0.0; ResUnits := tNoUnits; OffsetToColorMap := 0; OffsetToImageHeader := -1; StripOffsetsArray[1] := 0; for entry := 1 to nEntries do begin GetTiffEntry(f, tag, N, value); if tag = 0 then begin PutError('Invalid TIFF format.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; case tag of ImageWidth: width := value; ImageLength: height := value; BitsPerSample: begin if N = 1 then BitsPerPixel := value; if value = 1 then begin PutError('NIH Image cannot open 1-bit TIFF files.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; if (value = 16) and not importing then begin PutError('Use Import to open 16-bit TIFF files.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; end; SamplesPerPixelTag: if (value = 1) or (value = 3) then SamplesPerPixel:=value else begin PutError('NIH Image can only open TIFF files with 1 or 3 samples per pixel.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; PlanarConfigTag: PlanarConfig := value; Compression: if value <> 1 then begin PutError('NIH Image cannot open compressed TIFF files.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; PhotoInterp: ZeroIsBlack := value = 1; StripOffsets: if N = 1 then OffsetToData := value else begin err := GetFPos(f, SaveFPos); err := SetFPos(f, fsFromStart, value); ByteCount := 8; err := fsread(f, ByteCount, @StripOffsetsArray); if IntelByteOrder then begin Swap4Bytes(StripOffsetsArray[1]); Swap4Bytes(StripOffsetsArray[2]); end; err := SetFPos(f, fsFromStart, SaveFPos); end; RowsPerStrip: if (OffsetToData=0) and (value < height) then begin BytesPerStrip := value * width; if BitsPerPixel = 16 then BytesPerStrip := BytesPerStrip * 2 else if SamplesPerPixel = 3 then BytesPerStrip := BytesPerStrip * 3; if StripOffsetsArray[1] = 0 then begin PutError('Invalid TIFF directory.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; if StripOffsetsArray[2] <> (StripOffsetsArray[1] + BytesPerStrip) then begin PutError('NIH Image cannot open TIFF files with discontiguous strips.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; OffsetToData := StripOffsetsArray[1]; end; XResolution: XRes := GetResolution; YResolution: begin yRes := GetResolution; if (xRes = yRes) and (xRes > 0.0) then begin resolution := xRes; ResUnits := tInches; end; end; ResolutionUnit: case value of NoUnit: ResUnits := tNoUnits; Centimeter: ResUnits := tCentimeters; otherwise end; ColorMapTag: if N = 768 then OffsetToColorMap := value; ImageHdrTag: OffsetToImageHeader := value; otherwise end; end; {for} ByteCount := 4; err := FSRead(f, ByteCount, @NextIFD); if IntelByteOrder then Swap4Bytes(NextIFD); if OptionKeyWasDown then begin gstr := concat(gstr, 'Next IFD=', long2str(NextIFD)); ShowMessage(gstr); end; if width = 0 then begin PutError('Error opening TIFF directory'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; if (SamplesPerPixel = 3) and (PlanarConfig <> 1) then begin PutError('NIH Image cannot open RGB files with separate planes.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; end; {with} OpenTiffDirectory := true; end; procedure SaveTiffColorMap (f: integer; ImageDataSize: LongInt); var i: integer; err: OSErr; ColorMap: TiffColorMapType; ColorMapSize: LongInt; begin LoadLUT(info^.cTable); if ScreenDepth=8 then begin for i := 0 to 255 do with cScreenPort^.portPixMap^^.pmTable^^.ctTable[i].rgb do begin ColorMap[1, i] := red; ColorMap[2, i] := green; ColorMap[3, i] := blue; end; end else begin for i := 0 to 255 do with info^.cTable[i].rgb do begin ColorMap[1, i] := red; ColorMap[2, i] := green; ColorMap[3, i] := blue; end; end; err := SetFPos(f, FSFromStart, HeaderSize + TiffDirSize + ImageDataSize); ColorMapSize := SizeOf(ColorMap); err := fswrite(f, ColorMapSize, @ColorMap); if CheckIO(err) <> 0 then beep; end; procedure GetTiffColorMap (f: integer); var i: integer; ByteCount: LongInt; err: OSErr; ColorMap: TiffColorMapType; begin with info^ do begin ByteCount := SizeOf(ColorMap); err := SetFPos(f, fsFromStart, ColorMapOffset); err := fsRead(f, ByteCount, @ColorMap); if err = NoErr then begin if IntelByteOrder then for i := 0 to 255 do begin Swap2Bytes(ColorMap[1, i]); Swap2Bytes(ColorMap[2, i]); Swap2Bytes(ColorMap[3, i]); end; for i := 0 to 255 do with cTable[i].rgb do begin red := ColorMap[1, i]; green := ColorMap[2, i]; blue := ColorMap[3, i]; end; LoadLUT(cTable); LUTMode := ColorLut; SetupPseudocolor; IdentityFunction := false; if isGrayScaleLUT then begin info^.LutMode := CustomGrayScale; DrawMap; end; end else beep; end;{with} end; function SaveTiffDir (f, slines, sPixelsPerLine: integer; SavingSelection: boolean; ctabSize, ImageDataSize: LongInt): OSErr; var i: integer; err: OSErr; SavingStack, SavingRGBStack: boolean; ByteCount, width, height: LongInt; TiffInfo1: record Header: TiffHdr; {8} nEntries: integer; {2} TiffDir: array[1..9] of TiffEntry; {108} end; ColorMapEntry: TiffEntry; {12 (Optional)} TiffInfo2: record ImageHdrEntry: TiffEntry; {12} NextIFD: LongInt; {4} BitsPerPixelData: array[1..3] of integer; {6} {only used for RGB files} filler: array[1..TiffFillerSize] of integer; {116} end; BitsPerSampleData: record rBitsPerSample, gBitsPerSample, bBitsPerSample:integer; end; begin with info^ do begin SavingStack := false; SavingRGBStack := false; if StackInfo <> nil then SavingStack := StackInfo^.nSlices > 1; if SavingStack then if (StackInfo^.StackType = rgbStack) and (StackInfo^.nSlices = 3) then begin SavingRGBStack := true; ctabSize := 0; end; if SavingSelection then begin width := sPixelsPerLine; height := sLines end else begin width := PixelsPerLine; height := nLines end; with TiffInfo1 do begin with header do begin ByteOrder := 'MM'; Version := 42; FirstIFDOffset := 8; end; if ctabSize > 0 then nEntries := 11 else nEntries := 10; for i := 1 to 9 do with TiffDir[i] do begin ftype := 3; length := 1 end; with TiffDir[1] do begin TagField := NewSubfileType; ftype := 4; offset := 0; end; with TiffDir[2] do begin TagField := ImageWidth; offset := bsl(width, 16); end; with TiffDir[3] do begin TagField := ImageLength; offset := bsl(height, 16); end; with TiffDir[4] do begin TagField := BitsPerSample; if SavingRGBStack then begin ftype := 3; length := 3; offset := SizeOf(TiffInfo1) + SizeOf(TiffEntry) + SizeOf(LongInt); with TiffInfo2 do for i := 1 to 3 do BitsPerPixelData[i] := 8; end else begin offset := bsl(8, 16); with TiffInfo2 do for i := 1 to 3 do BitsPerPixelData[i] := 0; end; end; with TiffDir[5] do begin TagField := PhotoInterp; if SavingRGBStack then offset := bsl(2, 16) else if ctabSize > 0 then offset := bsl(3, 16) else offset := 0; end; with TiffDir[6] do begin TagField := StripOffsets; ftype := 4; offset := TiffDirSize + HeaderSize; end; with TiffDir[7] do begin TagField := SamplesPerPixelTag; if SavingRGBStack then offset := bsl(3, 16) else offset := bsl(1, 16); end; with TiffDir[8] do begin TagField := RowsPerStrip; offset := bsl(height, 16); end; with TiffDir[9] do begin TagField := StripByteCount; ftype := 4; if SavingRGBStack then offset := width * height * 3 else offset := width * height; end; end; ByteCount := SizeOf(TiffInfo1); err := SetFPos(f, FSFromStart, 0); err := FSWrite(f, ByteCount, @TiffInfo1); if CheckIO(err) <> NoErr then begin SaveTiffDir := err; exit(SaveTiffDir); end; if ctabSize > 0 then with ColorMapEntry do begin TagField := ColorMapTag; ftype := 3; length := 768; offset := HeaderSize + TiffDirSize + ImageDataSize; ByteCount := SizeOf(ColorMapEntry); err := FSWrite(f, ByteCount, @ColorMapEntry); if CheckIO(err) <> NoErr then begin SaveTiffDir := err; exit(SaveTiffDir); end; end; with TiffInfo2 do begin with ImageHdrEntry do begin TagField := ImageHdrTag; ftype := 3; length := 256; offset := TiffDirSize; end; NextIFD := 0; if SavingStack then NextIFD := HeaderSize + TiffDirSize + ImageDataSize + ctabSize; for i := 1 to TiffFillerSize do filler[i] := 0; end; end; {with info^} ByteCount := SizeOf(TiffInfo2); err := FSWrite(f, ByteCount, @TiffInfo2); SaveTiffDir := CheckIO(err); end; function WriteExtraTiffIFDs (f: integer; ImageDataSize, cTabSize: LongInt): integer; var IFD, entry: integer; StackIFD: StackIFDType; err: OSErr; IFDoffset, SliceOffset, ByteCount: LongInt; begin with info^, StackInfo^, StackIFD do begin IFDoffset := HeaderSize + TiffDirSize + ImageDataSize + ctabSize; err := SetFPos(f, FSFromStart, IFDoffset); SliceOffset := HeaderSize + TiffDirSize + ImageSize; for IFD := 2 to nSlices do {IFD=Image File Directory} begin nEntries := 6; for entry := 1 to nEntries do with TiffDir[entry] do begin ftype := 3; length := 1 end; with TiffDir[1] do begin TagField := NewSubfileType; ftype := 4; offset := 0; end; with TiffDir[2] do begin TagField := ImageWidth; offset := bsl(PixelsPerLine, 16); end; with TiffDir[3] do begin TagField := ImageLength; offset := bsl(nLines, 16); end; with TiffDir[4] do begin TagField := BitsPerSample; offset := bsl(8, 16); end; with TiffDir[5] do begin TagField := PhotoInterp; offset := 0; end; with TiffDir[6] do begin TagField := StripOffsets; ftype := 4; offset := SliceOffset; end; SliceOffset := SliceOffset + ImageSize; IFDoffset := IFDoffset + SizeOf(StackIFD); if IFD <> nSlices then NextIFD := IFDoffset else NextIFD := 0; ByteCount := SizeOf(StackIFD); err := fswrite(f, ByteCount, @StackIFD); if err <> NoErr then begin WriteExtraTiffIFDs := err; exit(WriteExtraTiffIFDs); end; end; {for} end; {with} WriteExtraTiffIFDs := NoErr; end; procedure SaveLUT (fname: str255; RefNum: integer); var err: integer; TheInfo: FInfo; LUT: array[1..3] of packed array[0..255] of byte; i, f: integer; ByteCount: LongInt; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'ICOL' then begin TypeMismatch(fname); exit(SaveLUT) end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'ICOL'); if CheckIO(err) <> 0 then exit(SaveLUT); end; otherwise if CheckIO(err) <> 0 then exit(SaveLUT); end; DisableDensitySlice; LoadLUT(Info^.cTable); for i := 0 to 255 do with cScreenPort^.portPixMap^^.pmTable^^.ctTable[i].rgb do begin LUT[1, i] := band(bsr(red, 8), 255); LUT[2, i] := band(bsr(green, 8), 255); LUT[3, i] := band(bsr(blue, 8), 255); end; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveLUT); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(LUT); err := fswrite(f, ByteCount, @LUT); if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, RefNum); exit(SaveLUT) end; err := SetEof(f, ByteCount); err := fsclose(f); err := GetFInfo(fname, RefNum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, RefNum, TheInfo); end; err := FlushVol(nil, RefNum); end; procedure SaveColorTable (fname: str255; RefNum: integer); var err: integer; TheInfo: FInfo; i, f: integer; ByteCount: LongInt; hdr: PaletteHeader; begin with info^ do err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'ICOL' then begin TypeMismatch(fname); exit(SaveColorTable) end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'ICOL'); if CheckIO(err) <> 0 then exit(SaveColorTable); end; otherwise if CheckIO(err) <> 0 then exit(SaveColorTable); end; with info^ do begin InitPaletteHeader(hdr); err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveColorTable); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(PaletteHeader); if ByteCount <> 32 then PutError('Palette header size <> 32.'); err := fswrite(f, ByteCount, @hdr); ByteCount := nColors; err := fswrite(f, ByteCount, @redLUT); ByteCount := nColors; err := fswrite(f, ByteCount, @greenLUT); ByteCount := nColors; err := fswrite(f, ByteCount, @blueLUT); if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, RefNum); exit(SaveColorTable) end; err := SetEOF(f, SizeOf(PaletteHeader) + 3 * nColors); err := fsclose(f); err := GetFInfo(fname, RefNum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, RefNum, TheInfo); end; err := FlushVol(nil, RefNum); end; {with info^} end; procedure SaveOutline (fname: str255; RefNum: integer); var err: integer; TheInfo: FInfo; i, f: integer; ByteCount, DataSize: LongInt; hdr: RoiHeader; SaveCoordinates: boolean; dX1, dY1, dX2, dY2: extended; begin with info^ do begin if not RoiShowing then begin PutError('No outline available to save.'); exit(SaveOutline); end; if (RoiType = FreeLineRoi) or (RoiType = SegLineRoi) then begin PutError('Freehand and segmented line selections cannot be saved.'); exit(SaveOutline); end; SaveCoordinates := (RoiType = PolygonRoi) or (RoiType = FreehandRoi) or (RoiType = TracedRoi); if SaveCoordinates then if not CoordinatesAvailableMsg then begin exit(SaveOutline); end; err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'Iout' then begin TypeMismatch(fname); exit(SaveOutline) end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'Iout'); if CheckIO(err) <> 0 then exit(SaveOutline); end; otherwise if CheckIO(err) <> 0 then exit(SaveOutline); end; with hdr do begin rID := 'Iout'; rVersion := version; rRoiType := RoiType; rRoiRect := RoiRect; rNCoordinates := nCoordinates; GetLoi(dX1, dY1, dX2, dY2); rX1:=dX1; rY1:=dY1; rX2:=dX2; rY2:=dY2; rLineWidth := LineWidth; for i := 1 to 14 do rUnused[i] := 0; end; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveOutline); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(RoiHeader); if ByteCount <> 64 then PutError('Roi header size <> 32.'); err := fswrite(f, ByteCount, @hdr); if SaveCoordinates then begin ByteCount := nCoordinates * 2; err := fswrite(f, ByteCount, ptr(xCoordinates)); ByteCount := nCoordinates * 2; err := fswrite(f, ByteCount, ptr(yCoordinates)); DataSize := nCoordinates * 4; end else DataSize := 0; if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, RefNum); exit(SaveOutline) end; err := SetEOF(f, SizeOf(RoiHeader) + DataSize); err := fsclose(f); err := GetFInfo(fname, RefNum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, RefNum, TheInfo); end; err := FlushVol(nil, RefNum); end; {with info^} end; procedure OpenOutline (fname: str255; RefNum: integer); var err, f, i: integer; count: LongInt; hdr: RoiHeader; okay: boolean; begin if Info = NoInfo then begin if (NewPicWidth * NewPicHeight) <= UndoBufSize then begin if not NewPicWindow('Untitled', NewPicWidth, NewPicHeight) then exit(OpenOutline) end else begin beep; exit(OpenOutline) end; end; KillRoi; err := fsopen(fname, RefNum, f); with info^, hdr do begin count := SizeOf(RoiHeader); err := fsread(f, count, @hdr); if rID <> 'Iout' then begin err := fsclose(f); PutError('File is corrupted.'); exit(OpenOutline) end; if (rRoiRect.right > PicRect.right) or (rRoiRect.bottom > PicRect.bottom) then begin err := fsclose(f); PutError('Image is too small for the outline.'); exit(OpenOutline) end; case rRoiType of LineRoi: begin LX1 := rX1; LY1 := rY1; LX2 := rX2; LY2 := rY2; RoiType := LineRoi; MakeRegion; SetupUndo; RoiShowing := true; end; RectRoi, OvalRoi: begin RoiType := rRoiType; RoiRect := rRoiRect; MakeRegion; SetupUndo; RoiShowing := true; end; PolygonRoi, FreehandRoi, TracedRoi: if (rNCoordinates > 2) and (rNCoordinates <= MaxCoordinates) then begin count := rNCoordinates * 2; err := fsread(f, count, ptr(xCoordinates)); count := rNCoordinates * 2; err := fsread(f, count, ptr(yCoordinates)); if CheckIO(err) = 0 then begin nCoordinates := rNCoordinates; SelectionMode := NewSelection; if rVersion >= 148 then for i := 1 to nCoordinates do with rRoiRect do begin xCoordinates^[i] := xCoordinates^[i] + left; yCoordinates^[i] := yCoordinates^[i] + top; end; MakeOutline(rRoiType); SetupUndo; end; end; end; end; err := fsclose(f); end; function GetTIFFParameters (name: str255; RefNum: integer; var HasColorMap: boolean): boolean; var err: OSErr; f: integer; DirOffset: LongInt; TiffInfo: TiffInfoRec; begin GetTIFFParameters := false; HasColorMap := false; err := fsopen(name, RefNum, f); if err <> NoErr then exit(GetTIFFParameters); if not OpenTiffHeader(f, DirOffset) then begin err := fsclose(f); exit(GetTIFFParameters) end; if not OpenTiffDirectory(f, DirOffset, TiffInfo, true) then begin err := fsclose(f); exit(GetTIFFParameters) end; with TiffInfo do begin ImportCustomWidth := width; ImportCustomHeight := height; ImportCustomOffset := OffsetToData; ImportAutoScale:=true; if BitsPerPixel = 16 then begin ImportCustomDepth := SixteenBitsUnsigned; ImportSwapBytes := IntelByteOrder; end else begin ImportCustomDepth := EightBits; ImportInvert := ZeroIsBlack; end; HasColorMap := OffsetToColorMap > 0; end; if ImportCustomDepth = EightBits then begin WhatToImport := ImportTiff; WhatToOpen := OpenTiff end else begin WhatToImport := ImportCustom; WhatToOpen := OpenCustom end; err := fsclose(f); GetTIFFParameters := true; end; procedure GetXUnits (UnitsKind: UnitsType); begin with info^ do case UnitsKind of Nanometers: xUnit := 'nm'; Micrometers: xUnit := 'µm'; Millimeters: xUnit := 'mm'; Centimeters: xUnit := 'cm'; Meters: xUnit := 'meter'; Kilometers: xUnit := 'km'; Inches: xUnit := 'inch'; feet: xUnit := 'ft'; Miles: xUnit := 'mile'; Pixels: xUnit := 'pixel'; otherwise ; end; end; procedure GetUnitsKInd (var UnitsKind: UnitsType; var UnitsPerCM: extended); begin with info^ do begin if xunit = 'nm' then begin UnitsKind := Nanometers; UnitsPerCm := 10000000.0; end else if xUnit = 'µm' then begin UnitsKind := Micrometers; UnitsPerCm := 10000.0; end else if xUnit = 'mm' then begin UnitsKind := Millimeters; UnitsPerCm := 10.0; end else if xUnit = 'cm' then begin UnitsKind := Centimeters; UnitsPerCm := 1.0; end else if xUnit = 'meter' then begin UnitsKind := Meters; UnitsPerCm := 0.01; end else if xUnit = 'km' then begin UnitsKind := Kilometers; UnitsPerCm := 0.00001; end else if xUnit = 'inch' then begin UnitsKind := Inches; UnitsPerCm := 0.3937; end else if xUnit = 'ft' then begin UnitsKind := feet; UnitsPerCm := 0.0328083; end else if xUnit = 'mile' then begin UnitsKind := Miles; UnitsPerCm := 0.000006213; end else if xUnit = 'pixel' then begin UnitsKind := pixels; UnitsPerCm := 0.0; SpatiallyCalibrated := false; end else begin UnitsKind := OtherUnits; UnitsPerCm := 0.0; end; end; end; end.