Related
Suppose I have an expression of the form
x^2Coth[y] + 2xyCoth[y] + y^2Coth[y],
this is equal to
(x - y)^2Coth[y].
Is there a way to ask Mathematica to do this collection? That is, something like
Collect[x^2Coth[y] + 2xyCoth[y] + y^2Coth[y], x - y]
giving output (x - y)^2Coth[y] ?
Thanks!
This uses Rojo's solution. There may be a simpler way.
expr = x^2 Coth[y] + 2 x y Coth[y] + y^2 Coth[y];
var = Coth[y];
doThat[expr_, vars_List] := Expand[Simplify[
expr /. Flatten[Solve[# == ToString##, First#Variables##] & /# vars]],
Alternatives ## ToString /# vars] /. Thread[ToString /# vars -> vars];
doThat[expr, {var}]
(* (x + y)^2 Coth[y] *)
Edit
Indeed there is a simpler way:
Collect[expr, var, Factor]
(* (x + y)^2 Coth[y] *)
A friend of mine showed me a home exercise in a C++ course which he attend. Since I already know C++, but just started learning Haskell I tried to solve the exercise in the "Haskell way".
These are the exercise instructions (I translated from our native language so please comment if the instructions aren't clear):
Write a program which reads non-zero coefficients (A,B,C,D) from the user and places them in the following equation:
A*x + B*y + C*z = D
The program should also read from the user N, which represents a range. The program should find all possible integral solutions for the equation in the range -N/2 to N/2.
For example:
Input: A = 2,B = -3,C = -1, D = 5, N = 4
Output: (-1,-2,-1), (0,-2, 1), (0,-1,-2), (1,-1, 0), (2,-1,2), (2,0, -1)
The most straight-forward algorithm is to try all possibilities by brute force. I implemented it in Haskell in the following way:
triSolve :: Integer -> Integer -> Integer -> Integer -> Integer -> [(Integer,Integer,Integer)]
triSolve a b c d n =
let equation x y z = (a * x + b * y + c * z) == d
minN = div (-n) 2
maxN = div n 2
in [(x,y,z) | x <- [minN..maxN], y <- [minN..maxN], z <- [minN..maxN], equation x y z]
So far so good, but the exercise instructions note that a more efficient algorithm can be implemented, so I thought how to make it better. Since the equation is linear, based on the assumption that Z is always the first to be incremented, once a solution has been found there's no point to increment Z. Instead, I should increment Y, set Z to the minimum value of the range and keep going. This way I can save redundant executions.
Since there are no loops in Haskell (to my understanding at least) I realized that such algorithm should be implemented by using a recursion. I implemented the algorithm in the following way:
solutions :: (Integer -> Integer -> Integer -> Bool) -> Integer -> Integer -> Integer -> Integer -> Integer -> [(Integer,Integer,Integer)]
solutions f maxN minN x y z
| solved = (x,y,z):nextCall x (y + 1) minN
| x >= maxN && y >= maxN && z >= maxN = []
| z >= maxN && y >= maxN = nextCall (x + 1) minN minN
| z >= maxN = nextCall x (y + 1) minN
| otherwise = nextCall x y (z + 1)
where solved = f x y z
nextCall = solutions f maxN minN
triSolve' :: Integer -> Integer -> Integer -> Integer -> Integer -> [(Integer,Integer,Integer)]
triSolve' a b c d n =
let equation x y z = (a * x + b * y + c * z) == d
minN = div (-n) 2
maxN = div n 2
in solutions equation maxN minN minN minN minN
Both yield the same results. However, trying to measure the execution time yielded the following results:
*Main> length $ triSolve' 2 (-3) (-1) 5 100
3398
(2.81 secs, 971648320 bytes)
*Main> length $ triSolve 2 (-3) (-1) 5 100
3398
(1.73 secs, 621862528 bytes)
Meaning that the dumb algorithm actually preforms better than the more sophisticated one. Based on the assumption that my algorithm was correct (which I hope won't turn as wrong :) ), I assume that the second algorithm suffers from an overhead created by the recursion, which the first algorithm isn't since it's implemented using a list comprehension.
Is there a way to implement in Haskell a better algorithm than the dumb one?
(Also, I'll be glad to receive general feedbacks about my coding style)
Of course there is. We have:
a*x + b*y + c*z = d
and as soon as we assume values for x and y, we have that
a*x + b*y = n
where n is a number we know.
Hence
c*z = d - n
z = (d - n) / c
And we keep only integral zs.
It's worth noticing that list comprehensions are given special treatment by GHC, and are generally very fast. This could explain why your triSolve (which uses a list comprehension) is faster than triSolve' (which doesn't).
For example, the solution
solve :: Integer -> Integer -> Integer -> Integer -> Integer -> [(Integer,Integer,Integer)]
-- "Buffalo buffalo buffalo buffalo Buffalo buffalo buffalo..."
solve a b c d n =
[(x,y,z) | x <- vals, y <- vals
, let p = a*x +b*y
, let z = (d - p) `div` c
, z >= minN, z <= maxN, c * z == d - p ]
where
minN = negate (n `div` 2)
maxN = (n `div` 2)
vals = [minN..maxN]
runs fast on my machine:
> length $ solve 2 (-3) (-1) 5 100
3398
(0.03 secs, 4111220 bytes)
whereas the equivalent code written using do notation:
solveM :: Integer -> Integer -> Integer -> Integer -> Integer -> [(Integer,Integer,Integer)]
solveM a b c d n = do
x <- vals
y <- vals
let p = a * x + b * y
z = (d - p) `div` c
guard $ z >= minN
guard $ z <= maxN
guard $ z * c == d - p
return (x,y,z)
where
minN = negate (n `div` 2)
maxN = (n `div` 2)
vals = [minN..maxN]
takes twice as long to run and uses twice as much memory:
> length $ solveM 2 (-3) (-1) 5 100
3398
(0.06 secs, 6639244 bytes)
Usual caveats about testing within GHCI apply -- if you really want to see the difference, you need to compile the code with -O2 and use a decent benchmarking library (like Criterion).
For example, I have symbollically
1/n*Sum[ee[k] + 1, {k, j, n}]^2
And I want to substitute Sum[ee[k], {k, j+1, n}] to be x. How can I do this? May thanks for your help!
You may use the recurrence relation for the sum. For example:
f[j] := f[j + 1] + (ee[j] + 1);
1/N f[j]^2 /. f[j + 1] -> x
Out
(1 + x + ee[j])^2/N
Edit
Based on several questions you posted, I think you are somehow misinterpreting what the Replace[] command does. It is not "algebraic" based, but "pattern" based. It doesn't understand nor use more algebraic transformations than those already defined (by you or by Mma itself).
For example:
x/. (x-1)->y
will not match anything. But
(x-1) /. x->y-1
Will give you (y-2) because the pattern x is matched.
Moreover:
x = 3;
(x - 1) /. x -> y - 1
will give you 2 because x is evaluated before the possible match, and the x in the pattern is also evaluated (just paste, execute and look at the symbol color).
1/N*Sum[ee[k] + 1, {k, j, N}]^2 /. Sum[ee[k] + 1, {k, j, N}] -> x
Doesn't that work, or do I misunderstand? By the way, you shouldn't use N as a variable. It's a Mathematica function.
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] &]
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!