dharr

Dr. David Harrington

8470 Reputation

22 Badges

21 years, 33 days
University of Victoria
Professor or university staff
Victoria, British Columbia, Canada

Social Networks and Content at Maplesoft.com

Maple Application Center
I am a retired professor of chemistry at the University of Victoria, BC, Canada. My research areas are electrochemistry and surface science. I have been a user of Maple since about 1990.

MaplePrimes Activity


These are answers submitted by dharr

Yes this factorial in the denominator jumping drives me crazy. It seems to be a side effect of the new 2-D entry system that abbreviates entering x^2 cursor-right + 2 to  x^2+2. It is still present in Maple 2025.1, so there is currently not a solution.

Well, this is probably cheating since I saw the answer, but maybe I would have thought of it anyway.

restart

interface(version)

`Standard Worksheet Interface, Maple 2025.1, Windows 11, June 12 2025 Build ID 1932578`

term := 2*cos(5*arcsin((1/2)*x))

2*cos(5*arcsin((1/2)*x))

term1 := expand(term)

-3*(-x^2+4)^(1/2)*x^2+(-x^2+4)^(1/2)+(-x^2+4)^(1/2)*x^4

Well, combine is usually the opposite of expand, so the first thing I'd try is

combine(term1)

-3*(-x^2+4)^(1/2)*x^2+(-x^2+4)^(1/2)+(-x^2+4)^(1/2)*x^4

I tried a lot of converts without success. Of course not many algebraic things are likely to be expressible as trig functions, so it is just "luck" that term1 came out so simply.

So I'll give Maple a hand, trying to forget that I saw the answer already. Now sqrt(1-x*2) for x = sin/cos(u) gives cos/sin(u), and for the 4's being 2^2 suggests a substitution

tr := x = 2*sin(u); p := simplify(eval(term1, tr))

x = 2*sin(u)

(32*cos(u)^5-40*cos(u)^3+10*cos(u))*csgn(cos(u))

We could play around with assumptions to handle the csgn, but let's be reckless

p2 := simplify(p, symbolic)

2*cos(5*u)

To go back to x we need to inverse transformation

itr := isolate(tr, u)

u = arcsin((1/2)*x)

which gives what we want.

f := eval(p2, itr)

2*cos(5*arcsin((1/2)*x))

If we had used cos instead

tr2 := x = 2*cos(u); q := simplify(eval(term1, tr2), symbolic)

x = 2*cos(u)

2*sin(5*u)

itr2 := isolate(tr2, u); g := eval(q, itr2)

u = arccos((1/2)*x)

2*sin(5*arccos((1/2)*x))

And the plots are on top of each other

plot([f, g], x = -2.5 .. 2.5)

which we can verify exactly

simplify(f-g)

0

NULL

Download test2.mw

Of course it is a bug, but notice that solve gives the same result. It's the classic problem of introducing extraneous solutions by squaring both sides of an equation.

restart;

sys := diff~(sqrt(2*a^2 - 8*a + 10) + sqrt(b^2 - 6*b + 10) + sqrt(2*a^2 - 2*a*b + b^2), {a, b});

{(1/2)*(4*a-8)/(2*a^2-8*a+10)^(1/2)+(1/2)*(4*a-2*b)/(2*a^2-2*a*b+b^2)^(1/2), (1/2)*(2*b-6)/(b^2-6*b+10)^(1/2)+(1/2)*(-2*a+2*b)/(2*a^2-2*a*b+b^2)^(1/2)}

solve(sys);

{a = 5/3, b = 5/2}, {a = a, b = 2*a/(a-1)}

If you solve with infolevel[solve]:=5; you see it solved 5 equations, so plenty of opportunity for extraneous solutions.
So I'm guessing it did something like this:

neweqs := {2*a^2-8*a+10 = s1^2, 2*a^2 - 2*a*b + b^2 = s2^2, b^2 - 6*b + 10 = s3^2};
sys2a:=simplify(eval(sys, neweqs)) assuming s1>0,s2>0,s3>0;
sys2:=numer~(%) union (lhs-rhs)~(neweqs);

{2*a^2-8*a+10 = s1^2, b^2-6*b+10 = s3^2, 2*a^2-2*a*b+b^2 = s2^2}

{(2*(a-2)*s2+(2*a-b)*s1)/(s1*s2), ((b-3)*s2-(a-b)*s3)/(s3*s2)}

{2*a^2-s1^2-8*a+10, b^2-s3^2-6*b+10, 2*a^2-2*a*b+b^2-s2^2, 2*a*s1+2*a*s2-b*s1-4*s2, -a*s3+b*s2+b*s3-3*s2}

The last two answers here are the problematic ones, but actually the first six are special cases of a=a, b=2*a/(a-1). The problem is that s1, s2, s2 are not all positive, so the squaring in neweqs with the assumptions led to the problem

ans:=sort([solve(sys2, {a, b, s1, s2, s3},explicit)]);

[{a = 2, b = 4, s1 = 2^(1/2), s2 = 2*2^(1/2), s3 = -2^(1/2)}, {a = 2, b = 4, s1 = -2^(1/2), s2 = -2*2^(1/2), s3 = 2^(1/2)}, {a = 3, b = 3, s1 = -2, s2 = 3, s3 = -1}, {a = 3, b = 3, s1 = -2, s2 = 3, s3 = 1}, {a = 3, b = 3, s1 = 2, s2 = -3, s3 = -1}, {a = 3, b = 3, s1 = 2, s2 = -3, s3 = 1}, {a = 5/3, b = 5/2, s1 = -(2/3)*5^(1/2), s2 = -(5/6)*5^(1/2), s3 = -(1/2)*5^(1/2)}, {a = 5/3, b = 5/2, s1 = (2/3)*5^(1/2), s2 = (5/6)*5^(1/2), s3 = (1/2)*5^(1/2)}, {a = a, b = 2*a/(a-1), s1 = (2*a^2-8*a+10)^(1/2), s2 = -(2*a^2-8*a+10)^(1/2)*a/(a-1), s3 = (2*a^2-8*a+10)^(1/2)/(a-1)}, {a = a, b = 2*a/(a-1), s1 = -(2*a^2-8*a+10)^(1/2), s2 = (2*a^2-8*a+10)^(1/2)*a/(a-1), s3 = -(2*a^2-8*a+10)^(1/2)/(a-1)}]

All these solutions check out for the expanded system

seq(simplify(eval(sys2,ans[i])), i=1..nops(ans));

{0}, {0}, {0}, {0}, {0}, {0}, {0}, {0}, {0}, {0}

Taking numer wasn't a problem

seq(simplify(eval(sys2a,ans[i])), i=1..nops(ans));

{0}, {0}, {0}, {0}, {0}, {0}, {0}, {0}, {0}, {0}

OK in neweqs

seq(simplify(eval(neweqs,ans[i])), i=1..nops(ans));

{2 = 2, 8 = 8}, {2 = 2, 8 = 8}, {1 = 1, 4 = 4, 9 = 9}, {1 = 1, 4 = 4, 9 = 9}, {1 = 1, 4 = 4, 9 = 9}, {1 = 1, 4 = 4, 9 = 9}, {5/4 = 5/4, 20/9 = 20/9, 125/36 = 125/36}, {5/4 = 5/4, 20/9 = 20/9, 125/36 = 125/36}, {(2*a^2-8*a+10)/(a-1)^2 = (2*a^2-8*a+10)/(a-1)^2, 2*a^2*(a^2-4*a+5)/(a-1)^2 = 2*a^2*(a^2-4*a+5)/(a-1)^2, 2*a^2-8*a+10 = 2*a^2-8*a+10}, {(2*a^2-8*a+10)/(a-1)^2 = (2*a^2-8*a+10)/(a-1)^2, 2*a^2*(a^2-4*a+5)/(a-1)^2 = 2*a^2*(a^2-4*a+5)/(a-1)^2, 2*a^2-8*a+10 = 2*a^2-8*a+10}

But not in sys

seq(simplify(eval(sys,ans[i])), i=1..nops(ans));

{0, 2^(1/2)}, {0, 2^(1/2)}, {0, 2}, {0, 2}, {0, 2}, {0, 2}, {0}, {0}, {(a-2)*(2/(2*a^2-8*a+10)^(1/2)+a*2^(1/2)/((a^2*(a^2-4*a+5)/(a-1)^2)^(1/2)*(a-1))), -(1/2)*2^(1/2)*(a-3)*(1/((a^2-4*a+5)/(a-1)^2)^(1/2)+a/(a^2*(a^2-4*a+5)/(a-1)^2)^(1/2))/(a-1)}, {(a-2)*(2/(2*a^2-8*a+10)^(1/2)+a*2^(1/2)/((a^2*(a^2-4*a+5)/(a-1)^2)^(1/2)*(a-1))), -(1/2)*2^(1/2)*(a-3)*(1/((a^2-4*a+5)/(a-1)^2)^(1/2)+a/(a^2*(a^2-4*a+5)/(a-1)^2)^(1/2))/(a-1)}

 

NULL

Download realsolve.mw

[Edit - modified so step 1 works as described in the literature - see more examples with refs below.]

restart

with(PDEtools)

undeclare(prime, quiet)

vars := x, t; declare(u(vars), quiet); declare(Phi(vars), quiet); declare(phi(vars), quiet)

Burgers eqn  - see https://doi.org/10.1063/1.525721

pde1 := diff(u(x, t), t)+u(x, t)*(diff(u(x, t), x))-sigma*(diff(u(x, t), x, x))

diff(u(x, t), t)+u(x, t)*(diff(u(x, t), x))-sigma*(diff(diff(u(x, t), x), x))

Routine to find symbolic exponent of phi

findexp := proc (T) options operator, arrow; simplify(phi(vars)*Physics:-diff(T, phi(vars))/T) end proc

Step 1

equ1 := u(vars) = chi*phi(vars)^a

u(x, t) = chi*phi(x, t)^a

eqphi := expand(eval(pde1, equ1))

chi*phi(x, t)^a*a*(diff(phi(x, t), t))/phi(x, t)+chi^2*(phi(x, t)^a)^2*a*(diff(phi(x, t), x))/phi(x, t)-sigma*chi*phi(x, t)^a*a^2*(diff(phi(x, t), x))^2/phi(x, t)^2-sigma*chi*phi(x, t)^a*a*(diff(diff(phi(x, t), x), x))/phi(x, t)+sigma*chi*phi(x, t)^a*a*(diff(phi(x, t), x))^2/phi(x, t)^2

Find all the distinct powers of phi

exps := [(`minus`(map(findexp, {op(eqphi+forceplus)}), {0}))[]]

[a-2, a-1, 2*a-1]

We are supposed to compare all pairs of lowest exponents. So first find the lowest line for each slope.

convert(ListTools:-Classify(diff, exps, a), list); expmins := `~`[min](%)

[{a-2, a-1}, {2*a-1}]

[a-2, 2*a-1]

Now compare all pairs of these to find the intersection with least a

eqa := a = min(seq(seq(solve(expmins[i] = expmins[j], a), i = 1 .. j-1), j = 1 .. nops(expmins)))

a = -1

eq6 := u(vars) = eval(chi*phi(vars)^a, eqa)

u(x, t) = chi/phi(x, t)

The following has all the terms, not just those from the highest derivative and higher nonlinearity

eq7 := expand(eval(pde1, eq6))

-chi*(diff(phi(x, t), t))/phi(x, t)^2-chi^2*(diff(phi(x, t), x))/phi(x, t)^3-2*sigma*chi*(diff(phi(x, t), x))^2/phi(x, t)^3+sigma*chi*(diff(diff(phi(x, t), x), x))/phi(x, t)^2

We want only the terms with phi^(mindeg), but we cannot collect wrt phi, so convert it to a simple name before collecting

eq7c := subs(phi[] = F, ToJet(eq7, phi(vars), jetnotation = jetvariableswithbrackets))

-chi*phi[t]/F^2-chi^2*phi[x]/F^3-2*sigma*chi*phi[x]^2/F^3+sigma*chi*phi[x, x]/F^2

mindeg := ldegree(eq7c, F)

-3

S := FromJet(coeff(collect(eq7c, F), F, mindeg), phi(vars))

-2*sigma*chi*(diff(phi(x, t), x))^2-chi^2*(diff(phi(x, t), x))

eqchi := chi = solve(S, chi)[2]

chi = -2*(diff(phi(x, t), x))*sigma

Following is u[0]/phi^a, which we use in step 2

u0phia := rhs(eval(eq6, eqchi))

-2*(diff(phi(x, t), x))*sigma/phi(x, t)

So we found (chi) and (a) which was our target for first step

Step 2 - finding resonance points. use Phi as short for phi_j

eq11 := u(vars) = u0phia+eval(Phi(vars)*phi(vars)^(j+a), eqa)

u(x, t) = -2*(diff(phi(x, t), x))*sigma/phi(x, t)+Phi(x, t)*phi(x, t)^(j-1)

We substitute into the pde, and seek "the coefficients of the dominant terms",

eq11b := expand(eval(pde1, eq11))

Following routine finds the exponent of phi in a term T

findexp := proc (T) options operator, arrow; simplify(phi(vars)*Physics:-diff(T, phi(vars))/T) end proc

proc (T) options operator, arrow; simplify(phi(vars)*Physics:-diff(T, phi(vars))/T) end proc

Want the dominant (least value).

exps := map(findexp, [op(eq11b)]); dom := `assuming`([min(select(has, %, j))], [j::posint])

[-1, j-1, -1, j-2, j-3, j-2, j-3, j-2, -2, 2*j-2, -3+2*j, j-1, -2, j-2, j-3, j-2, -3+2*j]

j-3

So we want all terms with exponent dom; Solve the equation with these terms to find the resonant points.

eq12 := select(proc (q) options operator, arrow; findexp(q) = dom end proc, eq11b); rp := [solve(eq12, j)]; maxrp := max(rp)

(diff(phi(x, t), x))^2*sigma*Phi(x, t)*phi(x, t)^j*j/phi(x, t)^3-sigma*Phi(x, t)*phi(x, t)^j*(diff(phi(x, t), x))^2*j^2/phi(x, t)^3+2*(diff(phi(x, t), x))^2*sigma*Phi(x, t)*phi(x, t)^j/phi(x, t)^3

[2, -1]

2

Step 3 -verifying the compatibility condition

eq14 := u(vars) = u0phia+eval(add(Phi[j](vars)*phi(vars)^(j+a), j = 1 .. maxrp), eqa)

u(x, t) = -2*(diff(phi(x, t), x))*sigma/phi(x, t)+Phi[1](x, t)+Phi[2](x, t)*phi(x, t)

Substitute back into the pde, and collect wrt phi(vars) = F.

depvars := [phi(vars), seq(Phi[i](vars), i = 1 .. maxrp)]; coll := collect(subs(phi[] = F, ToJet(eval(pde1, eq14), depvars, jetnotation = jetvariableswithbrackets)), F); mindegree := ldegree(coll, F)

Phi[2][]*Phi[2][x]*F^2+(Phi[2][t]+Phi[1][]*Phi[2][x]+Phi[2][]*(phi[x]*Phi[2][]+Phi[1][x])-sigma*Phi[2][x, x])*F+Phi[1][t]+Phi[2][]*phi[t]-2*phi[x]*sigma*Phi[2][x]+Phi[1][]*(phi[x]*Phi[2][]+Phi[1][x])-2*Phi[2][]*phi[x, x]*sigma-sigma*(2*phi[x]*Phi[2][x]+phi[x, x]*Phi[2][]+Phi[1][x, x])+(-2*phi[x, t]*sigma-2*phi[x]*sigma*(phi[x]*Phi[2][]+Phi[1][x])-2*Phi[1][]*phi[x, x]*sigma+2*Phi[2][]*phi[x]^2*sigma+2*sigma^2*phi[x, x, x])/F+(-2*sigma^2*phi[x]*phi[x, x]+2*sigma*phi[x]^2*Phi[1][]+2*sigma*phi[t]*phi[x])/F^2

-2

Find the coefficients of the maxrp least-degree terms, since we have maxrp variables to solve for

eqs := FromJet([seq(coeff(coll, F, mindegree+i), i = 0 .. maxrp-1)], depvars)

[-2*(diff(phi(x, t), x))*sigma^2*(diff(diff(phi(x, t), x), x))+2*Phi[1](x, t)*(diff(phi(x, t), x))^2*sigma+2*(diff(phi(x, t), x))*sigma*(diff(phi(x, t), t)), -2*(diff(diff(phi(x, t), t), x))*sigma-2*(diff(phi(x, t), x))*sigma*(Phi[2](x, t)*(diff(phi(x, t), x))+diff(Phi[1](x, t), x))-2*Phi[1](x, t)*(diff(diff(phi(x, t), x), x))*sigma+2*Phi[2](x, t)*(diff(phi(x, t), x))^2*sigma+2*sigma^2*(diff(diff(diff(phi(x, t), x), x), x))]

For the Burger's equation, solving the first equation gives u[1] - Eq. 3.7

u1 := Phi[1](vars) = solve(eqs[1], Phi[1](vars))

Phi[1](x, t) = ((diff(diff(phi(x, t), x), x))*sigma-(diff(phi(x, t), t)))/(diff(phi(x, t), x))

If we substitute this in the second equation, it simplifies to zero, which is why we cannot just solve the system.
This is because j=2 is a resonance point.
We have found Eq. 3.8; the factor in the first line below is the derivative wrt x of the eqn for u1.

simplify(eqs[2]); simplify(dsubs(u1, eqs[2]))

-2*sigma*((diff(phi(x, t), x))*(diff(Phi[1](x, t), x))+Phi[1](x, t)*(diff(diff(phi(x, t), x), x))-sigma*(diff(diff(diff(phi(x, t), x), x), x))+diff(diff(phi(x, t), t), x))

0

NULL

Download AllstepsBurgerNew.mw

Example 2: OP's Hirota Bilinear eqn

AllstepsBurgerNew.mw

Example 3: KdV equation

AllStepsKdVnew2.mw

 

If you create the Matrix with option shape = symmetric, then you will get only real eigenvalues and eigenvectors, and Maple will use a more efficient method specialized for symmetric matrices.

(If you just want to get rid of the +0*I after the fact, you can use simplify(..., zero)).

You didn't say how you want to export your plot, but if I assume you want vector graphics then there are two possibilities, encapsulated postscript (EPS) or SVG. (possibly also PDF but I've never tried it)

If I make a plot with no background, say plot(sin(x),axes=none): and export it as EPS with the right-click menu, then look at it with CorelDraw I find it has a white background (which I usually delete and then process further), so this does not work for you.

However, exporting as SVG gives a file that does not have a background, just the curve, so this is what you want.

If you actually want to export as a bitmap image (with loss of resolution), then I don't have much experience with that. Which formats would you want then?

An extract from the ?updates,Maple2017,Performance help page: "Maple 2017 includes a new compiled C implementation of the FGLM algorithm for computing a lexicographic Groebner basis from a total degree basis when there are a finite number of solutions.  This routine is used automatically by Groebner:-Basis when applicable and by the solve command when solving polynomial systems.  The example below runs about 200 times faster in Maple 2017."

The ?updates,Maple2018,index help page and the current help page for ?Groebner,Basis say "The Groebner[Basis] command was updated in Maple 2018", which I assume means the command itself has changed but not necessarily the algorithms.

(If you are using the bases for solving systems of polynomial equations, then there are new methods that don't use Groebner bases that may be more efficient.)

If I understand correctly what you mean, use ctrl-shift-K to insert above and ctrl-shift-J to insert below. (command-shift-K and command-shift-J on Mac). See ?worksheet,reference,hotmac or ..hotwin or .. hotunix.

The default behavior was changed in Maple 2020, see ?updates,Maple2020,IntegralTransforms.

To get the behavior you want, use setup(computederivatives = false);

Download laplace.mw

This is an answer to the followup question, now deleted, about plotting the solution in cartesian coordinates. Here is an example:

PDE_upd_5.mw

Note that VectorCalculus:-Laplacian(u(xi, eta), 'bipolar'[xi, eta]) assumes a=1, so I substituted your earlier laplacian.

Since you have already the functions x(xi,eta) and y(xi,eta), you can use the parametric version of contourplot.

PDE_upd_5.mw

I would probably play around with custom contour values because your large spike dominates and so the contours near zero do not have good resolution, but the I think you cannot then use the colorbar.

NOTE: I replaced VectorCalculus:-Laplacian(u(xi, eta), 'bipolar'[xi, eta]) with your earlier hand-calculated Laplacian, since the built-in one uses a = 1, which you had before but is not applicable here. VectorCalculus is supposed to have a mechanism for changing the a parameter (SetCoordinateParameters) but I couldn't get it to work with Laplacian. 

Yes, your substitutions missed an x. You can capture this with 

eqs := {coeffs(collect(numer(normal(eq)), {X, Y, Z, x}, 'distributed'), {X, Y, Z, x})}

but I think that you cannot constrain tanh(k*x + p*y - t*w) together as one variable, since x, y, and t are independent. If the ln was not there you could expand(tanh(k*x + p*y - t*w)) and substitute the individual sinh, cosh etc, or just convert to exp, but in both cases the ln is a problem.

I would almost always use simplify for this sort of thing, not is.

restart

d := proc (i, j) options operator, arrow; (x[i]-x[j])^2+(y[i]-y[j])^2 end proc

proc (i, j) options operator, arrow; (x[i]-x[j])^2+(y[i]-y[j])^2 end proc

q1:=d(1,2)*d(1,2)*d(3,4)+d(1,3)*d(1,3)*d(2,4)+d(1,4)*d(1,4)*d(2,3)+d(2,3)*d(2,3)*d(1,4)
+d(2,4)*d(2,4)*d(1,3)+d(3,4)*d(3,4)*d(1,2)+d(1,2)*d(2,3)*d(3,1)+d(1,2)*d(2,4)*d(4,1)
+d(1,3)*d(3,4)*d(4,1)+d(2,3)*d(3,4)*d(4,2);

((x[1]-x[2])^2+(y[1]-y[2])^2)^2*((x[3]-x[4])^2+(y[3]-y[4])^2)+((x[1]-x[3])^2+(y[1]-y[3])^2)^2*((x[2]-x[4])^2+(y[2]-y[4])^2)+((x[1]-x[4])^2+(y[1]-y[4])^2)^2*((x[2]-x[3])^2+(y[2]-y[3])^2)+((x[2]-x[3])^2+(y[2]-y[3])^2)^2*((x[1]-x[4])^2+(y[1]-y[4])^2)+((x[2]-x[4])^2+(y[2]-y[4])^2)^2*((x[1]-x[3])^2+(y[1]-y[3])^2)+((x[3]-x[4])^2+(y[3]-y[4])^2)^2*((x[1]-x[2])^2+(y[1]-y[2])^2)+((x[1]-x[2])^2+(y[1]-y[2])^2)*((x[2]-x[3])^2+(y[2]-y[3])^2)*((x[3]-x[1])^2+(y[3]-y[1])^2)+((x[1]-x[2])^2+(y[1]-y[2])^2)*((x[2]-x[4])^2+(y[2]-y[4])^2)*((x[4]-x[1])^2+(y[4]-y[1])^2)+((x[1]-x[3])^2+(y[1]-y[3])^2)*((x[3]-x[4])^2+(y[3]-y[4])^2)*((x[4]-x[1])^2+(y[4]-y[1])^2)+((x[2]-x[3])^2+(y[2]-y[3])^2)*((x[3]-x[4])^2+(y[3]-y[4])^2)*((x[4]-x[2])^2+(y[4]-y[2])^2)

q2:=d(1,2)*d(2,3)*d(3,4)+d(1,3)*d(3,2)*d(2,4)+d(1,2)*d(2,4)*d(4,3)+d(1,4)*d(4,2)*d(2,3)
+d(1,3)*d(3,4)*d(4,2)+d(1,4)*d(4,3)*d(3,2)+d(2,3)*d(3,1)*d(1,4)+d(2,1)*d(1,3)*d(3,4)
+d(2,4)*d(4,1)*d(1,3)+d(2,1)*d(1,4)*d(4,3)+d(3,1)*d(1,2)*d(2,4)+d(3,2)*d(2,1)*d(1,4);

((x[1]-x[2])^2+(y[1]-y[2])^2)*((x[2]-x[3])^2+(y[2]-y[3])^2)*((x[3]-x[4])^2+(y[3]-y[4])^2)+((x[1]-x[3])^2+(y[1]-y[3])^2)*((x[3]-x[2])^2+(y[3]-y[2])^2)*((x[2]-x[4])^2+(y[2]-y[4])^2)+((x[1]-x[2])^2+(y[1]-y[2])^2)*((x[2]-x[4])^2+(y[2]-y[4])^2)*((x[4]-x[3])^2+(y[4]-y[3])^2)+((x[1]-x[4])^2+(y[1]-y[4])^2)*((x[4]-x[2])^2+(y[4]-y[2])^2)*((x[2]-x[3])^2+(y[2]-y[3])^2)+((x[1]-x[3])^2+(y[1]-y[3])^2)*((x[3]-x[4])^2+(y[3]-y[4])^2)*((x[4]-x[2])^2+(y[4]-y[2])^2)+((x[1]-x[4])^2+(y[1]-y[4])^2)*((x[4]-x[3])^2+(y[4]-y[3])^2)*((x[3]-x[2])^2+(y[3]-y[2])^2)+((x[2]-x[3])^2+(y[2]-y[3])^2)*((x[3]-x[1])^2+(y[3]-y[1])^2)*((x[1]-x[4])^2+(y[1]-y[4])^2)+((x[2]-x[1])^2+(y[2]-y[1])^2)*((x[1]-x[3])^2+(y[1]-y[3])^2)*((x[3]-x[4])^2+(y[3]-y[4])^2)+((x[2]-x[4])^2+(y[2]-y[4])^2)*((x[4]-x[1])^2+(y[4]-y[1])^2)*((x[1]-x[3])^2+(y[1]-y[3])^2)+((x[2]-x[1])^2+(y[2]-y[1])^2)*((x[1]-x[4])^2+(y[1]-y[4])^2)*((x[4]-x[3])^2+(y[4]-y[3])^2)+((x[3]-x[1])^2+(y[3]-y[1])^2)*((x[1]-x[2])^2+(y[1]-y[2])^2)*((x[2]-x[4])^2+(y[2]-y[4])^2)+((x[3]-x[2])^2+(y[3]-y[2])^2)*((x[2]-x[1])^2+(y[2]-y[1])^2)*((x[1]-x[4])^2+(y[1]-y[4])^2)

simplify(q1-q2)

0

``

Download distances.mw

There were errors in V. Now it works but is very slow, even with only a 10 x 10 grid. There are common expressions in the integrand that some hand coding could optimize. One could also play with some of the integration options (method, errors).

restart; with(plots); with(LinearAlgebra); with(Student[VectorCalculus]); V := proc (k, x, t) options operator, arrow; -((1/2)*I)*exp(I*k*x-k^2*t)*(1/(k-I)+1/(k+I)-k*(1/(k^2+I)+1/(k^2-I)))/Pi end proc

proc (k, x, t) options operator, arrow; Student:-VectorCalculus:-`-`(Student:-VectorCalculus:-`*`(Student:-VectorCalculus:-`*`(Student:-VectorCalculus:-`*`(I, Student:-VectorCalculus:-`*`(2, Pi)^Student:-VectorCalculus:-`-`(1)), exp(Student:-VectorCalculus:-`+`(Student:-VectorCalculus:-`*`(Student:-VectorCalculus:-`*`(I, k), x), Student:-VectorCalculus:-`-`(Student:-VectorCalculus:-`*`(k^2, t))))), Student:-VectorCalculus:-`+`(Student:-VectorCalculus:-`+`(Student:-VectorCalculus:-`+`(k, Student:-VectorCalculus:-`-`(I))^Student:-VectorCalculus:-`-`(1), Student:-VectorCalculus:-`+`(k, I)^Student:-VectorCalculus:-`-`(1)), Student:-VectorCalculus:-`-`(Student:-VectorCalculus:-`*`(k, Student:-VectorCalculus:-`+`(Student:-VectorCalculus:-`+`(k^2, I)^Student:-VectorCalculus:-`-`(1), Student:-VectorCalculus:-`+`(k^2, Student:-VectorCalculus:-`-`(I))^Student:-VectorCalculus:-`-`(1))))))) end proc

V(k, x, t)

-((1/2)*I)*exp(I*k*x-k^2*t)*(1/(k-I)+1/(k+I)-k*(1/(k^2+I)+1/(k^2-I)))/Pi

phi1 := (1/8)*Pi; phi2 := 7*Pi*(1/8); k1 := proc (r) options operator, arrow; r*exp(I*phi1) end proc; k2 := proc (r) options operator, arrow; r*exp(I*phi2) end proc; dk1 := proc (r) options operator, arrow; diff(k1(r), r) end proc; dk2 := proc (r) options operator, arrow; diff(k2(r), r) end proc

Integrand now real

integr := `assuming`([simplify(evalc(V(k1(r), x, t)*dk1(r)-V(k2(r), x, t)*dk2(r)))], [r > 0])

r*exp(-(1/2)*(r*t*2^(1/2)+2*cos((3/8)*Pi)*x)*r)*(((r^8-2*r^4+1)*2^(1/2)-2*r^6-2*r^2)*cos((1/2)*(r*t*2^(1/2)-2*cos((1/8)*Pi)*x)*r)+sin((1/2)*(r*t*2^(1/2)-2*cos((1/8)*Pi)*x)*r)*(r^8*2^(1/2)+2*r^6-2*r^2-2^(1/2)))/((r^8+1)*(1+r^4+r^2*2^(1/2))*Pi)

evalf(eval(integr, {r = 2, t = 1, x = 1}))

0.1505152135e-2

u1 := unapply(Int(integr, r = 0 .. infinity), x, t)

proc (x, t) options operator, arrow; Int(r*exp(-(1/2)*(r*t*2^(1/2)+2*cos((3/8)*Pi)*x)*r)*(((r^8-2*r^4+1)*2^(1/2)-2*r^6-2*r^2)*cos((1/2)*(r*t*2^(1/2)-2*cos((1/8)*Pi)*x)*r)+sin((1/2)*(r*t*2^(1/2)-2*cos((1/8)*Pi)*x)*r)*(r^8*2^(1/2)+2*r^6-2*r^2-2^(1/2)))/((r^8+1)*(1+r^4+r^2*2^(1/2))*Pi), r = 0 .. infinity) end proc

Now real - but slow

evalf(u1(2, 1))

0.5826332317e-1

u := proc (x, t) options operator, arrow; exp(-x/sqrt(2))*cos(t-x/sqrt(2))+u1(x, t) end proc

proc (x, t) options operator, arrow; Student:-VectorCalculus:-`+`(Student:-VectorCalculus:-`*`(exp(Student:-VectorCalculus:-`-`(Student:-VectorCalculus:-`*`(x, sqrt(2)^Student:-VectorCalculus:-`-`(1)))), cos(Student:-VectorCalculus:-`+`(t, Student:-VectorCalculus:-`-`(Student:-VectorCalculus:-`*`(x, sqrt(2)^Student:-VectorCalculus:-`-`(1)))))), u1(x, t)) end proc

Very slow but it works

CodeTools:-Usage(plot3d(u(x, t), x = 0 .. 3, t = 0 .. 2*Pi, grid = [10, 10], adaptmesh = false, axes = boxed, shading = zhue, style = surface, labels = ["x", "t", "u(x,t)"]))

memory used=14.20GiB, alloc change=32.00MiB, cpu time=93.38s, real time=80.66s, gc time=22.44s

NULL

Download fokas_method.mw

 

Here's an attempt at a ternary plot. If you want tick marks along the edges of the triangle, that would be tricky to do, but undoubtedly possible. (One edge would be easy because it is along the x-axis.)

restart

with(plots); with(plottools)

prob of m and k successes in N trials with prob p,q per trial

trinomial := proc (m, k, N, p, q) options operator, arrow; factorial(N)*p^m*q^k*(1-p-q)^(N-m-k)/(factorial(m)*factorial(k)*factorial(N-m-k)) end proc

proc (m, k, N, p, q) options operator, arrow; factorial(N)*p^m*q^k*(1-p-q)^(N-m-k)/(factorial(m)*factorial(k)*factorial(N-m-k)) end proc

Ternary coords for m = N at (N,0), k=N at (1/2,sqrt(3)/2)*N, third one =N at the origin. - see  https://en.wikipedia.org/wiki/Ternary_plot

tcoords := proc (m, k) options operator, arrow; (2*m+k)/2., sqrt(3)*k/2. end proc

proc (m, k) options operator, arrow; (2*m+k)/2., sqrt(3)*k/2. end proc

triangle := proc (N) options operator, arrow; polygon([[tcoords(0, N), 0], [tcoords(N, 0), 0], [0, 0, 0]], color = yellow) end proc

pins := proc (N, p, q) options operator, arrow; [seq(seq(line([tcoords(m, k), 0], [tcoords(m, k), trinomial(m, k, N, p, q)], color = red, thickness = 3), m = 0 .. N-k), k = 0 .. N)] end proc

Warning, (in pins) `k` is implicitly declared local

Warning, (in pins) `m` is implicitly declared local

lbls := proc (N) options operator, arrow; textplot3d({[0, 0, 0, cat("var3 = ", N), align = [below, right]], [(1/2)*N, (1/2)*sqrt(3)*N, 0, cat("var2 = ", N), align = [below, right]], [N, 0, 0, cat("var1 = ", N), align = [below, left]]}) end proc

N := 20

20

display(pins(N, .2, .5), triangle(N), lbls(N), axes = normal, labels = ["", "", prob], axis[1, 2] = [color = white])

NULL

Download trinomial.mw

1 2 3 4 5 6 7 Last Page 2 of 83