unit Macros1; {Contains the recursive descent parser/interpreter} {for NIH Image's Pascal-like macro language.} {References:} { "Pascal User Manual and Report", Kathleen Jensen and Niklaus Wirth, Springer-Verlag} { "Building Your Own C Interpreter", Dr. Dobb's Journal, August 1989} interface uses Memory, QuickDraw, Packages, Menus, Events, Fonts, Scrap, ToolUtils,Resources, Errors, Palettes, ColorPicker, Globals, Utilities, RealUtils, Graphics, Edit, {} Analysis, Camera, File1, File2, Filters, Macros2, Stacks, Lut, Background, {} User, Devices, Serial, PlugIns, Text, projection, math, fft; {,UMacroDef, UMacroRun} procedure RunMacro (nMacro: integer); procedure RunKeyMacro (ch: char; KeyCode: integer); procedure CloseSerialPorts; implementation const EndExpected = '"end" or ";" expected'; ThenExpected = '"then" expected'; DivideByZero = 'Divide by zero'; DoExpected = '"do" expected'; UntilExpected = '"until" expected'; RightParenExpected = '")" expected'; NoImageOpen = 'No Image open'; MaxArgs = 25; MaxLoopCount = 20; var nSaves, ErrorPC, LineStartPC: integer; SaveBackground: integer; SavePicWidth, SavePicHeight: LongInt; SaveMethod: rsMethodType; SaveCreate, SaveInvertY, SaveScaleArithmetic, SaveScaleConvolutions: boolean; SaveCurrentFontID, SaveCurrentSize, SaveTextJust: integer; SaveCurrentStyle: Style; SaveTextBack: TextBackType; SaveAngle, SaveH, SaveV: extended; DoOption, MacroOpPending, StringsAllocated, InPhotoMode: boolean; RoutinesCalled: set of CommandType; MacroTicks: LongInt; LoopCounter: LongInt; procedure test; var op:TokenTypeX; begin op:=token; end; function GetExpression: extended; forward; function GetBooleanExpression: extended; forward; procedure DoStatement; forward; procedure SkipStatement; forward; procedure DoFor; forward; procedure MacroError (str: str255); forward; function GetString: str255; forward; function GetInteger: LongInt; forward; procedure SkipIf; forward; procedure SkipPartialStatement; forward; {$S MacroUtil} {Routines from here to the $S compiler directive go in the MacroUtil segment} procedure PutTokenBack; begin if token <> DoneT then begin pc := SavePC; token := SaveToken; end; end; procedure DeallocateStrings (first, last: integer); var i: integer; begin with MacrosP^ do begin for i := first to last do begin if Stack[i].StringH <> nil then begin DisposeHandle(handle(Stack[i].StringH)); Stack[i].StringH := nil; end; end; end; end; procedure TrimString (var str: str255); begin if length(str) > 0 then begin while (length(str) > 1) and (str[1] = ' ') do delete(str, 1, 1); while (length(str) > 1) and ((str[length(str)] = ' ') or (str[length(str)] = ';')) do delete(str, length(str), 1); end; end; procedure LookupVariable; var VarFound: boolean; i: integer; begin with MacrosP^ do begin VarFound := false; i := TopOfStack + 1; repeat i := i - 1; VarFound := SymbolTableLoc = Stack[i].SymbolTableIndex until VarFound or (i = 1); if VarFound then with stack[i] do begin TokenValue := value; if vType <> StringVar then token := Variable else begin token := StringVariable; if StringH <> nil then TokenStr := StringH^^ else TokenStr := 'Deallocated String'; end; TokenStackLoc := i; end; end; {with} end; function FetchInteger: integer; var temp: integer; begin with macrosP^ do begin temp := ord(macros[pc]); pc := pc + 1; FetchInteger := bor(bsl(temp, 8), ord(macros[pc])); pc := pc + 1; end; end; procedure LookupProcedure; begin with MacrosP^ do begin SymbolTableLoc := FetchInteger; with SymbolTable[SymbolTableLoc] do begin TokenLoc := loc; TokenSymbol := symbol; end; end; end; function FetchReal: real; type bytes=packed array[1..4] of char; var vrec:record case integer of 1: (rv: real); 2: (b: bytes) end; begin with macrosP^,vrec do begin b[1] := macros[pc]; pc := pc + 1; b[2] := macros[pc]; pc := pc + 1; b[3] := macros[pc]; pc := pc + 1; b[4] := macros[pc]; pc := pc + 1; FetchReal:=rv; end; end; procedure GetToken; begin with MacrosP^ do begin if token = DoneT then exit(GetToken); SavePC := PC; SaveToken := token; token := TokenTypeX(ord(macros[pc])); while token = NewLineT do begin MacroLineNumber := MacroLineNumber + 1; pc := pc + 1; LineStartPC := pc; if pc > EndMacros then begin Token := DoneT; exit(GetToken); end; SavePC := PC; SaveToken := token; token := TokenTypeX(band(ord(macros[pc]),255)); end; pc := pc + 1; if pc > EndMacros then begin Token := DoneT; exit(GetToken); end; case token of CommandT, FunctionT, StringFunctionT, ArrayT, UserCommandT, UserFuncT, UserStrFuncT: begin MacroCommand := CommandType(ord(macros[pc])); pc := pc + 1; end; Identifier: begin SymbolTableLoc := FetchInteger; if TopOfStack > 0 then LookupVariable; end; ProcedureT: LookupProcedure; NumericLiteral: TokenValue := FetchReal; StringLiteral: begin TokenStr := ''; while ord(macros[pc]) <> 0 do begin TokenStr := Concat(TokenStr, macros[pc]); pc := pc + 1; end; pc := pc + 1; end; end; {case} end; {with} end; procedure GetMacroName; var i, len: integer; begin with MacrosP^ do begin pc := PCStart; repeat pc := pc - 1; if pc < 0 then exit(GetMacroName); until macros[pc] = chr(ord(MacroT)); GetToken; {MacroT} GetToken; {Macro name} if Token = StringLiteral then begin len := length(TokenStr); if len > SymbolSize then len := SymbolSize; for i := 1 to len do MacroOrProcName[i] := TokenStr[i]; end; end; end; procedure ConvertTokenToString (t: TokenTypeX; var str: str255); var i, j, len: integer; begin with MacrosP^ do case token of semicolon: str := ';'; comma: str := ','; colon: str := ':'; LeftParen: str := '('; RightParen: str := ')'; LeftBracket: str := '['; RightBracket: str := ']'; PlusOp: str := '+'; MinusOp: str := '-'; MulOp: str := '*'; DivOp: str := '/'; eqOp: str := '='; ltOp: str := '<'; gtOp: str := '>'; neOp: str := '<>'; leOp: str := '<='; geOp: str := '>='; orOp: str := 'or'; IntDivOp: str := 'div'; modOp: str := 'mod'; andOp: str := 'and'; NotOp: str := 'not'; AssignOp: str := ':='; Identifier, Variable, StringVariable, ProcIdT: begin for i := 1 to SymbolSize do str := Concat(str, SymbolTable[SymbolTableLoc].symbol[i]); TrimString(str); end; NumericLiteral: begin if trunc(TokenValue) = TokenValue then RealToString(TokenValue, 1, 0, str) else RealToString(TokenValue, 1, 1, str); end; StringLiteral: str := concat('''', TokenStr, ''''); CommandT, FunctionT, StringFunctionT, ArrayT, UserCommandT, UserFuncT, UserStrFuncT: for i := 1 to nSymbols do begin with SymbolTable[i] do if (tType = token) and (MacroCommand = cType) then begin for j := 1 to SymbolSize do str := Concat(str, symbol[j]); TrimString(str); end; end; {for} otherwise for i := 1 to nSymbols do begin with SymbolTable[i] do if tType = token then begin for j := 1 to SymbolSize do str := Concat(str, symbol[j]); TrimString(str); end; end; {for} end; {case} end; procedure GetErrorLine (var ErrorLine: str255); var str: str255; begin with MacrosP^ do begin pc := LineStartPC; ErrorLine := ''; repeat str := ''; if ord(macros[pc]) = ord(NewLineT) then {ppc-bug} leave; GetToken; ConvertTokenToString(token, str); if SavePC = ErrorPC then str := concat('Ç', str, 'È'); ErrorLine := concat(ErrorLine, ' ', str); until token = DoneT; end; end; procedure GetLocalLineNumber; begin pc := PCStart; MacroLineNumber := 1; while (pc <= errorpc) and (token <> DoneT) do GetToken; end; procedure GetGlobalLineNumber; begin pc := 0; MacroLineNumber := 1; while (pc <= errorpc) and (token <> DoneT) do GetToken; end; procedure MacroError (str: str255); {Report run-time errors} var name, ErrorLine, Line: str255; i, count, ignore: integer; begin with MacrosP^ do begin if token = DoneT then exit(MacroError); if TopOfStack > 0 then DeAllocateStrings(nGlobals + 1, TopOfStack); ErrorPC := SavePC; if MacroOrProcName = BlankSymbol then GetMacroName; if MacroOrProcName[SymbolSize] <> ' ' then MacroOrProcName[SymbolSize] := 'É'; name:='123456789012'; for i:=1 to 12 do name[i]:=MacroOrProcName[i]; TrimString(name); GetLocalLineNumber; Line := StringOf(MacroLineNumber:1); GetErrorLine(ErrorLine); InitCursor; GetGlobalLineNumber; Line:=StringOf(Line,' (',MacroLineNumber:1,')'); ParamText(str, Line, Name, ErrorLine); Ignore := Alert(900, nil); Token := DoneT; end; {with} end; procedure DoDeclaration; var SaveStackLoc, StackLoc: integer; begin SaveStackLoc := TopOfStack; while (token = Identifier) or (token = variable) or (token = comma) or (token = StringVariable) do begin if token = StringVariable then begin MacroError('Variable previously defined'); exit(DoDeclaration); end; if TopOfStack >= MaxMacroStackSize then begin MacroError(StackOverflow); exit(DoDeclaration); end; TopOfStack := TopOfStack + 1; with MacrosP^.stack[TopOfStack] do begin SymbolTableIndex := SymbolTableLoc; value := 0.0; StringH := nil; end; GetToken; if token = comma then GetToken; end; {while} if (token = FunctionT) or (token = StringFunctionT) or (token = CommandT) or (token = ArrayT) then MacroError('Predefined identifier'); if token <> colon then MacroError('":" expected'); GetToken; if (token <> IntegerT) and (token <> RealT) and (token <> BooleanT) and (token <> StringT) then MacroError('"integer", "real", "boolean" or "string" expected'); for StackLoc := SaveStackLoc + 1 to TopOfStack do with macrosP^.stack[StackLoc] do case token of IntegerT: vType := IntVar; RealT: vType := RealVar; BooleanT: vType := BooleanVar; StringT: begin StringsAllocated := true; vType := StringVar; StringH := str255H(NewHandle(SizeOf(str255))); if StringH = nil then begin MacroError('Out of memory'); Token := DoneT end else StringH^^ := 'Local String'; end; otherwise end; GetToken; if Token = SemiColon then GetToken; end; procedure GetLeftParen; begin GetToken; if token <> LeftParen then MacroError('"(" expected'); end; procedure GetRightParen; begin GetToken; if token <> RightParen then MacroError(RightParenExpected); end; procedure GetComma; begin GetToken; if token <> comma then MacroError('"," expected'); end; procedure GetArguments (var str: str255); var width, fwidth: integer; i: LongInt; isExpression, ZeroFill, noArgs, notFormatted: boolean; n: extended; str2: str255; begin if MacroCommand = WritelnC then begin {Check for Writeln with no arguments} GetToken; noArgs := token <> LeftParen; PutTokenBack; if NoArgs then begin str := ''; exit(GetArguments); end; end; ZeroFill := not (MacroCommand in [DrawTextC, WriteC, WritelnC, PutMsgC, ShowMsgC, PutSerialC, ConcatC]); width := 4; fwidth := 0; str := ''; GetLeftParen; GetToken; repeat isExpression := token in [Variable, NumericLiteral, FunctionT, UserFuncT, TrueT, FalseT, ArrayT, MinusOp, LeftParen]; notFormatted := true; PutTokenBack; if isExpression then n := GetBooleanExpression else str2 := GetString; GetToken; if token = colon then begin notFormatted := false; width := GetInteger; if width < 0 then width := 0; if width > 100 then width := 100; GetToken; if token = colon then begin fwidth := GetInteger; if fwidth < 0 then width := 0; if fwidth > 12 then width := 12; GetToken; end; end; if token = comma then GetToken; if isExpression then begin if notFormatted then if (trunc(n) <> n) and (not ZeroFill) then begin width := 1; fwidth := 4; end; str2:=StringOf(n:width:fwidth); if ZeroFill and (n >= 0) then for i := 1 to width do if str2[i] = ' ' then str2[i] := '0'; end; str := concat(str, str2); until (token = RightParen) or (token = DoneT); end; procedure DoUserToken; begin MacroError('UMX package not installed'); end; function DoGetString: str255; {(prompt,default:str255)} const StringID = 3; var prompt, default: str255; Canceled: boolean; mylog: DialogPtr; item: integer; begin GetLeftParen; prompt := GetString; GetToken; if token = Comma then default := GetString else begin default := ''; PutTokenBack end; GetRightParen; if Token <> DoneT then begin InitCursor; ParamText(prompt, '', '', ''); mylog := GetNewDialog(170, nil, pointer(-1)); SetDString(MyLog, StringID, default); SelectdialogItemText(MyLog, StringID, 0, 32767); OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); until (item = ok) or (item = cancel); if item = ok then DoGetString := GetDString(MyLog, StringID) else begin DoGetString := 'cancel'; token := DoneT; end; DisposeDialog(mylog); end; end; function GetSerial: str255; var count: LongInt; buffer: packed array[1..100] of char; err: OSErr; c:char; begin if SerialBufferP = nil then begin MacroError('Serial port not open'); exit(GetSerial); end; Err := SerGetBuf(SerialIn, count); if count > 0 then begin count := 1; Err := FSRead(SerialIn, count, @buffer); c:=buffer[1]; {ppc-bug} GetSerial :=c; end else GetSerial := ''; end; procedure RangeCheck (i: LongInt); begin if (i < 0) or (i > 255) then MacroError('Argument is less than 0 or greater than 255'); end; function DoChr: str255; var i: LongInt; begin GetLeftParen; i := GetInteger; GetRightParen; RangeCheck(i); if Token <> DoneT then begin DoChr := chr(i); end; end; function GetWindowTitle: str255; var wPeek: WindowPeek; begin wPeek := WindowPeek(FrontWindow); if wPeek = nil then begin GetWindowTitle := ''; exit(GetWindowTitle); end; if wPeek^.WindowKind = PicKind then GetWindowTitle := Info^.title else GetWindowTitle := wPeek^.TitleHandle^^; end; function DoStringFunction: str255; var str: str255; begin case MacroCommand of GetStringC: DoStringFunction := DoGetString; ChrC: DoStringFunction := DoChr; GetSerialC: DoStringFunction := GetSerial; ConcatC: begin GetArguments(str); DoStringFunction := str; end; WindowTitleC: DoStringFunction := GetWindowTitle; otherwise MacroError('"GetString ", "GetSerial" or "chr" expected'); end; end; function GetString: str255; begin GetToken; if token = StringFunctionT then GetString := DoStringFunction else if token = UserStrFuncT then begin DoUserToken; {result in TokenStr} GetString := TokenStr; end else if (token = StringLiteral) or (token = StringVariable) then GetString := TokenStr else begin MacroError('String expected'); GetString := ''; end; end; function GetInteger: LongInt; var n: LongInt; r: extended; begin r := GetExpression; if token = DoneT then begin GetInteger := 0; exit(GetInteger); end; GetInteger := round(r); end; procedure CheckBoolean (b: extended); begin if (b <> ord(true)) and (b <> ord(false)) then MacroError('Boolean expression expected'); end; function GetBoolean: boolean; var value: extended; begin value := GetBooleanExpression; CheckBoolean(value); GetBoolean := value = ord(true); end; function GetBooleanArg: boolean; begin GetLeftParen; GetBooleanArg := GetBoolean; GetRightParen; end; function GetStringArg: str255; begin GetLeftParen; GetStringArg := GetString; GetRightParen; end; procedure DoConvolve; var err: OSErr; f: integer; FileFound: boolean; fname: str255; begin fname := GetStringArg; if token <> DoneT then begin if (fname = '') and (CurrentWindow = TextKind) then begin ConvolveUsingText; exit(DoConvolve); end; err := fsopen(fname, KernelsRefNum, f); FileFound := err = NoErr; err := fsclose(f); if FileFound then convolve(fname, KernelsRefNum) else convolve('', 0); end; end; function GetNumber: extended; {(prompt:str255; default:extended; [precision:integer])} var prompt: str255; default, n: extended; Canceled, OptionalArgument: boolean; begin GetLeftParen; prompt := GetString; GetComma; default := GetExpression; GetToken; OptionalArgument := token <> RightParen; PutTokenBack; if OptionalArgument then begin GetComma; precision := GetInteger; if precision < 0 then precision := 0; if precision > 5 then precision := 5; end else precision := 2; GetRightParen; n := 0.0; if Token <> DoneT then begin n := GetReal(prompt, default, precision, Canceled); if Canceled then begin n := default; token := DoneT; end; end; GetNumber := n; end; function DoGetPixel: extended; {(hloc,vloc:integer)} var hloc, vloc: LongInt; begin GetLeftParen; hloc := GetInteger; GetComma; vloc := GetInteger; GetRightParen; if (Token <> DoneT) and (info <> NoInfo) then DoGetPixel := MyGetPixel(hloc, vloc) else DoGetPixel := 0.0; end; function DoFunction (c: CommandType): extended; var n: extended; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; n := GetExpression; GetRightParen; if Token <> DoneT then case SaveCommand of truncC: DoFunction := trunc(n); roundC: DoFunction := round(n); oddC: if odd(trunc(n)) then DoFunction := ord(true) else DoFunction := ord(false); absC: DoFunction := abs(n); sqrtC: if n < 0.0 then MacroError('Sqrt Error') else DoFunction := sqrt(n); sqrC: DoFunction := sqr(n); sinC: DoFunction := sin(n); cosC: DoFunction := cos(n); expC: DoFunction := exp(n); lnC: if n <= 0.0 then MacroError('Log Error') else DoFunction := ln(n); arctanC: DoFunction := arctan(n); end else DoFunction := 0.0; end; function CalibrateValue: extended; var i: integer; begin GetLeftParen; i := GetInteger; GetRightParen; RangeCheck(i); if Token <> DoneT then begin CalibrateValue := cvalue[i]; end; end; function DoOrd: extended; var str: str255; begin GetLeftParen; str := GetString; GetRightParen; if Token <> DoneT then begin if length(str) >= 1 then DoOrd := ord(str[1]) else DoOrd := -1; end; end; function DoStringToNum: extended; var str: str255; n: extended; begin GetLeftParen; str := GetString; GetRightParen; if Token <> DoneT then begin n := StringToReal(str); if n = BadReal then DoStringToNum := 0.0 else DoStringToNum := n; end; end; function DoLogicalFunction (c: CommandType): extended; var n1, n2: LongInt; begin GetLeftParen; n1 := GetInteger; GetComma; n2 := GetInteger; GetRightParen; if Token <> DoneT then begin if c = BitAndC then DoLogicalFunction := band(n1, n2) else DoLogicalFunction := bor(n1, n2) end; end; function PidExists: boolean; {(pid:integer)} var pid, i: integer; begin GetLeftParen; pid := GetInteger; GetRightParen; if Token <> DoneT then begin PidExists := false; for i := 1 to nPics do if InfoPtr(WindowPeek(PicWindow[i])^.RefCon)^.pidNum = pid then begin PidExists := true; leave; end; end; end; function DoPos: integer; var substr, str: str255; begin GetLeftParen; substr := GetString; GetComma; str := GetString; GetRightParen; if Token <> DoneT then DoPos := pos(substr, str); end; function DoLength: integer; var str: str255; begin GetLeftParen; str := GetString; GetRightParen; if Token <> DoneT then DoLength := length(str); end; function isKeyDown:boolean; {(key:string)} var key: str255; begin GetLeftParen; key := GetString; GetRightParen; if token <> DoneT then begin MakeLowerCase(key); isKeydown:=false; if (pos('option', key) <> 0) and OptionKeyDown then isKeyDown:=true else if (pos('shift', key) <> 0) and ShiftKeyDown then isKeyDown:=true else if (pos('control', key) <> 0) and ControlKeyDown then isKeyDown:=true; end; end; function GetParameter:LongInt; {parameter:string} var param: str255; begin GetLeftParen; param := GetString; GetRightParen; if token <> DoneT then begin MakeLowerCase(param); if pos('maxmeasure', param) <> 0 then GetParameter := MaxMeasurements else if pos('undo', param) <> 0 then GetParameter := UndoBufSize else if pos('freemem', param) <> 0 then GetParameter := FreeMem else if pos('maxblock', param) <> 0 then GetParameter := MaxBlock else if pos('roitype', param) <> 0 then begin if info = nil then GetParameter := 0 else case Info^.RoiType of noRoi: GetParameter := 0; RectRoi: GetParameter := 1; OvalRoi: GetParameter := 2; PolygonRoi: GetParameter := 3; FreehandRoi: GetParameter := 4; TracedRoi: GetParameter := 5; LineRoi: GetParameter := 6; FreeLineRoi: GetParameter := 7; SegLineRoi: GetParameter := 8; end end else begin MacroError('Invalid argument'); GetParameter := 0; end; end; end; function ExecuteFunction: extended; begin case MacroCommand of TruncC, RoundC, oddC, absC, sqrtC, sqrC, sinC, cosC, expC, lnC, arctanC: ExecuteFunction := DoFunction(MacroCommand); GetNumC: ExecuteFunction := GetNumber; RandomC: ExecuteFunction := (random + 32767.0) / 65534.0; GetPixelC: ExecuteFunction := DoGetPixel; ButtonC: begin ExecuteFunction := ord(Button); FlushEvents(EveryEvent, 0); end; nPicsC: ExecuteFunction := nPics; PicNumC: ExecuteFunction := info^.PicNum; PidNumC: ExecuteFunction := info^.PidNum; PidExistsC: ExecuteFunction := ord(PidExists); SameSizeC: ExecuteFunction := ord(AllSameSize); cValueC: ExecuteFunction := CalibrateValue; CalibratedC: ExecuteFunction := ord(info^.fit <> uncalibrated); rCountC: ExecuteFunction := mCount; GetSliceC: with info^ do if StackInfo = nil then ExecuteFunction := 0 else ExecuteFunction := Info^.StackInfo^.CurrentSlice; nSlicesC: with info^ do if StackInfo = nil then ExecuteFunction := 0 else ExecuteFunction := Info^.StackInfo^.nSlices; GetSpacingC: with info^ do if StackInfo = nil then MacroError('No stack') else with Info^.StackInfo^ do begin if StackType = MovieStack then ExecuteFunction := Info^.StackInfo^.FrameInterval else ExecuteFunction := Info^.StackInfo^.SliceSpacing; end; nCoordinatesC: ExecuteFunction := nCoordinates; OrdC: ExecuteFunction := DoOrd; TickCountC: ExecuteFunction := TickCount; StringToNumC: ExecuteFunction := DoStringToNum; UndoSizeC: ExecuteFunction := UndoBufSize; BitAndC, BitOrC: ExecuteFunction := DoLogicalFunction(MacroCommand); PosC: ExecuteFunction := DoPos; LengthC: ExecuteFunction := DoLength; KeyDownC: ExecuteFunction := ord(isKeyDown); GetC: ExecuteFunction := GetParameter; end; {case} end; procedure CheckIndex (index, min, max: LongInt); begin if (index < min) or (index > max) then MacroError('Array index out of range'); end; function GetArrayValue: extended; var SaveArrayType: ArrayType; Index: LongInt; xcoord, ycoord: integer; begin SaveArrayType := ArrayType(MacroCommand); GetToken; if token <> LeftBracket then MacroError('"[" expected'); Index := GetInteger; GetToken; if token <> RightBracket then MacroError('"]" expected'); case SaveArrayType of HistogramA: begin RangeCheck(Index); GetArrayValue := histogram[Index]; end; rAreaA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := mArea^[Index]; end; rMeanA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := mean^[Index]; end; rStdDevA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := sd^[Index]; end; rXA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := xcenter^[Index]; end; rYA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := ycenter^[Index]; end; rLengthA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := pLength^[Index]; end; rMinA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := mMin^[Index]; end; rMaxA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := mMax^[Index]; end; rMajorA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := MajorAxis^[Index]; end; rMinorA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := MinorAxis^[Index]; end; rAngleA: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := orientation^[Index]; end; rUser1A: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := User1^[Index]; end; rUser2A: begin CheckIndex(Index, 1, MaxMeasurements); GetArrayValue := User2^[Index]; end; RedLutA, GreenLutA, BlueLutA: if OptionKeyDown then begin RangeCheck(Index); if Token <> DoneT then with cScreenPort^.portPixMap^^.pmTable^^.ctTable[index].rgb do case SaveArrayType of RedLutA: GetArrayValue := band(bsr(red, 8), 255); GreenLutA: GetArrayValue := band(bsr(green, 8), 255); BlueLutA: GetArrayValue := band(bsr(blue, 8), 255); end; {case} end else begin RangeCheck(Index); if Token <> DoneT then with osGDevice^^.gdPMap^^.pmTable^^.ctTable[index].rgb do case SaveArrayType of RedLutA: GetArrayValue := band(bsr(red, 8), 255); GreenLutA: GetArrayValue := band(bsr(green, 8), 255); BlueLutA: GetArrayValue := band(bsr(blue, 8), 255); end; {case} end; BufferA: begin CheckIndex(Index, 0, MaxLine - 1); if Token <> DoneT then GetArrayValue := MacrosP^.aLine[index]; end; PlotDataA: begin CheckIndex(Index, 0, MaxLine - 1); if Token <> DoneT then GetArrayValue := PlotData^[index]; end; xCoordinatesA: begin CheckIndex(Index, 1, MaxCoordinates); if Token <> DoneT then with info^ do begin xcoord := xCoordinates^[index]; if SpatiallyCalibrated then GetArrayValue := xcoord / xScale else GetArrayValue := xcoord end; end; yCoordinatesA: begin CheckIndex(Index, 1, MaxCoordinates); if Token <> DoneT then with info^ do begin ycoord := yCoordinates^[index]; if InvertYCoordinates and (Info <> NoInfo) then ycoord := Info^.PicRect.bottom - ycoord - 1; if SpatiallyCalibrated then GetArrayValue := ycoord / yScale else GetArrayValue := ycoord end; end; ScionA: begin if framegrabber <> ScionLG3 then MacroError('No Scion LG-3'); if Token <> DoneT then CheckIndex(Index, 1, 4); if Token <> DoneT then case index of 1: GetArrayValue := LG3DacA; 2: GetArrayValue := LG3DacB; 3: GetArrayValue := ControlReg^; 4: GetArrayValue := LG3DataOut; end; end; end; {case} end; function GetStringValue: extended; {Convert string to a base 102 number so we can do comparisons.} const base = 102; var i, j: integer; v, k: extended; begin MakeLowerCase(TokenStr); k := 1; v := 0.0; for i := 1 to length(TokenStr) do begin j := ord(TokenStr[i]); if j > 127 then j := 127; if j >= 91 then j := j - 26; v := v + j * k; k := k * base; end; GetStringValue := v; end; function GetValue: extended; begin case token of Variable, NumericLiteral: GetValue := TokenValue; FunctionT: GetValue := ExecuteFunction; StringFunctionT: begin TokenStr := DoStringFunction; GetValue := GetStringValue; end; UserFuncT: begin DoUserToken;{output in TokenValue} GetValue := TokenValue; end; UserStrFuncT: begin DoUserToken; {output in TokenStr} GetValue := GetStringValue; end; TrueT: GetValue := ord(true); FalseT: GetValue := ord(false); ArrayT: GetValue := GetArrayValue; StringVariable, StringLiteral: GetValue := GetStringValue; otherwise begin MacroError('Number expected'); GetValue := 0.0; exit(GetValue); end; end; {case} end; function GetFactor: extended; var fValue: extended; isUnaryMinus, isNot: boolean; begin GetToken; isUnaryMinus := token = MinusOp; isNot := token = NotOp; if isUnaryMinus or isNot then GetToken; case token of Variable, NumericLiteral, FunctionT, StringFunctionT, UserFuncT, UserStrFuncT, TrueT, FalseT, ArrayT, StringVariable, StringLiteral: fValue := GetValue; LeftParen: begin fValue := GetBooleanExpression; GetRightParen; end; otherwise begin macroError('Undefined identifier'); fvalue := 0.0 end; end; if isUnaryMinus then fValue := -fValue; if isNot then if fValue = ord(true) then fValue := ord(false) else fValue := ord(true); GetFactor := fValue; GetToken; end; function GetTerm: extended; var tValue, fValue: extended; op: TokenTypeX; begin tValue := GetFactor; while token in [MulOp, IntDivOp, ModOp, DivOp, AndOp] do begin op := token; fValue := GetFactor; case op of MulOp: tValue := tValue * fValue; IntDivOp: if fValue <> 0.0 then tValue := trunc(tValue) div trunc(fValue) else MacroError(DivideByZero); ModOp: if fValue <> 0.0 then tValue := trunc(tValue) mod trunc(fValue) else MacroError(DivideByZero); DivOp: if fValue <> 0.0 then tValue := tValue / fValue else MacroError(DivideByZero); AndOp: begin CheckBoolean(tValue); CheckBoolean(fValue); tValue := ord((tValue = ord(true)) and (fValue = ord(true))); end; end; {case} end; {while} GetTerm := tValue; end; function GetSimpleExpression: extended; var seValue, tValue: extended; op: TokenTypeX; begin seValue := GetTerm; while token in [PlusOp, MinusOp, OrOp] do begin op := token; tValue := GetTerm; case op of PlusOp: seValue := seValue + tValue; MinusOp: seValue := seValue - tValue; orOp: begin CheckBoolean(seValue); CheckBoolean(tValue); seValue := ord((seValue = ord(true)) or (tValue = ord(true))); end; end; end; GetSimpleExpression := seValue; end; function GetExpression: extended; var seValue, tValue: extended; op: TokenTypeX; begin seValue := GetTerm; while token in [PlusOp, MinusOp, OrOp] do begin op := token; tValue := GetTerm; case op of PlusOp: seValue := seValue + tValue; MinusOp: seValue := seValue - tValue; orOp: begin CheckBoolean(seValue); CheckBoolean(tValue); seValue := ord((seValue = ord(true)) or (tValue = ord(true))); end; end; end; GetExpression := seValue; PutTokenBack; end; function GetBooleanExpression: extended; var eValue, seValue: extended; op: TokenTypeX; begin eValue := GetSimpleExpression; while token in [eqOp, ltOp, gtOp, neOp, leOp, geOp] do begin op := token; seValue := GetSimpleExpression; case op of eqOp: eValue := ord(eValue = seValue); ltOp: eValue := ord(eValue < seValue); gtOp: eValue := ord(eValue > seValue); neOp: eValue := ord(eValue <> seValue); leOp: eValue := ord(eValue <= seValue); geOp: eValue := ord(eValue >= seValue); end; end; GetBooleanExpression := eValue; PutTokenBack; end; {$S} {Routines from here to the end of the file go in the macro1 segment} procedure DoCapture; begin CaptureAndDisplayFrame; if ContinuousHistogram then ShowContinuousHistogram; end; procedure DoWait; var seconds: extended; SaveTicks: LongInt; str: str255; theEvent: EventRecord; begin GetLeftParen; seconds := GetExpression; GetRightParen; if Token <> DoneT then begin SaveTicks := TickCount + round(seconds * 60.0); repeat if Digitizing then DoCapture; if EventAvail(everyEvent, theEvent) then ; {Allows background tasks to run} until (TickCount > SaveTicks) or CommandPeriod; end; end; procedure SetDensitySlice; {LowerLevel,UpperLevel:integer} {Disable density slicing if lower and upper=0 and enable it up lower and upper=255} var sStart, sEnd: integer; begin GetLeftParen; sStart := GetInteger; RangeCheck(sStart); GetComma; sEnd := GetInteger; RangeCheck(sEnd); GetRightParen; if Token <> DoneT then begin DisableDensitySlice; DisableThresholding; if (sEnd < sStart) or ((sStart = 0) and (sEnd = 0)) then exit(SetDensitySlice); if not ((sStart = 255) and (sEnd = 255)) then begin SliceStart := sStart; SliceEnd := sEnd; if SliceStart < 1 then SliceStart := 1; if SliceEnd > 254 then SliceEnd := 254; end; EnableDensitySlice; end; end; procedure SetColor; var index: integer; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; index := GetInteger; GetRightParen; RangeCheck(index); if Token <> DoneT then begin if SaveCommand = SetForeC then SetForegroundColor(index) else SetBackgroundColor(index); end; end; procedure DoConstantArithmetic; var constant: extended; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; constant := GetExpression; GetRightParen; if token <> DoneT then case SaveCommand of AddConstC: DoArithmetic(AddItem, constant); MulConstC: DoArithmetic(MultiplyItem, constant); end; end; procedure GetNextWindow; var n: integer; begin n := info^.PicNum + 1; if n > nPics then n := 1; StopDigitizing; SaveRoi; DisableDensitySlice; SelectWindow(PicWindow[n]); Info := pointer(WindowPeek(PicWindow[n])^.RefCon); ActivateWindow; GenerateValues; LoadLUT(info^.cTable); UpdatePicWindow; end; procedure DoRevert; begin if info^.revertable then begin RevertToSaved; UpdatePicWindow; end else MacroError('Unable to revert'); end; procedure MakeRoi; var Left, Top, Width, Height: integer; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; left := GetInteger; GetComma; top := GetInteger; GetComma; width := GetInteger; if width < 1 then width := 1; GetComma; height := GetInteger; if height < 1 then height := 1; GetRightParen; KillRoi; if token <> DoneT then with Info^ do begin StopDigitizing; if SaveCommand = MakeOvalC then RoiType := OvalRoi else RoiType := RectRoi; SetRect(RoiRect, left, top, left + width, top + height); MakeRegion; SetupUndo; RoiShowing := true; end; end; procedure MoveRoi; var DeltaH, DeltaV: integer; begin GetLeftParen; DeltaH := GetInteger; GetComma; DeltaV := GetInteger; GetRightParen; with info^ do begin if not RoiShowing then begin MacroError('No Selection'); exit(MoveRoi); end; OffsetRgn(roiRgn, DeltaH, DeltaV); RoiRect := roiRgn^^.rgnBBox; end; end; procedure InsetRoi; var delta: integer; begin GetLeftParen; delta := GetInteger; GetRightParen; with info^ do begin if not RoiShowing then begin MacroError('No Selection'); exit(InsetRoi); end; InsetRgn(roiRgn, delta, delta); RoiRect := roiRgn^^.rgnBBox; end; end; procedure DoMoveTo; {(x,y:integer)} begin GetLeftParen; CurrentX := GetInteger; GetComma; CurrentY := GetInteger; GetRightParen; InsertionPoint.h := CurrentX; InsertionPoint.v := CurrentY + 4; end; procedure DoDrawtext (str: str255; EndOfLine: boolean); begin if info <> NoInfo then begin KillRoi; DrawTextString(str, InsertionPoint, TextJust); if EndOfLine then begin CurrentY := CurrentY + CurrentSize; InsertionPoint.h := CurrentX; InsertionPoint.v := CurrentY + 4; end; end; end; procedure DrawNumber; var n: extended; str: str255; fwidth: integer; begin GetLeftParen; n := GetExpression; GetRightParen; if token <> DoneT then begin if n = trunc(n) then fwidth := 0 else fwidth := precision; RealToString(n, 1, fwidth, str); DoDrawText(str, true); end; end; procedure SetFont; var FontName: str255; id: integer; begin FontName := GetStringArg; if Token <> DoneT then begin GetFNum(FontName, id); if id = 0 then MacroError('Font not available') else CurrentFontID := id; end; end; procedure SetFontSize; var size: integer; begin GetLeftParen; Size := GetInteger; GetRightParen; if (size < 6) or (size > 720) then MacroError('Argument out of range'); if Token <> DoneT then CurrentSize := size; end; procedure SetText; var Attributes: str255; begin Attributes := GetStringArg; if Token <> DoneT then begin MakeLowerCase(Attributes); if pos('with', Attributes) <> 0 then TextBack := WithBack; if pos('no', Attributes) <> 0 then TextBack := NoBack; if pos('left', Attributes) <> 0 then TextJust := teJustLeft; if pos('center', Attributes) <> 0 then TextJust := teJustCenter; if pos('right', Attributes) <> 0 then TextJust := teJustRight; CurrentStyle := []; if pos('bold', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Bold]; if pos('italic', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Italic]; if pos('underline', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Underline]; if pos('outline', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Outline]; if pos('shadow', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Shadow]; end; end; procedure DoPutMessage; var str: str255; begin GetArguments(str); if Token <> DoneT then PutMessage(str) end; function GetVar: integer; begin GetVar := 0; GetToken; if token <> Variable then MacroError('Variable expected') else GetVar := TokenStackLoc; end; procedure GetPicSize; {(width,height)} var loc1, loc2: integer; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^ do if info = NoInfo then begin stack[loc1].value := 0.0; stack[loc2].value := 0.0; end else with info^ do begin stack[loc1].value := PixelsPerLine; stack[loc2].value := nLines; end; end; procedure GetRoi; {(hloc,vloc,width,height)} var loc1, loc2, loc3, loc4: integer; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetComma; loc3 := GetVar; GetComma; loc4 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^, Info^ do if RoiShowing then with RoiRect do begin stack[loc1].value := left; stack[loc2].value := top; stack[loc3].value := right - left; stack[loc4].value := bottom - top; end else begin stack[loc1].value := 0.0; stack[loc2].value := 0.0; stack[loc3].value := 0.0; stack[loc4].value := 0.0; end; end; procedure CaptureOneFrame; begin if FrameGrabber = noFrameGrabber then MacroError('Frame grabber not installed') else begin StartDigitizing; CaptureAndDisplayFrame; StopDigitizing; end; end; procedure DoMakeNewWindow; {(name:str255)} var name: str255; begin GetArguments(name); if token <> DoneT then if (NewPicWidth * NewPicHeight) > UndoBufSize then MacroError('New window larger than Undo buffer') else if not NewPicWindow(name, NewPicWidth, NewPicHeight) then MacroError('Out of memory'); end; procedure DoSetPalette; var PaletteType: str255; ok, OptionalArgument: boolean; nExtra: LongInt; begin GetLeftParen; PaletteType := GetString; GetToken; OptionalArgument := token <> RightParen; PutTokenBack; if OptionalArgument then begin GetComma; nExtra := GetInteger; if nExtra < 0 then nExtra := 0; if nExtra > 6 then nExtra := 6; end; GetRightParen; if token <> DoneT then begin MakeLowerCase(PaletteType); if pos('gray', PaletteType) <> 0 then ResetGrayMap else if pos('pseudo', PaletteType) <> 0 then SwitchColorTables(Pseudo20Item, true) else if pos('system', PaletteType) <> 0 then SwitchColorTables(SystemPaletteItem, true) else if pos('rainbow', PaletteType) <> 0 then SwitchColorTables(RainbowItem, true) else if pos('spectrum', PaletteType) <> 0 then SwitchColorTables(SpectrumItem, true); if OptionalArgument then begin nExtraColors := nExtra; RedrawLUTWindow; end; end; end; procedure DoOpenImage; var err: OSErr; f: integer; FileFound, result: boolean; fname: str255; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetArguments(fname); if token <> DoneT then begin if fname = '' then fname := DefaultFileName; err := fsopen(fname, DefaultRefNum, f); FileFound := err = NoErr; err := fsclose(f); if FileFound then case SaveCommand of OpenC: result := DoOpen(fname, DefaultRefNum); ImportC: result := ImportFile(fname, DefaultRefNum); end else case SaveCommand of OpenC: result := DoOpen('', 0); ImportC: result := ImportFile('', 0); end; if result then UpdatePicWindow else token := DoneT; end; end; procedure SetImportAttributes; var Attributes: str255; begin Attributes := GetStringArg; if Token <> DoneT then begin MakeLowerCase(Attributes); WhatToImport := ImportTIFF; ImportCustomDepth := EightBits; ImportSwapBytes := false; ImportCalibrate := false; ImportAll := false; ImportAutoScale := true; ImportInvert := false; if pos('dicom', Attributes) <> 0 then WhatToImport := ImportDICOM; if pos('mcid', Attributes) <> 0 then WhatToImport := ImportMCID; if pos('look', Attributes) <> 0 then WhatToImport := ImportLUT; if pos('palette', Attributes) <> 0 then WhatToImport := ImportLUT; if pos('text', Attributes) <> 0 then WhatToImport := ImportText; if pos('custom', Attributes) <> 0 then WhatToImport := ImportCustom; if (pos('8', Attributes) <> 0) or (pos('eight', Attributes) <> 0) then begin ImportCustomDepth := EightBits; WhatToImport := ImportCustom; end; if (pos('signed', Attributes) <> 0) then begin ImportCustomDepth := SixteenBitsSigned; WhatToImport := ImportCustom; end; if (pos('unsigned', Attributes) <> 0) then begin ImportCustomDepth := SixteenBitsUnsigned; WhatToImport := ImportCustom; end; if (pos('swap', Attributes) <> 0) then ImportSwapBytes := true; if (pos('calibrate', Attributes) <> 0) then ImportCalibrate := true; if (pos('fixed', Attributes) <> 0) then ImportAutoScale := false; if (pos('all', Attributes) <> 0) then ImportAll := true; if (pos('invert', Attributes) <> 0) then ImportInvert := true; end; end; procedure SetImportMinMax; {(min,max:integer)} var TempMin, TempMax: extended; begin GetLeftParen; TempMin := GetExpression; GetComma; TempMax := GetExpression; GetRightParen; if Token <> DoneT then begin ImportAutoScale := false; ImportMin := TempMin; ImportMax := TempMax; end; end; procedure SetCustomImport; {(width,height,offset[,nslices]:integer)} var width, height, nSlices: integer; offset: LongInt; begin GetLeftParen; width := GetInteger; GetComma; height := GetInteger; GetComma; offset := GetInteger; GetToken; if token = comma then nSlices := GetInteger else begin PutTokenBack; nSlices := 1 end; GetRightParen; if (width < 0) or (width > MaxPicSize) or (height < 0) or (offset < 0) or (nSlices < 1) then MacroError('Argument out of range'); if Token <> DoneT then begin ImportCustomWidth := width; ImportCustomHeight := height; ImportCustomOffset := offset; ImportCustomSlices := nSlices; WhatToImport := ImportCustom; end; end; procedure SelectImage (id: integer); begin StopDigitizing; SaveRoi; DisableDensitySlice; SelectWindow(PicWindow[id]); Info := pointer(WindowPeek(PicWindow[id])^.RefCon); ActivateWindow; GenerateValues; LoadLUT(info^.cTable); UpdatePicWindow; end; procedure SelectPic; {(PicN:integer)} var PicN, i: integer; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; PicN := GetInteger; GetRightParen; i := 0; while (PicN < 0) and (i < nPics) do begin i := i + 1; if InfoPtr(WindowPeek(PicWindow[i])^.RefCon)^.pidNum = PicN then PicN := i; end; if (PicN < 1) or (PicN > nPics) then MacroError('Specified image does not exist'); if Token <> DoneT then begin if SaveCommand = SelectPicC then SelectImage(PicN) else begin StopDigitizing; DisableDensitySlice; Info := pointer(WindowPeek(PicWindow[PicN])^.RefCon); end; end; end; procedure SetPicName; {(name:string)} var n, i: LongInt; isInteger: boolean; name: str255; begin GetArguments(name); if Token <> DoneT then begin with info^ do begin title := name; if PictureType <> FrameGrabberType then PictureType := NewPicture; UpdateWindowsMenuItem; UpdateTitleBar; end; end; end; procedure SetNewSize; {(width,height:integer)} var TempWidth, TempHeight: integer; begin GetLeftParen; TempWidth := GetInteger; GetComma; TempHeight := GetInteger; GetRightParen; if Token <> DoneT then begin NewPicWidth := TempWidth; NewPicHeight := TempHeight; if NewPicWidth > MaxPicSize then NewPicWidth := MaxPicSize; if NewPicWidth < 8 then NewPicWidth := 8; if NewPicHeight < 8 then NewPicHeight := 8; if NewPicHeight > MaxPicSize then NewPicHeight := MaxPicSize; end; end; procedure DoSaveAs; var name: str255; RefNum: integer; HasArgs: boolean; begin name := info^.title; if (name = 'Untitled') or (name = 'Camera') then name := ''; GetToken; HasArgs := token = LeftParen; PutTokenBack; if HasArgs then GetArguments(name); if token <> DoneT then begin StopDigitizing; if nSaves = 0 then RefNum := 0 else RefNum := DefaultRefNum; case CurrentWindow of TextKind: if pos(':', name) <> 0 then SaveTextUsingPath(name) else SaveTextAs; ResultsKind: Export('', RefNum); otherwise begin if info <> NoInfo then SaveAs(name, RefNum) else MacroError(NoImageOpen); end; end; nSaves := nSaves + 1; end; end; procedure DoSave; var kind: integer; begin StopDigitizing; kind := CurrentWindow; if (kind = PicKind) or (kind = TextKind) or (Kind = ResultsKind) then SaveFile else MacroError('Nothing to save'); end; procedure DoExport; var name: str255; RefNum: integer; HasArgs: boolean; begin StopDigitizing; name := info^.title; if (name = 'Untitled') or (name = 'Camera') then name := ''; GetToken; HasArgs := token = LeftParen; PutTokenBack; if HasArgs then GetArguments(name); if nSaves = 0 then RefNum := 0 else RefNum := DefaultRefNum; Export(name, RefNum); nSaves := nSaves + 1; end; procedure DoCopyResults; var IgnoreResult: boolean; begin if mCount < 1 then MacroError('Copy Results failed') else begin CopyResults; IgnoreResult := SystemEdit(3); {Fake Copy needed for MultiFinder} end; end; procedure DisposeAll; var i, ignore: integer; begin StopDigitizing; for i := nPics downto 1 do begin Info := pointer(WindowPeek(PicWindow[i])^.RefCon); ignore := CloseAWindow(info^.wptr); end; end; procedure DoDuplicate; var str: str255; begin GetArguments(str); if token <> DoneT then if not Duplicate(str, false) then token := DoneT else UpdatePicWindow; end; procedure DoLineTo; {(x,y:integer)} var x, y: integer; p1, p2: point; begin GetLeftParen; p2.h := GetInteger; GetComma; p2.v := GetInteger; GetRightParen; if token <> DoneT then begin KillRoi; p1.h := CurrentX; p1.v := CurrentY; CurrentX := p2.h; CurrentY := p2.v; OffscreenToScreen(p1); OffscreenToScreen(p2); DrawObject(LineObj, p1, p2); end; end; procedure DoGetLine; {(var x1,y1,x2,y2:real; LineWidth:integer)} var loc1, loc2, loc3, loc4, loc5: integer; x1, y1, x2, y2: extended; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetComma; loc3 := GetVar; GetComma; loc4 := GetVar; GetComma; loc5 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^, info^ do begin GetLoi(x1, y1, x2, y2); if RoiShowing and (RoiType = LineRoi) then stack[loc1].value := x1 else stack[loc1].value := -1; stack[loc2].value := y1; stack[loc3].value := x2; stack[loc4].value := y2; stack[loc5].value := LineWidth; end; end; procedure DoScaleAndRotate; {(hscale,vscale,angle:real)} var SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; rsHScale := GetExpression; GetComma; rsVScale := GetExpression; if SaveCommand <> ScaleSelectionC then begin GetComma; rsAngle := GetExpression; end; GetRightParen; if token <> DoneT then begin if SaveCommand = ScaleSelectionC then begin rsMethod := NearestNeighbor; rsCreateNewWindow := false; rsAngle := 0.0; end; ScaleAndRotate; end; end; procedure SetPlotScale; {(min,max:integer)} var min, max: extended; begin GetLeftParen; min := GetExpression; GetComma; max := GetExpression; GetRightParen; if info^.fit = uncalibrated then begin RangeCheck(trunc(min)); RangeCheck(trunc(max)); end; if token <> DoneT then begin AutoScalePlots := (min = 0.0) and (max = 0.0); ProfilePlotMin := min; ProfilePlotMax := max; end; end; procedure SetPlotDimensions; {(width,height:integer)} var width, height: integer; begin GetLeftParen; width := GetInteger; GetComma; height := GetInteger; GetRightParen; if token <> DoneT then begin FixedSizePlot := not ((width = 0) and (height = 0)); ProfilePlotWidth := width; ProfilePlotHeight := height; end; end; procedure GetResults; {(var n,mean,mode,min,max:real)} var loc1, loc2, loc3, loc4, loc5: integer; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetComma; loc3 := GetVar; GetComma; loc4 := GetVar; GetComma; loc5 := GetVar; GetRightParen; if mCount = 0 then MacroError('No results'); if Token <> DoneT then with MacrosP^, results do begin stack[loc1].value := PixelCount^[mCount]; stack[loc2].value := UncalibratedMean; stack[loc3].value := imode; stack[loc4].value := MinIndex; stack[loc5].value := MaxIndex; end; end; procedure DoPasteOperation; begin if not (OpPending and (CurrentOp = PasteOp)) then begin MacroError('Not pasting'); exit(DoPasteOperation); end; if MacroCommand in [AddC, SubC, MulC, DivC] then begin case MacroCommand of AddC: CurrentOp := AddOp; SubC: CurrentOp := SubtractOp; MulC: CurrentOp := MultiplyOp; DivC: CurrentOp := DivideOp; end; DoPasteMath; exit(DoPasteOperation); end; SetForegroundColor(BlackIndex); SetBackGroundColor(WhiteIndex); case MacroCommand of CopyModeC: SetPasteMode(CopyModeItem); AndC: SetPasteMode(AndItem); OrC: SetPasteMode(OrItem); XorC: SetPasteMode(XorItem); ReplaceC: SetPasteMode(ReplaceItem); BlendC: SetPasteMode(BlendItem); end; if OptionKeyWasDown then begin if PasteControl <> nil then DrawPasteControl; end else KillRoi; end; procedure SetWidth; {(width:integer)} var width: integer; begin GetLeftParen; width := GetInteger; GetRightParen; if (Token <> DoneT) and (width > 0) then begin LineWidth := width; ShowLIneWidth; end; end; function GetMType (index: integer): MeasurementTypes; begin case index of 0: GetMType := AreaM; 1: GetMType := MeanM; 2: GetMType := StdDevM; 3: GetMType := xyLocM; 4: GetMType := ModeM; 5: GetMType := LengthM; 6: GetMType := MajorAxisM; 7: GetMType := MinorAxisM; 8: GetMType := AngleM; 9: GetMType := IntDenM; 10: GetMType := MinMaxM; 11: GetMType := User1M; 12: GetMType := User2M; end; end; procedure SetPrecision; {(DigitsRightofDecimalPoint[,FieldWidth]:integer)} var digits, width: LongInt; begin GetLeftParen; digits := GetInteger; GetToken; if token = comma then width := GetInteger else PutTokenBack; GetRightParen; if Token <> DoneT then begin if (digits >= 0) and (digits <= 12) then precision := digits; if (width >= 1) and (width <= 18) then FieldWidth := width; end; end; procedure SetParticleSize; {(min,max:LongInt)} var min, max: LongInt; begin GetLeftParen; min := GetInteger; GetComma; max := GetInteger; GetRightParen; if Token <> DoneT then begin MinParticleSize := min; MaxParticleSize := max; end; end; procedure SetThreshold; {(level:integer)} var level: LongInt; begin GetLeftParen; level := GetInteger; GetRightParen; if level = -1 then begin DisableThresholding; exit(SetThreshold); end; RangeCheck(level); if Token <> DoneT then EnableThresholding(level); end; procedure DoPutPixel; {(hloc,vloc, value:integer)} var hloc, vloc: LongInt; value: integer; MaskRect: rect; begin GetLeftParen; hloc := GetInteger; GetComma; vloc := GetInteger; GetComma; value := GetInteger; GetRightParen; if (Token <> DoneT) and (info <> NoInfo) then begin KillRoi; PutPixel(hloc, vloc, value); SetRect(MaskRect, hloc, vloc, hloc + 1, vloc + 1); UpdateScreen(MaskRect); info^.changes := true; end; end; procedure CloseWindow; var OldPicNum, NewPicNum, ignore: integer; begin if CurrentWindow <> PicKind then begin ignore := CloseAWindow(CurrentWPtr); exit(CloseWindow); end; if info = NoInfo then begin MacroError(NoImageOpen); exit(CloseWindow); end; StopDigitizing; SaveRoi; with info^ do begin OldPicNum := PicNum; ignore := CloseAWindow(wptr); end; if nPics >= 1 then begin NewPicNum := OldPicNum - 1; if NewPicNum < 1 then NewPicNum := 1; SelectImage(NewPicNum); end; end; procedure SetScaling; var ScalingOptions: str255; ok: boolean; begin ScalingOptions := GetStringArg; if token <> DoneT then begin MakeLowerCase(ScalingOptions); rsInteractive := false; if pos('bilinear', ScalingOptions) <> 0 then rsMethod := Bilinear; if pos('nearest', ScalingOptions) <> 0 then rsMethod := NearestNeighbor; if pos('new', ScalingOptions) <> 0 then rsCreateNewWindow := true; if pos('same', ScalingOptions) <> 0 then rsCreateNewWindow := false; if pos('interactive', ScalingOptions) <> 0 then rsInteractive := true; end; end; procedure DoChangeValues; {(v1,v2,v3:integer)} var v1, v2, v3: integer; begin GetLeftParen; v1 := GetInteger; GetComma; v2 := GetInteger; GetComma; v3 := GetInteger; GetRightParen; RangeCheck(v1); RangeCheck(v2); RangeCheck(v3); if Token <> DoneT then ChangeValues(v1, v2, v3); end; procedure DoGetMouse; {(var x,y:integer)} var loc1, loc2, sh, sv: integer; loc: point; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^ do begin SetPort(info^.wptr); GetMouse(loc); with loc do begin sh := h; sv := v; ScreenToOffscreen(loc); if sh < 0 then h := sh; if sv < 0 then v := sv; stack[loc1].value := h; stack[loc2].value := v; end; end; end; procedure DoRotate (cmd: CommandType); var NoBoolean, NewWindow: boolean; begin GetToken; noBoolean := token <> LeftParen; PutTokenBack; if NoBoolean then NewWindow := false else NewWindow := GetBooleanArg; if NewWindow then begin case cmd of RotateRC: RotateToNewWindow(RotateRight); RotateLC: RotateToNewWindow(RotateLeft) end; if not macro then MacroError('Rotate failed') end else case cmd of RotateRC: FlipOrRotate(RotateRight); RotateLC: FlipOrRotate(RotateLeft) end; end; procedure DoSelectSlice; {(SliceNumber:integer)} var SliceNumber: LongInt; isRoi: boolean; SaveCommand: CommandType; begin SaveCommand := MacroCommand; GetLeftParen; SliceNumber := GetInteger; GetRightParen; with info^, info^.StackInfo^ do begin if (SliceNumber < 1) or (SliceNumber > nSlices) then MacroError('Illegal slice number'); if Token <> DoneT then begin isRoi := RoiShowing; if isRoi then KillRoi; CurrentSlice := SliceNumber; SelectSlice(CurrentSlice); if SaveCommand = SelectSliceC then begin UpdatePicWindow; UpdateTitleBar; end; if isRoi then RestoreRoi; end; end; end; procedure MakeNewStack; {(name:str255)} var name: str255; aok: boolean; begin GetArguments(name); if token <> DoneT then if (NewPicWidth * NewPicHeight) > UndoBufSize then MacroError('Stack larger than Undo Buffer') else if NewPicWindow(name, NewPicWidth, NewPicHeight) then if not MakeStackFromWindow then MacroError('Out of memory'); end; procedure MakeLineRoi; {(x1,y1,x2,y2:real)} var x1, y1, x2, y2: extended; begin GetLeftParen; x1 := GetExpression; GetComma; y1 := GetExpression; GetComma; x2 := GetExpression; GetComma; y2 := GetExpression; GetRightParen; if token <> DoneT then with Info^ do begin KillRoi; StopDigitizing; LX1 := x1; LY1 := y1; LX2 := x2; LY2 := y2; RoiType := LineRoi; MakeRegion; SetupUndo; RoiShowing := true; end; end; procedure DoGetTime; var date: DateTimeRec; loc1, loc2, loc3, loc4, loc5, loc6, loc7: integer; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetComma; loc3 := GetVar; GetComma; loc4 := GetVar; GetComma; loc5 := GetVar; GetComma; loc6 := GetVar; GetComma; loc7 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^, info^ do begin GetTime(date); with date do begin stack[loc1].value := year; stack[loc2].value := month; stack[loc3].value := day; stack[loc4].value := hour; stack[loc5].value := minute; stack[loc6].value := second; stack[loc7].value := DayOfWeek; end; end; end; function GetStringVar: integer; begin GetStringVar := 0; GetToken; if token <> StringVariable then MacroError('String variable expected') else GetStringVar := TokenStackLoc; end; procedure DoSetScale; {(scale:real; unit:string; [AspectRatio: real])} var id: integer; scale, AspectRatio: extended; str: str255; begin AspectRatio:=0.0; GetLeftParen; scale := GetExpression; GetComma; str := GetString; GetToken; if token=comma then AspectRatio:=GetExpression else PutTokenBack; GetRightParen; if token <> DoneT then with info^ do begin if str = '' then begin SetScale; {Display Set Scale dialog box} exit(DoSetScale); end; if scale < 0.0 then begin MacroError('Scale<0'); exit(DoSetScale); end; MakeLowerCase(str); TruncateString(str, maxUnit); xUnit := str; xScale := scale; yScale := scale; if AspectRatio>0.0 then begin PixelAspectRatio:=AspectRatio; yScale := xScale / PixelAspectRatio; end else PixelAspectRatio := 1.0; SpatiallyCalibrated := (xUnit <> '') and (xUnit <> 'pixel') and (xUnit <> 'pixels') and (xScale <> 0.0); UpdateTitleBar; end; end; procedure GetScale; {(var scale:real; unit:string; [AspectRatio:real])} var loc1, loc2, loc3, index, count: integer; str: str255; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetStringVar; loc3:=0; GetToken; if token=comma then loc3 := GetVar else PutTokenBack; GetRightParen; if Token <> DoneT then with info^, MacrosP^ do if SpatiallyCalibrated then begin stack[loc1].value := xScale; stack[loc2].StringH^^ := xUnit; if loc3>0 then stack[loc3].value := PixelAspectRatio; end else begin stack[loc1].value := 1.0; stack[loc2].StringH^^ := 'pixel'; if loc3>0 then stack[loc3].value := 1.0; end; end; procedure SaveState; begin SaveForeground := ForegroundIndex; SaveBackground := BackgroundIndex; SavePicWidth := NewPicWidth; SavePicHeight := NewPicHeight; SaveMethod := rsMethod; SaveCreate := rsCreateNewWindow; SaveAngle := rsAngle; SaveH := rsHScale; SaveV := rsVScale; SaveInvertY := InvertYCoordinates; SaveScaleArithmetic := ScaleArithmetic; SaveScaleConvolutions := ScaleConvolutions; SaveCurrentFontID:=CurrentFontID; SaveCurrentSize:=CurrentSize; SaveCurrentStyle:=CurrentStyle; SaveTextJust:=TextJust; SaveTextBack:=TextBack; end; procedure RestoreState; begin if SaveForeground = -1 then MacroError('State not saved') else begin SetForegroundColor(SaveForeground); SetBackgroundColor(SaveBackground); NewPicWidth := SavePicWidth; NewPicHeight := SavePicHeight; rsMethod := SaveMethod; rsCreateNewWindow := SaveCreate; rsAngle := SaveAngle; rsHScale := SaveH; rsVScale := SaveV; InvertYCoordinates := SaveInvertY; ScaleArithmetic := SaveScaleArithmetic; ScaleConvolutions := SaveScaleConvolutions; CurrentFontID:=SaveCurrentFontID; CurrentSize:=SaveCurrentSize; CurrentStyle:=SaveCurrentStyle; TextJust:=SaveTextJust; TextBack:=SaveTextBack; end; end; procedure DoPrint; begin FindWhatToPrint; if WhatToPrint <> NothingToPrint then Print(false) else MacroError('NothingToPrint'); end; procedure SetCounter; {(n:integer)} var N, i: LongInt; begin GetLeftParen; N := GetInteger; GetRightParen; if (N < 0) or (N > MaxMeasurements) then MacroError('Argument out of range'); if Token <> DoneT then begin if N = 0 then ResetCounter; for i := mCount + 1 to N do ClearResults(i); mCount := N; UpdateList; ShowInfo; end; end; procedure OutputText; var NewLine: boolean; str: str255; i: integer; SaveCommand: CommandType; begin NewLine := MacroCommand <> WriteC; SaveCommand := MacroCommand; GetArguments(str); if token <> DoneT then begin if SaveCommand = ShowMsgC then begin for i := 1 to length(str) do if str[i] = '\' then str[i] := cr; InfoMessage := str; ShowInfo; end else begin if CurrentWindow = TextKind then begin InsertText(str, NewLine); if not macro then MacroError('32K text limit exceeded') end else DoDrawText(str, NewLine); end; end; end; procedure SetErosionDilationCount; {(n:integer)} var n: LongInt; begin GetLeftParen; n := GetInteger; GetRightParen; if (n < 1) or (n > 8) then MacroError('Argument out of range'); if Token <> DoneT then begin BinaryCount := n; BinaryThreshold := BinaryCount * 255; end; end; procedure SetSliceSpacing; {(n:real)} var n: extended; {pixels} begin GetLeftParen; n := GetExpression; GetRightParen; if (n <= 0.0) or (n > 100.0) then MacroError('Argument out of range'); if info^.StackInfo = nil then MacroError('No stack'); if Token <> DoneT then info^.StackInfo^.SliceSpacing := n; end; procedure GetOrPutLineOrColumn; {(x,y,count:integer:integer)} var x, y, count, i: integer; MaskRect: rect; aLine2: LineType; begin GetLeftParen; x := GetInteger; GetComma; y := GetInteger; GetComma; count := GetInteger; GetRightParen; if (Token <> DoneT) and (count <= MaxLine) then with MacrosP^ do begin KillRoi; case MacroCommand of GetRowC: GetLine(x, y, count, aLine); PutRowC: begin PutLine(x, y, count, aLine); SetRect(MaskRect, x, y, x + count, y + 1); UpdateScreen(MaskRect); info^.changes := true; end; GetColumnC: GetColumn(x, y, count, aLine); PutColumnC: begin PutColumn(x, y, count, aLine); SetRect(MaskRect, x, y, x + 1, y + count); UpdateScreen(MaskRect); info^.changes := true; end; end; {case} end; end; procedure CheckVersion; {(RequiredVersion:real)} var RequiredVersion: extended; str: str255; begin GetLeftParen; RequiredVersion := GetExpression; GetRightParen; if (Token <> DoneT) then if round(RequiredVersion * 100.0) > version then begin RealToString(RequiredVersion, 1, 2, str); {Begin Scion} {PutError(concat('This macro requires version ', str, ' or later of NIH Image.'));} PutError(concat('This macro requires version ', str, ' or later of Scion Image.')); {End Scion} Token := DoneT; end; end; procedure SetOptions; {(Options:string)} var options: str255; mtype: MeasurementTypes; i, LastOption: integer; SaveMeasurements: SetOfMeasurements; begin GetLeftParen; Options := GetString; GetRightParen; if (Token <> DoneT) then begin SaveMeasurements := measurements; MakeLowerCase(options); Measurements := []; if pos('area', options) <> 0 then Measurements := Measurements + [AreaM]; if pos('mean', options) <> 0 then Measurements := Measurements + [MeanM]; if pos('st', options) <> 0 then Measurements := Measurements + [StdDevM]; if pos('center', options) <> 0 then Measurements := Measurements + [xyLocM]; if pos('mode', options) <> 0 then Measurements := Measurements + [ModeM]; if (pos('per', options) <> 0) or (pos('length', options) <> 0) then Measurements := Measurements + [LengthM]; if pos('major', options) <> 0 then Measurements := Measurements + [MajorAxisM]; if pos('minor', options) <> 0 then Measurements := Measurements + [MinorAxisM]; if pos('angle', options) <> 0 then Measurements := Measurements + [AngleM]; if pos('int', options) <> 0 then Measurements := Measurements + [IntDenM]; if pos('max', options) <> 0 then Measurements := Measurements + [MinMaxM]; if pos('1', options) <> 0 then Measurements := Measurements + [User1M]; if pos('2', options) <> 0 then Measurements := Measurements + [User2M]; UpdateFitEllipse; if Measurements <> SaveMeasurements then UpdateList; end; end; procedure SetLabel; var SaveCommand: CommandType; str, SaveLabel: str255; begin SaveCommand := MacroCommand; GetArguments(str); TruncateString(str, maxLabelLength); case SaveCommand of SetMajorC: begin SaveLabel := MajorLabel; MajorLabel := str; Measurements := Measurements + [MajorAxisM]; end; SetMinorC: begin SaveLabel := MinorLabel; MinorLabel := str; Measurements := Measurements + [MinorAxisM]; end; SetUser1C: begin SaveLabel := User1Label; User1Label := str; Measurements := Measurements + [User1M]; end; SetUser2C: begin SaveLabel := User2Label; User2Label := str; Measurements := Measurements + [User2M]; end; end; {case} ShowInfo; if str <> SaveLabel then UpdateList; end; procedure DoUpdateLUT; begin with info^ do begin LoadLUT(ctable); IdentityFunction := false; if isGrayScaleLUT then LutMode := CustomGrayScale else begin SetupPseudocolor; LutMode := PseudoColor; end; UpdateMap; if ScreenDepth<>8 then UpdatePicWindow; end; end; procedure SubtractBackground; {(Options:string; BallRadius:integer)} var options: str255; radius, item: integer; begin GetLeftParen; Options := GetString; GetComma; radius := GetInteger; GetRightParen; if (Token <> DoneT) then begin MakeLowerCase(options); FasterBackgroundSubtraction := pos('faster', options) <> 0; item := Sub2DItem; if pos('hor', options) <> 0 then item := HorizontalItem; if pos('ver', options) <> 0 then item := VerticalItem; if pos('roll', options) <> 0 then item := Sub2DItem; if pos('remove', options) <> 0 then item := RemoveStreaksItem; end; BallRadius := Radius; if Radius < 1 then BallRadius := 1; if Radius > 319 then BallRadius := 319; DoBackgroundMenuEvent(Item); end; procedure SetExportMode; var mode: str255; begin mode := GetStringArg; if Token <> DoneT then begin MakeLowerCase(mode); ExportAsWhat := AsRaw; if pos('mcid', mode) <> 0 then ExportAsWhat := asMCID; if pos('text', mode) <> 0 then ExportAsWhat := asText; if pos('lut', mode) <> 0 then ExportAsWhat := asLUT; if pos('meas', mode) <> 0 then ExportAsWhat := asMeasurements; if pos('plot', mode) <> 0 then ExportAsWhat := asPlotValues; if pos('hist', mode) <> 0 then ExportAsWhat := asHistogramValues; if pos('xy', mode) <> 0 then ExportAsWhat := asCoordinates; end; end; procedure SetSaveAsMode; var mode: str255; begin mode := GetStringArg; if Token <> DoneT then begin MakeLowerCase(mode); SaveAsWhat := asTiff; if pos('tiff', mode) <> 0 then SaveAsWhat := asTiff; if pos('pict', mode) <> 0 then SaveAsWhat := asPict; if pos('paint', mode) <> 0 then SaveAsWhat := asMacPaint; if pos('pics', mode) <> 0 then SaveAsWhat := asPICS; if pos('lut', mode) <> 0 then SaveAsWhat := AsPalette; if pos('outline', mode) <> 0 then SaveAsWhat := AsOutline; if pos('rgb', mode) <> 0 then with info^ do begin if StackInfo = nil then begin MacroError('Stack required'); exit(SetSaveAsMode); end; if StackInfo^.nSlices <> 3 then begin MacroError('Stack must have 3 slices'); exit(SetSaveAsMode); end; StackInfo^.StackType := rgbStack; UpdateTitleBar; end; end; end; procedure MoveCurrentWindow;{(x,y:integer)} var x, y: integer; ignore: integer; fwptr: WindowPtr; kind: integer; begin GetLeftParen; x := GetInteger; GetComma; y := GetInteger; GetRightParen; fwptr := FrontWindow; if fwptr <> nil then begin kind := WindowPeek(fwptr)^.WindowKind; if (kind = PicKind) or (kind = ProfilePlotKind) or (kind = CalibrationPlotKind) or (kind = HistoKind) or (Kind = PasteControlKind) or (Kind = ResultsKind) or (Kind = TextKind) then MoveWindow(fwptr, x, y, true); end; end; procedure DoUserCode; {str:str255; Param1,Param2,Param3:real;} {Contributed by Mark Vivino} var WhichCode: integer; Param1, Param2, Param3: extended; str: str255; NewVersion: boolean; begin GetLeftParen; GetToken; NewVersion := (token = StringLiteral) or (token = StringVariable); PutTokenBack; WhichCode := 0; str := ''; if NewVersion then str := GetString else WhichCode := GetInteger; GetComma; Param1 := GetExpression; GetComma; Param2 := GetExpression; GetComma; Param3 := GetExpression; GetRightParen; if Token <> DoneT then begin if NewVersion then UserMacroCode(str, Param1, Param2, Param3) else begin if (WhichCode < 1) or (WhichCode > 10) then MacroError('Range error . Allowable range is 1 to 10.'); OldUserMacroCode(WhichCode, Param1, Param2, Param3); end; end; end; procedure CloseSerialPorts; var err: OSErr; begin if SerialBufferP <> nil then begin err := CloseDriver(SerialOut); err := CloseDriver(SerialIn); DisposePtr(SerialBufferP); end; end; procedure OpenSerial; const SerialBufferSize = 1024; var err: OSErr; baud, data, stop, parity, i: integer; config: integer; flags: SerShk; str: str255; begin CloseSerialPorts; baud := baud9600; data := data8; stop := stop10; parity := noParity; str := GetStringArg; if token = DoneT then exit(OpenSerial); MakeLowerCase(str); if pos('300', str) <> 0 then baud := baud300; if pos('1200', str) <> 0 then baud := baud1200; if pos('2400', str) <> 0 then baud := baud2400; if pos('19200', str) <> 0 then baud := baud19200; if pos('two', str) <> 0 then stop := stop20; if pos('seven', str) <> 0 then data := data7; i:=pos('even', str); if (i <> 0) and (str[i-1]<>'s') then parity := evenParity; if pos('odd', str) <> 0 then parity := oddParity; if (OpenDriver('.AOut', SerialOut) <> NoErr) or (OpenDriver('.AIn', SerialIn) <> NoErr) then begin MacroError('Error opening modem port'); exit(OpenSerial); end; SerialBufferP := NewPtr(SerialBufferSize); if SerialBufferP = nil then begin MacroError('Out of Memory'); exit(OpenSerial); end; with flags do begin fXOn := ord(false); {Disable xon/xoff output flow control} fCTS := ord(false); {Disable CTS (output) flow control} xOn := chr(17); xOff := chr(19); errs := 0; evts := 0; fInX := ord(true); {Enable xon/xoff input flow control} fDTR := ord(true); {Enable DTR (input) flow control} end; Config := baud + data + stop + parity; Err := SerHShake(SerialOut, flags); Err := SerSetBuf(SerialIn, SerialBufferP, SerialBufferSize); Err := SerReset(SerialOut, Config); end; procedure PutSerial; var i: integer; Size: LongInt; OutputBuffer: packed array[1..256] of char; str: str255; err: OSErr; begin GetArguments(str); if token = DoneT then exit(PutSerial); if SerialBufferP = nil then begin MacroError('Serial port not open'); exit(PutSerial); end; Size := 0; for i := 1 to length(str) do begin size := size + 1; OutputBuffer[size] := str[i]; end; if size > 0 then err := fswrite(SerialOut, size, @OutputBuffer); end; procedure DoSetCursor; {str: string} var str: str255; begin str := GetStringArg; if Token <> DoneT then begin MakeLowerCase(str); if pos('watch', str) <> 0 then SetCursor(watch); if pos('cross', str) <> 0 then SetCursor(ToolCursor[SelectionTool]); if pos('arrow', str) <> 0 then InitCursor; if pos('finger', str) <> 0 then SetCursor(FingerCursor); end; end; procedure SetVideoOptions; {options: string[, gain:integer, offset:integer]} var options: str255; NewSyncMode: SyncModeType; gain, offset: integer; procedure SetOption (id: integer; var option: boolean; enable: boolean); {Updates the modeless Video Control dialog box.} begin if option <> enable then DoVideoControl(id) end; begin GetLeftParen; options := GetString; GetToken; if token = comma then begin gain := GetInteger; GetComma; offset := GetInteger end else begin PutTokenBack; gain := 255 - (DacHigh - DacLow); offset := DacLow; end; GetRightParen; if Token <> DoneT then begin MakeLowerCase(options); SetOption(InvertID, InvertVideo, pos('invert', options) <> 0); SetOption(HighlightID, HighlightSaturatedPixels, pos('high', options) <> 0); SetOption(TriggerID, ExternalTrigger, pos('trig', options) <> 0); {Begin Scion} SetOption(VideoRateMathID, VideoRateMath, pos('math', options) <> 0); SetOption(VideoRateBlankID, VideoRateBlank, pos('blank', options) <> 0); SetOption(VideoPassID, VideoPass, pos('pass', options) <> 0); {End Scion} if pos('sep', options) <> 0 then NewSyncMode := SeparateSync else NewSyncMode := NormalSync; if NewSyncMode <> SyncMode then DoVideoControl(SyncID); SetOffset(offset, gain); SetGain(offset, gain); if VideoControl <> nil then begin gain := 255 - (DacHigh - DacLow); ShowOffsetAndGain(DacLow, gain); end; OscillatingMovies := pos('osc', options) <> 0; BlindMovieCapture := pos('blind', options) <>0; if (FrameGrabber = ScionLG3) or (FrameGrabber=ScionAG5) or (FrameGrabber=ScionVG5f) then begin DacLowReg^ := DacLow; DacHighReg^ := DacHigh; end; end; end; procedure SetChannel; {(channel:integer)} var channel: integer; begin GetLeftParen; channel := GetInteger; GetRightParen; if (channel < 1) or (channel > 4) then MacroError('Bad channel number') else DoVideoControl(FirstChannelID + channel - 1); end; procedure DoAcquire; var fname: str255; begin fname := GetStringArg; LoadAcqPlugIn(fname); end; procedure CallExportPlugin; var fname: str255; begin fname := GetStringArg; LoadExportPlugIn(fname); end; procedure CallFilterPlugin; var fname: str255; begin fname := GetStringArg; LoadFilterPlugIn(fname); end; procedure DoPhotoMode; var erase: boolean; begin erase := GetBooleanArg; if Token <> DoneT then begin if erase then begin EraseScreen; UpdatePicWindow; InPhotoMode := true; end else if InPhotoMode then RestoreScreen; end; end; procedure RGBToIndexed; {options: string} var options: str255; begin options := GetStringArg; if Token <> DoneT then begin MakeLowerCase(options); RGBLut := CustomLUT; DitherColor := false; if pos('exist', options) <> 0 then RGBLut := ExistingLUT; if pos('system', options) <> 0 then RGBLut := SystemLUT; if pos('dither', options) <> 0 then DitherColor := true; ConvertRGBToEightBitColor(false); end; end; procedure DoAverageFrames; {[(Options:string; nFrames:integer)]} var options: str255; nFrames: LongInt; HasArguments,ShowDialog,okay: boolean; begin GetToken; HasArguments := token = LeftParen; PutTokenBack; ShowDialog:=false; if HasArguments then begin GetLeftParen; Options := GetString; GetComma; nFrames := GetInteger; ShowDialog:= nFrames <= 0; if not ShowDialog then FramesToAverage := nFrames; GetRightParen; if (Token <> DoneT) then begin MakeLowerCase(options); VideoRateAveraging := false; SumFrames := false; IntegrateOnChip := false; if (pos('int', options) <> 0) or (pos('sum', options) <> 0) then sumFrames := true; if pos('video', options) <> 0 then VideoRateAveraging := true; if (pos('camera', options) <> 0) or (pos('chip', options) <> 0) then begin if (FrameGrabber<>ScionLG3) and (FrameGrabber<>ScionAG5) and (FrameGrabber<>ScionVG5f) then begin MacroError('On-chip integration requires a Scion frame grabber.'); exit(DoAverageFrames) end; VideoRateAveraging := false; SumFrames := false; IntegrateOnChip := true; end; end; end; {has arguments} if token <> DoneT then begin if ShowDialog then okay:=DoAveragingOptions else okay:=true; if okay then AverageFrames; end; end; procedure DoSelectWindow;{('str')} var str, wTitle: str255; WPeek, NextWPeek: WindowPeek; id: integer; TempInfo: InfoPtr; begin GetArguments(str); MakeLowerCase(str); if Token <> DoneT then begin wPeek := WindowPeek(FrontWindow); while wPeek <> nil do begin NextWPeek := wPeek^.NextWindow; if wPeek^.WindowKind = PicKind then begin TempInfo := InfoPtr(wPeek^.RefCon); wTitle := TempInfo^.title; end else wTitle := wPeek^.TitleHandle^^; MakeLowerCase(wTitle); if str = wTitle then begin if wPeek^.WindowKind = PicKind then begin info := InfoPtr(wPeek^.RefCon); with info^ do if (PicNum >= 1) and (PicNum <= nPics) then SelectImage(PicNum); end else SelectWindow(WindowPtr(wPeek)); leave; end; wpeek := NextWPeek; end; if wPeek = nil then MacroError('Window not found'); end; end; procedure GetThreshold; {(lower,upper)} var loc1, loc2: integer; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^ do with info^ do begin if Thresholding then begin stack[loc1].value := ColorStart; stack[loc2].value := 255; end else if DensitySlicing then begin stack[loc1].value := SliceStart; stack[loc2].value := SliceEnd; end else begin stack[loc1].value := 0; stack[loc2].value := 0; end; end; end; procedure SortPalette; type MyHSVColor = record lHue, lSaturation, lValue: LongInt; end; HSVRec = record index: integer; hsv: MyHSVColor; end; HSVArrayType = array[0..255] of HSVRec; var TempTable: MyCSpecArray; i: integer; HSVArray: HSVArrayType; h, s, v: LongInt; fHue, fSaturation, fValue: fixed; TempHSV: HSVColor; table: LookupTable; procedure SortByHue; {Selection sorts from "Algorithms" by Robert Sedgewick.} var i, j, min: integer; t: HSVRec; begin for i := 1 to 254 do begin min := i; for j := i + 1 to 254 do if HSVArray[j].hsv.lHue < HSVArray[min].hsv.lHue then min := j; t := HSVArray[min]; HSVArray[min] := HSVArray[i]; HSVArray[i] := t; end; end; begin ShowWatch; DisableDensitySlice; with info^ do begin for i := 1 to 254 do begin HSVArray[i].index := i; rgb2hsv(cTable[i].rgb, TempHSV); with TempHSV do begin fHue := SmallFract2Fix(hue); fSaturation := SmallFract2Fix(saturation); fValue := SmallFract2Fix(value); end; with HSVArray[i].hsv do begin lHue := ord4(band(fHue, $ffff)); lSaturation := ord4(band(fSaturation, $ffff)); lValue := ord4(band(fValue, $ffff)); end; end; SortByHue; for i := 1 to 254 do TempTable[i].rgb := cTable[HSVArray[i].index].rgb; cTable := TempTable; LoadLUT(cTable); if info <> NoInfo then begin table[0] := 0; table[255] := 255; for i := 1 to 254 do table[HSVArray[i].index] := i; ApplyTable(table); end; WhatToUndo := NothingToUndo; SetupPseudocolor; ColorTable := CustomTable; end; {with} end; procedure DoProject; begin if info^.StackInfo = nil then begin MacroError('Stack required'); exit(DoProject); end; if not ((ProjectC in RoutinesCalled) or (SetProjectionC in RoutinesCalled)) then begin if ShowProjectDialogBox then DoProjection else token := DoneT; end else with info^.StackInfo^ do begin if SliceSpacing <= 0.0 then SliceSpacing := 1.0; if DensitySlicing then with info^ do begin TransparencyLower := SliceStart; TransparencyUpper := SliceEnd; end; DoProjection; end; RoutinesCalled := RoutinesCalled + [ProjectC]; end; procedure DoNewTextWindow; {(name,width,height)} var str: str255; okay, OptionalArguments: boolean; width, height: LongInt; begin GetLeftParen; str := GetString; GetToken; OptionalArguments := token <> RightParen; PutTokenBack; width := 500; height := 400; if OptionalArguments then begin GetComma; width := GetInteger; if width < 8 then width := 8; GetComma; height := GetInteger; if height < 8 then height := 8; end; GetRightParen; if Token <> DoneT then okay := MakeNewTextWindow(str, width, height); end; procedure ImageMath; {('op',pic1,pic2,gain,offset,'result')} var op, result: str255; pic1, pic2, DstPidNum: LongInt; gain, offset: extended; roi:rect; DstInfo:InfoPtr; isPidNum:boolean; begin GetLeftParen; op := GetString; GetComma; pic1 := GetInteger; GetComma; pic2 := GetInteger; GetComma; gain := GetExpression; GetComma; offset := GetExpression; GetComma; GetToken; isPidNum:=token=variable; PutTokenBack; if isPidNum then DstPidNum:=GetInteger else result := GetString; GetRightParen; if token <> DoneT then begin MakeLowerCase(op); RealImageMath:=false; if pos('calibrate', op) <> 0 then RealImageMath := true; if pos('real', op) <> 0 then RealImageMath := true; if pos('add', op) <> 0 then CurrentMathOp := AddMath; if pos('sub', op) <> 0 then CurrentMathOp := SubMath; if pos('mul', op) <> 0 then CurrentMathOp := MulMath; if (pos('cmul', op) <> 0) or (pos('conjugate', op) <> 0) then begin CurrentMathOp := cMulMath; RealImageMath := true; end; if pos('div', op) <> 0 then CurrentMathOp := DivMath; if pos('and', op) <> 0 then CurrentMathOp := AndMath; if pos('or', op) <> 0 then CurrentMathOp := OrMath; if pos('xor', op) <> 0 then CurrentMathOp := XorMath; if pos('max', op) <> 0 then CurrentMathOp := MaxMath; if pos('min', op) <> 0 then CurrentMathOp := MinMath; if pos('copy', op) <> 0 then CurrentMathOp := CopyMath; MathGain := gain; MathOffset := offset; if not GetMathRoi(pic1, pic2, roi) then exit(ImageMath); if isPidNum then begin DstInfo := GetInfoPtr(DstPidNum); if DstInfo=nil then begin MacroError('Bad pid number'); exit(ImageMath); end; if RealImageMath and (DstInfo^.dataH = nil) then begin MacroError('Real output image required'); exit(ImageMath); end; SelectWindow(DstInfo^.wptr); Info := DstInfo; ActivateWindow; LoadLUT(info^.cTable); UpdatePicWindow; KillRoi; end else begin with roi do if RealImageMath then begin if not NewRealWindow(result, right-left, bottom-top) then exit(ImageMath) end else begin if not NewPicWindow(result, right-left, bottom-top) then exit(ImageMath) end; DstInfo := Info; end; DoMath(pic1, pic2, DstInfo, roi); end; end; procedure PasteLive; begin with info^ do begin if not RoiShowing or (RoiType <> RectRoi) then begin MacroError('No selection'); exit(PasteLive); end; if PictureType = FrameGrabberType then begin MacroError('Can''t paste into Camera window'); exit(PasteLive); end; if FrameGrabber = NoFrameGrabber then begin MacroError('No frame grabber'); exit(PasteLive); end; if (RoiRect.right > fgwidth) or (RoiRect.bottom > fgheight) then begin MacroError('Selection out of range'); exit(PasteLive); end; SetupUndo; WhatToUndo := UndoPaste; ClipBufInfo^.RoiRect := RoiRect; OpPending := true; CurrentOp := PasteOp; LivePasteMode := true; WhatsOnClip := LivePic; end;{with} end; procedure GetPlotData; {(var nValues,PixelsPerValue, Min,Max:real)} var loc1, loc2, loc3, loc4: integer; begin GetLeftParen; loc1 := GetVar; GetComma; loc2 := GetVar; GetComma; loc3 := GetVar; GetComma; loc4 := GetVar; GetRightParen; if Token <> DoneT then with MacrosP^, results do begin ShowPlot := false; PlotDensityProfile; ShowPlot := true; stack[loc1].value := PlotCount; stack[loc2].value := PlotAvg; stack[loc3].value := ActualPlotMin; stack[loc4].value := ActualPlotMax; end; end; procedure DoDelete; {(var dest; index, count:integer)} var StackLoc, index, count: integer; str: str255; begin GetLeftParen; StackLoc := GetStringVar; str := TokenStr; GetComma; index := GetInteger; GetComma; count := GetInteger; GetRightParen; if Token <> DoneT then with MacrosP^.stack[StackLoc] do begin delete(str, index, count); if StringH <> nil then StringH^^ := str; end; end; procedure DoAutoOutline; {(x,y:integer)} var x, y: integer; start: point; begin GetLeftParen; x := GetInteger; GetComma; y := GetInteger; GetRightParen; if Token <> DoneT then begin start.h := x; start.v := y; AutoOutline(start); end; end; procedure DoFilter; {(fType:string)} var fType: str255; doMore:boolean; t:FateTable; begin GetLeftParen; fType := GetString; GetRightParen; if token <> DoneT then begin MakeLowerCase(fType); doMore:=pos('more', fType) <> 0; if pos('smooth', fType) <> 0 then begin if doMore then Filter(UnweightedAvg, 0, t) else Filter(WeightedAvg, 0, t); exit(DoFilter); end; if pos('sharpen', fType) <> 0 then begin if doMore then Filter(SharpenMore, 0, t) else Filter(fsharpen, 0, t); exit(DoFilter); end; if pos('median', fType) <> 0 then begin RankFilter := MedianRank; DoRankFilter; exit(DoFilter); end; if (pos('edges', fType) <> 0) or (pos('sobel', fType)<>0) then begin Filter(FindEdges, 0, t); exit(DoFilter); end; if pos('dither', fType) <> 0 then begin Filter(Dither, 0, t); exit(DoFilter); end; if pos('min', fType) <> 0 then begin RankFilter := MinRank; DoRankFilter; exit(DoFilter); end; if pos('max', fType) <> 0 then begin RankFilter := MaxRank; DoRankFilter; exit(DoFilter); end; MacroError('Undefined filter'); end; end; procedure DoShadow; {[(Direction:string)]} var direction: str255; t: FateTable; begin GetToken; if token =LeftParen then begin direction := GetString; MakeLowerCase(direction); GetRightParen; end else begin PutTokenBack; direction:='se'; end; if Token <> DoneT then if direction='n' then Filter(ShadowN, 0, t) else if direction='ne' then Filter(ShadowNE, 0, t) else if direction='e' then Filter(ShadowE, 0, t) else if direction='se' then Filter(ShadowSE, 0, t) else if direction='s' then Filter(ShadowS, 0, t) else if direction='sw' then Filter(ShadowSW, 0, t) else if direction='w' then Filter(ShadowW, 0, t) else if direction='nw' then Filter(ShadowNW, 0, t) else MacroError('Invalid direction'); end; procedure DoCalibrate; {(fit,unit:string,m1,k1,m2,k2,...)} var sFit, sUnit: str255; Measured, Known:StandardsArray; nPairs, i:integer; begin GetLeftParen; sFit := GetString; if token <> DoneT then with info^ do begin MakeLowerCase(sFit); if pos('straight', sFit) <> 0 then fit:=StraightLine else if pos('rodbard', sFit) <> 0 then fit:=RodbardFit else if pos('od', sFit) <> 0 then fit:=UncalibratedOD else if pos('uncal', sFit) <> 0 then fit:=Uncalibrated else if pos('exp', sFit) <> 0 then fit:=ExpoFit else if pos('log', sFit) <> 0 then fit:=LogFit else if pos('pow', sFit) <> 0 then fit:=PowerFit else if pos('poly2', sFit) <> 0 then fit:=Poly2 else if pos('poly3', sFit) <> 0 then fit:=Poly3 else if pos('poly4', sFit) <> 0 then fit:=Poly4 else if pos('poly5', sFit) <> 0 then fit:=Poly5 else begin MacroError('Unknown fit'); exit(DoCalibrate); end; if (fit=Uncalibrated) or (fit=UncalibratedOD) then begin GetRightParen; Calibrate; exit(DoCalibrate); end; end; GetComma; sUnit := GetString; GetComma; nPairs:=0; GetToken; while (token<>RightParen) and (token<>DoneT) do begin PutTokenBack; if nPairs DoneT then with info^ do begin if nPairs<2 then begin MacroError('More arguments expected'); exit(DoCalibrate); end; TruncateString(sUnit, maxUM); UnitOfMeasure:=sUnit; nStandards:=nPairs; nKnownValues:=nPairs; for i:=1 to nStandards do begin ClearResults(i); uMean[i]:=Measured[i]; Mean^[i]:=Measured[i]; StandardValues[i]:=Known[i]; end; mCount := nStandards; UpdateList; Calibrate; end; end; procedure DoMakeMovie; {(Options:string; nFrames:integer; delay:extended)} var options: str255; nFrames: integer; delay: extended; ShowDialog: boolean; begin GetLeftParen; Options := GetString; GetComma; nFrames := GetInteger; GetComma; delay := GetExpression; GetRightParen; if (Token <> DoneT) then begin ShowDialog := pos('dialog', options) <> 0; if ShowDialog and (length(options) = 6) then begin MakeMovie(true); exit(DoMakeMovie); end; if nFrames > 0 then FramesWanted := nFrames; if delay >= 0.0 then SecondsPerFrame := delay; MakeLowerCase(options); BlindMovieCapture := false; LG3BufferCapture := false; TriggerFirstFrameOnly := true; TimeStamp := false; UseExistingStack := false; if pos('blind', options) <> 0 then BlindMovieCapture := true; if (pos('buffer', options) <> 0) then LG3BufferCapture := true; if (pos('stamp', options) <> 0) then TimeStamp := true; if (pos('trigger', options) <> 0) and (pos('first', options) <> 0) then begin ExternalTrigger := true; TriggerFirstFrameOnly := true; end; if (pos('trigger', options) <> 0) and (pos('each', options) <> 0) then begin ExternalTrigger := true; TriggerFirstFrameOnly := false; end; if (pos('existing', options) <> 0) then UseExistingStack := true; MakeMovie(ShowDialog); end; end; procedure DoAnalyzeParticles; {[(Options:string)]} var options: str255; hasOptions, okay: boolean; begin GetToken; hasOptions := token = LeftParen; PutTokenBack; if hasOptions then begin GetArguments(options); MakeLowerCase(options); if pos('dialog', options) <> 0 then begin okay := DoAPDialog; if okay then AnalyzeParticles; exit(DoAnalyzeParticles); end; LabelParticles := false; OutlineParticles := false; IgnoreParticlesTouchingEdge := false; IncludeHoles := false; APReset := false; if pos('label', options) <> 0 then LabelParticles := true; if pos('outline', options) <> 0 then OutlineParticles := true; if pos('ignore', options) <> 0 then IgnoreParticlesTouchingEdge := true; if pos('include', options) <> 0 then IncludeHoles := true; if pos('reset', options) <> 0 then APReset := true; end; AnalyzeParticles; end; procedure SetProjection; var v: extended; s: str255; begin GetLeftParen; s := GetString; MakeLowerCase(s); if pos('x-axis', s) <> 0 then AxisOfRotation := XAxis else if pos('y-axis', s) <> 0 then AxisOfRotation := YAxis else if pos('z-axis', s) <> 0 then AxisOfRotation := ZAxis else if pos('nearest', s) <> 0 then ProjectionMethod := NearestPoint else if pos('brightest', s) <> 0 then ProjectionMethod := BrightestPoint else if pos('mean', s) <> 0 then ProjectionMethod := MeanValue else begin GetComma; if pos('save', s) <> 0 then SaveProjections := GetBoolean else if pos('minimize', s) <> 0 then MinProjSize := GetBoolean else begin v := GetExpression; if pos('initial', s) <> 0 then InitAngle := round(v) else if pos('total', s) <> 0 then TotalAngle := round(v) else if pos('increment', s) <> 0 then AngleInc := round(v) else if pos('opacity', s) <> 0 then Opacity := round(v) else if pos('surface', s) <> 0 then DepthCueSurf := 100 - round(v) else if pos('interior', s) <> 0 then DepthCueInt := 100 - round(v) else MacroError('String not recognized:'); end; end; GetRightParen; RoutinesCalled := RoutinesCalled + [SetProjectionC]; end; procedure DoGetHistogram; var Left, Top, Width, Height: integer; SaveRoiRect: rect; begin GetLeftParen; left := GetInteger; GetComma; top := GetInteger; GetComma; width := GetInteger; if width < 1 then width := 1; GetComma; height := GetInteger; if height < 1 then height := 1; GetRightParen; if token <> DoneT then with Info^ do begin SaveRoiRect := RoiRect; SetRect(RoiRect, left, top, left + width, top + height); GetRectHistogram; RoiRect := SaveRoiRect; end; end; procedure doFFTMacro; {(Options:string)} var options: str255; begin GetLeftParen; Options := GetString; GetRightParen; if (Token <> DoneT) then begin MakeLowerCase(options); if pos('foreward', options) <> 0 then doFFT(ForewardFFT) else if pos('inverse', options) <> 0 then begin if pos('without', options) <> 0 then doFFT(InverseFFT) else if pos('filter', options) <> 0 then doFFT(InverseFFTWithFilter) else doFFT(InverseFFTWithMask) end else if pos('display', options) <> 0 then RedisplayPowerSpectrum else if pos('swap', options) <> 0 then doSwapQuadrants else MacroError('Unrecognized argument'); end; end; {Begin Scion} procedure VideoMath; {('op',pic1,gain,offset)} const AG5LutOffset = $80000; var op: str255; pic1, offset: LongInt; gain: extended; SrcInfo: InfoPtr; begin if FrameGrabber <> ScionAG5 then begin MacroError('Live Video Math requires a Scion AG-5.'); exit(VideoMath); end; GetLeftParen; op := GetString; GetComma; pic1 := GetInteger; GetComma; gain := GetExpression; GetComma; offset := GetInteger; GetRightParen; if token <> DoneT then begin MakeLowerCase(op); if pos('add', op) <> 0 then CurrentVideoMathOp := AddVideoMath; if pos('sub', op) <> 0 then CurrentVideoMathOp := SubVideoMath; if pos('mul', op) <> 0 then CurrentVideoMathOp := MulVideoMath; if pos('div', op) <> 0 then CurrentVideoMathOp := DivVideoMath; if pos('and', op) <> 0 then CurrentVideoMathOp := AndVideoMath; if pos('or', op) <> 0 then CurrentVideoMathOp := OrVideoMath; if pos('xor', op) <> 0 then CurrentVideoMathOp := XorVideoMath; if pos('max', op) <> 0 then CurrentVideoMathOp := MaxVideoMath; if pos('min', op) <> 0 then CurrentVideoMathOp := MinVideoMath; VideoMathGain := gain; VideoMathOffset := offset; VideoMathSrc := pic1; if not VideoRateBlankValid or not VideoRateBlank then begin SrcInfo := GetInfoPtr(VideoMathSrc); with SrcInfo^ do begin if (PicRect.right - PicRect.left <> fgWidth) or (PicRect.bottom - PicRect.top <> fgHeight) then begin if fgwidth = 640 then MacroError('Source image must be 640 x 480 pixels.') else MacroError('Source image must be 768 x 512 pixels.'); exit(VideoMath); end; end; DoVideoMath(false); end; end; {end token <> DoneT} end; {end VideoMath} {End Scion} procedure ExecuteCommand; var AutoSelectAll: boolean; t: FateTable; {Needed for MakeSkeleton} okay: boolean; theEvent: EventRecord; begin if Info = NoInfo then if not (MacroCommand in LegalWithoutImage) then begin MacroError('No image window active'); exit(ExecuteCommand); end; if DoOption then begin OptionKeyWasDown := true; DoOption := false; end; if OpPending then if not (MacroCommand in [CopyModeC, AndC, OrC, XorC, BlendC, ReplaceC, AddC, SubC, MulC, DivC, SetOptionC, PasteLiveC, GetRoiC, RequiresC, UndoC]) then begin KillRoi; {Terminate any pending paste operation.} RestoreRoi; end; case MacroCommand of RotateRC, RotateLC: DoRotate(MacroCommand); FlipVC: FlipOrRotate(FlipVertical); FlipHC: FlipOrRotate(FlipHorizontal); CopyC: begin FindWhatToCopy; if WhatToCopy = NothingToCopy then MacroError('Copy failed') else DoCopy; end; SelectC: if CurrentWindow = TextKind then SelectAllText else begin StopDigitizing; SelectAll(true); end; PasteC: DoPaste; ClearC, FillC, InvertC, FrameC: with info^ do begin AutoSelectAll := not RoiShowing; if AutoSelectAll then SelectAll(true); case MacroCommand of ClearC: DoOperation(EraseOp); FillC: DoOperation(PaintOp); InvertC: DoOperation(InvertOp); FrameC: DoOperation(FrameOp); end; UpdateScreen(RoiRect); if AutoSelectAll then KillRoi; end; KillC: KillRoi; RestoreC: if NoInfo^.RoiType <> NoRoi then RestoreRoi; AnalyzeC: DoAnalyzeParticles; ConvolveC: DoConvolve; NextC: GetNextWindow; MarkC: MarkSelection(mCount); MeasureC: begin Measure; InitCursor; end; MakeBinC: MakeBinary; DitherC: Filter(Dither, 0, t); SmoothC: if OptionKeyWasDown then Filter(UnweightedAvg, 0, t) else Filter(WeightedAvg, 0, t); SharpenC: Filter(fsharpen, 0, t); ShadowC: DoShadow; TraceC: Filter(EdgeDetect, 0, t); ReduceC: Filter(ReduceNoise, 0, t); RedirectC: RedirectSampling := GetBooleanArg; ThresholdC: SetThreshold; AutoThresholdC: AutoThreshold; ResetgmC: ResetGrayMap; WaitC: DoWait; ResetmC: ResetCounter; SetSliceC: SetDensitySlice; UndoC: DoUndo; SetForeC, SetBackC: SetColor; HistoC: begin DoHistogram; DrawHistogram; end; EnhanceC: EnhanceContrast; EqualizeC: EqualizeHistogram; ErodeC: begin BinaryIterations := 1; DoErosion; end; DilateC: begin BinaryIterations := 1; DoDilation; end; OutlineC: filter(OutlineFilter, 0, t); ThinC: MakeSkeleton; AddConstC, MulConstC: DoConstantArithmetic; RevertC: DoRevert; BeepC: Beep; NopC: ; MakeC, MakeOvalC: MakeRoi; MoveC: MoveRoi; InsetC: InsetRoi; MoveToC: DoMoveTo; DrawTextC, WriteC, WritelnC, ShowMsgC: OutputText; SetFontC: SetFont; SetFontSizeC: SetFontSize; SetTextC: SetText; DrawNumC: DrawNumber; ExitC: token := DoneT; GetPicSizeC: GetPicSize; PutMsgC: DoPutMessage; GetRoiC: GetRoi; MakeNewC: DoMakeNewWindow; DrawScaleC: if info^.RoiShowing then begin DrawScale; UpdatePicWindow end else MacroError('No Selection'); SetPaletteC: DoSetPalette; OpenC, ImportC: DoOpenImage; SetImportC: SetImportAttributes; SetMinMaxC: SetImportMinMax; SetCustomC: SetCustomImport; SelectPicC, ChoosePicC: SelectPic; SetPicNameC: SetPicName; ApplyLutC: ApplyLookupTable; SetSizeC: SetNewSize; SaveC: DoSave; SaveAllC: SaveAll; SaveAsC: DoSaveAs; CopyResultsC: DoCopyResults; CloseC, DisposeC: CloseWindow; DisposeAllC: DisposeAll; DupC: DoDuplicate; GetInfoC: GetInfo; PrintC: DoPrint; LineToC: DoLineTo; GetLineC: DoGetLine; ShowPasteC: if PasteControl = nil then ShowPasteControl else BringToFront(PasteControl); ChannelC: SetChannel; ColumnC, PlotProfileC: begin PlotDensityProfile; if PlotWindow <> nil then UpdatePlotWindow; end; ScaleC, ScaleSelectionC: DoScaleAndRotate; SetOptionC: DoOption := true; SetLabelsC: DrawPlotLabels := GetBooleanArg; SetPlotScaleC: SetPlotScale; SetDimC: SetPlotDimensions; GetResultsC: GetResults; CopyModeC, AndC, OrC, XorC, BlendC, ReplaceC, AddC, SubC, MulC, DivC: DoPasteOperation; ScaleMathC: ScaleArithmetic := GetBooleanArg; InvertYC: InvertYCoordinates := GetBooleanArg; SetWidthC: SetWidth; ShowResultsC: begin ShowResults; UpdateList end; StartC: StartDigitizing; StopC: StopDigitizing; CaptureC: CaptureOneFrame; GetRowC, PutRowC, GetColumnC, PutColumnC: GetOrPutLineOrColumn; PlotXYZC: PlotXYZ; IncludeC: IncludeHoles := GetBooleanArg; AutoC: WandAutoMeasure := GetBooleanArg; LabelC: LabelParticles := GetBooleanArg; OutlineParticlesC: OutlineParticles := GetBooleanArg; IgnoreC: IgnoreParticlesTouchingEdge := GetBooleanArg; AdjustC: WandAdjustAreas := GetBooleanArg; SetParticleSizeC: SetParticleSize; SetPrecisionC: SetPrecision; PutPixelC: DoPutPixel; ScalingOptionsC: SetScaling; SetExportC: SetExportMode; ExportC: DoExport; ChangeC: DoChangeValues; UpdateResultsC: begin ShowInfo; DeleteLines(mCount, mCount); AppendResults; end; TileC: TileImages; SetMajorC, SetMinorC, SetUser1C, SetUser2C: SetLabel; GetMouseC: DoGetMouse; SelectSliceC, ChooseSliceC, AddSliceC, DeleteSliceC, ResliceC: begin if info^.StackInfo = nil then MacroError('No stack'); if token <> DoneT then case MacroCommand of SelectSliceC, ChooseSliceC: DoSelectSlice; AddSliceC: okay := AddSlice(true); DeleteSliceC: DeleteSlice; ResliceC: Reslice; end; end; MakeStackC: MakeNewStack; AverageFramesC: DoAverageFrames; TriggerC: WaitForTrigger; MakeLineC: MakeLineRoi; GetTimeC: DoGetTime; SetScaleC: DoSetScale; SaveStateC: SaveState; RestoreStateC: RestoreState; SetCounterC: SetCounter; UpdateLutC: DoUpdateLUT; SetCountC: SetErosionDilationCount; PropagateLutC: DoPropagate(1); PropagateSpatialC: DoPropagate(2); PropagateDensityC: DoPropagate(3); SetSpacingC: SetSliceSpacing; RequiresC: CheckVersion; SetOptionsC: SetOptions; SubtractBackgroundC: SubtractBackground; MoveWindowC: MoveCurrentWindow; UserCodeC: DoUserCode; InvertLutC: begin InvertPalette; UpdateLUT; end; OpenSerialC: OpenSerial; PutSerialC: PutSerial; SetCursorC: DoSetCursor; SetVideoC: SetVideoOptions; AcquireC: DoAcquire; CallFilterC: CallFilterPlugin; PhotoModeC: DoPhotoMode; RGBToIndexedC: RGBToIndexed; SurfacePlotC: PlotSurface; SelectWindowC: DoSelectWindow; NewTextWindowC: DoNewTextWindow; CaptureColorC: CaptureColor; GetThresholdC: GetThreshold; AverageSlicesC: AverageSlices; SortPaletteC: SortPalette; ProjectC: DoProject; ScaleConvolutionsC: ScaleConvolutions := GetBooleanArg; ImageMathC: ImageMath; PasteLiveC: PasteLive; GetPlotDataC: GetPlotData; DeleteC: DoDelete; GetScaleC: GetScale; AutoOutlineC: DoAutoOutline; FilterC: DoFilter; SetSaveAsC: SetSaveAsMode; CalibrateC: DoCalibrate; CallExportC: CallExportPlugin; IndexedToRGBC: ConvertEightBitColorToRGB; MakeMovieC: DoMakeMovie; SetProjectionC: SetProjection; GetHistogramC: DoGetHistogram; fftC: doFFTMacro; {Begin Scion} PrintVideoC: PrintVideo; VideoMathC: VideoMath; {End Scion} end; {case} OptionKeyWasDown := false; if not macro then begin Token := DoneT; KillRoi; end; if TickCount > MacroTicks then begin if EventAvail(everyEvent, theEvent) then; {Allows background tasks to run} if CommandPeriod then begin Token := DoneT; KillRoi; end; MacroTicks := TickCount + 15; end; end; procedure DoCompoundStatement; begin if token <> BeginT then MacroError('"begin" expected'); GetToken; while (token <> endT) and (token <> DoneT) do begin DoStatement; GetToken; if Token = SemiColon then GetToken else if token <> EndT then MacroError(EndExpected); end; end; procedure SkipCompoundStatement; var count: integer; begin count := 1; repeat GetToken; case token of beginT: count := count + 1; endT: count := count - 1; DoneT: begin MacroError('"end" expected'); exit(SkipCompoundStatement); end; otherwise end; {case} until count = 0; end; procedure DoDeclarations; begin if token = SemiColon then GetToken; if token = VarT then begin GetToken; while ((token = Identifier) or (token = variable) or (token = StringVariable)) and (Token <> DoneT) do DoDeclaration; end; end; procedure DoFor; var SavePC, StackLoc: integer; StartValue, EndValue, i: LongInt; begin StackLoc := GetVar; GetToken; if token <> AssignOp then begin MacroError('":=" expected'); exit(DoFor); end; StartValue := GetInteger; if token = DoneT then exit(DoFor); GetToken; if token <> ToT then begin MacroError('"to" expected'); exit(DoFor); end; EndValue := GetInteger; if token = DoneT then exit(DoFor); GetToken; if token <> DoT then begin MacroError(DoExpected); exit(DoFor); end; SavePC := pc; if StartValue > EndValue then begin GetToken; SkipStatement end else for i := StartValue to EndValue do with MacrosP^ do begin Stack[StackLoc].value := i; pc := SavePC; GetToken; DoStatement; LoopCounter := LoopCounter + 1; if LoopCounter >= MaxLoopCount then begin if CommandPeriod then token := DoneT; LoopCounter := 0; end; if Token = DoneT then leave; if Digitizing then DoCapture; end; end; procedure SkipFor; begin GetToken; SkipPartialStatement; GetToken; if token <> doT then MacroError(DoExpected); GetToken; SkipStatement end; procedure DoAssignment; var SaveStackLoc: integer; begin SaveStackLoc := TokenStackLoc; GetToken; if token <> AssignOp then begin MacroError('":=" expected'); exit(DoAssignment); end; MacrosP^.stack[SaveStackLoc].value := GetBooleanExpression; end; procedure DoStringAssignment; var SaveStackLoc: integer; str: Str255; begin SaveStackLoc := TokenStackLoc; GetToken; if token <> AssignOp then begin MacroError('":=" expected'); exit(DoStringAssignment); end; str := GetString; if token <> DoneT then with MacrosP^.stack[SaveStackLoc] do if StringH <> nil then StringH^^ := str; end; procedure SkipPartialStatement; var done: Boolean; begin done := token = DoneT; while not done do begin case token of ThenT, DoT, SemiColon, EndT, ElseT, UntilT: begin PutTokenBack; done := true; end; DoneT, BeginT, ForT, IfT, WhileT, RepeatT: begin MacroError('end of statement expected'); done := true; end; otherwise GetToken; end; end; end; procedure DoIf; var isTrue: boolean; begin isTrue := GetBoolean; GetToken; if token <> ThenT then MacroError(ThenExpected); if isTrue then begin GetToken; DoStatement end else begin GetToken; SkipStatement; end; GetToken; if token = elseT then begin if isTrue then begin GetToken; SkipStatement end else begin GetToken; DoStatement; end; end else PutTokenBack; end; procedure SkipIf; begin GetToken; SkipPartialStatement; GetToken; if token <> thenT then MacroError(ThenExpected); GetToken; SkipStatement; GetToken; if token <> elseT then PutTokenBack else begin GetToken; SkipStatement end end; procedure DoWhile; var isTrue: boolean; SavePC: integer; begin SavePC := pc; repeat pc := SavePC; isTrue := GetBoolean; GetToken; if token <> doT then MacroError(DoExpected); if isTrue then begin GetToken; DoStatement end else begin GetToken; SkipStatement; end; if Digitizing then DoCapture; LoopCounter := LoopCounter + 1; if LoopCounter >= MaxLoopCount then begin if CommandPeriod then token := DoneT; LoopCounter := 0; end; until not isTrue or (Token = DoneT); end; procedure SkipWhile; begin GetToken; SkipPartialStatement; GetToken; if token <> doT then MacroError(DoExpected); GetToken; SkipStatement end; procedure DoRepeat; var isTrue: boolean; SavePC: integer; begin SavePC := pc; isTrue := true; repeat pc := SavePC; GetToken; while (token <> untilT) and (token <> DoneT) do begin DoStatement; GetToken; if Token = SemiColon then GetToken; LoopCounter := LoopCounter + 1; if LoopCounter >= MaxLoopCount then begin if CommandPeriod then token := DoneT; LoopCounter := 0; end; end; if token <> untilT then MacroError(UntilExpected); isTrue := GetBoolean; if Digitizing then DoCapture; until isTrue or (Token = DoneT); end; procedure SkipRepeat; begin GetToken; while (token <> untilT) and (token <> DoneT) do begin SkipStatement; GetToken; if token = SemiColon then GetToken else if token <> UntilT then MacroError(UntilExpected); end; GetToken; SkipPartialStatement; end; procedure DoArrayAssignment; var SaveArrayType: ArrayType; index, LutValue, PixelValue, RegisterValue: LongInt; SyncChannel: integer; begin SaveArrayType := ArrayType(MacroCommand); GetToken; if token <> LeftBracket then MacroError('"[" expected'); Index := GetInteger; GetToken; if token <> RightBracket then MacroError('"]" expected'); GetToken; if token <> AssignOp then MacroError('":=" expected'); if SaveArrayType = BufferA then begin CheckIndex(index, 0, MaxLine - 1); PixelValue := GetInteger; RangeCheck(PixelValue); if token <> DoneT then MacrosP^.aLine[index] := PixelValue; exit(DoArrayAssignment); end; if SaveArrayType in [RedLutA, BlueLutA, GreenLutA] then begin RangeCheck(index); LutValue := GetInteger; RangeCheck(LutValue); if token <> DoneT then with info^.cTable[index].rgb do case SaveArrayType of RedLutA: red := bsl(LutValue, 8); GreenLutA: green := bsl(LutValue, 8); BlueLutA: blue := bsl(LutValue, 8); end; exit(DoArrayAssignment); end; if SaveArrayType = ScionA then begin if framegrabber <> ScionLG3 then MacroError('No Scion LG-3'); if Token <> DoneT then CheckIndex(index, 1, 4); if Token = DoneT then exit(DoArrayAssignment); if index = 3 then MacroError('DataIn is read-only'); RegisterValue := GetInteger; if token <> DoneT then begin if RegisterValue < 0 then RegisterValue := 0; if RegisterValue > 255 then RegisterValue := 255; case index of 1: begin LG3DacA := RegisterValue; DacAReg^ := LG3DacA end; 2: begin LG3DacB := RegisterValue; DacBReg^ := LG3DacB end; 4: begin LG3DataOut := band(RegisterValue, $f); if SyncMode = SeparateSync then SyncChannel := 3 else SyncChannel := VideoChannel; ChannelReg^ := bor(LG3DataOut, bor(bsl(VideoChannel, 4), bsl(SyncChannel, 6))); end; end; {case} end; exit(DoArrayAssignment); end; if SaveArrayType = PlotDataA then begin CheckIndex(index, 0, MaxLine - 1); PlotData^[index] := GetExpression; exit(DoArrayAssignment); end; CheckIndex(index, 1, MaxMeasurements); if token <> DoneT then case SaveArrayType of rAreaA: mArea^[Index] := GetExpression; rMeanA: mean^[Index] := GetExpression; rStdDevA: sd^[Index] := GetExpression; rXA: xcenter^[Index] := GetExpression; rYA: ycenter^[Index] := GetExpression; rLengthA: plength^[Index] := GetExpression; rMinA: mMin^[Index] := GetExpression; rMaxA: mMax^[Index] := GetExpression; rMajorA: MajorAxis^[Index] := GetExpression; rMinorA: MinorAxis^[Index] := GetExpression; rAngleA: orientation^[Index] := GetExpression; rUser1A: User1^[Index] := GetExpression; rUser2A: User2^[Index] := GetExpression; otherwise MacroError('Read-only array'); end; {case} end; procedure PushArguments (var nArgs: integer); var arg: array[1..MaxArgs] of extended; StringArg: array[1..MaxArgs] of boolean; i, nStringArgs: integer; TempName: SymbolType; begin nArgs := 0; nStringArgs := 0; GetToken; while token in [Variable, StringVariable, StringLiteral, NumericLiteral, TrueT, FalseT, FunctionT, StringFunctionT, ArrayT, comma, MinusOp, LeftParen] do begin if token = comma then GetToken; if nArgs < MaxArgs then nArgs := nArgs + 1 else MacroError('Too many arguments'); if (token = StringVariable) or (token = StringLiteral) or (token = StringFunctionT) then begin nStringArgs := nStringArgs + 1; arg[nArgs] := 0.0; StringArg[nArgs] := true; if token = StringFunctionT then TokenStr := DoStringFunction; end else begin PutTokenBack; arg[nArgs] := GetBooleanExpression; StringArg[nArgs] := false; end; if nStringArgs > 1 then MacroError('No more than one string argument allowed'); GetToken; end; if token <> RightParen then MacroError(RightParenExpected); for i := 1 to nArgs do begin if TopOfStack < MaxMacroStackSize then TopOfStack := TopOfStack + 1 else MacroError(StackOverflow); with MacrosP^.stack[TopOfStack] do begin value := arg[i]; StringH := nil; if StringArg[i] then begin vType := StringVar; StringsAllocated := true; StringH := str255H(NewHandle(SizeOf(str255))); if StringH = nil then begin MacroError('Out of memory'); Token := DoneT end else StringH^^ := TokenStr; end else vType := RealVar; value := arg[i]; end; end; end; procedure DoProcedure; var SavePC, SavePCStart, NewPCStart, SaveStackLoc, nArgs, i: integer; SaveProcName, NewProcName: SymbolType; SaveStringsAllocated: boolean; begin NewPCStart := TokenLoc; NewProcName := TokenSymbol; SaveStackLoc := TopOfStack; SaveStringsAllocated := StringsAllocated; StringsAllocated := false; GetToken; if token = LeftParen then PushArguments(nArgs) else begin nArgs := 0; PutTokenBack; end; SavePCStart := PCStart; PCStart := NewPCStart; LineStartPC := NewPCStart; SaveProcName := MacroOrProcName; MacroOrProcName := NewProcName; SavePC := pc; pc := pcStart; if nArgs > 0 then begin GetLeftParen; i := 0; GetToken; while token in [Identifier, Variable, StringVariable, comma, colon, SemiColon, RealT, IntegerT, BooleanT, StringT] do begin if (token = Identifier) or (token = Variable) or (token = StringVariable) then begin if i < nArgs then i := i + 1 else MacroError('Too many formal arguments'); MacrosP^.stack[SaveStackLoc + i].SymbolTableIndex := SymbolTableloc; end; GetToken; end; if Token = VarT then MacroError('VAR parameters not supported'); if i < nArgs then MacroError('Too few formal arguments'); if token <> RightParen then MacroError(RightParenExpected); end; GetToken; if (token = LeftParen) and (nArgs = 0) then MacroError('Arguments not expected'); DoDeclarations; DoCompoundStatement; pc := SavePC; if StringsAllocated then DeallocateStrings(SaveStackLoc + 1, TopOfStack); StringsAllocated := SaveStringsAllocated; TopOfStack := SaveStackLoc; pcStart := SavePCStart; MacroOrProcName := SaveProcName; end; procedure CannotBeginWithThis; var str: str255; begin str := ''; ConvertTokenToString(token, str); MacroError(concat('Statement cannot begin with ', '"', str, '"')); end; procedure DoStatement; begin case token of BeginT: DoCompoundStatement; CommandT: ExecuteCommand; UserCommandT: DoUserToken; ForT: DoFor; IfT: DoIf; WhileT: DoWhile; RepeatT: DoRepeat; Identifier: MacroError('Undefined identifier'); Variable: DoAssignment; StringVariable: DoStringAssignment; ArrayT: DoArrayAssignment; ProcedureT: DoProcedure; ElseT: MacroError('Statement expected'); FunctionT, StringFunctionT, UserFuncT, UserStrFuncT: MacroError('Variable expected'); SemiColon: PutTokenBack; {Null statement} otherwise CannotBeginWithThis end; end; procedure SkipStatement; begin case token of BeginT: SkipCompoundStatement; ForT: SkipFor; IfT: SkipIf; WhileT: SkipWhile; RepeatT: SkipRepeat; CommandT, Variable, StringVariable, ArrayT, ProcedureT: SkipPartialStatement; DoneT: ; {Aborting the macro} SemiColon, EndT, ElseT, UntilT: PutTokenBack; {These tokens can follow a statement} otherwise CannotBeginWithThis end; end; procedure RunMacro (nMacro: integer); var count: integer; str: str255; SaveInfo: InfoPtr; begin DefaultFileName := ''; str := ''; nSaves := 0; DefaultRefNum := 0; count := 0; pcStart := MacroStart[nMacro]; pc := pcStart; SavePC := pcStart; LineStartPC := pcStart; token := NullT; macro := true; DoOption := false; SaveInfo := info; TopOfStack := nGlobals; MacroOrProcName := BlankSymbol; StringsAllocated := false; InPhotoMode := false; RoutinesCalled := []; MacroTicks := TickCount + 15; LoopCounter := 0; GetToken; DoDeclarations; DoCompoundStatement; if (info <> SaveInfo) and (info <> NoInfo) then SelectWindow(info^.wptr); with info^, RoiRect do begin if ((right - left) <= 0) or ((bottom - top) <= 0) then KillRoi; end; if info^.RoiShowing then if not (OpPending and (CurrentOp = PasteOp)) then begin KIllRoi; RestoreRoi; end; macro := false; if StringsAllocated then DeallocateStrings(nGlobals + 1, TopOfStack); if InPhotoMode then RestoreScreen; end; procedure RunKeyMacro (ch: char; KeyCode: integer); const FunctionKey = 16; var i: integer; begin if (ord(ch) = 0) then exit(RunKeyMacro); if (ch >= 'A') and (ch <= 'Z') then ch := chr(ord(ch) + 32); {Convert to lower case} if ord(ch) = FunctionKey then case KeyCode of 122: ch := 'A'; 120: ch := 'B'; 99: ch := 'C'; 118: ch := 'D'; 96: ch := 'E'; 97: ch := 'F'; 98: ch := 'G'; 100: ch := 'H'; 101: ch := 'I'; 109: ch := 'J'; 103: ch := 'K'; 111: ch := 'L'; 105: ch := 'M'; 107: ch := 'N'; 113: ch := 'O'; otherwise end; for i := 1 to nMacros do if ch = MacroKey[i] then begin RunMacro(i); leave; end; end; end.