# Defining a Function programmatically

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»,
InternalInheritedBlock[«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[NDSolveMonitor];
mons = Table[Unique[mon], {3}];
vars = {t, x, y};


would result in the desired output:

Function[{NDSolveMonitor$3080}, Function[{NDSolveMonitor$3080$3081, NDSolveMonitor$3080$3082, NDSolveMonitor$3080$3083}, InternalInheritedBlock[{t, x, y}, t =.; x =.; y =.; t = NDSolveMonitor$3080$3081; x[t] = NDSolveMonitor$3080$3082; y[t] = NDSolveMonitor$3080$3083; NDSolveMonitor$3080
]]]


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

str = "Function[{" <> ToString[mon] <> "},
Function[" <> ToString[mons] <> ",
InternalInheritedBlock[" <> 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?

• Sorry, it is not at all clear to me what you try to achieve. Would you please give a concrete example? Jul 28, 2019 at 15:35
• @HenrikSchumacher I want to make the third code block based on the info given in the second code block. The code following “One possible solution...” does what I want, but it’s slow. Jul 28, 2019 at 15:55
• Uuuh... Do you really want to have such a side effect in a pure function? Yes, Mathematica allows you to do that by I would not consider it programming practice. Jul 28, 2019 at 16:02
• It might be worth mentioning that you need this for a specific purpose (working with the StateData internals) such that it must be a pure function like this. Jul 28, 2019 at 16:45
• As @b3m2a1 alludes to, I do have a specific reason to achieve what I asked for. Maybe there's an easier way, but I thought it would be better to ask this question on its own rather than mixed in with that complicated project. Anyhow, I'll link to the Q&A that motivates this question as soon as I write it up. Jul 28, 2019 at 16:48

Possibly this:

mon = Unique[NDSolveMonitor];
mons = Table[Unique[mon], {3}];
vars = {t, x, y};

Block[{Set, Unset, CompoundExpression},
With[{code = CompoundExpression @@ Join[
Unset /@ #3,
Set,
{Prepend[Through[Rest[#3][First[#3]]], First[#3]], #2}],
{#1}
]},
Function @@ {{#1},
Function @@ Hold[#2, InternalInheritedBlock[#3, code]]}
]] &[mon, mons, vars]

(*
Function[{NDSolveMonitor$234166}, Function[{NDSolveMonitor$$234166$$234167, NDSolveMonitor$234166$234168, NDSolveMonitor$$234166$$234169}, InternalInheritedBlock[{t, x, y}, t =.; x =.; y =.; t = NDSolveMonitor$$234166$$234167; x[t] = NDSolveMonitor$234166$234168; y[t] = NDSolveMonitor$$234166$$234169; NDSolveMonitor$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,
InternalInheritedBlock[v, CompoundExpression[body]]]]]
] &[mon, mons, vars]

(*  same output as above  *)

• Also Block[{Set, Unset, CompoundExpression}, Function[#1, Function[#2, InternalInheritedBlock[#3, #4]]] &[ mon, mons, vars, CompoundExpression @@ Join[ Unset /@ vars, MapThread[Set, {Prepend[Through[Rest[vars]@First[vars]], First[vars]], mons}], {mon}] ] ] Jul 28, 2019 at 21:28
• Wow, just the kind of answer I was hoping for. One trivial point - outer Function needs its first arguments as a list, but even I can figure out that tweak. Jul 29, 2019 at 8:37
• @ChrisK Thanks. I thought Function[x,...] and Function[{x},...] were the same, but maybe it matters to NDSolve internals? Anyway, updated so that the code can be simply copied. Jul 29, 2019 at 12:50
• Both this answer and @kglr's deserve acceptance for their elegance -- thanks! Jul 29, 2019 at 20:08
ClearAll[makeArgs, makeFunc]
makeArgs[m_, ms_, v_] := {{m}, ms, Inactive[InternalInheritedBlock][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[{NDSolveMonitor$30945}, Function[{NDSolveMonitor$30945$30952, NDSolveMonitor$30945$30953, NDSolveMonitor$30945$30954}, InternalInheritedBlock[{t, x, y}, t =.; x =.; y =.; t = NDSolveMonitor$30945$30952; x[t] = NDSolveMonitor$30945$30953; y[t] = NDSolveMonitor$30945$30954; NDSolveMonitor$30945]]]

• +1 In my opinion, Inactive/Activate are purpose-built for this task. Jul 29, 2019 at 8:32
• Nice, lots of techniques to learn from here. Jul 29, 2019 at 8:38

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] *)

• I think injecting the variable bits into the InternalInheritedBlock is more my problem, but thanks. Jul 28, 2019 at 16:50

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,
InternalInheritedBlock[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},
InternalInheritedBlock[{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;
timeVar = Hold@t;

paramList =

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},
InternalInheritedBlock[{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},
InternalInheritedBlock[{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]]]