I'm looking to learn how to search through a polynomial and replace all points P[x,y] that are contained within a list of finite points {P[a,b], P[c,d],..., P[x,y]} with a term such as (q+ab) and replace all points, P[a,b] that are not contained in the list with a different term, (w+cd), for example.
Here's some code that I've been trying...
K[poly_, pairs_] :=
poly //. IF[MemberQ[pairs, P[a_, b_]], P[a_, b_] :> (q+xy),
P[a_, b_] :> (w+cd)]
where //. is to replace through all pairs, IF conditional to replace pairs with the appropriate term, and MemberQ to check whether a pair P[a,b] is within a given list, 'pairs'
To verify any suggestions, the input
K[ -q P[1,3] P[4,6] , {P[1,3], P[2,7]}]
should output
-ab cd q - cd q^2 - ab q w - q^2 w
Thank you in advance for any help!
try something like this
K[poly_, pairs_] := poly /. ( #-> q+ab & /# pairs ) /. P[__,__]-> w + cd
Or, closer to your approach:
K[poly_, pairs_] := poly /. P[a_,b_] :> If[MemberQ[pairs,P[a,b]], q+ab, w +cd ]
note you need to expand to get the desired form..
Expand[K[-q P[1, 3] P[4, 6], {P[1, 3], P[2, 7]}]]
(* -ab cd q - cd q^2 - ab q w - q^2 w *)
Related
I am trying to simplify some formulas like
F[a,b,c]*F[a,c,b]+F[c,a,b] /. {a->1,b->2,c->3}
where
F[a,b,c] := LegendreP[a,x]+LegendreP[b,x]*LegendreP[c,x]
And Mathematica can give a polynomial of x.
But I would like to keep all LegendreP instead of expanding it. By setting the HoldAll attribute of LegendreP, I can stop this, but the arguments are also kept, which is not intended.
Could anyone give some advice to solve this problem? Thanks.
Edited: I would like to have a result like this for the above formula (where L=LegendreP)
L[3,x]+L[1,x]*L[2,x]+L[1,x]*L[1,x]+L[3,x]*L[2,x]*L[1,x]+L[1,x]*L[2,x]*L[3,x]+L[3,x]*L[2,x]*L[2,x]*L[3,x]
But I would like to keep all LegendreP instead of expanded it.
Can't you use HoldForm?
F[a_, b_, c_] := HoldForm[LegendreP[a, x] + LegendreP[b, x]*LegendreP[c, x]];
F[a, b, c]*F[a, c, b] + F[c, a, b] /. {a -> 1, b -> 2, c -> 3}
ReleaseHold[%]
Simplify[%]
without knowing fully what you are trying to accomplish, one approach is to simply use some other symbol, eg:
F[a,b,c] := legendreP[a,x]+legendreP[b,x]*legendreP[c,x]
(note the lower case "l" )
When you get to the stage where you want evaluation apply a pattern substitution:
expr /. legendreP->LegendreP
(I made some changes...)
very often I want to simplify the function's argument, or apply a pattern to it, eg. I want to change:
Exp[a(b+c)]
into
Exp[a b + a c]
simple pattern doesn't help:
Sin[a(b+c)] /. Sin[aaa_] -> Sin[Expand[aaa]]
gives again
Sin[a(b+c)]
However, with functions other than Simplify / Expand it seems to do what I expect:
Sin[a (b + c)] /. Sin[aaa_] -> Sin[f[aaa]]
gives
Sin[ f[a(b+c)] ]
My usual solution was to use 2 patterns and Hold:
(Exp[a(b+c)] /. Exp[aaa_] -> Exp[Hold[ Expand[aaa] ]] ) /. Hold[xxx_] -> xxx
which results in
E^(a*b + a*c)
The disadvantage of this method is that code gets more complicated than it's neccesary.
MY REAL LIFE EXAMPLE is:
ppp2 =
( ppp1
/. { ExpIntegralEi[aaa_] ->
ExpIntegralEi[Hold[aaa /. { u2 -> 0, w2 -> 0, u3 -> x, w3 -> x}]],
Log[aaa_] ->
Log[Hold[aaa /. {u2 -> 0, w2 -> 0, u3 -> x, w3 -> x}]]
}
) /. Hold[xxx_] -> xxx;
where ppp1 is a long sum of terms containing u2, w2, u3, w3 and so on. I want to change the values of u, w2... ONLY in ExpIntegral and Log.
My other solution is a function:
ExpandArgument[expr_, what_] := Module[{list},
list = Extract[expr, Position[ expr, what[_] ]];
list = Map[Rule[#, what[Expand[ #[[1]] ]]] &, list];
Return[expr /. list]
]
The function I wrote can be easily generalised to make it possible to use not only Expand but also Simplify and so on:
ApplyToArgument[expr_, ToWhat_, WhatFunction_] := Module[{list},
list = Extract[expr, Position[ expr, ToWhat[_] ]];
list = Map[Rule[#, ToWhat[WhatFunction[ #[[1]] ]]] &, list];
Return[expr /. list]
]
For example:
ApplyToArgument[Sin[a (b + c)], Sin, Expand]
gives
Sin[a b + a c]
and
ApplyToArgument[Sin[a b + a c ], Sin, Simplify]
gives
Sin[a (b + c)]
This solution is easy to read but needs some refinement before being applied to many-argument functions (and I need these functions).
I guess I'm missing something fundamental about patterns in mathematica... How should I apply patterns to arguments of functions? (Or simplify, expand, etc. them)
Thanks a lot!
For the first part of the question, you could consider using RuleDelayed:
Sin[a (b + c)] /. Sin[aaa_] :> Sin[Expand[aaa]]
gives
Sin[a b + a c]
Use :> instead of ->. With ->, the right hand side is immediately evaluated, and only then applied. Expansion of aaa of course gives just aaa, and therefore evaluation of Sin[Expand[aaa]] gives Sin[aaa], thus the rule asks for replacing each application of Sin by itself. Then you also should not need those Hold constructs.
In a related note: Instead of applying the rule Hold[xxx_]->xxx, you can just pass your expression to ReleaseHold, for example ReleaseHold[Hold[1+1] /. 1->2] gives 4.
Also consider using ExpandAll:
ExpandAll[Exp[a (b + c)]] // FullForm
will give:
Power[E, Plus[Times[a, b], Times[a, c]]]
(This will turn Exp[...] into E^... though)
This is not a direct answer (others provided that), but for these kinds of manipulations the Algebraic Manipulation Palette (Palettes -> Other) is often quite convenient:
The disadvantage is that unlike typed-in commands, this operation won't be "recorded" and saved in the notebook.
Right now I have code where some function func executes the way I want it to when I give it specific arguments in its definition (so I make it func[x1_,x2_]:=... and then later I make it func[x1_,x2_,x3_]:=... without changing anything else and it works the way I would like it to). Is there a way to automatically substitute whatever arguments I specify for this function?
UPDATE:
I haven't isolated the problem code yet, but this code here does not do what I want:
(* Clear all stuff each time before running, just to be safe! *)
\
Clear["Global`*"]
data = {{238.2, 0.049}, {246.8, 0.055}, {255.8, 0.059}, {267.5,
0.063}, {280.5, 0.063}, {294.3, 0.066}, {307.7, 0.069}, {318.2,
0.069}};
errors = {{x1, 0.004}, {x2, 0.005}};
getX[x1_, x2_] := 1/x2^2
getY[x__] =
Evaluate[Simplify[
Sqrt[Sum[(D[getX[x], errors[[i]][[1]]] errors[[i]][[2]])^2, {i,
Length[errors]}]]]]
map[action_, list_] := action ### list
y = map[getY, data];
y
getY[2, 3]
This code here does: (gives {67.9989, 48.0841, 38.9524, 31.994, 31.994, 27.8265, 24.3525, 24.3525} for y)
(* Clear all stuff each time before running, just to be safe! *) \ Clear["Global`*"]
data = {{238.2, 0.049}, {246.8,
0.055}, {255.8, 0.059}, {267.5,
0.063}, {280.5, 0.063}, {294.3, 0.066}, {307.7, 0.069}, {318.2,
0.069}}; errors = {{x2, 0.004}, {x1, 0.005}};
getX[x1_, x2_] := 1/x2^2
getY[x1_, x2_] := Evaluate[Simplify[ Sqrt[Sum[(D[getX[x1, x2], errors[[i]][[1]]]
errors[[i]][[2]])^2, {i, Length[errors]}]]]]
map[action_, list_] := action ### list
y = map[getY, data]; y
getY[2, 3]
UPDATE 2:
My math:
I intend to take the square root of the sum of the squares of all the partial derivatives of the getX function. Thus the body of the getY function. Then I want to evaluate that expression for different values of x1 and x2. Thus I have the arguments for getY.
Use __, e.g.
In[4]:= f[x__] = {x}
Out[4]= {x}
In[5]:= f[1,2,3,4,5,6]
Out[5]= {1, 2, 3, 4, 5, 6}
In[6]:= f[a,b,c]
Out[6]= {a, b, c}
Well the issue is that in the first version, with explicit number of arguments, you have used Evaluate to evaluate the right hand side. You can not do this when the number of arguments is variable, because evaluator does not know which signature of getX to use.
So the solution is to replace getY with the following:
getY[x__] := (Simplify[
Sqrt[(D[getX ##
errors[[1 ;; Length[{x}], 1]], {errors[[All, 1]]}].
errors[[All, 2]])^2]]) /.
Thread[errors[[1 ;; Length[{x}], 1]] -> {x}]
This would first use variables from errors list exactly as many as you have supplied in the arguments of getY, compute the derivative symbolically, and then perform the Dot, instead of Sum which is faster. Then the outputs will be the same.
Notice that in your two versions of the code, errors have different values.
Alternatively, you can use Derivative like so:
getY2[x__] :=
Abs[(Derivative[##][getX][x] & ###
IdentityMatrix[Length[{x}]].errors[[All, 2]])]
Using it gives the same result.
I need to find the minimum of a function f(t) = int g(t,x) dx over [0,1]. What I did in mathematica is as follows:
f[t_] = NIntegrate[g[t,x],{x,-1,1}]
FindMinimum[f[t],{t,t0}]
However mathematica halts at the first try, because NIntegrate does not work with the symbolic t. It needs a specific value to evaluate. Although Plot[f[t],{t,0,1}] works perferctly, FindMinimum stops at the initial point.
I cannot replace NIntegrate by Integrate, because the function g is a bit complicated and if you type Integrate, mathematica just keep running...
Any way to get around it? Thanks!
Try this:
In[58]:= g[t_, x_] := t^3 - t + x^2
In[59]:= f[t_?NumericQ] := NIntegrate[g[t, x], {x, -1, 1}]
In[60]:= FindMinimum[f[t], {t, 1}]
Out[60]= {-0.103134, {t -> 0.57735}}
In[61]:= Plot[f[t], {t, 0, 1}]
Two relevant changes I made to your code:
Define f with := instead of with =. This effectively gives a definition for f "later", when the user of f has supplied the values of the arguments. See SetDelayed.
Define f with t_?NumericQ instead of t_. This says, t can be anything numeric (Pi, 7, 0, etc). But not anything non-numeric (t, x, "foo", etc).
An ounce of analysis...
You can get an exact answer and completely avoid the heavy lifting of the numerical integration, as long as Mathematica can do symbolic integration of g[t,x] w.r.t x and then symbolic differentiation w.r.t. t. A less trivial example with a more complicated g[t,x] including polynomial products in x and t:
g[t_, x_] := t^2 + (7*t*x - (x^3)/13)^2;
xMax = 1; xMin = -1; f[t_?NumericQ] := NIntegrate[g[t, x], {x, xMin, xMax}];
tMin = 0; tMax = 1;Plot[f[t], {t, tMin, tMax}];
tNumericAtMin = t /. FindMinimum[f[t], {t, tMax}][[2]];
dig[t_, x_] := D[Integrate[g[t, x], x], t];
Print["Differentiated integral is ", dig[t, x]];
digAtXMax = dig[t, x] /. x -> xMax; digAtXMin = dig[t, x] /. x -> xMin;
tSymbolicAtMin = Resolve[digAtXMax - digAtXMin == 0 && tMin ≤ t ≤ tMax, {t}];
Print["Exact: ", tSymbolicAtMin[[2]]];
Print["Numeric: ", tNumericAtMin];
Print["Difference: ", tSymbolicAtMin [[2]] - tNumericAtMin // N];
with the result:
⁃Graphics⁃
Differentiated integral is 2 t x + 98 t x^3 / 3 - 14 x^5 / 65
Exact: 21/3380
Numeric: 0.00621302
Difference: -3.01143 x 10^-9
Minimum of the function can be only at zero-points of it's derivate, so why to integrate in the first place?
You can use FindRoot or Solve to find roots of g
Then you can verify that points are really local minimums by checking derivates of g (it should be positive at that point).
Then you can NIntegrate to find minimum value of f - only one numerical integration!
I'm trying to figure out how to use Mathematica to solve systems of equations where some of the variables and coefficients are vectors. A simple example would be something like
where I know A, V, and the magnitude of P, and I have to solve for t and the direction of P. (Basically, given two rays A and B, where I know everything about A but only the origin and magnitude of B, figure out what the direction of B must be such that it intersects A.)
Now, I know how to solve this sort of thing by hand, but that's slow and error-prone, so I was hoping I could use Mathematica to speed things along and error-check me. However, I can't see how to get Mathematica to symbolically solve equations involving vectors like this.
I've looked in the VectorAnalysis package, without finding anything there that seems relevant; meanwhile the Linear Algebra package only seems to have a solver for linear systems (which this isn't, since I don't know t or P, just |P|).
I tried doing the simpleminded thing: expanding the vectors into their components (pretend they're 3D) and solving them as if I were trying to equate two parametric functions,
Solve[
{ Function[t, {Bx + Vx*t, By + Vy*t, Bz + Vz*t}][t] ==
Function[t, {Px*t, Py*t, Pz*t}][t],
Px^2 + Py^2 + Pz^2 == Q^2 } ,
{ t, Px, Py, Pz }
]
but the "solution" that spits out is a huge mess of coefficients and congestion. It also forces me to expand out each of the dimensions I feed it.
What I want is a nice symbolic solution in terms of dot products, cross products, and norms:
But I can't see how to tell Solve that some of the coefficients are vectors instead of scalars.
Is this possible? Can Mathematica give me symbolic solutions on vectors? Or should I just stick with No.2 Pencil technology?
(Just to be clear, I'm not interested in the solution to the particular equation at top -- I'm asking if I can use Mathematica to solve computational geometry problems like that generally without my having to express everything as an explicit matrix of {Ax, Ay, Az}, etc.)
With Mathematica 7.0.1.0
Clear[A, V, P];
A = {1, 2, 3};
V = {4, 5, 6};
P = {P1, P2, P3};
Solve[A + V t == P, P]
outputs:
{{P1 -> 1 + 4 t, P2 -> 2 + 5 t, P3 -> 3 (1 + 2 t)}}
Typing out P = {P1, P2, P3} can be annoying if the array or matrix is large.
Clear[A, V, PP, P];
A = {1, 2, 3};
V = {4, 5, 6};
PP = Array[P, 3];
Solve[A + V t == PP, PP]
outputs:
{{P[1] -> 1 + 4 t, P[2] -> 2 + 5 t, P[3] -> 3 (1 + 2 t)}}
Matrix vector inner product:
Clear[A, xx, bb];
A = {{1, 5}, {6, 7}};
xx = Array[x, 2];
bb = Array[b, 2];
Solve[A.xx == bb, xx]
outputs:
{{x[1] -> 1/23 (-7 b[1] + 5 b[2]), x[2] -> 1/23 (6 b[1] - b[2])}}
Matrix multiplication:
Clear[A, BB, d];
A = {{1, 5}, {6, 7}};
BB = Array[B, {2, 2}];
d = {{6, 7}, {8, 9}};
Solve[A.BB == d]
outputs:
{{B[1, 1] -> -(2/23), B[2, 1] -> 28/23, B[1, 2] -> -(4/23), B[2, 2] -> 33/23}}
The dot product has an infix notation built in just use a period for the dot.
I do not think the cross product does however. This is how you use the Notation package to make one. "X" will become our infix form of Cross. I suggest coping the example from the Notation, Symbolize and InfixNotation tutorial. Also use the Notation Palette which helps abstract away some of the Box syntax.
Clear[X]
Needs["Notation`"]
Notation[x_ X y_\[DoubleLongLeftRightArrow]Cross[x_, y_]]
Notation[NotationTemplateTag[
RowBox[{x_, , X, , y_, }]] \[DoubleLongLeftRightArrow]
NotationTemplateTag[RowBox[{ ,
RowBox[{Cross, [,
RowBox[{x_, ,, y_}], ]}]}]]]
{a, b, c} X {x, y, z}
outputs:
{-c y + b z, c x - a z, -b x + a y}
The above looks horrible but when using the Notation Palette it looks like:
Clear[X]
Needs["Notation`"]
Notation[x_ X y_\[DoubleLongLeftRightArrow]Cross[x_, y_]]
{a, b, c} X {x, y, z}
I have run into some quirks using the notation package in the past versions of mathematica so be careful.
I don't have a general solution for you by any means (MathForum may be the better way to go), but there are some tips that I can offer you. The first is to do the expansion of your vectors into components in a more systematic way. For instance, I would solve the equation you wrote as follows.
rawSol = With[{coords = {x, y, z}},
Solve[
Flatten[
{A[#] + V[#] t == P[#] t & /# coords,
Total[P[#]^2 & /# coords] == P^2}],
Flatten[{t, P /# coords}]]];
Then you can work with the rawSol variable more easily. Next, because you are referring the vector components in a uniform way (always matching the Mathematica pattern v_[x|y|z]), you can define rules that will aid in simplifying them. I played around a bit before coming up with the following rules:
vectorRules =
{forms___ + vec_[x]^2 + vec_[y]^2 + vec_[z]^2 :> forms + vec^2,
forms___ + c_. v1_[x]*v2_[x] + c_. v1_[y]*v2_[y] + c_. v1_[z]*v2_[z] :>
forms + c v1\[CenterDot]v2};
These rules will simplify the relationships for vector norms and dot products (cross-products are left as a likely painful exercise for the reader). EDIT: rcollyer pointed out that you can make c optional in the rule for dot products, so you only need two rules for norms and dot products.
With these rules, I was immediately able to simplify the solution for t into a form very close to yours:
In[3] := t /. rawSol //. vectorRules // Simplify // InputForm
Out[3] = {(A \[CenterDot] V - Sqrt[A^2*(P^2 - V^2) +
(A \[CenterDot] V)^2])/(P^2 - V^2),
(A \[CenterDot] V + Sqrt[A^2*(P^2 - V^2) +
(A \[CenterDot] V)^2])/(P^2 - V^2)}
Like I said, it's not a complete way of solving these kinds of problems by any means, but if you're careful about casting the problem into terms that are easy to work with from a pattern-matching and rule-replacement standpoint, you can go pretty far.
I've taken a somewhat different approach to this issue. I've made some definitions that return this output:
Patterns that are known to be vector quantities may be specified using vec[_], patterns that have an OverVector[] or OverHat[] wrapper (symbols with a vector or hat over them) are assumed to be vectors by default.
The definitions are experimental and should be treated as such, but they seem to work well. I expect to add to this over time.
Here are the definitions. The need to be pasted into a Mathematica Notebook cell and converted to StandardForm to see them properly.
Unprotect[vExpand,vExpand$,Cross,Plus,Times,CenterDot];
(* vec[pat] determines if pat is a vector quantity.
vec[pat] can be used to define patterns that should be treated as vectors.
Default: Patterns are assumed to be scalar unless otherwise defined *)
vec[_]:=False;
(* Symbols with a vector hat, or vector operations on vectors are assumed to be vectors *)
vec[OverVector[_]]:=True;
vec[OverHat[_]]:=True;
vec[u_?vec+v_?vec]:=True;
vec[u_?vec-v_?vec]:=True;
vec[u_?vec\[Cross]v_?vec]:=True;
vec[u_?VectorQ]:=True;
(* Placeholder for matrix types *)
mat[a_]:=False;
(* Anything not defined as a vector or matrix is a scalar *)
scal[x_]:=!(vec[x]\[Or]mat[x]);
scal[x_?scal+y_?scal]:=True;scal[x_?scal y_?scal]:=True;
(* Scalars times vectors are vectors *)
vec[a_?scal u_?vec]:=True;
mat[a_?scal m_?mat]:=True;
vExpand$[u_?vec\[Cross](v_?vec+w_?vec)]:=vExpand$[u\[Cross]v]+vExpand$[u\[Cross]w];
vExpand$[(u_?vec+v_?vec)\[Cross]w_?vec]:=vExpand$[u\[Cross]w]+vExpand$[v\[Cross]w];
vExpand$[u_?vec\[CenterDot](v_?vec+w_?vec)]:=vExpand$[u\[CenterDot]v]+vExpand$[u\[CenterDot]w];
vExpand$[(u_?vec+v_?vec)\[CenterDot]w_?vec]:=vExpand$[u\[CenterDot]w]+vExpand$[v\[CenterDot]w];
vExpand$[s_?scal (u_?vec\[Cross]v_?vec)]:=Expand[s] vExpand$[u\[Cross]v];
vExpand$[s_?scal (u_?vec\[CenterDot]v_?vec)]:=Expand[s] vExpand$[u\[CenterDot]v];
vExpand$[Plus[x__]]:=vExpand$/#Plus[x];
vExpand$[s_?scal,Plus[x__]]:=Expand[s](vExpand$/#Plus[x]);
vExpand$[Times[x__]]:=vExpand$/#Times[x];
vExpand[e_]:=e//.e:>Expand[vExpand$[e]]
(* Some simplification rules *)
(u_?vec\[Cross]u_?vec):=\!\(\*OverscriptBox["0", "\[RightVector]"]\);
(u_?vec+\!\(\*OverscriptBox["0", "\[RightVector]"]\)):=u;
0v_?vec:=\!\(\*OverscriptBox["0", "\[RightVector]"]\);
\!\(\*OverscriptBox["0", "\[RightVector]"]\)\[CenterDot]v_?vec:=0;
v_?vec\[CenterDot]\!\(\*OverscriptBox["0", "\[RightVector]"]\):=0;
(a_?scal u_?vec)\[Cross]v_?vec :=a u\[Cross]v;u_?vec\[Cross](a_?scal v_?vec ):=a u\[Cross]v;
(a_?scal u_?vec)\[CenterDot]v_?vec :=a u\[CenterDot]v;
u_?vec\[CenterDot](a_?scal v_?vec) :=a u\[CenterDot]v;
(* Stealing behavior from Dot *)
Attributes[CenterDot]=Attributes[Dot];
Protect[vExpand,vExpand$,Cross,Plus,Times,CenterDot];