Kitonum

20354 Reputation

26 Badges

16 years, 8 days

MaplePrimes Activity


These are Posts that have been published by Kitonum

Consider the equation  (2^x)*(27^(1/x)) = 24  for which we need to find the exact values ​​of its real roots. This is not difficult to solve by hand if you first take the logarithm of this equation to any base, after which the problem is reduced to solving a quadratic equation. But the  solve  command fails to solve this equation and returns the result in RootOf form. The problem is solved if we first ask Maple to take the logarithm of the equation. I wonder if the latest versions of Maple also do not directly address the problem?

restart;
Eq:=2^x*27^(1/x)=24:
solve(Eq, x, explicit);

map(ln, Eq); # Taking the logarithm of the equation
solve(%, x);
simplify({%}); # The final result

                  

 

A checkered figure is a connected flat figure consisting of unit squares. The problem is to cut this figure into several equal parts (in area and shape). Cuts can only be made on the sides of the cells. In mathematics, such figures are called polyominoes, and the problem is called the tiling of a certain polyomino with copies of a single polyomino. See https://en.wikipedia.org/wiki/Polyomino

Below are 3 examples of such figures:

We will define such figures by the coordinates of the centers of the squares of which it consists. These points must lie in the first quarter, and points of this figure must lie on each of the coordinate axes.

Below are the codes for two procedures named  CutEqualParts  and  Picture . Required formal parameters of the first procedure: set  S  specifies the initial figure, r is the initial cell for generating subfigures, m is the number of parts into which the original figure needs to be divided. The optional parameter  s  equals (by default onesolution) or allsolutions. The starting cell  r  should be the corner cell of the figure. Then the set of possible subshapes for partitioning will be smaller. If there are no solutions, then the empty set will be returned. The second procedure  Picture  returns a picture of the obtained result as one partition (for a single solution) or in the form of a matrix if there are several solutions. In the second case, the optional parameter  d  specifies the number of rows and columns of this matrix.

restart;
CutEqualParts:=proc(S::set(list),r::list,m::posint, s:=onesolution)
local OneStep, n, i1, i2, j1, j2, R, v0, Tran, Rot, Ref, OneStep1, M, MM, MM1, T, T0, h, N, L;
n:=nops(S)/m;
if irem(nops(S), m)<>0 then error "Should be (nops(S)/m)::integer" fi;
if not (r in S) then error "Should be r in S" fi;
if m=1 then return {S} fi;
if m=nops(S) then return map(t->{t}, S) fi;
i1:=min(map(t->t[1],select(t->t[2]=0,S)));
i2:=max(map(t->t[1],select(t->t[2]=0,S)));
j1:=min(map(t->t[2],select(t->t[1]=0,S)));
j2:=max(map(t->t[2],select(t->t[1]=0,S)));
OneStep:=proc(R)
local n1, R1, P, NoHoles;
R1:=R;
n1:=nops(R1);
R1:={seq(seq(seq(`if`(r1 in S and not (r1 in R1[i]) , subsop(i={R1[i][],r1}, R1)[],NULL),r1=[[R1[i,j][1],R1[i,j][2]-1],[R1[i,j][1]+1,R1[i,j][2]],[R1[i,j][1],R1[i,j][2]+1],[R1[i,j][1]-1,R1[i,j][2]]]), j=1..nops(R1[i])), i=1..n1)};
NoHoles:=proc(s)
local m1, m2, M1, M2, M;
m1:=map(t->t[1],s)[1]; M1:=map(t->t[1],s)[-1];
m2:=map(t->t[2],s)[1]; M2:=map(t->t[2],s)[-1];
M:={seq(seq([i,j],i=m1..M1),j=m2..M2)}; 
if ormap(s1->not (s1 in s) and `and`(seq(s1+t in s, t=[[1,0],[-1,0],[0,1],[0,-1]])), M) then return false fi;
true;
end proc:
P:=proc(t)
if `and`(seq(seq(seq(([i,0] in t) and ([j,0] in t) and not ([k,0] in t) implies not ([k,0] in S), k=i+1..j-1), j=i+2..i2-1), i=i1..i2-2)) and `and`(seq(seq(seq(([0,i] in t) and ([0,j] in t) and not ([0,k] in t) implies not ([0,k] in S), k=i+1..j-1), j=i+2..j2-1), i=j1..j2-2))  then true else false fi;
end proc:
select(t->nops(t)=nops(R[1])+1 and NoHoles(t) and P(t) , R1);
end proc:
R:={{r}}:
R:=(OneStep@@(n-1))(R):
v0:=[floor(max(map(t->t[1], S))/2),floor(max(map(t->t[2], S))/2)]:
h:=max(v0);
Tran:=proc(L,v) L+v; end proc:
Rot:=proc(L, alpha,v0) <cos(alpha),-sin(alpha); sin(alpha),cos(alpha)>.convert(L-v0,Vector)+convert(v0,Vector); convert(%,list); end proc:
Ref:=proc(T) map(t->[t[2],t[1]], T); end proc:
OneStep1:=proc(T)
local T1, n2, R1;
T1:=T; n2:=nops(T1);
T1:={seq(seq(`if`(r1 intersect `union`(T1[i][])={}, subsop(i={T1[i][],r1}, T1), NULL)[], r1=MM1 minus T1[i]), i=1..n2)};
end proc:
N:=0; 
for M in R do
MM:={seq(seq(seq(map(t->Tran(Rot(t,Pi*k/2,v0),[i,j]),M),i=-h-1..h+1),j=-h-1..h+1),k=0..3),seq(seq(seq(map(t->Tran(Rot(t,Pi*k/2,v0),[i,j]),Ref(M)),i=-h-1..h+1),j=-h-1..h+1), k=0..3)}:
MM1:=select(t->(t intersect S)=t, MM):
T:={{M}}:
T:=(OneStep1@@(m-1))(T):
T0:=select(t->nops(t)=m, T):
if T0<>{} then if s=onesolution then return T0[1] else N:=N+1;
 L[N]:=T0[] fi; fi; 
od:
L:=convert(L,list);
if L[]::symbol then return {} else L fi;
end proc:
Picture:=proc(L::{list,set},Colors::list,d:=NULL)
local r;
uses plots, plottools;
if L::set or (L::list and nops(L)=1) or d=NULL then return
display( seq(polygon~(map(t->[[t[1]-1/2,t[2]-1/2],[t[1]+1/2,t[2]-1/2],[t[1]+1/2,t[2]+1/2],[t[1]-1/2,t[2]+1/2]] ,`if`(L::set,L[j],L[1][j])), color=Colors[j]),j=1..nops(Colors)) , scaling=constrained, size=[800,600]) fi;
if d::list then r:=irem(nops(L),d[2]);
if r=0 then return
display(Matrix(d[],[seq(display(seq(polygon~(map(t->[[t[1]-1/2,t[2]-1/2],[t[1]+1/2,t[2]-1/2],[t[1]+1/2,t[2]+1/2],[t[1]-1/2,t[2]+1/2]]  ,L[i,j]), color=Colors[j]),j=1..nops(Colors)), scaling=constrained, size=[400,300], axes=none), i=1..nops(L))])) else
display(Matrix(d[],[seq(display(seq(polygon~(map(t->[[t[1]-1/2,t[2]-1/2],[t[1]+1/2,t[2]-1/2],[t[1]+1/2,t[2]+1/2],[t[1]-1/2,t[2]+1/2]]  ,L[i,j]), color=Colors[j]),j=1..nops(Colors)), scaling=constrained, size=[400,300], axes=none), i=1..nops(L)), seq(plot([[0,0]], axes=none, size=[10,10]),k=1..d[2]-r)]))  fi; fi; 
end proc:

Examples of use for figures 1, 2, 3
In the first example for Fig.1 we get 4 solutions for m=4:

S:=({seq(seq([i,j], i=0..4), j=0..2)} union {[2,3],[3,3],[3,4]}) minus {[0,0],[0,1]}:
L:=CutEqualParts(S,[0,2],4,allsolutions);
C:=["Cyan","Red","Yellow","Green"]:
nops(L);
Picture(L,C,[2,2]);

In the second example for Fig.2 for m=2, we get 60 solutions (the first 16 are shown in the figure):

S:={seq(seq([i,j], i=0..4), j=0..4)} minus {[2,2]}:
L:=CutEqualParts(S,[0,0],2,allsolutions):
nops(L);
 C:=["Cyan","Red"]:
Picture(L[1..16],C,[4,4]);


In the third example for Fig.3 and  m=2  there will be a unique solution:

S:={seq(seq([i,j], i=0..5), j=0..3)}  minus {[5,0],[4,2]} union {[1,4],[2,4]}:
L:=CutEqualParts(S,[0,0],2):
 C:=["Cyan","Red"]:
Picture(L,C);


Addition. It is proven that the problem of tiling a certain polyomino with several copies of a single polyomino is NP-complete. Therefore, it is recommended to use the CutEqualParts procedure when the numbers  nops(S)  and  nops(S)/m  are relatively small (nops(S)<=24  and nops(S)/m<=12), otherwise the execution time may be unacceptably long.

Cutting_equal_parts.mw

In the two examples below (in the second example, the range for the roots is simply expanded), we see bugs in both examples (Maple 2018.2). I wonder if these errors are fixed in Maple 2020?
 

restart;

solve({log[1/3](2*sin(x)^2-3*cos(2*x)+6)=-2,x>=-7*Pi/2,x<=-2*Pi}, explicit, allsolutions); # Example 1 - strange error message
solve({log[1/3](2*sin(x)^2-3*cos(2*x)+6)=-2,x>=-4*Pi,x<=-2*Pi}, explicit, allsolutions);  # Example 2 - two roots missing

Error, (in assume) contradictory assumptions

 

{x = -(11/3)*Pi}, {x = -(10/3)*Pi}

(1)

plot(log[1/3](2*sin(x)^2-3*cos(2*x)+6)+2, x=-7*Pi/2..-2*Pi);
plot(log[1/3](2*sin(x)^2-3*cos(2*x)+6)+2, x=-4*Pi..-2*Pi);

 

 

Student:-Calculus1:-Roots(log[1/3](2*sin(x)^2-3*cos(2*x)+6)=-2, x=-7*Pi/2..-2*Pi);  # OK
Student:-Calculus1:-Roots(log[1/3](2*sin(x)^2-3*cos(2*x)+6)=-2, x=-4*Pi..-2*Pi);  # OK

[-(10/3)*Pi, -(8/3)*Pi, -(7/3)*Pi]

 

[-(11/3)*Pi, -(10/3)*Pi, -(8/3)*Pi, -(7/3)*Pi]

(2)

 


I am glad that  Student:-Calculus1:-Roots  command successfully handles both examples.

 

Download bugs-in-solve.mw

When we plot a curve with the option  style=point  , symbols go evenly not along the length of this curve, but along the range of the independent variable. For this reason the plot often looks unattractive. Here are two examples. In the first example, the default option  adaptive=true  is used, in which Maple adds points in some places.

restart;
plot(surd(x,3), x=-2.5..2.5, style=point, scaling=constrained, symbol=solidcircle, symbolsize=8, numpoints=30, size=[800,300]);
plot(surd(x,3), x=-2.5..2.5, style=point, scaling=constrained, symbol=solidcircle, symbolsize=8, numpoints=30, adaptive=false, size=[800,300]);

                

                           


The  UniformPointPlot  procedure allows you to plot curves by symbols (as for  style=point), and these symbols go from each other at equal distances, measured along this curve. The procedure uses a well-known formula for the length of a curve in two and three dimensions. The procedure parameters are clear from the three examples below.

UniformPointPlot:=proc(F::{algebraic,list},eq::`=`,n::posint:=40,Opt::list:=[symbol=solidcircle, symbolsize=8, scaling=constrained])
local t, R, P, g, L, step, L1, L2;
uses plots;
Digits:=4:
t:=lhs(eq); R:=rhs(eq);
P:=`if`(type(F,algebraic),[t,F],F); 
g:=x->`if`(F::algebraic or nops(F)=2,evalf(Int(sqrt(diff(P[1],t)^2+diff(P[2],t)^2), t=lhs(R)..x, epsilon=0.001)),evalf(Int(sqrt(diff(P[1],t)^2+diff(P[2],t)^2+diff(P[3],t)^2), t=lhs(R)..x, epsilon=0.001))):
L:=g(rhs(R)); step:=L/(n-1);
L1:=[lhs(R),seq(fsolve(g-k*step, fulldigits),k=1..n-2),rhs(R)];
L2:=map(s->`if`(type(F,algebraic),[s,eval(F,t=s)],eval(F,t=s)), L1):
`if`(F::algebraic or nops(F)=2,plot(L2, style=point, Opt[]),pointplot3d(L2, Opt[]));
end proc:

   
Examples of use:

UniformPointPlot(surd(x,3), x=-2.5..2.5, 30);

                             

UniformPointPlot([5*cos(t),3*sin(t)], t=0..2*Pi, [color=red,symbol=solidcircle,scaling=constrained, symbolsize=8,  size=[800,400]]);

                             

UniformPointPlot([cos(t),sin(t),2-2*cos(t)], t=0..2*Pi, 41, [color=red,symbol=solidsphere, symbolsize=8,scaling=constrained, labels=[x,y,z]]);

                             
Here's another example of using the same technique as in the procedure. In this example, we are plotting Archimedean spiral uniformly colored with 7 rainbow colors:

f:=t->[t*cos(t),t*sin(t)]:
g:=t->evalf(Int(sqrt(diff(f(s)[1],s)^2+diff(f(s)[2],s)^2), s=0..t)):
h:=s->fsolve(s=g(t), t):
L:=evalf(g(2*Pi)): step:=L/7:
L1:=[0,seq(h(k*step), k=1..6),2*Pi]:
Colors:=convert~([Red,Orange,Yellow,Green,Blue,Indigo,Violet], string):
plots:-display(seq(plot([f(t)[], t=L1[i]..L1[i+1]], color=Colors[i], thickness=12), i=1..7), scaling=constrained, size=[500,400]);

                             

Uniform_Point_Plot.mw

The following puzzle prompted me to write this post: "A figure is drawn on checkered paper that needs to be cut into 2 equal parts (the cuts must pass along the sides of the squares.)" (parts are called equal if, after cutting, they can be superimposed on one another, that is, if one of them can be moved, rotated and (if need to) flip so that they completely coincide) (see the first picture below). 
I could not solve it manually and wrote a procedure called  CutTwoParts  that does this automatically (of course, this procedure applies to other similar puzzles). This procedure uses my procedure  AreIsometric  published earlier  https://www.mapleprimes.com/posts/200157-Testing-Of-Two-Plane-Sets-For-Isometry  (for convenience, I have included its text here). In the procedure  CutTwoParts  the figure is specified by the coordinates of the centers of the squares of which it consists).

I advise everyone to first try to solve this puzzle manually in order to feel its non-triviality, and only then load the worksheet with the procedure for automatic solution.


For some reason, the worksheet did not load and I was only able to insert the link.

Cuttings.mw



 

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