Addition of Functions - wolfram-mathematica

So generally, if you have two functions f,g: X -->Y, and if there is some binary operation + defined on Y, then f + g has a canonical definition as the function x --> f(x) + g(x).
What's the best way to implement this in Mathematica?
f[x_] := x^2
g[x_] := 2*x
h = f + g;
h[1]
yields
(f + g)[1]
as an output
of course,
H = Function[z, f[z] + g[z]];
H[1]
Yields '3'.

Consider:
In[1]:= Through[(f + g)[1]]
Out[1]= f[1] + g[1]
To elaborate, you can define h like this:
h = Through[ (f + g)[#] ] &;
If you have a limited number of functions and operands, then UpSet as recommended by yoda is surely syntactically cleaner. However, Through is more general. Without any new definitions involving Times or h, one can easily do:
i = Through[ (h * f * g)[#] ] &
i[7]
43218

Another way of doing what you're trying to do is using UpSetDelayed.
f[x_] := x^2;
g[x_] := 2*x;
f + g ^:= f[#] + g[#] &; (*define upvalues for the operation f+g*)
h[x_] = f + g;
h[z]
Out[1]= 2 z + z^2
Also see this very nice answer by rcollyer (and also the ones by Leonid & Verbeia) for more on UpValues and when to use them

I will throw in a complete code for Gram - Schmidt and an example for function addition etc, since I happened to have that code written about 4 years ago. Did not test extensively though. I did not change a single line of it now, so a disclaimer (I was a lot worse at mma at the time). That said, here is a Gram - Schmidt procedure implementation, which is a slightly generalized version of the code I discussed here:
oneStepOrtogonalizeGen[vec_, {}, _, _, _] := vec;
oneStepOrtogonalizeGen[vec_, vecmat_List, dotF_, plusF_, timesF_] :=
Fold[plusF[#1, timesF[-dotF[vec, #2]/dotF[#2, #2], #2]] &, vec, vecmat];
GSOrthogonalizeGen[startvecs_List, dotF_, plusF_, timesF_] :=
Fold[Append[#1,oneStepOrtogonalizeGen[#2, #1, dotF, plusF, timesF]] &, {}, startvecs];
normalizeGen[vec_, dotF_, timesF_] := timesF[1/Sqrt[dotF[vec, vec]], vec];
GSOrthoNormalizeGen[startvecs_List, dotF_, plusF_, timesF_] :=
Map[normalizeGen[#, dotF, timesF] &, GSOrthogonalizeGen[startvecs, dotF, plusF, timesF]];
The functions above are parametrized by 3 functions, realizing addition, multiplication by a number, and the dot product in a given vector space. The example to illustrate will be to find Hermite polynomials by orthonormalizing monomials. These are possible implementations for the 3 functions we need:
hermiteDot[f_Function, g_Function] :=
Module[{x}, Integrate[f[x]*g[x]*Exp[-x^2], {x, -Infinity, Infinity}]];
SetAttributes[functionPlus, {Flat, Orderless, OneIdentity}];
functionPlus[f__Function] := With[{expr = Plus ## Through[{f}[#]]}, expr &];
SetAttributes[functionTimes, {Flat, Orderless, OneIdentity}];
functionTimes[a___, f_Function] /; FreeQ[{a}, # | Function] :=
With[{expr = Times[a, f[#]]}, expr &];
These functions may be a bit naive, but they will illustrate the idea (and yes, I also used Through). Here are some examples to illustrate their use:
In[114]:= hermiteDot[#^2 &, #^4 &]
Out[114]= (15 Sqrt[\[Pi]])/8
In[107]:= functionPlus[# &, #^2 &, Sin[#] &]
Out[107]= Sin[#1] + #1 + #1^2 &
In[111]:= functionTimes[z, #^2 &, x, 5]
Out[111]= 5 x z #1^2 &
Now, the main test:
In[115]:=
results =
GSOrthoNormalizeGen[{1 &, # &, #^2 &, #^3 &, #^4 &}, hermiteDot,
functionPlus, functionTimes]
Out[115]= {1/\[Pi]^(1/4) &, (Sqrt[2] #1)/\[Pi]^(1/4) &, (
Sqrt[2] (-(1/2) + #1^2))/\[Pi]^(1/4) &, (2 (-((3 #1)/2) + #1^3))/(
Sqrt[3] \[Pi]^(1/4)) &, (Sqrt[2/3] (-(3/4) + #1^4 -
3 (-(1/2) + #1^2)))/\[Pi]^(1/4) &}
These are indeed the properly normalized Hermite polynomials, as is easy to verify. The normalization of built-in HermiteH is different. Our results are normalized as one would normalize the wave functions of a harmonic oscillator, say. It is trivial to obtain a list of polynomials as expressions depending on a variable, say x:
In[116]:= Through[results[x]]
Out[116]= {1/\[Pi]^(1/4),(Sqrt[2] x)/\[Pi]^(1/4),(Sqrt[2] (-(1/2)+x^2))/\[Pi]^(1/4),
(2 (-((3 x)/2)+x^3))/(Sqrt[3] \[Pi]^(1/4)),(Sqrt[2/3] (-(3/4)+x^4-3 (-(1/2)+x^2)))/\[Pi]^(1/4)}

I would suggest defining an operator other than the built-in Plus for this purpose. There are a number of operators provided by Mathematica that are reserved for user definitions in cases such as this. One such operator is CirclePlus which has no pre-defined meaning but which has a nice compact representation (at least, it is compact in a notebook -- not so compact on a StackOverflow web page). You could define CirclePlus to perform function addition thus:
(x_ \[CirclePlus] y_)[args___] := x[args] + y[args]
With this definition in place, you can now perform function addition:
h = f \[CirclePlus] g;
h[x]
(* Out[3]= f[x]+g[x] *)
If one likes to live on the edge, the same technique can be used with the built-in Plus operator provided it is unprotected first:
Unprotect[Plus];
(x_ + y_)[args___] := x[args] + y[args]
Protect[Plus];
h = f + g;
h[x]
(* Out[7]= f[x]+g[x] *)
I would generally advise against altering the behaviour of built-in functions -- especially one as fundamental as Plus. The reason is that there is no guarantee that user-added definitions to Plus will be respected by other built-in or kernel functions. In some circumstances calls to Plus are optimized, and those optimizations might be not take the user definitions into account. However, this consideration may not affect any particular application so the option is still a valid, if risky, design choice.

Related

Plotting sigmoid function in mathematica

I am new to Mathematica.
I want to write my own sigmoid function where I can give coefficients to e and x. When plotting, I don't get any output, what could be the problem?
sigmoid_f[x_, a_, b_] := 1/(1 + ae^-bx)
Plot[sigmoid_f[x, 1, 1], {x, -5, 5}]
Thank you for your help!
I expect that when you write
sigmoid_f[x_, a_, b_] := 1/(1 - ae^-bx)
you mean to write
sigmoidf[x_, a_, b_] := 1/(1 - a*E^(-b*x))
where E is the built-in representation of Euler's number and * is the usual text form for the multiplication operator.
Also, as #Alan commented, don't use _ in the names of objects you define.
Mathematica is extremely particular about matters of case and punctuation. In your original expression ae and bx are both names of (presumably unknown) objects.

Trying to get Mathematica to approximate an integral

I am trying to get Mathematica to approximate an integral that is a function of various parameters. I don't need it to be extremely precise -- the answer will be a fraction, and 5 digits would be nice, but I'd settle for as few as 2.
The problem is that there is a symbolic integral buried in the main integral, and I can't use NIntegrate on it since its symbolic.
F[x_, c_] := (1 - (1 - x)^c)^c;
a[n_, c_, x_] := F[a[n - 1, c, x], c];
a[0, c_, x_] = x;
MyIntegral[n_,c_] :=
NIntegrate[Integrate[(D[a[n,c,y],y]*y)/(1-a[n,c,x]),{y,x,1}],{x,0,1}]
Mathematica starts hanging when n is greater than 2 and c is greater than 3 or so (generally as both n and c get a little higher).
Are there any tricks for rewriting this expression so that it can be evaluated more easily? I've played with different WorkingPrecision and AccuracyGoal and PrecisionGoal options on the outer NIntegrate, but none of that helps the inner integral, which is where the problem is. In fact, for the higher values of n and c, I can't even get Mathematica to expand the inner derivative, i.e.
Expand[D[a[4,6,y],y]]
hangs.
I am using Mathematica 8 for Students.
If anyone has any tips for how I can get M. to approximate this, I would appreciate it.
Since you only want a numerical output (or that's what you'll get anyway), you can convert the symbolic integration into a numerical one using just NIntegrate as follows:
Clear[a,myIntegral]
a[n_Integer?Positive, c_Integer?Positive, x_] :=
a[n, c, x] = (1 - (1 - a[n - 1, c, x])^c)^c;
a[0, c_Integer, x_] = x;
myIntegral[n_, c_] :=
NIntegrate[D[a[n, c, y], y]*y/(1 - a[n, c, x]), {x, 0, 1}, {y, x, 1},
WorkingPrecision -> 200, PrecisionGoal -> 5]
This is much faster than performing the integration symbolically. Here's a comparison:
yoda:
myIntegral[2,2]//Timing
Out[1]= {0.088441, 0.647376595...}
myIntegral[5,2]//Timing
Out[2]= {1.10486, 0.587502888...}
rcollyer:
MyIntegral[2,2]//Timing
Out[3]= {1.0029, 0.647376}
MyIntegral[5,2]//Timing
Out[4]= {27.1697, 0.587503006...}
(* Obtained with WorkingPrecision->500, PrecisionGoal->5, MaxRecursion->20 *)
Jand's function has timings similar to rcollyer's. Of course, as you increase n, you will have to increase your WorkingPrecision way higher than this, as you've experienced in your previous question. Since you said you only need about 5 digits of precision, I've explicitly set PrecisionGoal to 5. You can change this as per your needs.
To codify the comments, I'd try the following. First, to eliminate infinite recursion with regards to the variable, n, I'd rewrite your functions as
F[x_, c_] := (1 - (1-x)^c)^c;
(* see note below *)
a[n_Integer?Positive, c_, x_] := F[a[n - 1, c, x], c];
a[0, c_, x_] = x;
that way n==0 will actually be a stopping point. The ?Positive form is a PatternTest, and useful for applying additional conditions to the parameters. I suspect the issue is that NIntegrate is re-evaluating the inner Integrate for every value of x, so I'd pull that evaluation out, like
MyIntegral[n_,c_] :=
With[{ int = Integrate[(D[a[n,c,y],y]*y)/(1-a[n,c,x]),{y,x,1}] },
NIntegrate[int,{x,0,1}]
]
where With is one of several scoping constructs specifically for creating local constants.
Your comments indicate that the inner integral takes a long time, have you tried simplifying the integrand as it is a derivative of a times a function of a? It seems like the result of a chain rule expansion to me.
Note: as per Yoda's suggestion in the comments, you can add a cacheing, or memoization, mechanism to a. Change its definition to
d:a[n_Integer?Positive, c_, x_] := d = F[a[n - 1, c, x], c];
The trick here is that in d:a[ ... ], d is a named pattern that is used again in d = F[...] cacheing the value of a for those particular parameter values.

NMinimize seems to be on crack

Say I have a crazy function, f, defined like so:
util[x_, y_, c_] := 0.5*Log[c-x] + 0.5*Log[c-y]
cost[x_, y_, l_] := c /. First[NSolve[util[x, y, c+l] == Log[10+l], c]]
prof[x_, y_] := 0.01*Norm[{x,y}, 2]
liquid[x_, y_] := 0.01*Norm[{x,y}, 2]
f[x_, y_, a_, b_] := cost[a, b, liquid[x,y] + liquid[a-x, b-y]] - Max[a,b]
- cost[0,0,0] + prof[x,y] + liquid[x,y] + prof[a-x, b-y] + liquid[a-x, b-y]
Now I call NMinimize like this:
NMinimize[{f[50, 50, k, j], k >= 49, k <= 51, j >= 49, j <= 51}, {j, k}]
Which tells me this:
{-21.0465, {j -> 51., k -> 49.}}
But then if I actually check what f[50,50,49,51] is, it's this:
0.489033
Which is pretty different from the -21.0465 that NMinimize said.
Is this par for the course with NMinimize?
Floating point errors compounding or whatnot?
Any ideas for beating NMinimize (or some such function) into submission?
It certainly seems to be related to your function f not being restricted to numerical arguments, plus the symbolic preprocessing performed by NMinimize. Once you change the signature to
f[x_?NumericQ, y_?NumericQ, a_?NumericQ, b_?NumericQ]:=...
The result is as expected, although it takes considerably longer to get it.
EDIT
We can dig deeper to reveal the true reason. First, note that your f (the original one, args unrestricted) is quite a function:
In[1423]:= f[50,50,49.,51.]
Out[1423]= 0.489033
In[1392]:= f[50,50,k,j]/.{j->51.`,k->49.`}
Out[1392]= -21.0465
The real culprit is NSolve, which gives two ordered solutions:
In[1398]:= NSolve[util[x,y,c+l]==Log[10+l],c]
Out[1398]= {{c->0.5 (-2. l+1. x+1. y-2. Sqrt[100.+20. l+1. l^2+0.25 x^2-0.5 x y+0.25 y^2])},
{c->0.5 (-2. l+1. x+1. y+2. Sqrt[100.+20. l+1. l^2+0.25 x^2-0.5 x y+0.25 y^2])}}
The problem is, what is the ordering. It turns out to be different for symbolic and numeric arguments to NSolve, because in the latter case we don't have any symbols around. This can be seen as:
In[1399]:=
Block[{cost},
cost[x_,y_,l_]:=c/.Last[NSolve[util[x,y,c+l]==Log[10+l],c]];
f[50,50,k,j]/.{j->51.,k->49.}]
Out[1399]= 0.489033
So you really have to settle on what is the right ordering for you, and which solution you really want to pick.

Mathematica: using simplify to do common sub-expression elimination and reduction in strength

So lately I have been toying around with how Mathematica's pattern matching and term rewriting might be put to good use in compiler optimizations...trying to highly optimize short blocks of code that are the inner parts of loops. Two common ways to reduce the amount of work it takes to evaluate an expression is to identify sub-expressions that occur more than once and store the result and then use the stored result at subsequent points to save work. Another approach is to use cheaper operations where possible. For instance, my understanding is that taking square roots take more clock cycles than additions and multiplications. To be clear, I am interested in the cost in terms of floating point operations that evaluating the expression would take, not how long it takes Mathematica to evaluate it.
My first thought was that I would tackle the problem developing using Mathematica's simplify function. It is possible to specify a complexity function that compares the relative simplicity of two expressions. I was going to create one using weights for the relevant arithmetic operations and add to this the LeafCount for the expression to account for the assignment operations that are required. That addresses the reduction in strength side, but it is the elimination of common subexpressions that has me tripped up.
I was thinking of adding common subexpression elimination to the possible transformation functions that simplify uses. But for a large expression there could be many possible subexpressions that could be replaced and it won't be possible to know what they are till you see the expression. I have written a function that gives the possible substitutions, but it seems like the transformation function you specify needs to just return a single possible transformation, at least from the examples in the documentation. Any thoughts on how one might get around this limitation? Does anyone have a better idea of how simplify uses transformation functions that might hint at a direction forward?
I imagine that behind the scenes that Simplify is doing some dynamic programming trying different simplifications on different parts of the expressions and returning the one with the lowest complexity score. Would I be better off trying to do this dynamic programming on my own using common algebraic simplifications such as factor and collect?
EDIT: I added the code that generates possible sub-expressions to remove
(*traverses entire expression tree storing each node*)
AllSubExpressions[x_, accum_] := Module[{result, i, len},
len = Length[x];
result = Append[accum, x];
If[LeafCount[x] > 1,
For[i = 1, i <= len, i++,
result = ToSubExpressions2[x[[i]], result];
];
];
Return[Sort[result, LeafCount[#1] > LeafCount[#2] &]]
]
CommonSubExpressions[statements_] := Module[{common, subexpressions},
subexpressions = AllSubExpressions[statements, {}];
(*get the unique set of sub expressions*)
common = DeleteDuplicates[subexpressions];
(*remove constants from the list*)
common = Select[common, LeafCount[#] > 1 &];
(*only keep subexpressions that occur more than once*)
common = Select[common, Count[subexpressions, #] > 1 &];
(*output the list of possible subexpressions to replace with the \
number of occurrences*)
Return[common];
]
Once a common sub-expression is chosen from the list returned by CommonSubExpressions the function that does the replacement is below.
eliminateCSE[statements_, expr_] := Module[{temp},
temp = Unique["r"];
Prepend[ReplaceAll[statements, expr -> temp], temp[expr]]
]
At the risk of this question getting long, I will put a little example code up. I thought a decent expression to try to optimize would be the classical Runge-Kutta method for solving differential equations.
Input:
nextY=statements[y + 1/6 h (f[t, n] + 2 f[0.5 h + t, y + 0.5 h f[t, n]] +
2 f[0.5 h + t, y + 0.5 h f[0.5 h + t, y + 0.5 h f[t, n]]] +
f[h + t,
y + h f[0.5 h + t, y + 0.5 h f[0.5 h + t, y + 0.5 h f[t, n]]]])];
possibleTransformations=CommonSubExpressions[nextY]
transformed=eliminateCSE[nextY, First[possibleTransformations]]
Output:
{f[0.5 h + t, y + 0.5 h f[0.5 h + t, y + 0.5 h f[t, n]]],
y + 0.5 h f[0.5 h + t, y + 0.5 h f[t, n]],
0.5 h f[0.5 h + t, y + 0.5 h f[t, n]],
f[0.5 h + t, y + 0.5 h f[t, n]], y + 0.5 h f[t, n], 0.5 h f[t, n],
0.5 h + t, f[t, n], 0.5 h}
statements[r1[f[0.5 h + t, y + 0.5 h f[0.5 h + t, y + 0.5 h f[t, n]]]],
y + 1/6 h (2 r1 + f[t, n] + 2 f[0.5 h + t, y + 0.5 h f[t, n]] +
f[h + t, h r1 + y])]
Finally, the code to judge the relative cost of different expressions is below. The weights are conceptual at this point as that is still an area I am researching.
Input:
cost[e_] :=
Total[MapThread[
Count[e, #1, Infinity, Heads -> True]*#2 &, {{Plus, Times, Sqrt,
f}, {1, 2, 5, 10}}]]
cost[transformed]
Output:
100
There are also some routines here implemented here by this author: http://stoney.sb.org/wordpress/2009/06/converting-symbolic-mathematica-expressions-to-c-code/
I packaged it into a *.M file and have fixed a bug (if the expression has no repeated subexpressions the it dies), and I am trying to find the author's contact info to see if I can upload his modified code to pastebin or wherever.
EDIT: I have received permission from the author to upload it and have pasted it here: http://pastebin.com/fjYiR0B3
To identify repeating subexpressions, you could use something like this
(*helper functions to add Dictionary-like functionality*)
index[downvalue_,
dict_] := (downvalue[[1]] /. HoldPattern[dict[x_]] -> x) //
ReleaseHold;
value[downvalue_] := downvalue[[-1]];
indices[dict_] :=
Map[#[[1]] /. {HoldPattern[dict[x_]] -> x} &, DownValues[dict]] //
ReleaseHold;
values[dict_] := Map[#[[-1]] &, DownValues[dict]];
items[dict_] := Map[{index[#, dict], value[#]} &, DownValues[dict]];
indexQ[dict_, index_] :=
If[MatchQ[dict[index], HoldPattern[dict[index]]], False, True];
(*count number of times each sub-expressions occurs *)
expr = Cos[x + Cos[Cos[x] + Sin[x]]] + Cos[Cos[x] + Sin[x]];
Map[(counts[#] = If[indexQ[counts, #], counts[#] + 1, 1]; #) &, expr,
Infinity];
items[counts] // Column
I tried to mimic the dictionary compression function appears on this blog: https://writings.stephenwolfram.com/2018/11/logic-explainability-and-the-future-of-understanding/
Here is what I made:
DictionaryCompress[expr_, count_, size_, func_] := Module[
{t, s, rule, rule1, rule2},
t = Tally#Level[expr, Depth[expr]];
s = Sort[
Select[{First##, Last##, Depth[First##]} & /#
t, (#[[2]] > count && #[[3]] > size) &], #1[[2]]*#1[[3]] < #2[[
2]]*#2[[2]] &];
rule = MapIndexed[First[#1] -> func ## #2 &, s];
rule = (# //. Cases[rule, Except[#]]) & /# rule;
rule1 = Select[rule, ! FreeQ[#, Plus] &];
rule2 = Complement[rule, rule1];
rule = rule1 //. (Reverse /# rule2);
rule = rule /. MapIndexed[ Last[#1] -> func ## #2 &, rule];
{
expr //. rule,
Reverse /# rule
}
];
poly = Sum[Subscript[c, k] x^k, {k, 0, 4}];
sol = Solve[poly == 0, x];
expr = x /. sol;
Column[{Column[
MapIndexed[
Style[TraditionalForm[Subscript[x, First[#2]] == #], 20] &, #[[
1]]], Spacings -> 1],
Column[Style[#, 20] & /# #[[2]], Spacings -> 1, Frame -> All]
}] &#DictionaryCompress[expr, 1, 1,
Framed[#, Background -> LightYellow] &]

Solving vector equations in Mathematica

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];

Resources