Mfcttrf

I need to create a function programmatically. For example, suppose I've got:

1. mon - a Symbol


2. mons - a List of Symbols


3. vars - another List of Symbols (same Length)

and want to make a function as:

Function[«mon»,
 Function[«mons»,
 Internal`InheritedBlock[«vars»,
 «vars[[1]]» =.;
 «vars[[2]]» =.;
 ...
 «vars[[-1]]» =.;
 «vars[[1]]» = «mons[[1]]»;
 «vars[[2]]»[t] = «mons[[2]]»;
 ...
 «vars[[-1]]»[t] = «mons[[-1]]»;
 «mon»
]]]

where «» denotes injecting from the given mon, mons, and vars.

So the input

mon = Unique[NDSolve`Monitor];
mons = Table[Unique[mon], 3];
vars = t, x, y;

would result in the desired output:

Function[NDSolve`Monitor$3080, 
 Function[NDSolve`Monitor$3080$3081, NDSolve`Monitor$3080$3082, NDSolve`Monitor$3080$3083,
 Internal`InheritedBlock[t, x, y,
 t =.;
 x =.;
 y =.;
 t = NDSolve`Monitor$3080$3081;
 x[t] = NDSolve`Monitor$3080$3082; 
 y[t] = NDSolve`Monitor$3080$3083;
 NDSolve`Monitor$3080
]]]

One possible solution involves building up a String, then using ToExpression:

str = "Function[" <> ToString[mon] <> ",
 Function[" <> ToString[mons] <> ",
 Internal`InheritedBlock[" <> ToString[vars] <> ",
";
Do[
 str = str <> ToString[var] <> "=.;n"
, var, vars];
str = str <> "t=" <> ToString[mons[[1]]] <> ";n";
Do[
 str = str <> ToString[vars[[i]]] <> "[t]=" <> ToString[mons[[i]]] <> ";n"
, i, 2, Length[vars]];
str = str <> ToString[mon] <> "]]]n";

but this is kind of inelegant and can be slow for large lists.

Are there any nicer and/or faster alternatives?

Possibly this:

mon = Unique[NDSolve`Monitor];
mons = Table[Unique[mon], 3];
vars = t, x, y;

Block[Set, Unset, CompoundExpression,
 With[code = CompoundExpression @@ Join[
 Unset /@ #3,
 MapThread[
 Set,
 Prepend[Through[Rest[#3][First[#3]]], First[#3]], #2],
 #1
 ],
 Function @@ #1, 
 Function @@ Hold[#2, Internal`InheritedBlock[#3, code]]
 ]] &[mon, mons, vars]

(*
 Function[NDSolve`Monitor$234166, 
 Function[NDSolve`Monitor$234166$234167, 
 NDSolve`Monitor$234166$234168, NDSolve`Monitor$234166$234169,
 Internal`InheritedBlock[t, x, y,
 t =.;
 x =.;
 y =.;
 t = NDSolve`Monitor$234166$234167; 
 x[t] = NDSolve`Monitor$234166$234168; 
 y[t] = NDSolve`Monitor$234166$234169;
 NDSolve`Monitor$234166
 ]]]
*)

Update:
This avoids blocking system functions. It shouldn't be a problem above because of the limited scope of the Block[] and the fact that the arguments mon, mons, vars are all evaluated before injected; but maybe it seems safer the following way.

With[code = Join[
 Hold[#1, #2, #3], (* first args of Function and InheritedBlock *)
 Unset /@ Hold @@ #3, (* beginning of body *)
 Set @@@ Hold @@ Transpose@
 Prepend[Through[Rest[#3][First[#3]]], First[#3]], #2,
 Hold[#1]
 ],
 Replace[code, Hold[m1_, m2_, v_, body__] :>
 Function[m1, Function[m2,
 Internal`InheritedBlock[v, CompoundExpression[body]]]]]
 ] &[mon, mons, vars] 

(* same output as above *)

ClearAll[makeArgs, makeFunc]
makeArgs[m_, ms_, v_] := m, ms, Inactive[Internal`InheritedBlock][v, 
 Inactive[CompoundExpression] @@ Flatten[
 Inactive[Unset] /@ v, Inactive[Set][ v[[1]], ms[[1]]], 
 Inactivate[Thread[Through[Rest[v] @ First[v]] = Rest[ms]], Set], m]];

makeFunc = Function[#, Evaluate @ Activate @ Function[#2, #3]] & @@ makeArgs[##] &;

makeFunc[mon, mons, vars]

Function[NDSolve`Monitor$30945,
Function[NDSolve`Monitor$30945$30952, NDSolve`Monitor$30945$30953,
NDSolve`Monitor$30945$30954,
Internal`InheritedBlock[t, x, y,
t =.; x =.; y =.;
t = NDSolve`Monitor$30945$30952;
x[t] = NDSolve`Monitor$30945$30953;
y[t] = NDSolve`Monitor$30945$30954;
NDSolve`Monitor$30945]]]

Rather than try to figure out what your detailed intentions are, let me just give a simple example. This kind of thing is easy with Function because it holds its arguments until it is applied. You may thus reach into a Function and perform arbitrary replacements. There is no need to clumsily edit text. Here, I define powerN as a prototype, and do replacements:

powerN = Function[x, x^n];
power2 = powerN /. n -> 2
(* Function[x, x^2] *)

Another way is to define a constructor:

power[n_] := Function[x, x^n]
power[2]
(* Function[x$, x$^2] *)

Is there any reason why this won't work?

doopDoopDoop~SetAttributes~HoldAll;
doopDoopDoop[
 mon_Symbol, mons : __Symbol, vars : __Symbol, t_Symbol,
 body1_,
 body2_
 ] :=
 Function[mon,
 Function[mons,
 Internal`InheritedBlock[vars,
 vars[[1]] =.;
 vars[[2]] =.;
 body1;
 vars[[-1]] =.;
 vars[[1]] vars = mons[[1]] mons;
 vars[[2]][t] = mons[[2]];
 body2;
 vars[[-1]][t] = mons[[-1]];
 mon
 ]
 ]
 ]

Then:

doopDoopDoop[
 a, b, c, d, e, t,
 1,
 2
 ]

Function[a, 
 Function[b, c, 
 Internal`InheritedBlock[d, e, (d, e[[1]]) =.; (d, e[[2]]) =.; 
 1; (d, e[[-1]]) =.; d, e[[1]] d, e = b, c[[1]] b, c; d, e[[2]][
 t] = b, c[[2]]; 2; d, e[[-1]][t] = b, c[[-1]]; a]]]

The annoying thing will be the parameter injection if you have mons stored as a list. In this case I'm going to assume you have each variable wrapped in Hold, because that makes it a bit more subtle. The way we'll prep the parameter list is then:

depVar = Hold@a;
mons = Thread@Hold@b, c;
vars = Thread@Hold@d, e;
timeVar = Hold@t;

paramList =
 Thread[depVar, Thread[mons, Hold], Thread[vars, Hold], timeVar, Hold]

Hold[a, b, c, d, e, t]

Then we inject it like:

Replace[
 paramList,
 Hold[pars_] :>
 doopDoopDoop[
 pars,
 1,
 2
 ]
 ]

Function[a, 
 Function[b, c, 
 Internal`InheritedBlock[d, e, (d, e[[1]]) =.; (d, e[[2]]) =.; 
 1; (d, e[[-1]]) =.; d, e[[1]] d, e = b, c[[1]] b, c; d, e[[2]][
 t] = b, c[[2]]; 2; d, e[[-1]][t] = b, c[[-1]]; a]]]

In general, the final thing you'll want to do with an injection is wrap it in a Replace to inject the contents of the Hold or provide a function with DownValues that does the injection, e.g.:

doopDoopDoopHold~SetAttributes~HoldRest;
doopDoopDoopHold[
 Hold[pars : mon_Symbol, mons : __Symbol, vars : __Symbol, t_Symbol],
 body1_,
 body2_
 ] :=
 doopDoopDoop[pars, body1, body2];

doopDoopDoopHold[paramList, 1, 2]

Function[a, 
 Function[b, c, 
 Internal`InheritedBlock[d, e, (d, e[[1]]) =.; (d, e[[2]]) =.; 
 1; (d, e[[-1]]) =.; d, e[[1]] d, e = b, c[[1]] b, c; d, e[[2]][
 t] = b, c[[2]]; 2; d, e[[-1]][t] = b, c[[-1]]; a]]]