11
$\begingroup$

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?

$\endgroup$
  • $\begingroup$ Sorry, it is not at all clear to me what you try to achieve. Would you please give a concrete example? $\endgroup$ – Henrik Schumacher Jul 28 at 15:35
  • $\begingroup$ @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. $\endgroup$ – Chris K Jul 28 at 15:55
  • 1
    $\begingroup$ 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. $\endgroup$ – Henrik Schumacher Jul 28 at 16:02
  • 2
    $\begingroup$ 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. $\endgroup$ – b3m2a1 Jul 28 at 16:45
  • 1
    $\begingroup$ 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. $\endgroup$ – Chris K Jul 28 at 16:48
9
$\begingroup$

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  *)
$\endgroup$
  • $\begingroup$ Also Block[{Set, Unset, CompoundExpression}, Function[#1, Function[#2, Internal`InheritedBlock[#3, #4]]] &[ mon, mons, vars, CompoundExpression @@ Join[ Unset /@ vars, MapThread[Set, {Prepend[Through[Rest[vars]@First[vars]], First[vars]], mons}], {mon}] ] ] $\endgroup$ – Michael E2 Jul 28 at 21:28
  • $\begingroup$ 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. $\endgroup$ – Chris K Jul 29 at 8:37
  • $\begingroup$ @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. $\endgroup$ – Michael E2 Jul 29 at 12:50
  • $\begingroup$ Both this answer and @kglr's deserve acceptance for their elegance -- thanks! $\endgroup$ – Chris K Jul 29 at 20:08
8
$\begingroup$
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]]]

$\endgroup$
  • $\begingroup$ +1 In my opinion, Inactive/Activate are purpose-built for this task. $\endgroup$ – David Zhang Jul 29 at 8:32
  • $\begingroup$ Nice, lots of techniques to learn from here. $\endgroup$ – Chris K Jul 29 at 8:38
3
$\begingroup$

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] *)
$\endgroup$
  • $\begingroup$ I think injecting the variable bits into the Internal`InheritedBlock is more my problem, but thanks. $\endgroup$ – Chris K Jul 28 at 16:50
3
$\begingroup$

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]]]
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.