R/rFpars.R

In rFocal: Run 'FOCAL' Language Source Code

# Take FOCAL source code as input; translate each line into equivalent R code,
# do some fancy adjustments to handle "GOTO" , and then execute the R code .

#TODO

rFocal <- function(focFile, rFile, runit=TRUE, saveit = FALSE ) {
#  3 ways: file name string, object which is FOCAL code, or a list object
# which is result of a previous run.  
makeVars <- FALSE
# set up my working environment.
#  as seen at   http://stackoverflow.com/questions/30416292
# add all new runXXX funcs. Also note have to include every func that ops pass thru
 fenv <- environment(runRcode) <- environment(runASK) <- environment(runDO)  <- environment(makeASK) <- environment(makeFOR) <- environment(makeIF)<- environment(makeQUIT) <- environment(makeSET) <- environment(makeTYPE) <- environment(parsefoc)<- environment(prepareCode) <- list2env(list(dummy='HiThere'))

if(is(focFile,'foclist')){
# re-load variables from a previous run's output
	if(missing(rFile)) rFile <- paste0(as.character(substitute(focFile)), '.r', collapse='')
	retcode <- focFile$code
	retidx <- focFile$retidx
	strnum <- focFile$strnum
	makeVars <- TRUE
} else {
	if(is.name(substitute(focFile)) ) {
	# it's raw FOCAL code; so make "rFile" from  focFile 
	if(missing(rFile)) rFile <- paste0(as.character(substitute(focFile)), '.r', collapse='')
		foor <- focFile
		gotIt <- prepareCode(foor, fenv)
		retcode <- gotIt$retcode
		retidx <- gotIt$retidx
		strnum <- gotIt$strnum	
	} else {	
		#read the file in, then process teh FOCAL code
		if(missing(rFile)){
			thename <- gsub('[.][^.]{1,}$','',focFile)
			rFile <- paste0(thename,'.r',collapse='')
		}
		con <- file(focFile,'r')
		foor <- readLines(con)
		close(con)
		gotIt <- prepareCode(foor, fenv)
		retcode <- gotIt$retcode
		retidx <- gotIt$retidx
		strnum <- gotIt$strnum	
		}
	}
if(makeVars) {
	for(jv in 1:length(focFile$newvar)){
		assign(focFile$newvar[jv], NULL, envir = fenv)
	}
}
#FOCAL uses up-arrow for exponentiation.  just tell user to replace with "^" and live with it. 
# remove rownames from retcode
rownames(retcode) <- NULL
# for safety, write stuff  to file before trying to execute.
coderef <- gsub('\\n', '\\\\n' ,retcode)
reftab <- cbind(strnum,retidx,coderef)
colnames(reftab) <- c('maj','min','idx','nextidx','coderef')
# safer to allow quotes and parse numbers later if desired
if(saveit) {
	suppressWarnings(write.table(reftab, rFile, append=TRUE, row.names=FALSE, col.names=TRUE)  )

}
#call  the func that executes the R code as directed by indices.
# it returns a list of what's in fenv
if(runit) {
	allnewvar <- runRcode(retcode, retidx, strnum, fenv=fenv, saveit)
}
# create an output with class "foclist"
datout <-  list(code = unname(retcode), retidx = retidx, strnum = strnum,newvar = allnewvar)
class(datout) <- c('foclist','list')
return(invisible(datout )) 
} # end of main() func

# "pre-parse" raw FOCAL code
# TODO
# 1) simplify bracket work by recognizing that a CMD string is always separated with
# whitespace from   whatever follows.  
prepareCode <- function(foor, fenv) {
# SEPARATING NUMBERING AND COMMANDS
foor <- gsub('[[<]', '(', foor, perl=TRUE)
foor <- gsub('[>\\]]', ')', foor, perl=TRUE)
thestr <- tolower(foor)
 # check for empty lines and remove them
 # TODO: may want to do this "last" in case new empty things sneak in
thestr <- thestr[!(thestr =='')]

#  want to reject "f***" as being a function but everything
# here's a regex which only catches 2-char names.  Don't use. 
#thestr <- gsub('([^a-z][a-z]{1,2})[(]([0-9]{1,})[)]' ,'\\1\\[\\2\\] ' , thestr)
#FOCAL has IF (....) , the only place where there are brackets other than a
# vector index or a function.  We will   "de-bracket" inside makeIF.
# This version, i.e.
#'([^f][a-eg-z]{1,}[^(]{0,})[(]([^)]{1,})[)]' 
# fails badly since it will start with any 2 alpha chars together (not f)
# fixed this one to reject Fxxx

for(jstr in 1:length(thestr)) {
	doit <- TRUE 
	while (doit) {
		strtmp <- gsub('([^a-z][a-eg-z]{1,}[a-z0-9]{0,}\\s{0,})[(]([^)]{1,})[)]', '\\1\\[\\2\\] ', thestr[jstr])
		if(identical(thestr[jstr],strtmp)) doit <- FALSE else thestr[jstr] <- strtmp
	}
#  Now collapse all inside [...] so that ab[1+g[kk]] gets to makeXXX as a single item
	 strvec <- unlist(strsplit(thestr[jstr], '')  ) 
	barop <- strvec == '['
	barcl <- strvec == ']'
	matchit <- rle(sign(cumsum(barop-barcl)))
	edges <- cumsum(matchit$lengths)
	packit <- TRUE  # do the collapse
	if(length(edges) > 1 ) {
		newstr <- strvec[1:edges[1]]
		for(je in 1:(length(edges)-1)  ) {
			if(packit){
				blob <- paste0(strvec[(edges[je]+1): (edges[je+1]+1)],collapse='')
				blob <- gsub('\\s{1,}', '', blob)
			}  else blob <- c(strvec[(edges[je]+2) :edges[je+1]])
			newstr <- c(newstr,blob)
			packit <- !packit  #flip every time
		}
		thestr[jstr] <- paste0(newstr,collapse='')
	}  
# make sure variable name is "stuck on" brackets
# The only command word which is followed by brackets is IF, so fix that in makeiF 
	thestr[jstr] <- gsub('\\s{1,}\\[','[', thestr[jstr])
} # end of jstr loop

# find all "["	and replace contents  with contents +1 for proper indexing
# NOTE: do not adjust loop indexing, as code may depend on that value, e.g.  
#  FOR J = 0,5 ; y(J) = J   becomes for(j in 0:5) y[1+j] = j 
thestr <- gsub('[[]','[1+', thestr)
# replace builtin function names	
thestr <- gsub('fabs','abs', thestr)
thestr <- gsub('fitr','as.integer', thestr)
thestr <- gsub('fsqt','sqrt', thestr)
thestr <- gsub('fsin','sin', thestr)
thestr <- gsub('fcos','cos', thestr)
thestr <- gsub('fexp','exp', thestr)
thestr <- gsub('fsgn','sign', thestr)
thestr <- gsub('fatn','atan', thestr)
thestr <- gsub('flog','log', thestr)
thestr <- gsub('fran\\([:blank:]{0,}\\)', 'runif(1, -1, 1)', thestr)
# remove "?" because that causes TRACE.  
# thanks to SO  https://stackoverflow.com/questions/68432655
# (?<!"");(?!"")(?=((?:[^"]*"){2})*[^"]*$)
#  this now clears out all unwanted TRACE '?' .
thestr <- gsub('(?<!"")\\?(?!"")(?=((?:[^"]*"){2})*[^"]*$)',' ',thestr,perl=TRUE)
# in oddball cases, whitespace might sneak in, so
thestr <-trimws(thestr)
# and... have to handle lines which start with "COMMENT" rather than a line number
thestr <- thestr[!(grepl('^c',thestr))]

# check for any "number-alpha" strings that need conversion to numeric
# numchar2num() does handle multiple instances in a single line
for(jnum in 1:length(thestr)) {
# lesson learned in runASK:  check for "4f" and "2e3" -- like things
	barg <- gregexpr('[^a-z][0-9]{1,}[a-z]{1,}[^0-9-]',thestr[jnum],perl=TRUE)
#if nomatch, barg == -1 
	if(barg[[1]][1]>0) {
#	note: the characters 'found' by gregexpr include a trailing char not wanted
		thestr[jnum] <- numchar2num(thestr[jnum], barg)
	}
}
# Save major pain in various makeXXX and runXXX funcs: make sure that the 
# '%' in print formatting is tied to its numbers.
thestr <- gsub('[%]\\s{1,}','%',thestr)
# Now break each thestr[k] into separate commands, and build index tables.
strchar <- NULL   
strcmd <- list()
cmd <- rep('',times = length(thestr))
crunch <- NULL 
# jlin is 'main' loop which parses and cleans up each line , and separates 
# multi-commands into individual commands in the table. 
for(jlin in 1:length(thestr)) {
	splittmp <- trimws(strsplit(thestr[jlin],'\\s{1,}',perl=TRUE)[[1]] )   
# remove the line number, leaving just commands
	thisexec <- paste0(splittmp[-1],collapse= ' ')
#  don't go numeric yet.
	majmin <- unlist(strsplit(splittmp[[1]][1],'[.]') ) 
	if(length(majmin) < 2) majmin <- c(majmin,'0')
#  separate into a regular vector, each element being one command,
	cmdinit <- strsplit(thisexec,';')  # don't unlist, at least for now
#	cmdinit <- trimws(cmdinit[[1]])  # still breaks the list
# IF is the only command which is followed by a bracket pair. To survive various
# filters and parsing, I need to have a space after "if"
	fooif <- grepl('^i',trimws(cmdinit[[1]]))
	cmdinit[[1]][fooif] <- sub('(i[a-z]{0,})','if ',cmdinit[[1]][fooif] )
# "put back together" FOR statements...
	thislen <- length(cmdinit[[1]])
# "FOR" could be "F" or "FO"; but a line can't start with a Faaa function name
	foundfor <- grep('^f',trimws(cmdinit[[1]]))
	if(length(foundfor)){
		if(foundfor[1] ==1){		
		 cmdinit[[1]] <- paste0(cmdinit[[1]],';',collapse = ' ')
		 } else {
		 	thefor <-  paste0(cmdinit[[1]][foundfor[1]:length(cmdinit[[1]]) ],';',collapse = ' ')
		 	cmdinit[[1]] <- c(cmdinit[[1]][1:(foundfor[1]-1)], thefor)
		 }
	}
	
# catch TYPE,ASK and convert "!" to a linefeed.
	for(jtype in 1:thislen) {
		tmpcmd <- unlist(strsplit(cmdinit[[1]][jtype],' ',perl=TRUE))[1]
		if(!is.na(pmatch(tmpcmd,'type')) || !is.na(pmatch(tmpcmd,'ask'))) {
	# no need to remove the command element  
			tmpbody <- gsub('[!]',' ! ', cmdinit[[1]][jtype], perl=TRUE)
			tmpbody <- unlist(strsplit(tmpbody,' ',perl=TRUE))
#catch oddities like  "helloworld"!  
			barsplat <- grep('[!]', tmpbody)
			barquot <- grep('["]', tmpbody)
			if(length(barsplat)){
				for(jsp in 1: length(barsplat)) {
					qpair <- sum(barquot < barsplat[jsp] )
					if(!(qpair%%2)) {				
					tmpbody[barsplat[jsp]] <- gsub('[!]',',!,', tmpbody[barsplat[jsp]])
					} 
				}
			} #end of if barsplat
	# reassemble
#   (never will have more than 1 element in cmdinit)			
			cmdinit[[1]][jtype] <- paste0(tmpbody, collapse = ' ')
			}		#end of if(type) 
	} #end of TYPE munging, jtype loop
	exectmp <- list()  
# build the list of commands
	for (jcmd in 1: length(cmdinit[[1]])) {
#  I split on spaces.... fixed inside makeIF		
		foo <- unlist(strsplit(cmdinit[[1]][jcmd],'\\s{1,}',perl=TRUE)  )
# somewhere I allowed empty elements to sneak in
		foo <- foo[which(nchar(foo)>0)]
		if(!is.na(pmatch(foo[1], 'comment'))) {

# if it's a comment, collapse ALL of cmdinit, which is a list
			foo <- unlist(strsplit(cmdinit[[1]],'\\s{1,}',perl=TRUE)  )
			fooend <-paste0(c(foo[-1]),collapse= ' ')
			foo <- c(foo[1],fooend)
			exectmp[[jcmd]] <- foo
			break  # no further processing of comment line desired. 
			}
		exectmp[[jcmd]] <- foo
	} # end of jcmd loop
	crunch <- c(crunch,exectmp)
# I pass crunch[[lidx]][[jcmd]] to parsefoc
	for (jc in 1: length(exectmp)) strchar <- rbind(strchar, majmin)

}  #end of jlin loop
# note: loop above guarantees there's a numeral in 2nd column of strchar, even if its a 0
# if FOCAL sends "3" or"3.00", meaning "all of 3.x", it is not a legal 
# line number to use in codeing.  It's only valid, I think, for  DO,
# manual: "The numbers 1.00, 2.00,etc., are illegal line numbers; they are used to indicate the entire group. "

str2 <- strchar[,2]
str1 <- as.numeric(strchar[,1])
str2[nchar(str2) < 2] <- paste0(str2[nchar(str2) < 2],'0')
strnum <- unname(cbind(str1,as.numeric(str2)) )
# Now the first object in each element of each  crunch[[j]] is teh FOCAL command
#This is the loop that creates the table, or list, of R-command strings.
lidx <- cmdidx <- 1
retcode <- NULL
retidx <-NULL  # but now will just be a line counter
while(lidx <= length(crunch)) {
	cmdidx <- lidx
	outstr <- parsefoc(cmdidx, crunch[[lidx]], crunch, strnum,fenv)   			
	theLine <- paste0(outstr$rcode, collapse= ' ')
	retcode <- rbind(retcode, theLine)
	retidx <- rbind(retidx, c(cmdidx, outstr$newidx ) )
	lidx <- lidx + 1
	cmdidx <- cmdidx + 1
}  #end of lidx while
return(list(retcode = retcode, retidx = retidx, strnum = strnum))
}  

parsefoc <- function(theidx, thecmd, crunch, strnum,fenv) {
# thecmd is the current element of crunch[[lidx]]
#  it's a list all by  itself,so do:
thecmd <- trimws(unlist(thecmd))
# removed unsupported items - pass to the default 
allcmds <- c('type' , 'ask' , 'write' , 'set' ,  'goto' , 'do' , 'if' , 'return' , 'quit' , 'comment' , 'for')

this <- try(argcmd <- match.arg(thecmd[1], allcmds) ,silent=TRUE   )
if(nchar(this) > 10) argcmd <- 'unknowncommand'
#if(!this %in% allcmds) stop('Unknown command "', thecmd[1],'"')
	switch(argcmd,
	'for' = {
		linesout <- makeFOR(theidx, thecmd[-1], crunch,strnum, fenv=fenv)				
	},
	'do' = {

			linesout <- makeDO(theidx, thecmd[-1], crunch, strnum, fenv=fenv)
	},
	'ask'  = {
		linesout <- makeASK(theidx, thecmd[-1], crunch, strnum, fenv=fenv)		
	},
	'goto' = {
		linesout <- makeGOTO(theidx, thecmd[-1], crunch, strnum, fenv=fenv)
	},
	'set'  = {
		linesout <- makeSET(theidx, thecmd[-1], crunch, strnum, fenv=fenv)		
	},
	'return' = {
		linesout <- makeRETURN(theidx, thecmd[-1], crunch,strnum, fenv=fenv)		
	}, 
	'quit'  = {
		linesout <- makeQUIT(theidx, thecmd[-1], crunch,strnum, fenv=fenv)		
	},
# RETURN is handled inside makeDO --- TODO: make sure an IF() 4,RETURN,5 will work
	 'type' = {
		 linesout <- makeTYPE(theidx, thecmd[-1], crunch,strnum, fenv=fenv)	
	 },
# With 'realtime translation', comments are not going anywhere
	'comment'  = {
		linesout <- list(rcode = paste0(c('# ',thecmd[-1] ),collapse = ' ' ), newidx = theidx+1)		
	},
	'if' = {		
		linesout <- makeIF(theidx, thecmd[-1], crunch,strnum, fenv=fenv)				
	},
	 {
# default all others into a comment
		linesout <- list(rcode = paste0(c('# ',thecmd),collapse = ' '), newidx = theidx+1)
	}				
	) #end of switch	
return(linesout)
}  #endof parsefoc