同じ数の繰り返しで作られる数列について，そこに含まれる数を１つずつ使い、目的の数を作るための式を総当たりで求める

npuzzle.R

## 同じ整数の繰り返しである数列に含まれる数を１つずつ使い、目的の数を作るための式を総当たりで求める
## Usage: npuzzle(2,4,24) => (2,2,2,2)を１つずつ使って24を作るにはどうするか．
npuzzle <- function(num, nrep, target, twofuncs = list(
	"*"=function(x,y){x*y},
	"/"=function(x,y){x/y},
	"+"=function(x,y){x+y},
	"-"=function(x,y){x-y},
	"^"=function(x,y){x^y}), onefuncs = list(
	" "=function(x){x},
	"factorial"=function(x){factorial(x)},
	"10^"=function(x){10^x},
	"sqrt"=function(x){sqrt(x)}
	)) {

	calcres <- function(first, rest) {
	  #print(paste("First:",first, "(",names(first),") / Rest:", rest, "(", names(rest), ")"))
		valv <- sapply(onefuncs, do.call, list(first))
		names(valv) <- paste(names(onefuncs),"(", names(first),")",sep="")
		valv <- na.omit(valv)
	  resa <- vector()
	  for(i in 1:length(rest)) {
			pal <- rest[i]
			palv <- sapply(onefuncs, do.call, list(pal))
			names(palv) <- paste(names(onefuncs), "(", names(pal), ")", sep="")
			palv <- na.omit(palv)	
			twopar <- expand.grid(valv, palv)
			twoparn <- expand.grid(names(valv), names(palv))
			for(r in 1:nrow(twopar)) {
				resv <- sapply(twofuncs, do.call, list(twopar[r,1], twopar[r,2]))
				names(resv) <- paste("(",twoparn[r,1], names(twofuncs), twoparn[r,2],")",sep="")
				resv <- na.omit(resv)
				if(length(resv) > 0) {
				  if(length(rest) > 1) # もしまだ残りの数字があるなら再帰動作
  				  for(ri in 1:length(resv)) {
  				    rv <- resv[ri]
  				    resa <- append(resa, calcres(rv, rest[-i]))
  				  }
				  else # もう残りの数字はない
				    resa <- append(resa, resv)
				}
			 }
		}
		resa
	}

#   任意数列に拡張を試みた名残
# 	pm <- permn(param)
# 	for(i in length(pm):2)
# 	  for(j in (i-1):1)
# 	    if(identical(pm[[i]], pm[[j]])) {
#   	     pm[[i]] <- NULL
#   	     break
# 	    }
#     
# 	result <- vector()
# 	for(r in 1:length(pm)) {
# 	  firstparam <- pm[[r]][1]
# 	  names(firstparam) <- firstparam
# 	  restparam <- pm[[r]][-1]
# 	  names(restparam) <- restparam
# 	  result <- append(result,calcres(firstparam, restparam))
# 	}
	
	params <- rep(num, nrep)
	names(params) <- params
  result <- calcres(params[1], params[-1])  
	result[result==target]
}