unit UMUtilities;

{Contributed by Edward J. Huff <huff@mcclb0.med.nyu.edu> }
{Copyright is hereby waived:  UMUtilities.p is in the public domain.}

{User Macro "Utilities" package. }
{Macros which use these extensions should specify "requiresUser('Utilities',1)".}

interface

	uses
		QuickDraw, Palettes, PrintTraps, Globals, Utilities, File2, UMacroDef, GetFolder;
	procedure UMUtilitiesInit;
	procedure UMUtilitiesFinal;
	procedure UMUtilitiesAdd;
	procedure UMUtilitiesLookup (var uma: UserMacroArgs);
	procedure UMUtilitiesRun (var uma: UserMacroArgs);

implementation

{constants, types, vars for setMemo('str',value) and v := getMemo('str')}
	const
		maxhash = 1023; {must be a power of 2 minus 1}
		maxMemo = 12; {longest memo name string, must be even and at least 12}

	type
		memoName = packed array[1..maxMemo] of char;
		memoHandle = ^memoPtr;
		memoPtr = ^memoBucket;
		memoBucket = record
				nxt: memoHandle;
				nam: memoName;
				val: extended;
			end;
		memoTabHandle = ^memoTabPtr;
		memoTabPtr = ^memoTabType;
		memoTabType = array[0..maxhash] of memoHandle;
		p16s = ^integer;
	var
		memoTabH: memoTabHandle;
{end setMemo/getMemo}

	procedure DumpTokenName (tok: TokenType; var str: str255);
	begin
		case tok of
			NullT: 
				str := 'NullT';
			MacroT: 
				str := 'MacroT';
			NewLineT: 
				str := 'NewLineT';
			Identifier: 
				str := 'Identifier';
			UnknownIdentifier: 
				str := 'UnknownIdentifier';
			DoneT: 
				str := 'DoneT';
			StringLiteral: 
				str := 'StringLiteral';
			NumericLiteral: 
				str := 'NumericLiteral';
			CommandT: 
				str := 'CommandT';
			FunctionT: 
				str := 'FunctionT';
			ArrayT: 
				str := 'ArrayT';
			Variable: 
				str := 'Variable';
			ProcedureT: 
				str := 'ProcedureT';
			ProcIdT: 
				str := 'ProcIdT';
			StringT: 
				str := '';
			StringVariable: 
				str := '';
			StringFunctionT: 
				str := 'StringFunctionT';
			UserCommandT: 
				str := 'UserCommandT';
			UserFuncT: 
				str := 'UserFuncT';
			UserStrFuncT: 
				str := 'UserStrFuncT';
			otherwise begin
          {a bunch of tokens are left out...}
					NumToString(ord(tok), str);
					str := concat('token', str);
				end;
		end{case}
	end;


	procedure DumpSymbolTable (var uma: UserMacroArgs);
		var
			i: integer;
			str2: Str255;
	begin
		with uma do begin
				str := '';
				i := arg[1].ival;
				with MacrosP^ do
					if i > 0 then
						if i <= nSymbols then
							with SymbolTable[i] do begin
									DumpTokenName(tType, str);
									NumToString(ord(cType), str2);
									str := concat(symbol, ' ', str, ' command', str2, ' loc');
									NumToString(loc, str2);
									str := concat(str, str2);
								end;
			end;
	end;


	procedure UMUtilitiesInit;
	begin
		memoTabH := nil;
	end;


	procedure UMUtilitiesFinal;
	begin
	end;


	procedure UMUtilitiesAdd;
	begin
		AddUMSym('dumpSymbolTable', UserStrFuncT, dumpSymbolTableUC);
		AddUMSym('GetFolder', UserCommandT, getFolderUC);
		AddUMSym('GetDefFolder', UserCommandT, getDefFolderUC);
		AddUMSym('SetDefFolder', UserCommandT, setDefFolderUC);
		AddUMSym('GetMemo', UserFuncT, getMemoUC);
		AddUMSym('SetMemo', UserCommandT, setMemoUC);
		AddUMSym('ImportOnto', UserCommandT, importOntoUC);
		AddUMSym('getPicName', UserStrFuncT, getPicNameUC);
	end;


	procedure UMUtilitiesLookup (var uma: UserMacroArgs);
	begin
		with uma do
			case UserMacroCommand of
				dumpSymbolTableUC:  begin
						nArgs := 1;
						arg[1].atype := UMATinteger;
					end;
				getFolderUC:  begin
						nArgs := 0;
					end;
				getDefFolderUC:  begin
						nArgs := 2;
						arg[1].atype := UMATintvar;
						arg[2].atype := UMATintvar;
					end;
				setDefFolderUC:  begin
						nArgs := 2;
						arg[1].atype := UMATinteger;
						arg[2].atype := UMATinteger;
					end;
				getMemoUC:  begin
						nArgs := 1;
						arg[1].atype := UMATstring;
					end;
				setMemoUC:  begin
						nArgs := 2;
						arg[1].atype := UMATstring;
						arg[2].atype := UMATreal;
					end;
				importOntoUC:  begin
						nArgs := 3;
						arg[1].atype := UMATinteger;
						arg[2].atype := UMATinteger;
						arg[3].atype := UMATstring;
					end;
				getPicNameUC:  begin
						nArgs := 0;
					end;
				otherwise begin
						ErrorOccurred := true;
						str := 'Error UMUtilities.p LookupUserMacro';
					end;
			end;
	end;

{temporary solution which has the effect that the selected folder }
{cannot be thrashed in finder until after the application exits.}
{Proper solution is to eliminate use of DefaultRefNum}
{and use a DefaultDirID and DefaultVRefNum instead.}
{Parameter block}
{- - > 12 ioCompletion pointer}
{< - - 16 ioResult word }
{- - > 18 ioNamePtr pointer}
{ < - > 22 ioVRefNum word}
{- - > 28 ioWDProcID long word }
{- - > 48 ioWDDirID long word }

	procedure doGetFolder;
		var
			theSFR: StandardFileReply;
			theWD: WDPBRec;
			err: OSErr;
	begin
		StandardGetFolder(theSFR);
		with theSFR, theWD do
			if sfGood then begin
					ioCompletion := nil;
					ioNamePtr := @sfFile.name;
					ioVRefNum := sfFile.vRefNum;
					ioWDProcID := 0;
					ioWDDirID := sfFile.parID;
					err := PBOpenWD(@theWD, false);
					if err = NoErr then
						DefaultRefNum := ioVRefNum;
				end;
	end;


{Implemented using working directories.}
{When working directories are no longer used (replace fdopen with hopen }
{and replace DefaultRefNum with DefaultVRefNum and DefaultDirID) }
{then this will be much simpler.}

	procedure doGetDefFolder (var uma: UserMacroArgs);
		var
			wdRefNum: integer;
			vRefNum: integer;
			dirID: longint;
			procID: longint;
	begin
		with uma do begin
				if DefaultRefNum = 0 then
					doGetFolder;
				wdRefNum := DefaultRefNum;
				procID := 0;
				vRefNum := 0;
				dirID := 0;
				if GetWDInfo(wdRefNum, vRefNum, dirID, procID) <> noErr then begin
						errorOccurred := true;
						str := 'Default folder not found';
					end;
				arg[1].ival := vRefNum;
				arg[2].ival := dirID;
			end;
	end;


	procedure doSetDefFolder (var uma: UserMacroArgs);
		var
			theWD: WDPBRec;
			err: OSErr;
	begin
		with uma do begin
				with theWD do begin
						ioCompletion := nil;
						ioNamePtr := nil;
						ioVRefNum := arg[1].ival;
						ioWDProcID := 0;
						ioWDDirID := arg[2].ival;
						err := PBOpenWD(@theWD, false);
						if err = NoErr then
							DefaultRefNum := ioVRefNum;
					end;
			end;
	end;

	function memoHash (mn: memoName): integer;
		var
			h: integer;
			ip: p16s;
	begin
		h := 0;
		ip := p16s(@mn);
		h := bxor(ip^, h);
		ip := p16s(ord4(ip) + sizeof(integer));
		h := bxor(ip^, h);
		ip := p16s(ord4(ip) + sizeof(integer));
		h := bxor(ip^, h);
		ip := p16s(ord4(ip) + sizeof(integer));
		h := bxor(ip^, h);
		ip := p16s(ord4(ip) + sizeof(integer));
		h := bxor(ip^, h);
		ip := p16s(ord4(ip) + sizeof(integer));
		h := bxor(ip^, h);
		h := bxor(h, h div 32); {what is code for logical shift right?}
		memoHash := band(h, maxhash); {maxhash+1 is a power of 2}
	end;

	function initMemo (var uma: UserMacroArgs): Boolean;
		var
			i: integer;
	begin
		with uma do begin
				if memoTabH = nil then begin
						memoTabH := memoTabHandle(newHandle(sizeof(memoTabType)));
						if memoTabH = nil then begin
								errorOccurred := true;
								str := 'Out of memory';
								initMemo := true;
								exit(initMemo);
							end;
						for i := 0 to maxhash do begin
								memoTabH^^[i] := nil;
							end;
					end;
			end;
		initMemo := false;
	end;

	function mvstr (var uma: UserMacroArgs; var mn: memoName): Boolean;
		var
			i, len: integer;
			c: char;
	begin
		with uma do begin
				len := length(str);
				if len > maxMemo then begin
						errorOccurred := true;
						str := 'String too long';
						mvstr := true;
						exit(mvstr);
					end;
				i := 1;
				while i <= len do begin
						c := str[i];
						if (c >= 'A') and (c <= 'Z') then
							c := chr(ord(c) + 32);
						mn[i] := c;
						i := i + 1;
					end;
				while i <= maxMemo do begin
						mn[i] := ' ';
						i := i + 1;
					end;
			end;
		mvstr := false;
	end;


	procedure doSetMemo (var uma: UserMacroArgs);
		var
			hash: LongInt;
			h, prev: memoHandle;
			mn: memoName;
	begin
		with uma do begin
				if initMemo(uma) then
					exit(doSetMemo);
				if mvstr(uma, mn) then
					exit(doSetMemo);
				hash := memoHash(mn);
				h := memoTabH^^[hash];
				prev := nil;
				while h <> nil do begin
						if h^^.nam = mn then begin
								h^^.val := arg[2].aval;
								exit(doSetMemo);
							end;
						prev := h;
						h := h^^.nxt;
					end;
				h := memoHandle(newHandle(sizeof(memoBucket)));
				if h = nil then begin
						errorOccurred := true;
						str := 'Out of memory';
						exit(doSetMemo);
					end;
				h^^.nxt := nil;
				if prev = nil then
					memoTabH^^[hash] := h
				else
					prev^^.nxt := h;
				h^^.nam := mn;
				h^^.val := arg[2].aval;
			end;
	end;

	procedure doGetMemo (var uma: UserMacroArgs);
		var
			hash: LongInt;
			h: memoHandle;
			mn: memoName;
	begin
		with uma do begin
				if initMemo(uma) then
					exit(doGetMemo);
				if mvstr(uma, mn) then
					exit(doGetMemo);
				hash := memoHash(mn);
				h := memoTabH^^[hash];
				while h <> nil do begin
						if h^^.nam = mn then begin
								FuncResult := h^^.val;
								exit(doGetMemo);
							end;
						h := h^^.nxt;
					end;
        {create a new entry with value zero}
				FuncResult := 0.0;
				arg[2].aval := 0.0;
				doSetMemo(uma);
			end;
	end;

{copied from File1.p.  Alternatively, make it an interface proc in File1.p}
	procedure UnpackLines;
  {For odd width images, adds an extra byte to each line so RowBytes is even.}
		var
			i: integer;
			SrcPtr, DstPtr: ptr;
	begin
		with info^ do begin
				SrcPtr := ptr(ord4(PicBaseAddr) + LongInt(nlines - 1) * PixelsPerLine);
				DstPtr := ptr(ord4(PicBaseAddr) + LongInt(nlines - 1) * BytesPerRow);
				for i := 1 to nlines - 1 do begin
						BlockMove(SrcPtr, DstPtr, PixelsPerLine);
						SrcPtr := ptr(ord4(SrcPtr) - PixelsPerLine);
						DstPtr := ptr(ord4(DstPtr) - BytesPerRow);
					end;
			end;
	end;

	procedure doImportOnto (var uma: UserMacroArgs);
		var
			err: OSErr;
			vRefNum: integer;
			dirID: LongInt;
			f: integer;
			FileSize, DataSize: LongInt;
	begin
		with uma, Info^ do begin
				if Info = NoInfo then begin
						errorOccurred := true;
						str := 'No image window active';
						exit(doImportOnto);
					end;
				if (PixelsPerLine <> ImportCustomWidth) or (nlines <> ImportCustomHeight) then begin
						errorOccurred := true;
						str := 'Image size does not match import size';
						exit(doImportOnto);
					end;
				vRefNum := arg[1].ival;
				dirID := arg[2].ival;
				err := HOpenDF(vRefNum, dirID, str, fsRdPerm, f);
				if err <> NoErr then begin
						errorOccurred := true;
						str := 'file Open error';
						exit(doImportOnto);
					end;
				err := GetEof(f, FileSize);
				if (ImportCustomOffset + LongInt(ImportCustomWidth) * ImportCustomHeight) > FileSize then begin
						errorOccurred := true;
						str := 'File does not contain enough data';
						exit(doImportOnto)
					end;
				err := SetFPos(f, fsFromStart, ImportCustomOffset);
				DataSize := LongInt(nlines) * PixelsPerLine;
				err := fsread(f, DataSize, PicBaseAddr);
				if CheckIO(err) <> NoErr then begin
						err := fsclose(f);
						errorOccurred := true;
						str := 'file read error';
						exit(doImportOnto);
					end;
				if odd(PixelsPerLine) then
					UnpackLines;
				err := fsclose(f);
			end;
	end;

	procedure doGetPicName (var uma: UserMacroArgs);
	begin
		with uma do
			if Info = noInfo then begin
					errorOccurred := true;
					str := 'No Image window active';
				end
			else begin
					str := Info^.title;
				end;
	end;

	procedure UMUtilitiesRun (var uma: UserMacroArgs);
	begin
		with uma do
			case UserMacroCommand of
				dumpSymbolTableUC: 
					DumpSymbolTable(uma);
				getFolderUC: 
					doGetFolder;
				getDefFolderUC: 
					doGetDefFolder(uma);
				setDefFolderUC: 
					doSetDefFolder(uma);
				getMemoUC: 
					doGetMemo(uma);
				setMemoUC: 
					doSetMemo(uma);
				importOntoUC: 
					doImportOnto(uma);
				getPicNameUC: 
					doGetPicName(uma);
				otherwise begin
						ErrorOccurred := true;
						str := 'Error UMUtilities.p DoUserMacro';
					end;
			end;
	end;


end.