Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2003
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2003

[Date Index] [Thread Index] [Author Index]

Search the Archive

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


  • Prev by Date: Re: Improper integral
  • Next by Date: Re: Re: Just trying to import an image
  • Previous by thread: A MapLevelParts Routine
  • Next by thread: NoteBookFind[ ] with multiple criteria?