; $Id: inftopre.pro,v 1.5 2005/02/03 18:04:12 azuah Exp $
;###############################################################################
;
; LICENSE:
;  The software in this file is written by an employee of 
;  National Institute of Standards and Technology 
;  as part of the DAVE software project.
;
;  The DAVE software package is not subject to copyright protection
;  and is in the public domain. It should be considered as an
;  experimental neutron scattering data reduction, visualization, and
;  analysis system. As such, the authors assume no responsibility
;  whatsoever for its use, and make no guarantees, expressed or
;  implied, about its quality, reliability, or any other
;  characteristic. The use of certain trade names or commercial
;  products does not imply any endorsement of a particular product,
;  nor does it imply that the named product is necessarily the best
;  product for the stated purpose. We would appreciate acknowledgment
;  if the DAVE software is used of if the code in this file is
;  included in another product.
;
;###############################################################################
;;;**********************************************************************
;;; IDL Infix to Prefix translator.
;;; By Bruce R. Miller on 2001-10-12 for John Copley
;
; Modified by R.M.Dimeo (01/10/02): removed all common blocks and
; replaced with a pointer.
;		Further modified by J.R.D.Copley (01/16/02) following advice from
;		Bruce R. Miller:
;		(1) Improved error handling.
;		(2)	Handles known functions.
;		(3)
;;;**********************************************************************

FORWARD_FUNCTION inftopre,known_function
FORWARD_FUNCTION parse_expr,parse_atom,parse_funcall,op_precedence

;
FUNCTION checknext,input,c,errPtr
	isnt_there = strmid(input,0,1) NE c
	if (isnt_there) THEN *errPtr = "Missing "+c+" at "+input
	RETURN,isnt_there
END

;
FUNCTION known_function,func
	x=func
	case x of
		'sin':
		'cos':
		'sqrt':
		'alog':
		'alog10':
		'ln': x='alog'; convert to recognized IDL function
		'log': x='alog10'; convert to recognized IDL function
		else: return,{s:"",mn:0,max:0}; unknown function name
	endcase
	return,{s:x+strcompress(" 2d",/remove_all),mn:1,mx:1}
END

; What is the precedence of the operator op?
FUNCTION op_precedence,op
	CASE op OF
		'^': RETURN, {p:40,s:"p2d"}
		'*': RETURN, {p:30,s:"m2d"}
		'/': RETURN, {p:30,s:"d2d"}
		'+': RETURN, {p:20,s:"a2d"}
		'-': RETURN, {p:20,s:"s2d"}
		'=': RETURN, {p:10,s:"e2d"}
		ELSE: RETURN, {p:-1,s:""} ; isn't even a recognized operator
	ENDCASE
END

;;;**********************************************************************
; Parse a function call.
FUNCTION parse_funcall,info,input,varPtr,errPtr
	input = strtrim(input,1)
	IF (checknext(input,'(',errPtr)) THEN RETURN,"" ; check next character
	input = strmid(input,1)
	input = strtrim(input,1)
	call = info.s + "("
	nargs = 0
	while (1) do begin
		IF (strmid(input,0,1) EQ ')') THEN break ; closing parenthesis found
		arg = parse_expr(0,input,varPtr,errPtr)
		IF (*errPtr ne "") THEN RETURN,""
		nargs = nargs + 1
		call = call + arg
		IF (strmid(input,0,1) EQ ')') THEN break ; closing parenthesis found
		IF (checknext(input,',',errPtr)) THEN RETURN,""
		input = strmid(input,1)
		call = call + ','
	endwhile
	if (nargs lt info.mn or nargs gt info.mx) then begin
		*errPtr = "Incorrect number of arguments at "+input
		RETURN,""
	ENDIF
	IF (checknext(input,')',errPtr)) THEN RETURN,""
	input = strmid(input,1)
	call = call + ')'
	return,call
END

;;;**********************************************************************
; Parse an expression consisting of infix operators with precedence > prec
;   input is modified!!
FUNCTION parse_expr, prec,input,varPtr,errPtr
	left = parse_atom(input,varPtr,errPtr)
	IF (*errPtr ne "") THEN RETURN,""
	pos = stregex(left,'^[a-zA-Z]+[0-9]*',length=len)
	input = strtrim(input,1)
	WHILE(strlen(input) GT 0) DO BEGIN
		op = strmid(input,0,1)
		opprec = op_precedence(op)
		IF (opprec.p LE prec) THEN RETURN, left
		input = strmid(input,1)
		right = parse_expr(opprec.p,input,varPtr,errPtr)
		IF (*errPtr ne "") THEN RETURN,""
		newop = opprec.s
		left = '( ' + newop + ' ( ' + left + ' , ' + right + ' ) )'
	ENDWHILE
	RETURN, left
END

;;;**********************************************************************
; Parse an atomic expression (variable, number or parenthesized expression)
; from the beginning of input.  NB input is modified!!
FUNCTION parse_atom,input,varPtr,errPtr
	input = strtrim(input,1)
	IF (strmid(input,0,1) EQ '(') THEN BEGIN  ; Parenthesized expression
		input = strmid(input,1)
		atom = parse_expr(0,input,varPtr,errPtr)
		IF (*errPtr ne "") THEN RETURN,""
		input = strtrim(input,1)
		IF (checknext(input,')',errPtr)) THEN RETURN,""
		input = strmid(input,1)
	ENDIF ELSE BEGIN  ; Not a parenthesized expression
		pos=stregex(input,'^[a-zA-Z][a-zA-Z0-9_]*',length=len) ; Variable or function name
		IF (len GT 0) THEN BEGIN
			atom = strmid(input,0,len)
			input = strmid(input,len)
			info = known_function(atom) ; Is it a known function?
			if (info.s ne "") then begin
				return,parse_funcall(info,input,varPtr,errPtr)
			endif else $ ; Add to list of variables.
				if ((*varPtr)[0] eq "") THEN *varPtr=atom ELSE *varPtr=[*varPtr,atom]
		ENDIF ELSE BEGIN  ; Try for a numeric format
			pos=stregex(input,'^[0-9]*(\.[0-9]*)?([eEdD][\+-]?[0-9]+)?',length=len)
			IF (len GT 0) THEN BEGIN  ; Found something
				atom = strmid(input,0,len);
				input = strmid(input,len);
			ENDIF ELSE BEGIN
				*errPtr = "Missing operand"
				RETURN,""
			ENDELSE
		ENDELSE
	ENDELSE
	RETURN, atom
END

;;;**********************************************************************
;;; Infix to Prefix converter.
;;; instring and outstring are input and output strings
;;;	lvar contains the list of variables found in the expression
;;;	message is a null string or else an erro message
PRO inftopre, instring, outstring, lvar, message
	input = instring   ; make `copy' of input: (it will be modified).
	varPtr = ptr_new("")
	errPtr = ptr_new("")
	input = strjoin(strsplit(input,/extract)); remove all blanks.
	outstring = parse_expr(0,input,varPtr,errPtr)
	IF (*errPtr ne "") THEN message = *errPtr ELSE BEGIN
		message=""
 		IF (strlen(input) GT 0) THEN message="Unparsed input remains: "+input
	ENDELSE
	lvar=*varPtr
	ptr_free,varPtr
	ptr_free,errPtr
END
