RE: A MapLevelParts Routine

*To*: mathgroup at smc.vnet.net*Subject*: [mg44640] RE: [mg44604] A MapLevelParts Routine*From*: "Wolf, Hartmut" <Hartmut.Wolf at t-systems.com>*Date*: Wed, 19 Nov 2003 04:59:07 -0500 (EST)*Sender*: owner-wri-mathgroup at wolfram.com

>-----Original Message----- >From: David Park [mailto:djmp at earthlink.net] To: mathgroup at smc.vnet.net >Sent: Monday, November 17, 2003 9:39 AM >To: mathgroup at smc.vnet.net >Subject: [mg44640] [mg44604] A MapLevelParts Routine > > >I've often wanted a routine that would map a function onto a >subset of level parts in an expression without affecting the >remaining level parts. I don't know of an easy way to do this >with regular Mathematica functions. As far as I can tell >neither MapAt nor ReplacePart will do this. At best they will >map a function onto the individual pieces of a level set of >parts. So I came up with the following routine. > >MapLevelParts::usage = > "MapLevelParts[function, {topposition, >levelpositions}][expr] will map \ >the function onto the specified level positions in an expression. \ >Levelpositions is a list of the selected parts. The function >is applied to \ >them as a group and they are replaced with a single new >expression. Other \ >parts not specified in levelpositions are left >unchanged.\nExample:\na + b + \ >c + d + e // MapLevelParts[f, {{2,4,5}}] -> a + c + f[b + d + e]"; > >MapLevelParts[func_, > part : {toppart___Integer?Positive, > subp : {_Integer?Positive, > eprest__Integer?Positive}}][expr_] := > Module[{work, subparts, npos, null, i, nnull = Length[{eprest}]}, > work = func@Part[expr, Sequence @@ part]; > subparts = Thread[{toppart, subp}]; > newparts = {work, Table[null[i], {i, 1, nnull}]} // Flatten; > npos = Partition[Range[nnull + 1], 1]; > ReplacePart[expr, newparts, subparts, npos] /. null[_] -> > Sequence[] > ] > >The indexed nulls were necessary to keep them from combining >in expressions. Try Sequence[]^2 or 2 Sequence[]. > >Examples: > >a + b + c + d + e // MapLevelParts[f, {{2, 4, 5}}] >a + c + f[b + d + e] > >a b c d e // MapLevelParts[f, {{1, 4, 5}}] >b c f[a d e] > >g[a + b + c + d + e] // MapLevelParts[f, {1, {2, 4}}] >g[a + c + e + f[b + d]] > >{a, b, c, d, e} // MapLevelParts[f @@ # &, {{2, 5}}] >{a, f[b, e], c, d} > >Of course, these are simple examples that could be done with >replacement rules. But suppose in the following expression q >was actually a long expression and furthermore that it was >formatted so you couldn't copy it and didn't want to type it >in. Then you might not want to use a replacement rule or >Collect. But you could still factor the subset of terms. > >a + b/(1 + a q + b + c q + d + f q); >% // MapLevelParts[Factor, {2, 2, 1, {4, 5, 6}}] >a + b/(1 + b + d + a*q + c*q + f*q) >a + b/(1 + b + d + (a + c + f)*q) > >Maybe someone can show me a simple way to do this with regular >Mathematica. Otherwise I think it would be nice if Mathematica >had a routine like this. > >David Park >djmp at earthlink.net >http://home.earthlink.net/~djmp/ > > > > > > Dear David, it might be interesting to know where this would apply. It certainly will not be easy to use, perhaps it should be reduced somehow (or only applied to Flat and Orderless subexprs). I can't give a simple solution, however I reimplemented your function (not quite your function, but something coming close). Both functions yield the same at subexpressions with header Flat and Orderless (in effect I followed you hesitantly to Flatten the subexpression, but denied to perturb order when head ist not Orderless). After all, you may play with the code. Effectively it's a one-liner. The basic idea is simple: cut out the expression at the toppart location, Hold the head for a while, MapAt the function at subpart, Release just for a second to rearrage for Orderless, group resulting adjaced arguments with the replacement function, switch heads there with the subexpression header, remove those for the other arguments (Flatten), and let run. Symbol tempf is introduced to simply allow Split and Thread (switching heads), and is finally replaced by the target function expression. It's not quite such simple as perhaps desired (not too complicated, though), but MapAt and ReplacePart do the work. MapLevelParts0[func_, part : {toppart___Integer?NonNegative, subp : {__Integer?Positive}}][expr_] := ReplacePart[expr, Module[{tempf}, ReleaseHold@ Flatten[Thread[#, tempf] & /@ Split[MapAt[Hold, ReleaseHold[ MapAt[tempf, MapAt[Hold, Part[expr, toppart], {0}], Thread[{subp}]]], {0}], Head[#1] === Head[#2] === tempf &]] /. tempf -> func], {{toppart}}] Comparisons: a + b + c + d + e + f // MapLevelParts0[f, {{2, 4, 5}}] ==> a + c + f + f[b + d + e] a + b + c + d + e + f // MapLevelParts[f, {{2, 4, 5}}] ==> a + c + f + f[b + d + e] a b c d e f // MapLevelParts0[f, {{1, 4, 5}}] ==> b c f f[a d e] a b c d e f // MapLevelParts[f, {{1, 4, 5}}] ==> b c f f[a d e] g[a + b + c + d + e + f] // MapLevelParts0[f, {1, {1, 2, 4}}] ==> g[c + e + f + f[a + b + d]] g[a + b + c + d + e + f] // MapLevelParts[f, {1, {1, 2, 4}}] ==> g[c + e + f + f[a + b + d]] {a, b, c, d, e, f} // MapLevelParts0[f @@ # &, {{2, 3, 5}}] ==> {a, f[b, c], d, f[e], f} {a, b, c, d, e, f} // MapLevelParts[f @@ # &, {{2, 3, 5}}] ==> {a, f[b, c, e], d, f} (here we disagree, but that's a matter of specification) {f, e, d, c, b, a} // MapLevelParts[f, {{2, 5}}] ==> {f, f[{e, b}], d, c, a} {f, e, d, c, b, a} // MapLevelParts0[f, {{2, 5}}] ==> {f, f[{e}], d, c, f[{b}], a} a + b/(1 + a q + b + c q + d + f q) // MapLevelParts0[Factor, {2, 2, 1, {4, 5, 6}}] ==> (a + b/(1 + b + d + (a + c + f) q)) a + b/(1 + a q + b + c q + d + f q) // MapLevelParts[Factor, {2, 2, 1, {4, 5, 6}}] ==> (a + b/(1 + b + d + (a + c + f) q)) -- Hartmut