19069 Reputation

26 Badges

14 years, 145 days

MaplePrimes Activity

These are Posts that have been published by Kitonum


Code of the animation:


N := 192:

A := seq(plot([[.85*sin(t)^3-2+1.25*i/N, .85*(13*cos(t)*(1/15)-(1/3)*cos(2*t)-2*cos(3*t)*(1/15)-(1/15)*cos(4*t)), t = 0 .. Pi*i/N], [-.85*sin(t)^3-2+1.25*i/N, .85*(13*cos(t)*(1/15)-(1/3)*cos(2*t)-2*cos(3*t)*(1/15)-(1/15)*cos(4*t)), t = 0 .. Pi*i/N], [sin(t)^3+2-1.25*i/N, 13*cos(t)*(1/15)-(1/3)*cos(2*t)-2*cos(3*t)*(1/15)-(1/15)*cos(4*t), t = 0 .. Pi*i/N], [-sin(t)^3+2-1.25*i/N, 13*cos(t)*(1/15)-(1/3)*cos(2*t)-2*cos(3*t)*(1/15)-(1/15)*cos(4*t), t = 0 .. Pi*i/N]], color = red, thickness = 5, view = [-3 .. 3, -1.2 .. .9]), i = 1 .. N):

plots[display](A, insequence = true, scaling = constrained, axes = none);

An isometry of the Euclidean plane is a distance-preserving transformation of the plane.  There are four types: translations,  rotations,  reflections,  and  glide reflections. See

Procedure  AreIsometric  checks two plane sets  Set1  and  Set2  and  if there is an isometry of the plane mapping the first set to the second one, then the procedure returns true and false otherwise. Global variable  T  saves the type of isometry and all its parameters. For example, it returns  the rotation center and rotation angle, etc.

Each of the sets  Set1  and  Set2   is the set (or list) consisting of the following objects in any combinations:

1) The points that are defined as a list of coordinates  [х, y] .

2) Segments, which are defined as a set (or list)  of two points  {[x1, y1], [x2, y2]}  or  [[x1, y1], [x2, y2]]  .

3) Curves, which should  be defined as a list of points   [[x1, y1], [x2, y2], ..., [xn, yn]].

Of course, if  n = 2, then the curve is identical to the segment.


Code of the procedure:

AreIsometric:=proc(Set1::{set,list}, Set2::{set,list}) 

local n1, n2, n3, n4,s1, S, s, l1, l2, S11, f, x0, y0, phi, Sol, x, y, M1, M2, A1, A2, A3, A4, B1, B2, B3, B4, line1, line2, line3, line4, u, v, Sign, g, M, Line1, Line2, Line3, A, B, C, h, AB, CD, Eq, Eq1, T1, T2, i, S1, S2, T11; 

global T; 

uses combinat;     


S1:={};  S2:={};  T1:={}; T2:={}; 


for i in Set1 do 

if i[1]::realcons  then S1:={op(S1),i} else 

S1:={op(i), op(S1)};  T1:={op(T1), seq({i[k],i[k+1]}, k=1..nops(i)-1)} fi;  



for i in Set2 do 

if i[1]::realcons  then S2:={op(S2),i} else 

S2:={op(i), op(S2)};  T2:={op(T2), seq({i[k],i[k+1]}, k=1..nops(i)-1)} fi; 



n1:=nops(S1);  n2:=nops(S2);  n3:=nops(T1); n4:=nops(T2); 

if is(S1=S2) and is(T1=T2) then T:=identity;  return true fi; 

if n1<>n2 or n3<>n4 then return false fi; 

if n1=1 then T:=[translation, <S2[1,1]-S1[1,1], S2[1,2]-S1[1,2]>];  return true fi;


f:=(x,y,phi)->[(x-x0)*cos(phi)-(y-y0)*sin(phi)+x0, (x-x0)*sin(phi)+(y-y0)*cos(phi)+y0];  g:=(x,y)->[(B^2*x-A^2*x-2*A*B*y-2*A*C)/(A^2+B^2), (A^2*y-B^2*y-2*A*B*x-2*B*C)/(A^2+B^2)]; 

_Envsignum0 := 1;


s1:=[S1[1], S1[2]];  S:=select(s->is((s1[2,1]-s1[1,1])^2+(s1[2,2]-s1[1,2])^2=(s[2,1]-s[1,1])^2+(s[2,2]-s[1,2])^2),permute(S2, 2));    

for s in S do   


# Checking for translation    

l1:=s[1]-s1[1]; l2:=s[2]-s1[2]; 

if is(l1=l2) then S11:=map(x->x+l1, S1); 

if n3<>0 then T11:={seq(map(x->x+l1, T1[i]), i=1..nops(T1))}; fi; 

if n3=0 then  if is(S11=S2) then T:=[translation, convert(l1, Vector)]; return true fi;  else 

if is(S11=S2) and is(T11=T2) then T:=[translation, convert(l1, Vector)]; return true fi; fi; 



# Checking for rotation   

x0:='x0'; y0:='y0'; phi:='phi'; u:='u'; v:='v'; Sign:='Sign';    

if  is(s1[1]-s[1]<>s1[2]-s[2]) then  

M1:=[(s1[1,1]+s[1,1])/2, (s1[1,2]+s[1,2])/2]; M2:=[(s1[2,1]+s[2,1])/2, (s1[2,2]+s[2,2])/2]; A1:=s1[1,1]-s[1,1]; B1:=s1[1,2]-s[1,2]; A2:=s1[2,1]-s[2,1]; B2:=s1[2,2]-s[2,2];    line1:=A1*(x-M1[1])+B1*(y-M1[2])=0; line2:=A2*(x-M2[1])+B2*(y-M2[2])=0;  

if is(A1*B2-A2*B1<>0) then Sol:=solve({line1, line2}); x0:=simplify(rhs(Sol[1]));   y0:=simplify(rhs(Sol[2])); u:=[s1[1,1]-x0,s1[1,2]-y0]; v:=[s[1,1]-x0,s[1,2]-y0];    else   

if is(s[2]-s1[1]=s[1]-s1[2])  then   x0:=(s1[1,1]+s[1,1])/2;  y0:=(s1[1,2]+s[1,2])/2; 

if is([x0,y0]<>s1[1]) then  u:=[s1[1,1]-x0,s1[1,2]-y0]; v:=[s[1,1]-x0,s[1,2]-y0]; else 

u:=[s1[2,1]-x0,s1[2,2]-y0]; v:=[s[2,1]-x0,s[2,2]-y0]; fi;

else  A3:=s1[2,1]-s1[1,1];  B3:=s1[2,2]-s1[1,2]; A4:=s[2,1]-s[1,1];  B4:=s[2,2]-s[1,2];  line3:=B3*(x-s1[1,1])-A3*(y-s1[1,2])=0;  line4:=B4*(x-s[1,1])-A4*(y-s[1,2])=0;Sol:=solve({line3, line4}); x0:=simplify(rhs(Sol[1])); y0:=simplify(rhs(Sol[2]));   

if is(s1[1]=s[1]) then    u:=s1[2]-[x0,y0]; v:=s[2]-[x0,y0]; else   

u:=s1[1]-[x0,y0]; v:=s[1]-[x0,y0];  fi;  fi;  fi;   

Sign:=signum(u[1]*v[2]-u[2]*v[1]);   phi:=Sign*arccos(expand(rationalize(simplify((u[1]*v[1]+u[2]*v[2])/sqrt(u[1]^2+u[2]^2)/sqrt(v[1]^2+v[2]^2)))));      S11:=expand(rationalize(simplify(map(x->f(op(x), phi), S1))));   

if n3<>0 then T11:={seq(expand(rationalize(simplify(map(x->f(op(x), phi), T1[i])))), i=1..nops(T1))}; fi; 

if n3=0 then  if is(S11=expand(rationalize(simplify(S2))))  then T:=[rotation, [x0,y0], phi]; return true fi;  else 

if is(S11=expand(rationalize(simplify(S2)))) and  is(T11=expand(rationalize(simplify(T2)))) then  

T:=[rotation, [x0,y0], phi]; return true fi;  fi; 





# Checking for reflection or glide reflection   

for s in S do    

AB:=s1[2]-s1[1]; CD:=s[2]-s[1];  

if is(AB[1]*CD[2]-AB[2]*CD[1]=0) then  M:=(s1[2]+s[1])/2;

if  is(AB[1]*CD[1]+ AB[2]*CD[2]>0) then  A:=AB[2]; B:=-AB[1];    Line1:=A*(x-M[1])+B*(y-M[2])=0;  else 

A:=AB[1]; B:=AB[2];  Line2:=A*(x-M[1])+B*(y-M[2])=0; fi;  

else     u:=[AB[1]+CD[1], AB[2]+CD[2]];  A:=u[2]; B:=-u[1];     M:=[(s1[1,1]+s[1,1])/2, (s1[1,2]+s[1,2])/2]; Line3:=A*(x-M[1])+B*(y-M[2])=0;   fi;    C:=-A*M[1]-B*M[2];  h:= simplify(expand(rationalize(s[1]-g(op(s1[1])))));    S11:=expand(rationalize(simplify(map(x->g(op(x))+h, S1))));  

if n3<>0 then T11:={seq(expand(rationalize(simplify(map(x->g(op(x))+h, T1[i])))), i=1..nops(T1))}; fi;    

if n3=0 then   if is(S11=expand(rationalize(S2))) then 

Eq:=A*x+B*y+C=0; Eq1:=`if`(is(coeff(lhs(Eq), y)<>0), y=solve(Eq, y),  x=solve(Eq, x)); 

if h=[0,0] then  T:=[reflection, Eq1] else T:=[glide_reflection,Eq1,convert(h, Vector)] fi; return true fi; else  

if is(S11=expand(rationalize(S2))) and is(T11=expand(rationalize(T2))) then 

Eq:=A*x+B*y+C=0; Eq1:=`if`(is(coeff(lhs(Eq), y)<>0), y=solve(Eq, y),  x=solve(Eq, x)); 

if h=[0,0] then T:=[reflection, Eq1] else

T:=[glide_reflection,Eq1,convert(h, Vector)] fi; return true fi;  fi;   



T:='T';   false;  

end proc:


Three simple examples:

AreIsometric({[4, 0], [7, 4], [14, 0]}, {[4, 14], [9, 14], [10, 6]});  T;


AreIsometric({[2, 0], [2, 2], [5, 0]}, {[3, 3], [3, 6], [5, 3]});  T;


S1 := {[[5, 5], [5, 20], [10, 15], [15, 20], [15, 5]]}: 
S2 := {[[21, 11], [30, 23], [31, 16], [38, 17], [29, 5]]}: 
S3 := {[[50, 23], [41, 11], [51, 16], [49, 5], [58, 17]]}: 
AreIsometric(S1, S2); T; AreIsometric(S1, S3);

plots[display](plottools[curve](op(S1), thickness = 2, color = green), plottools[curve](op(S2), thickness = 2, color = green), plottools[curve](op(S3), thickness = 2, color = red), scaling = constrained, view = [-1 .. 60, -1 .. 25]);  # Green sets are isometric,  green and red sets aren't


Example with animation:

S1:={[0,0],[-1,2],[2,4],[4,2]}:  S2:={[8,3],[6,6],[8,8],[10,4]}:

AreIsometric(S1, S2);  T;  

with(plots): with(plottools): 

#  For clarity, instead of points polygons depicted with vertices at these points 


A:=seq(rotate(polygon([[0,0],[-1,2],[2,4],[4,2]], color=blue), (k*Pi)/(2*N), [3,7]), k=0..N):  B:=polygon([[8,3],[6,6],[8,8],[10,4]], color=green):  E:=line([3,7], [6,6], color=black, linestyle=2): 

C:=seq(rotate(line([3,7], [2,4], color=black, linestyle=2), (k*Pi)/(2*N), [3,7]), k=0..N):  L:=curve([[3,7],[2,4], [-1,2], [0,0],[4,2], [2,4]], color=black, linestyle=2):  T:=textplot([3, 7.2, "Center of rotation"]): 

Frames:=seq(display(A[k], B, E,T,L, C[k]), k=1..N+1):   

display(seq(Frames[k],k=1..N+1), insequence=true, scaling=constrained);



Finding unique solutions to the problem of Queens (m chess queens on an n×n chessboard not attacking one another). Used the procedures  Queens  and  QueenPic  . See

Queens(8, 8);  M := [ListTools[Categorize](AreIsometric, S)]:


seq(op(M[k])[1], k = 1 .. %);   # 12 unique solutions from total 92 solutions

QueensPic([%], 4);  #  Visualization of obtained solutions



Finding unique solutions to the problem "Polygons of matches"  (all polygons with specified perimeter and area). See

N := 12: S := 6: Polygons(N, S);

M := [ListTools[Categorize](AreIsometric, T)]:

n := nops(M);

seq([op(M[k][1])], k = 1 .. n);  #  7 unique solutions from total 35 solutions with perimeter 12 and area 6

Visual([%], 4);  #  Visualization of obtained solutions


Thу post is the answer to

This message contains two procedures . The first procedure called  LargestIncircle  symbolically looks for the largest circle inscribed in a convex polygon . Polygon must be specified as a list of lists of its vertices . If the polygon does not have parallel sides , the problem has a unique solution , otherwise may be several solutions . It is easy to prove that there is always a maximum circle that touches three sides of the polygon . Procedure code based on this property of the optimal solution.

The second procedure called  MinCoveringCircle  symbolically seeking smallest circle that encloses a given set of points. The set of points can be anyone not necessarily being vertices of a convex polygon. Procedure code based on the following geometric properties of the optimal solution , which can easily be proved :

1) The minimum covering circle is unique.

2) The minimum covering circle of a set Set can be determined by at most three points in  Set  which lie on the boundary of the circle. If it is determined by only two points, then the line segment joining those two points must be a diameter of the minimum circle. If it is determined by three points, then the triangle consisting of those three points is not obtuse.


Code of the 1st procedure:



local n, x, y, P, S, T, Eqs, IsInside, OC, Pt, E, R, t, Sol, P0, R1, Circle;

uses combinat, geometry;


n:=nops(L); _EnvHorizontalName := x; _EnvVerticalName := y;

P:=[seq(point(A||i, L[i]), i=1..n)];

if nops(convexhull(P))<n then error "L should be a convex polygon" fi;

S:={seq(line(l||i,[A||i, A||(i+1)]), i=1..n-1), line(l||n,[A||n, A||1])};

Eqs:=map(lhs,{seq(Equation(l||i), i=1..n)});

T:=choose({seq(l||i, i=1..n)}, 3);


IsInside:=proc(Point, OC, Eqs)

convert([seq(is(eval(Eqs[i], {x=Point[1], y=Point[2]})*eval(Eqs[i], {x=OC[1], y=OC[2]})>0), i=1..n)], `and`);

end proc;


OC:=[add(L[i,1], i=1..n)/n, add(L[i,2], i=1..n)/n]; 

R:=0; point(Pt,[x,y]);

   for t in T do

     solve([distance(Pt,t[1])=distance(Pt,t[2]),      distance(Pt,t[2])=distance(Pt,t[3])],[x,y]);

     Sol:=map(a->[rhs(a[1]), rhs(a[2])], %);

     P0:=op(select(b->IsInside(b, OC, Eqs), Sol)); if P0<>NULL then R1:=distance(point(E,P0),      t[1]);

     if convert([seq(is(R1<=distance(E, i)), i=S minus t)], `and`) and is(R1>R) then R:=R1;      Circle:=[P0, R] fi; fi;



end proc:


Code the 2nd procedure:

MinCoveringCircle:=proc(Set::{set, list}(list))

local S, T, t, d, A, B, C, P, R, R1, O1, Coord, L;

uses combinat, geometry; 

if type(Set, list) then S:=convert(Set, set) else S:=Set fi;

T:=choose(S, 2);

   for t in T do

      d:=simplify(distance(point(A, t[1]), point(B, t[2]))); midpoint(C, A, B);

      if convert([seq(is(distance(point(P, p), C)<=d/2), p in S minus {t[1], t[2]})], `and`)   then return            [coordinates(C), d/2] fi;


T:=choose(S, 3);


   for t in T do

      point(A, t[1]); point(B, t[2]); point(C, t[3]);

      if is(distance(A, B)^2<=distance(B, C)^2+distance(A, C)^2 and        distance(A,C)^2<=distance(B,        C)^2+distance(A, B)^2 and distance(B, C)^2 <= distance(A, C)^2 + distance(A, B)^2) then

      circle(c, [A,B,C],'centername'=O1); R1:=radius(c); Coord:=coordinates(O1);

      if convert([seq(is(distance(point(P, p), O1)<=R1), p in S minus {t[1], t[2], t[3]})], `and`) and is(R1<R) then    R:=R1; L:=[Coord, R] fi; fi;



end proc: 


Examples of using the first procedure:



A:=plottools[disk](op(C), color=green):

B:=plottools[polygon](L, style=line, thickness=2):

plots[display](A,B, scaling=constrained);



The procedure can be used to find the largest circle inscribed in a convex shape, bounded by the curves, if these curves are approximated by broken lines:

L:=[seq([k,k^2], k=-1..2, 0.1)]:


A:=plottools[disk](op(C), color=green):

B:=plottools[polygon](L, style=line, thickness=2):

plots[display](A,B, scaling=constrained);



Examples of using the second procedure:



A:=plottools[circle](op(C), color=red, thickness=2):

B:=plottools[polygon](L, color=cyan):




The smallest circle covering 30 random points:

> roll:=rand(1..10):

L:=[seq([roll(), roll()], i=1..30)]:


A:=plottools[circle](op(C), color=red, thickness=2):

B:=seq(plottools[disk](L[i],0.07,color=blue), i=1..nops(L)):

C1:=plottools[disk](C[1], 0.07, color=red):

T:=plots[textplot]([C[1,1]-0.2, C[1,2]-0.2, "C"], font=[TIMES,ROMAN,16]):

plots[display](A, B, C1, T);



The work consists of two independent procedures. The first procedure  IsConvex  checks the convexity of a polygon. The second procedure  IsSimple  verifies the simplicity of a polygon. Formal argument   is the list of vertices of the polygon.

Regarding the basic concepts, see



local n, Z, f, i, x, y;




   for i to n do

    if  convert([seq(is(subs(x=j[1],y=j[2],f[i])<=0), j in {op(X)} minus  {X[i],X[irem(i,n)+1]})],`or`) and      convert([seq(is(subs(x=j[1],y=j[2],f[i])>=0),

    j in {op(X)} minus {X[i],X[irem(i,n)+1]})], `or`) then break fi;


if i<=n then return false else true fi;

end proc:



local n, Z, i, j, f, T, Q, x, y;

Z:=[op(X),X[1],X[2]]; n:=nops(X);

if n>nops({op(X)}) then   return false  fi;

   for i from 2 to nops(Z)-1 do

     if is((Z[i-1,1]-Z[i,1])*(Z[i+1,1]-Z[i,1])+(Z[i-1,2]-Z[i,2])*(Z[i+1,2]-Z[i,2]) =  sqrt((Z[i-1,1] -Z[i,1])^2+(Z[i-1,2]-Z[i,2])^2)*sqrt((Z[i+1,1]-Z[i,1])^2 +(Z[i+1,2]-Z[i,2])^2)) then return false fi;



_Envsignum0:= 0: 

   for i from 1 to n do

   T[i]:=[]; Q[i]:=[];

      for j from 1 to n do

      if modp(j-i,n)<>0 and modp(j-i,n)<>1 and modp(j-i,n)<>n-1 and                  not(signum(subs(x=Z[j,1],y=Z[j,2],f[i])*subs(x=Z[j+1,1],y=Z[j+1,2],f[i]))=-1 and             signum(subs(x=Z[i,1],y=Z[i,2],f[j])*subs(x=Z[i+1,1],y=Z[i+1,2],f[j]))=-1) then

      if (subs(x=Z[j,1],y=Z[j,2],f[i])=0 implies (signum((Z[j,1]-Z[i,1])*(Z[i+1,1]-Z[j,1]))=-1 or             signum((Z[j,2]-Z[i,2])*(Z[i+1,2]-Z[j,2]))=-1)) then

      T[i]:=[op(T[i]),1]; Q[i]:=[op(Q[i]),1] else  T[i]:=[op(T[i]),1]  fi; fi;   od;


convert([seq(nops(T[i])=n-3,i=1..n), seq(nops(Q[i])=n-3,i=1..n)],`and`)  

end proc:



X:=[[0,0],[1,0],[2,1],[3,0],[4,0],[2,2]]: IsConvex(X), IsSimple(X);

X:=[[0,0],[2,0],[1,1],[1,-1]]: IsConvex(X), IsSimple(X);

X:=[[0,0],[2,0],[1,1],[1,0], [-1,-1]]: IsConvex(X), IsSimple(X);

X:=[[0,0],[1,0],[1,2],[-2,2],[-2,-2],[3,-2],[3,4],[-4,4],[-4,-4],[5,-4],[5,6],[-6,6],[-6,-6],[7,-6],[7,8],[-6,8],[-6,7],[6,7],[6,-5],[-5,-5],[-5,5],[4,5],[4,-3],[-3,-3],[-3,3],[2,3],[2,-1],[-1,-1],[-1,1],[0,1]]: IsConvex(X), IsSimple(X);

X:=[seq([cos(2*Pi*k/17), sin(2*Pi*k/17)], k=0..16)]: IsConvex(X), IsSimple(X);


Edited: The variables  x  and  y  are made local.


Well-known problem is the problem of placing eight shess queens on an 8×8 chessboard so that no two queens attack each other. In this post, we consider the same problem of placing  m  shess queens on an  n×n  chessboard. The problem has a solution if  n>3  and  m<=n .

Work consists of two procedures. The first procedure  Queens  returns the total number of solutions and saves a complete list of all solutions (global variable  S ). The second procedure  QueensPic  shows the user-defined solutions from the list  S  on the board. Formal argument  t  is the number of solutions in each row of the display. The second procedure should be used in the standard interface, rather than in the classic one, since in the latter it may not work properly.

Queens := proc (m::posint, n::posint)

local It, K, l, L, M, P;

global S, p, q;

It := proc (L)

local P, k, i, j;

M := []; k := nops(L[1]);

for i in L do

for j to n do

if convert([seq(j <> i[s, 2], s = 1 .. k)], `and`) and convert([seq(l[k+1]-i[s, 1] <> i[s, 2]-j, s = 1 .. k)], `and`) and convert([seq(l[k+1]-i[s, 1] <> j-i[s, 2], s = 1 .. k)], `and`) then M := [op(M), [op(i), [l[k+1], j]]]


od; od;


end proc;

K := combinat:-choose([`$`(1 .. n)], m);

S := [];

for l in K do P := [];

L := [seq([[l[1], i]], i = 1 .. n)];

P := [op(P), op((It@@(m-1))(L))];

S := [op(S), op(P)]


p := args[1]; q := args[2];


end proc:


QueensPic := proc (M, t::posint)

local m, n, HL, VL, T, A, N;

uses plottools, plots;

m := p; n := q; N := nops(args[1]);

HL := seq(line([.5, .5+k], [.5+n, .5+k], color = black, thickness = 2), k = 0 .. n);

VL := seq(line([.5+k, .5], [.5+k, .5+n], color = black, thickness = 2), k = 0 .. n);

T := [seq(textplot([seq([op(M[i, j]), Q], j = 1 .. m)], color = red, font = [TIMES, ROMAN, 24]), i = 1 .. N)];

if m <= n and 3 < n then

A := seq(display(HL, VL, T[k], axes = none, scaling = constrained), k = 1 .. N), seq(display(plot([[0, 0]]), axes = none, scaling = constrained), k = 1 .. t*ceil(N/t)-N);

Matrix(ceil(N/t), t, [A]);



end proc:


Examples of work:

Queens(5, 6);  

S[70], S[140], S[210];

QueensPic([%], 3); 


[[1, 5], [2, 3], [3, 6], [4, 4], [6, 1]], [[1, 3], [2, 5], [4, 1], [5, 4], [6, 2]], [[2, 1], [3, 4], [4, 2], [5, 5], [6, 3]]


Two solutions of classic problem:

Queens(8, 8); 


QueensPic(%, 2);


[[[1, 5], [2, 8], [3, 4], [4, 1], [5, 7], [6, 2], [7, 6], [8, 3]], [[1, 6], [2, 1], [3, 5], [4, 2], [5, 8], [6, 3], [7, 7], [8, 4]]]

First 6 7 8 9 10 11 Page 8 of 11