How to write an operator that acts on pure function (to give another pure function)

Question

I would like to write an operator oper that acts on a pure function f with an undetermined number of arguments, with the syntax oper[n][f] to give another pure function, where n is an integer. The point of this is to be able compose the operator like this:

oper[n2][oper[n1][f]]

The function f is a polynomial in all its arguments, and oper[f] will also be a polynomial. Here is what oper is supposed to do for the case where $f$ takes three arguments:

$$\text{oper}[1][f](x,y,z) = [f(x,y,z)-f(0,y,z)]/x$$ $$\text{oper}[2][f](x,y,z) = [f(x,y,z)-f(x,0,z)]/y$$ $$\text{oper}[3][f](x,y,z) = [f(x,y,z)-f(x,y,0)]/z$$

It's supposed to take the difference of $f$ with itself but with the $n$th argument set to zero, and then divide the difference by the $n$th argument.

In general $f$ can have any number of arguments. Bonus: How about defining the composition like this: oper[n1,n2,...][f], instead of oper[…[oper[n2][oper[n1][f]]]…]?

Answer 1

This is one possibility:

oper[ns__] := 
 Fold[Function[{f, 
     n}, (f[##] - f @@ ReplacePart[{##},n -> 0])/Slot[n] &], #, {ns}] &

With this, you can do

oper[2,1][f][x,y,z]

(-((-f[0, 0, z] + f[0, y, z])/y) + (-f[x, 0, z] + f[x, y, z])/y)/x

Note that even though ns__ is a pattern (hence not totally "pure"), any operation oper[n1,n2,...][f] returns a pure function if f is pure.

Answer 2

Here is one way to define oper:

oper[n_][f_] := (f[##] - Apply[f, {##}(1-UnitVector[Length@{##}, n])]) / {##}[[n]] &

oper[n1_, ns__][f_] := oper[n1][oper[ns][f]]

The first definition is the main one. It generates the desired pure function for a given input function (which may or may not be pure itself):

oper[2][f]
(* (f[##1] - f @@ ({##1}*(1 - UnitVector[Length[{##1}], 2])))/{##1}[[2]] & *)

The generated pure function has the requested property that it can be applied to any number of arguments:

pf = oper[2][f];

pf[x, y, z]
(* (-f[x, 0, z] + f[x, y, z]) / y *)

pf[a, b, c, d]
(* (-f[a, 0, c, d] + f[a, b, c, d]) / b *)

The second oper definition implements the multiple-argument generalization, so that:

oper[3, 1, 2][f][x,y,z] === (oper[3]@oper[1]@oper[2]@f)[x,y,z]
(* True *)

Answer 3

I propose:

oper[n_][fn_] := 
 Function[Null, (fn[##] - fn @@ ReplacePart[Hold[##], n -> 0])/Slot[n], HoldAll]

oper[2][f][x, y, z]

(-f[x, 0, z] + f[x, y, z])/y

This also works on Functions that hold their arguments, e.g.:

foo = Function[Null, HoldForm[+##], HoldAll];

oper[1][foo][2 + 2, 1/0, Print[7]]

(-(0+1/0+Print[7])+((2+2)+1/0+Print[7]))

Answer 4

There is a closely related function DifferenceDelta, which you could use as follows:

op[n_][f_] := 
 -DifferenceDelta[f[##], {#, 1, -#} &@{##}[[n]]]/{##}[[n]] &

Here is an example:

op[2][g][x, y, z]

(* ==> (-g[x, 0, z] + g[x, y, z])/y *)

The bonus question has already been answered by WReach, and I don't have anything shorter for that.

Edit:

I overlooked that the operation should use the function slots and not the arguments themselves. To extend the application of DifferenceDelta to this scenario, one could do this:

op[n_][f_] := -Module[{fn, i},
    DifferenceDelta[ReplacePart[fn[##], n -> i], {i, 1, -i}]/ i 
     /. {fn -> f, i -> Slot[n]}] &

Then the definition also works with examples like this, where the contents of the slots are arbitrary:

op[2][h][y, y^4, z^2]

(* ==> -((h[y, 0, z^2] - h[y, y^4, z^2])/y^4) *)

Answer 5

Update

On further thought and experimentation, neither the number of arguments nor the special definitions need be specified, since both frontSlotSequence[0] and SlotSequence[n] (when n > (number of arguments of f)) evaluate to Sequence[]. Therefore, this seems to work (although it is the least elegant of all the answers here, I think):

frontSlotSequence[n_] := Unevaluated[##][[;; n]] &

oper[n_] := With[{dec = n - 1, inc = n + 1}, 
  Function[f,
    (f[##] - f[frontSlotSequence[dec][##], 0, SlotSequence[inc]])/Slot[n] &
  ]
 ]

Original post

Here's a general answer, using the adapted SlotSequence from this question.

We first define

frontSlotSequence[n_] := Unevaluated[##][[;; n]] &

which allows us to use all of the arguments to the function up to n along with SlotSequence[n] that allows us to use all the arguments from n.

If the number of arguments is num = 5, then define

Clear[num,oper]
num = 5;
oper[1] := Function[f, (f[##] - f[0, ##2])/Slot[1] &]
oper[n_ /; 1 < n < num] := With[{dec = n - 1, inc = n + 1}, 
  Function[f, (
    f[##] - f[frontSlotSequence[dec][##], 0, SlotSequence[inc]])/
    Slot[n] &]]
oper[num] := With[{num = num}, 
  Function[f, (f[##] - f[frontSlotSequence[num - 1][##], 0])/
    Slot[num] &]]

Then, for instance, the composition of oper[1] with oper[2] yields

oper[1][oper[2][f]][x,y,z]
(* f[0, 0, z]/(x y) - f[0, y, z]/(x y) - f[x, 0, z]/(x y) + f[x, y, z]/(x y) *)