unit File2;

{Routines used by NIH Image for printing plus a few additional File Menu routines.}

interface


	uses
		QuickDraw, Palettes, PrintTraps, 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);
	procedure Swap2Bytes (var i: 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: double);


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, eof, 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);
						DisposHandle(HexBufH);
						Show2Values(vloc - vstart, iheight);
						if CommandPeriod then begin
								beep;
								eof := chr(4);
								DrawString(eof);
								exit(PrintHalftone)
							end;
					end;
			end;
	end;


	procedure PrintTheImage (PageWidth, PageHeight: integer);
		var
			PrintRect: rect;
			Width, Height: integer;

		procedure ScaleToFitPage;
			var
				hscale, vscale, scale: real;
		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 OptionKeyDown) and (not OptionKeyWasDown) 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(thePort^.portBits.rowBytes, $8000) = $8000 then begin
               {Assume driver understands Color QD}
							hlock(handle(CGrafPort(ThePort^).PortPixMap));
							CopyBits(BitMapHandle(osPort^.portPixMap)^^, BitMapHandle(CGrafPort(ThePort^).PortPixMap)^^, RoiRect, PrintRect, SrcCopy, nil);
							hunlock(handle(CGrafPort(ThePort^).PortPixMap))
						end
					else
						CopyBits(BitMapHandle(osPort^.portPixMap)^^, thePort^.PortBits, RoiRect, PrintRect, SrcCopy, nil);
					hunlock(handle(osPort^.portPixMap));
				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;
		var
			mylog: DialogPtr;
			item, i, ignore, SaveFrequency, SaveAngle: integer;
			SaveFunction: boolean;
			str: str255;
	begin
		if DriverHalftoning then begin
				PutMessage('Custom halftoning is only available when Custom Grayscale Halftoning is checked in the Preferences dialog box.');
				exit(SetHalftone);
			end;
		SaveFrequency := HalftoneFrequency;
		SaveAngle := HalftoneAngle;
		SaveFunction := HalftoneDotFunction;
		mylog := GetNewDialog(30, nil, pointer(-1));
		SetDNum(MyLog, FrequencyID, HalftoneFrequency);
		SelIText(MyLog, FrequencyID, 0, 32767);
		SetDNum(MyLog, AngleID, HalftoneAngle);
		OutlineButton(MyLog, ok, 16);
		if HalftoneDotFunction then
			SetDialogItem(mylog, DotID, 1)
		else
			SetDialogItem(mylog, LineID, 1);
		repeat
			ModalDialog(nil, item);
			if item = FrequencyID then
				HalftoneFrequency := GetDNum(MyLog, FrequencyID);
			if item = AngleID then begin
					HalftoneAngle := GetDNum(MyLog, AngleID);
					if (HalftoneAngle < 0) or (HalftoneAngle > 180) then begin
							beep;
							HalftoneAngle := SaveAngle;
						end;
				end;
			if (item >= DotID) and (item <= LineID) then begin
					for i := DotID to LineID do
						SetDialogItem(mylog, i, 0);
					SetDialogItem(mylog, item, 1);
					HalftoneDotFunction := item = DotID;
				end;
		until (item = ok) or (item = cancel);
		DisposDialog(mylog);
		if item = cancel then begin
				HalftoneFrequency := SaveFrequency;
				HalftoneAngle := SaveAngle;
				HalftoneDotFunction := SaveFunction;
			end;
	end;


{$POP}

	procedure GetFileInfo (name: str255; vnum: integer; var DateCreated, LastModified: str255);
		var
			FileParmBlock: ParmBlkPtr;
			theErr: OSErr;
			DateVar, TimeVar: str255;
			Secs: LongInt;
	begin
		DateCreated := '';
		new(FIleParmBlock);
		if FileParmBlock <> nil then
			with FileParmBlock^ do begin
					ioCompletion := nil;
					ioNamePtr := @name;
					ioVRefNum := vnum;
					ioFVersNum := 0;
					ioFDirIndex := 0;
					theErr := PBGetFInfo(FileParmBlock, false);
					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;
					Dispose(FileParmBlock);
				end;
	end;


	procedure GetVolumnInfo (vnum: integer; var VolumnName: str255; var FreeSpace: LongInt);
		var
			theErr: OSErr;
			SPtr: StringPtr;
			VolParmBlock: ParmBlkPtr;
	begin
		VolumnName := '';
		new(SPtr);
		new(VolParmBlock);
		if (SPtr <> nil) and (VolParmBlock <> nil) then
			with VolParmBlock^ do begin
					SPtr^ := '';
					ioVRefNum := vnum;
					ioNamePtr := SPtr;
					ioCompletion := nil;
					ioVolIndex := -1;
					theErr := PBGetVInfo(VolParmBlock, false);
					VolumnName := ioNamePtr^;
					FreeSpace := ioVAlBlkSiz * ioVFrBlk;
					dispose(SPtr);
					dispose(VolParmBlock);
				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
							NeededSize := LongInt(slines) * sPixelsPerLine
						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
								PutMessage('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: real;
			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(ApplFont);
					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
						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 iVersion > 0 then begin
							DrawBString('Version: ');
							DrawString('Created by NIH Image ');
							DrawReal(iVersion / 100.0, 1, 2);
							NewLine;
						end;
					if vref <> 0 then begin
							GetVolumnInfo(vref, VolumnName, FreeSpace);
							if VolumnName <> '' then begin
									DrawBString('Volume: ');
									DrawString(VolumnName);
									DrawString(' (');
									DrawLong(FreeSpace div 1024);
									DrawString('K free)');
									NewParagraph;
								end;
						end;
					DrawBString('Type: ');
					if StackInfo <> nil then
						str := concat('Stack (', long2str(StackInfo^.nSlices), '  slices)')
					else begin
							case PictureType of
								pdp11: 
									str := 'PDP-11';
								NewPicture: 
									str := 'New';
								normal: 
									str := 'Normal';
								PictFile: 
									str := 'PICT';
								TiffFile, InvertedTIFF: 
									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';
								ScionType: 
									str := 'Camera(Scion)';
								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: ');
									RealToString(SliceSpacing, 1, 1, str);
									DrawString(str);
									DrawString(' 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(xSpatialScale, 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 DensityCalibrated 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
							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');
								FreeLineRoi: 
									DrawString('Freehand Line');
								SegLineRoi: 
									DrawString('Segmented Line');
							end;
							NewLine;
							case RoiType of
								PolygonRoi, FreehandRoi, RectRoi, OvalRoi: 
									with RoiRect do begin
											DrawBString('    Left: ');
											DrawXDimension(left, 0);
											NewLine;
											DrawBString('    Top: ');
											if InvertYCoordinates then
												DrawYDimension(PicRect.bottom - top - 1, 0)
											else
												DrawYDimension(top, 0);
											NewLine;
											DrawBString('    Width: ');
											DrawXDimension(right - left, 0);
											NewLine;
											DrawBString('    Height: ');
											DrawYDimension(bottom - top, 0);
										end;
								LineRoi:  begin
										info := ImageInfo;
										GetLengthOrPerimeter(ulength, clength);
										GetLoi(x1, y1, x2, y2);
										Info := InfoWindowInfo;
										DrawBString('    Length: ');
										if SpatiallyCalibrated then begin
												DrawReal(cLength, 1, 2);
												DrawString(xUnit);
											end
										else
											DrawReal(uLength, 1, 2);
										NewLine;
										DrawBString('    Angle: ');
										DrawReal(LAngle, 1, 2);
										DrawString('¡');
										NewLine;
										DrawBString('    X1: ');
										DrawXDimension(x1, 2);
										NewLine;
										DrawBString('    Y1: ');
										if InvertYCoordinates then
											DrawYDimension(PicRect.bottom - y1 - 1, 2)
										else
											DrawYDimension(y1, 2);
										NewLine;
										DrawBString('    X2: ');
										DrawXDimension(x2, 2);
										NewLine;
										DrawBString('    Y2: ');
										if InvertYCoordinates then
											DrawYDimension(PicRect.bottom - y2 - 1, 2)
										else
											DrawYDimension(y2, 2);
									end;
								FreeLineRoi, SegLineRoi:  begin
										info := ImageInfo;
										GetLengthOrPerimeter(ulength, clength);
										Info := InfoWindowInfo;
										DrawBString('    Length: ');
										if SpatiallyCalibrated then begin
												DrawReal(cLength, 1, 2);
												DrawString(xUnit);
											end
										else
											DrawReal(uLength, 1, 2);
										NewLine;
									end;
								otherwise
							end; {case}
						end
					else
						DrawBString('No Selection');
					SetGDevice(SaveGDevice);
				end; {with ImageInfo^}
		SetForegroundColor(SaveForeIndex);
		SetBackgroundColor(SaveBackIndex);
	end;


	function NewPtrClear (blockSize: Size): Ptr;
    {This function will return a pointer of size specified and will}
    {clear the memory to zeros . This is done to create an empty bit}
    {map containing nothing but white bits . }

    {MOVE . L  ( SP ) + , D0  ; get Size variable from stack}
    {_NewPtr , clear           ; make pointer }
    {MOVE.L  A0 , ( SP )       ; return pointer }
    {MOVE.W D0, MemErr     ; set up MemErr }
	inline
		$201F, $A31E, $2E88, $31C0, $0220;


	function CheckIO (err: OSerr): integer;
		var
			ErrStr, Message: str255;
			ignore: integer;
	begin
		if err <> 0 then begin
				Message := '';
				case err of
					-34: 
						Message := 'Disk Full';
					-36: 
						Message := 'I/O Error';
					-49: 
						Message := 'File in Use';
					-61: 
						Message := 'Write Permission Error';
				end;
				NumToString(err, ErrStr);
				ParamText(Message, ErrStr, '', '');
				InitCursor;
				ignore := alert(IOErrorID, nil);
				macro := false; {If macro, abort it}
			end;
		CheckIO := err;
	end;


	function OpenMacPaint (fname: str255; vnum: integer): boolean;
		const
			MaxUnPackedSize = 51840;   {Max MacPaint size in bytes=720 lines * 72 bytes/line }
		type
			mpLine = array[1..18] of LongInt;
			mpArrayT = array[1..720] of mpLine;
			mpArrayP = ^mpArrayT;
		var
			i, f, ScanLine, LastLine, LastWord, LastColumn: integer;
			err: osErr;
			srcSize: LongInt;
			srcPtr, dstPtr, src, dst: ptr;
			theBitMap: BitMap;
			mpArray: mpArrayP;
			BlankLine, BlankColumn: boolean;
			frect: rect;
			SaveGDevice: GDHandle;

		procedure abort;
		begin
			beep;
			if srcPtr <> nil then
				DisposPtr(srcPtr);
			if dstPtr <> nil then
				DisposPtr(dstPtr);
			exit(OpenMacPaint);
		end;

	begin
		OpenMacPaint := false;
		err := fsOpen(fname, vnum, f);
		if CheckIO(err) <> noErr then
			exit(OpenMacPaint);
		err := GetEOF(f, srcSize);
		srcSize := srcSize - 512;
		srcPtr := NewPtr(srcSize);
		if srcPtr = nil then
			abort;
		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
			abort;
		src := srcPtr;
		dst := dstPtr;
		for scanLine := 1 to 720 do
			UnPackBits(src, dst, 72); {bumps both ptrs}
		DisposPtr(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
			abort;
		SaveGDevice := GetGDevice;
		SetGDevice(osGDevice);
		SetForegroundColor(BlackIndex);
		SetBackgroundColor(WhiteIndex);
		with info^ do begin
				hlock(handle(osPort^.portPixMap));
				CopyBits(theBitMap, BitMapHandle(osPort^.PortPixMap)^^, frect, frect, SrcCopy, nil);
				hunlock(handle(osPort^.PortPixMap));
				DisposPtr(dstPtr);
				PictureType := imported;
				BinaryPic := true;
				SetGDevice(SaveGDevice);
				if PixMapSize > UndoBufSize then
					PutWarning;
			end;
		OpenMacPaint := true;
	end;


	procedure TypeMismatch (fname: str255);
	begin
		PutMessage(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
				DisposPtr(mpBufPtr);
			if f <> -1 then
				err := fsclose(f);
			exit(SaveAsMacPaint);
		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
			abort;
		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);
				hlock(handle(osPort^.portPixMap));
				CopyBits(BitMapHandle(osPort^.PortPixMap)^^, theBitMap, srect, drect, srcCopy, nil);
				hunlock(handle(osPort^.PortPixMap));
			end;
		err := fsOpen(fname, RefNum, f);
		if CheckIO(err) <> noErr then
			abort;
		for I := 1 to 128 do
			dstBuffer[I] := 0;
		Size := 512;
		err := FSWrite(f, Size, @dstBuffer);
		if CheckIO(err) <> noErr then
			abort;
		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
					abort;
			end;
		err := fsclose(f);
		DisposPtr(mpBufPtr);
		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] := eof;
				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: real;
		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 = eof) then begin
					TextEol := true;
					TextEof := c = eof;
					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 = eof) then begin
						TextEol := true;
						TextEof := c = eof;
					end;
			end;
		GetNumber := StringToReal(str);
	end;


	procedure GetLineFromText (var rLine: RealLine; var count: integer);
		var
			n: real;
	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: real;
			min, max, ScaleFactor, DefaultValue, tvalue: extended;
			err: OSErr;
			line, BlankLine: LineType;
			TheInfo: FInfo;
	begin
		ImportTextFile := false;
		err := GetFInfo(name, RefNum, TheInfo);
		if TheInfo.fdType <> 'TEXT' then begin
				PutMessage('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 ', cr, 'width, height,min, and max.', cr, cr, 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);
						if CommandPeriod then begin
								beep;
								err := fsclose(Textf);
								Exit(ImportTextFile);
							end;
					end;
			end;
		ShowMessage(concat('rows= ', long2str(nRows), cr, 'columns= ', long2str(ncolumns), cr, 'min= ', long2str(round(min)), cr, 'max= ', long2str(round(max))));
		if nColumns > MaxLine then begin
				PutMessage('More than 2048 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;
					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;
												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);
									if CommandPeriod then begin
											beep;
											err := fsclose(Textf);
											Exit(ImportTextFile);
										end;
								end;
						end;
					fit := StraightLine;
					nCoefficients := 2;
					coefficient[2] := (max - min) / 253.0;
					coefficient[1] := min - coefficient[2];
					DensityCalibrated := true;
					UpdateTitleBar;
					if macro then
						GenerateValues;
					ZeroClip := false;
					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
				PutMessage('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;


{$IFC false}

	procedure SaveDefaultWorkingDir (var settings: SettingsType);
		var
			DefaultVRefNum, err: integer;
			DefaultDirID: LongInt;
			ProcID: LongInt;
	begin
		with settings do begin
				if DefaultRefNum <> 0 then begin
						err := GetWDInfo(DefaultRefNum, DefaultVRefNum, DefaultDirID, ProcID);
						if err = NoErr then begin
								sDefaultVRefNum := DefaultVRefNum;
								sDefaultDirID := DefaultDirID;
							end
						else
							beep;
					end;
       {ShowMessage(concat('KernelsRefNum=', long2str(KernelsRefNum), cr, 'vRefNum=', long2str(sKernelsVRefNum), cr, 'DirID=', long2str(sKernelsDirID)));}
			end; {with}
	end;


	procedure SaveKernelsWorkingDir (var settings: SettingsType);
		var
			KernelsVRefNum, err: integer;
			KernelsDirID: LongInt;
			ProcID: LongInt;
	begin
		with settings do begin
				if KernelsRefNum <> 0 then begin
						err := GetWDInfo(KernelsRefNum, KernelsVRefNum, KernelsDirID, ProcID);
						if err = NoErr then begin
								sKernelsVRefNum := KernelsVRefNum;
								sKernelsDirID := KernelsDirID;
							end
						else
							beep;
					end;
      {ShowMessage(concat('KernelsRefNum=', long2str(KernelsRefNum), cr, 'vRefNum=', long2str(sKernelsVRefNum), cr, 'DirID=', long2str(sKernelsDirID)));}
			end; {with}
	end;
{$ENDC}


	procedure SaveSettings;
		var
			TheInfo: FInfo;
			ByteCount: LongInt;
			f, i: integer;
			err: OSErr;
			settings: SettingsType;
	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;
				sLG3DacLow := LG3DacLow;
				sLG3DacHigh := LG3DacHigh;
				sSyncMode := SyncMode;
				sSwitchLUTOnSuspend := SwitchLUTOnSuspend;
				sVideoRateAveraging := VideoRateAveraging;
				sImportInvert := ImportInvert;
				sTextCreator := TextCreator;
				for i := 1 to 10 do
					sUnused[i] := 0;
			end; {with}
{PBGetWDInfo seems to crash a lot, particularly under System 7. Does anyone know why?}
{SaveDefaultWorkingDir(settings);}
{SaveKernelsWorkingDir(settings);}
		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);
		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: boolean;
			tLine: LineType;
	begin
		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, 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^.RoiRect do begin
				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
								PutLong(tLine[hloc], 0);
								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;
					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, 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, 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
						PutMessage('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), cr);
						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 := 1;
				OffsetToData := 0;
				Resolution := 0.0;
				ResUnits := tNoUnits;
				OffsetToColorMap := 0;
				OffsetToImageHeader := -1;
				for entry := 1 to nEntries do begin
						GetTiffEntry(f, tag, N, value);
						if tag = 0 then begin
								PutMessage('Invalid TIFF format.');
								OpenTiffDirectory := false;
								exit(OpenTiffDirectory)
							end;
						case tag of
							ImageWidth: 
								width := value;
							ImageLength: 
								height := value;
							BitsPerSample:  begin
									BitsPerPixel := value;
									if value = 1 then begin
											PutMessage('NIH Image cannot open 1-bit TIFF files.');
											OpenTiffDirectory := false;
											exit(OpenTiffDirectory)
										end;
									if (value = 16) and not importing then begin
											PutMessage('Use Import to open 16-bit TIFF files.');
											OpenTiffDirectory := false;
											exit(OpenTiffDirectory)
										end;
								end;
							SamplesPerPixel: 
								if value > 1 then begin
										PutMessage('NIH Image cannot open 24-bit TIFF files.');
										OpenTiffDirectory := false;
										exit(OpenTiffDirectory)
									end;
							Compression: 
								if value <> 1 then begin
										PutMessage('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 value < height then begin
										if BitsPerPixel = 16 then
											BytesPerStrip := value * width * 2
										else
											BytesPerStrip := value * width;
										if StripOffsetsArray[2] <> (StripOffsetsArray[1] + BytesPerStrip) then begin
												PutMessage('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
						PutMessage('Error opening TIFF directory');
						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);
		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;
		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;
			ByteCount, width, height: LongInt;
			TiffInfo1: record
					Header: TiffHdr;   {8}
					nEntries: integer; {2}
					TiffDir: array[1..8] of TiffEntry; {96}
				end;
			ColorMapEntry: TiffEntry;  {12(Optional)}
			TiffInfo2: record
					ImageHdrEntry: TiffEntry;  {12}
					NextIFD: LongInt;  {4}
					filler: array[1..TiffFillerSize] of integer; {134}
				end;
	begin
		with info^ do begin
				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 := 10
						else
							nEntries := 9;
						for i := 1 to 8 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;
								offset := bsl(8, 16);
							end;
						with TiffDir[5] do begin
								TagField := PhotoInterp;
								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 := RowsPerStrip;
								offset := bsl(height, 16);
							end;
						with TiffDir[8] do begin
								TagField := StripByteCount;
								ftype := 4;
								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 StackInfo <> nil then
							if StackInfo^.nSlices > 1 then
								NextIFD := HeaderSize + TiffDirSize + ImageDataSize + ctabSize;
						for i := 1 to TiffFillerSize do
							filler[i] := 0;
					end;
			end;
		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
					PutMessage('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;
	begin
		with info^ do begin
				if not RoiShowing then begin
						PutMessage('No outline available to save.');
						exit(SaveOutline);
					end;
				if (RoiType = FreeLineRoi) or (RoiType = SegLineRoi) then begin
						PutMessage('Freehand and segmented line selections cannot be saved.');
						exit(SaveOutline);
					end;
				SaveCoordinates := (RoiType = PolygonRoi) or (RoiType = FreehandRoi);
				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(rX1, rY1, rX2, rY2);
						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
					PutMessage('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 (LongInt(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);
						PutMessage('File is corrupted.');
						exit(OpenOutline)
					end;
				if (rRoiRect.right > PicRect.right) or (rRoiRect.bottom > PicRect.bottom) then begin
						err := fsclose(f);
						PutMessage('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: 
						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;
				if BitsPerPixel = 16 then begin
						ImportCustomDepth := SixteenBitsUnsigned;
						ImportSwapBytes := IntelByteOrder;
					end
				else begin
						ImportCustomDepth := EightBits;
						ImportInvert := ZeroIsBlack;
					end;
				HasColorMap := OffsetToColorMap > 0;
			end;
		WhatToImport := ImportCustom;
		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: double);
	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.