reduce-historical/r38/packages/geometry/geometry.rlg

Thu Jan 28 23:37:50 MET 1999
REDUCE 3.7, 15-Jan-99 ...

1: 1: 
2: 2: 2: 2: 2: 2: 2: 2: 2: 
 Geometry  1.1  Last update  Sept 6, 1998 

3: 3: % Author H.-G. Graebe | Univ. Leipzig | Version 6.9.1998
% graebe@informatik.uni-leipzig.de

comment 

Test suite for the package GEOMETRY 1.1

end comment;


algebraic;


load cali,geometry;


off nat;


on echo;


showtime;


Time: 190 ms



% #####################
% Some one line proofs
% #####################

% A generic triangle ABC

A:=Point(a1,a2);


a := {a1,a2}$
 B:=Point(b1,b2);


b := {b1,b2}$
 C:=Point(c1,c2);


c := {c1,c2}$


% Its midpoint perpendiculars have a point in common:

	concurrent(mp(a,b),mp(b,c),mp(c,a));


0$

 
% This point

	M:=intersection_point(mp(a,b),mp(b,c));


m := {(a1**2*b2 - a1**2*c2 + a2**2*b2 - a2**2*c2 - a2*b1**2 - a2*b2**2 + a2*c1**
2 + a2*c2**2 + b1**2*c2 + b2**2*c2 - b2*c1**2 - b2*c2**2)/(2*(a1*b2 - a1*c2 - a2
*b1 + a2*c1 + b1*c2 - b2*c1)),
( - a1**2*b1 + a1**2*c1 + a1*b1**2 + a1*b2**2 - a1*c1**2 - a1*c2**2 - a2**2*b1 +
 a2**2*c1 - b1**2*c1 + b1*c1**2 + b1*c2**2 - b2**2*c1)/(2*(a1*b2 - a1*c2 - a2*b1
 + a2*c1 + b1*c2 - b2*c1))}$


% is the center of the circumscribed circle

	sqrdist(M,A) - sqrdist(M,B);


0$
	

% The altitutes intersection theorem

	concurrent(altitude(a,b,c),altitude(b,c,a),altitude(c,a,b));


0$


% The median intersection theorem

	concurrent(median(a,b,c),median(b,c,a),median(c,a,b));


0$


% Euler's line

        M:=intersection_point(mp(a,b),mp(b,c));


m := {(a1**2*b2 - a1**2*c2 + a2**2*b2 - a2**2*c2 - a2*b1**2 - a2*b2**2 + a2*c1**
2 + a2*c2**2 + b1**2*c2 + b2**2*c2 - b2*c1**2 - b2*c2**2)/(2*(a1*b2 - a1*c2 - a2
*b1 + a2*c1 + b1*c2 - b2*c1)),
( - a1**2*b1 + a1**2*c1 + a1*b1**2 + a1*b2**2 - a1*c1**2 - a1*c2**2 - a2**2*b1 +
 a2**2*c1 - b1**2*c1 + b1*c1**2 + b1*c2**2 - b2**2*c1)/(2*(a1*b2 - a1*c2 - a2*b1
 + a2*c1 + b1*c2 - b2*c1))}$

        H:=intersection_point(altitude(a,b,c),altitude(b,c,a));


h := {( - a1*a2*b1 + a1*a2*c1 + a1*b1*b2 - a1*c1*c2 - a2**2*b2 + a2**2*c2 + a2*
b2**2 - a2*c2**2 - b1*b2*c1 + b1*c1*c2 - b2**2*c2 + b2*c2**2)/(a1*b2 - a1*c2 - 
a2*b1 + a2*c1 + b1*c2 - b2*c1),
(a1**2*b1 - a1**2*c1 + a1*a2*b2 - a1*a2*c2 - a1*b1**2 + a1*c1**2 - a2*b1*b2 + a2
*c1*c2 + b1**2*c1 + b1*b2*c2 - b1*c1**2 - b2*c1*c2)/(a1*b2 - a1*c2 - a2*b1 + a2*
c1 + b1*c2 - b2*c1)}$

        S:=intersection_point(median(a,b,c),median(b,c,a));


s := {(a1 + b1 + c1)/3,(a2 + b2 + c2)/3}$


                collinear(M,H,S);


0$

                sqrdist(S,varpoint(M,H,2/3));


0$


% Feuerbach's circle

	% Choose a special coordinate system
	A:=Point(0,0);


a := {0,0}$
 B:=Point(u1,0);


b := {u1,0}$
 C:=Point(u2,u3);


c := {u2,u3}$


        M:=intersection_point(mp(a,b),mp(b,c));


m := {u1/2,( - u1*u2 + u2**2 + u3**2)/(2*u3)}$

        H:=intersection_point(altitude(a,b,c),altitude(b,c,a));


h := {u2,(u2*(u1 - u2))/u3}$

        N:=midpoint(M,H);


n := {(u1 + 2*u2)/4,(u1*u2 - u2**2 + u3**2)/(4*u3)}$


                sqrdist(N,midpoint(A,B))-sqrdist(N,midpoint(B,C));


0$

                sqrdist(N,midpoint(A,B))-sqrdist(N,midpoint(H,C));


0$


        D:=intersection_point(pp_line(A,B),pp_line(H,C));


d := {u2,0}$


                sqrdist(N,midpoint(A,B))-sqrdist(N,D);


0$


clear_ndg();


{}$
 clear(A,B,C,D,M,H,S,N);



% ############################# 
% Non-linear Geometric Objects
% #############################

% Bisector intersection theorem
 
A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 C:=Point(u1,u2);


c := {u1,u2}$

P:=Point(x1,x2);


p := {x1,x2}$

 
polys:={
        point_on_bisector(P,A,B,C),
        point_on_bisector(P,B,C,A),
        point_on_bisector(P,C,A,B)};


polys := { - 2*u1*x1*x2 + 2*u1*x2 + u2*x1**2 - 2*u2*x1 - u2*x2**2 + u2 + 2*x1*x2
 - 2*x2,
 - 2*u1**3*x2 + 2*u1**2*u2*x1 - u1**2*u2 + 2*u1**2*x1*x2 + 2*u1**2*x2 - 2*u1*u2
**2*x2 - 2*u1*u2*x1**2 + 2*u1*u2*x2**2 - 2*u1*x1*x2 + 2*u2**3*x1 - u2**3 - 2*u2
**2*x1*x2 + 2*u2**2*x2 + u2*x1**2 - u2*x2**2,
2*u1*x1*x2 - u2*x1**2 + u2*x2**2}$


con1:=num(sqrdist(P,pedalpoint(p,pp_line(A,C)))-x2^2);


con1 := u2*( - 2*u1**3*x1*x2 + u1**2*u2*x1**2 - u1**2*u2*x2**2 - 2*u1*u2**2*x1*
x2 + u2**3*x1**2 - u2**3*x2**2)$

con2:=num(sqrdist(p,pedalpoint(p,pp_line(B,C)))-x2^2);


con2 := u2*( - 2*u1**3*x1*x2 + 2*u1**3*x2 + u1**2*u2*x1**2 - 2*u1**2*u2*x1 - u1
**2*u2*x2**2 + u1**2*u2 + 6*u1**2*x1*x2 - 6*u1**2*x2 - 2*u1*u2**2*x1*x2 + 2*u1*
u2**2*x2 - 2*u1*u2*x1**2 + 4*u1*u2*x1 + 2*u1*u2*x2**2 - 2*u1*u2 - 6*u1*x1*x2 + 6
*u1*x2 + u2**3*x1**2 - 2*u2**3*x1 - u2**3*x2**2 + u2**3 + 2*u2**2*x1*x2 - 2*u2**
2*x2 + u2*x1**2 - 2*u2*x1 - u2*x2**2 + u2 + 2*x1*x2 - 2*x2)$


setring({x1,x2},{},lex);


{{x1,x2},{},lex,{1,1}}$

setideal(polys,polys);


{u2*x1**2 - (2*u1 - 2)*x1*x2 - (2*u2)*x1 - u2*x2**2 + (2*u1 - 2)*x2 + u2,
 - (2*u1*u2 - u2)*x1**2 + (2*u1**2 - 2*u1 - 2*u2**2)*x1*x2 + (2*u1**2*u2 + 2*u2
**3)*x1 + (2*u1*u2 - u2)*x2**2 - (2*u1**3 - 2*u1**2 + 2*u1*u2**2 - 2*u2**2)*x2 -
 (u1**2*u2 + u2**3),
 - u2*x1**2 + (2*u1)*x1*x2 + u2*x2**2}$

gbasis polys;


{(4*u2)*x2**4 - (8*u1**2 - 8*u1 + 8*u2**2)*x2**3 + (4*u1**2*u2 - 4*u1*u2 + 4*u2
**3 - 4*u2)*x2**2 + (4*u2**2)*x2 - u2**3,
(2*u1*u2**2 - u2**2)*x1 + (2*u2)*x2**3 - (4*u1**2 - 4*u1 + 2*u2**2)*x2**2 - (2*
u1**2*u2 - 2*u1*u2 + 2*u2)*x2 - (u1*u2**2 - u2**2)}$

{con1,con2} mod gbasis polys;


{0,0}$


% Bisector intersection theorem. A constructive proof.
 
A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 P:=Point(u1,u2);


p := {u1,u2}$

l1:=pp_line(A,B);


l1 := {0,-1,0}$

l2:=symline(l1,pp_line(A,P));


l2 := { - 2*u1*u2,u1**2 - u2**2,0}$

l3:=symline(l1,pp_line(B,P));


l3 := {2*u2*( - u1 + 1),
u1**2 - 2*u1 - u2**2 + 1,
2*u2*(u1 - 1)}$


point_on_bisector(P,A,B,intersection_point(l2,l3));


0$


clear_ndg();


{}$
 clear(A,B,C,P,l1,l2,l3);



% Miquel's theorem

on gcd;


A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 C:=Point(c1,c2);


c := {c1,c2}$

P:=choose_pl(pp_line(A,B),u1);


p := {u1,0}$

Q:=choose_pl(pp_line(B,C),u2);


q := {u2,(c2*(u2 - 1))/(c1 - 1)}$

R:=choose_pl(pp_line(A,C),u3);


r := {u3,(c2*u3)/c1}$


X:=other_cc_point(P,p3_circle(A,P,R),p3_circle(B,P,Q))$



point_on_circle(X,p3_circle(C,Q,R));


0$


off gcd;


clear_ndg();


{}$
 clear(A,B,C,P,Q,R,X);



% ########################
% Theorems of linear type
% ########################

% Pappus' theorem

A:=Point(u1,u2);


a := {u1,u2}$
 B:=Point(u3,u4);


b := {u3,u4}$
 C:=Point(x1,u5);


c := {x1,u5}$
 
P:=Point(u6,u7);


p := {u6,u7}$
 Q:=Point(u8,u9);


q := {u8,u9}$
 R:=Point(u0,x2);


r := {u0,x2}$


polys:={collinear(A,B,C), collinear(P,Q,R)};


polys := {u1*u4 - u1*u5 - u2*u3 + u2*x1 + u3*u5 - u4*x1,
u0*u7 - u0*u9 + u6*u9 - u6*x2 - u7*u8 + u8*x2}$


con:=collinear(
	intersection_point(pp_line(A,Q),pp_line(P,B)),
	intersection_point(pp_line(A,R),pp_line(P,C)),
	intersection_point(pp_line(B,R),pp_line(Q,C)))$



vars:={x1,x2};


vars := {x1,x2}$

sol:=solve(polys,vars);


sol := {{x1=( - u1*u4 + u1*u5 + u2*u3 - u3*u5)/(u2 - u4),
x2=(u0*u7 - u0*u9 + u6*u9 - u7*u8)/(u6 - u8)}}$


sub(sol,con);


0$


% Pappus' theorem. A constructive approach

A:=Point(u1,u2);


a := {u1,u2}$
 B:=Point(u3,u4);


b := {u3,u4}$
  
P:=Point(u6,u7);


p := {u6,u7}$
 Q:=Point(u8,u9);


q := {u8,u9}$
 

C:=choose_pl(pp_line(A,B),u5);


c := {u5,
(u1*u4 - u2*u3 + u2*u5 - u4*u5)/(u1 - u3)}$

R:=choose_pl(pp_line(P,Q),u0);


r := {u0,
(u0*u7 - u0*u9 + u6*u9 - u7*u8)/(u6 - u8)}$


con:=collinear(intersection_point(pp_line(A,Q),pp_line(P,B)),
	intersection_point(pp_line(A,R),pp_line(P,C)),
	intersection_point(pp_line(B,R),pp_line(Q,C)));


con := 0$


clear_ndg();


{}$
 clear(A,B,C,P,Q,R);



% ###########################
% Theorems of non linear type
% ###########################

% Fermat Point

A:=Point(0,0);


a := {0,0}$
 B:=Point(0,2);


b := {0,2}$
 C:=Point(u1,u2);


c := {u1,u2}$

P:=Point(x1,x2);


p := {x1,x2}$
 Q:=Point(x3,x4);


q := {x3,x4}$
 R:=Point(x5,x6);


r := {x5,x6}$


polys1:={sqrdist(P,B)-sqrdist(B,C), sqrdist(P,C)-sqrdist(B,C), 
	sqrdist(Q,A)-sqrdist(A,C), sqrdist(Q,C)-sqrdist(A,C), 
	sqrdist(R,B)-sqrdist(A,B), sqrdist(R,A)-sqrdist(A,B)};


polys1 := { - u1**2 - u2**2 + 4*u2 + x1**2 + x2**2 - 4*x2,
 - 2*u1*x1 - 2*u2*x2 + 4*u2 + x1**2 + x2**2 - 4,
 - u1**2 - u2**2 + x3**2 + x4**2,
 - 2*u1*x3 - 2*u2*x4 + x3**2 + x4**2,
x5**2 + x6**2 - 4*x6,
x5**2 + x6**2 - 4}$


con:=concurrent(pp_line(A,P), pp_line(B,Q), pp_line(C,R));


con :=  - u1*x1*x4*x6 + 2*u1*x1*x6 + u1*x2*x3*x6 - 2*u1*x2*x3 + 2*u2*x1*x3 + u2*
x1*x4*x5 - 2*u2*x1*x5 - u2*x2*x3*x5 - 2*x1*x3*x6 + 2*x2*x3*x5$


vars:={x1,x2,x3,x4,x5,x6};


vars := {x1,
x2,
x3,
x4,
x5,
x6}$

setring(vars,{},lex);


{{x1,x2,x3,x4,x5,x6},{},lex,{1,1,1,1,1,1}}$

iso:=isolatedprimes polys1;


iso := {{x5**2 - 3,
x6 - 1,
u1*x5 - u2 + 2*x4,
 - u1*x5 - u2 + 2*x2 - 2,
 - u1 - u2*x5 + 2*x3,
 - u1 + u2*x5 + 2*x1 - 2*x5},
{x5**2 - 3,
x6 - 1,
 - u1*x5 - u2 + 2*x4,
u1*x5 - u2 + 2*x2 - 2,
 - u1 + u2*x5 + 2*x3,
 - u1 - u2*x5 + 2*x1 + 2*x5},
{x5**2 - 3,
x6 - 1,
u1*x5 - u2 + 2*x4,
u1*x5 - u2 + 2*x2 - 2,
 - u1 - u2*x5 + 2*x3,
 - u1 - u2*x5 + 2*x1 + 2*x5},
{x5**2 - 3,
x6 - 1,
 - u1*x5 - u2 + 2*x4,
 - u1*x5 - u2 + 2*x2 - 2,
 - u1 + u2*x5 + 2*x3,
 - u1 + u2*x5 + 2*x1 - 2*x5}}$


for each u in iso collect con mod u;


{ - 3*u1**2*u2 + 3*u1**2 - 2*u1*u2*x5 + 2*u1*x5 - 3*u2**3 + 9*u2**2 - 6*u2,
0,
(u1**3*x5 + 3*u1**2*u2 - 6*u1**2 + u1*u2**2*x5 - 4*u1*u2*x5 + 3*u2**3 - 18*u2**2
 + 24*u2)/2,
( - u1**3*x5 + 3*u1**2*u2 - u1*u2**2*x5 + 4*u1*x5 + 3*u2**3 - 12*u2)/2}$


polys2:={sqrdist(P,B)-sqrdist(P,C), 
	sqrdist(Q,A)-sqrdist(Q,C),  
	sqrdist(R,A)-sqrdist(R,B), 
	num(p3_angle(R,A,B)-p3_angle(P,B,C)), 
	num(p3_angle(Q,C,A)-p3_angle(P,B,C))};


polys2 := { - u1**2 + 2*u1*x1 - u2**2 + 2*u2*x2 - 4*x2 + 4,
 - u1**2 + 2*u1*x3 - u2**2 + 2*u2*x4,
4*(x6 - 1),
 - u1*x1*x5 - u1*x2*x6 + 2*u1*x6 + u2*x1*x6 - u2*x2*x5 + 2*u2*x5 - 2*x1*x6 + 2*
x2*x5 - 4*x5,
u1**3*x2 - 2*u1**3 - u1**2*u2*x1 + u1**2*x1*x4 + 2*u1**2*x1 - u1**2*x2*x3 + 2*u1
**2*x3 + u1*u2**2*x2 - 2*u1*u2**2 - 2*u1*x1*x3 - 2*u1*x2*x4 + 4*u1*x4 - u2**3*x1
 + u2**2*x1*x4 + 2*u2**2*x1 - u2**2*x2*x3 + 2*u2**2*x3 - 2*u2*x1*x4 + 2*u2*x2*x3
 - 4*u2*x3}$


sol:=solve(polys2,{x1,x2,x3,x4,x6});


sol := {{x2=( - u1*x5 + u2 + 2)/2,
x4=(u1*x5 + u2)/2,
x1=(u1 + u2*x5 - 2*x5)/2,
x3=(u1 - u2*x5)/2,
x6=1}}$

sub(sol,con);


0$


clear_ndg();


{}$
 clear(A,B,C,P,Q,R);



% ####################
%  Desargue's theorem
% ####################

% A constructive proof.

A:=Point(a1,a2);


a := {a1,a2}$
 B:=Point(b1,b2);


b := {b1,b2}$
 
C:=Point(c1,c2);


c := {c1,c2}$
 R:=Point(d1,d2);


r := {d1,d2}$


S:=choose_pl(par(R,pp_line(A,B)),u);


s := {u,
(a1*d2 - a2*d1 + a2*u - b1*d2 + b2*d1 - b2*u)/(a1 - b1)}$

T:=intersection_point(par(R,pp_line(A,C)),par(S,pp_line(B,C)));


t := {(a1*u - b1*d1 + c1*d1 - c1*u)/(a1 - b1),
(a1*d2 - a2*d1 + a2*u - b1*d2 + c2*d1 - c2*u)/(a1 - b1)}$

 
con:=concurrent(pp_line(A,R),pp_line(B,S),pp_line(C,T));


con := 0$


% Desargue's theorem as theorem of linear type.

A:=Point(u1,u2);


a := {u1,u2}$
 B:=Point(u3,u4);


b := {u3,u4}$
 C:=Point(u5,u6);


c := {u5,u6}$

R:=Point(u7,u8);


r := {u7,u8}$
 S:=Point(u9,x1);


s := {u9,x1}$
 T:=Point(x2,x3);


t := {x2,x3}$


polys:={parallel(pp_line(R,S),pp_line(A,B)),
	parallel(pp_line(S,T),pp_line(B,C)),
	parallel(pp_line(R,T),pp_line(A,C))};


polys := { - u1*u8 + u1*x1 + u2*u7 - u2*u9 + u3*u8 - u3*x1 - u4*u7 + u4*u9,
 - u3*x1 + u3*x3 + u4*u9 - u4*x2 + u5*x1 - u5*x3 - u6*u9 + u6*x2,
 - u1*u8 + u1*x3 + u2*u7 - u2*x2 + u5*u8 - u5*x3 - u6*u7 + u6*x2}$


con:=concurrent(pp_line(A,R),pp_line(B,S),pp_line(C,T));


con :=  - u1*u3*u6*u8 + u1*u3*u6*x1 + u1*u3*u8*x3 - u1*u3*x1*x3 + u1*u4*u5*u8 - 
u1*u4*u5*x3 - u1*u4*u6*u9 + u1*u4*u6*x2 - u1*u4*u8*x2 + u1*u4*u9*x3 - u1*u5*u8*
x1 + u1*u5*x1*x3 + u1*u6*u8*u9 - u1*u6*x1*x2 - u1*u8*u9*x3 + u1*u8*x1*x2 - u2*u3
*u5*x1 + u2*u3*u5*x3 + u2*u3*u6*u7 - u2*u3*u6*x2 - u2*u3*u7*x3 + u2*u3*x1*x2 - 
u2*u4*u5*u7 + u2*u4*u5*u9 + u2*u4*u7*x2 - u2*u4*u9*x2 + u2*u5*u7*x1 - u2*u5*u9*
x3 - u2*u6*u7*u9 + u2*u6*u9*x2 + u2*u7*u9*x3 - u2*u7*x1*x2 + u3*u5*u8*x1 - u3*u5
*u8*x3 - u3*u6*u7*x1 + u3*u6*u8*x2 + u3*u7*x1*x3 - u3*u8*x1*x2 + u4*u5*u7*x3 - 
u4*u5*u8*u9 + u4*u6*u7*u9 - u4*u6*u7*x2 - u4*u7*u9*x3 + u4*u8*u9*x2 - u5*u7*x1*
x3 + u5*u8*u9*x3 + u6*u7*x1*x2 - u6*u8*u9*x2$


sol:=solve(polys,{x1,x2,x3});


sol := {{x1=(u1*u8 - u2*u7 + u2*u9 - u3*u8 + u4*u7 - u4*u9)/(u1 - u3),
x2=(u1*u9 - u3*u7 + u5*u7 - u5*u9)/(u1 - u3),
x3=(u1*u8 - u2*u7 + u2*u9 - u3*u8 + u6*u7 - u6*u9)/(u1 - u3)}}$

sub(sol,con);


0$


% The general theorem of Desargue.

A:=Point(0,0);


a := {0,0}$
 B:=Point(0,1);


b := {0,1}$
 C:=Point(u5,u6);


c := {u5,u6}$

R:=Point(u7,u8);


r := {u7,u8}$
 S:=Point(u9,u1);


s := {u9,u1}$
 T:=Point(u2,x1);


t := {u2,x1}$


con1:=collinear(intersection_point(pp_line(R,S),pp_line(A,B)),
	intersection_point(pp_line(S,T),pp_line(B,C)),
	intersection_point(pp_line(R,T),pp_line(A,C)));


con1 := (u5*( - u1**2*u2**2*u6*u7 + u1**2*u2*u5*u7*x1 + u1**2*u2*u6*u7**2 - u1**
2*u5*u7**2*x1 + u1*u2**2*u6*u7*u8 + u1*u2**2*u6*u7 + u1*u2**2*u6*u8*u9 - u1*u2**
2*u8*u9 - u1*u2*u5*u7*u8*x1 - u1*u2*u5*u7*x1 - u1*u2*u5*u8*u9*x1 + u1*u2*u5*u8*
u9 - u1*u2*u6*u7**2*x1 - u1*u2*u6*u7**2 - 2*u1*u2*u6*u7*u8*u9 + u1*u2*u6*u7*u9*
x1 - u1*u2*u6*u7*u9 + u1*u2*u7*u8*u9 + u1*u2*u7*u9*x1 + u1*u5*u7**2*x1**2 + u1*
u5*u7**2*x1 + 2*u1*u5*u7*u8*u9*x1 - u1*u5*u7*u8*u9 - u1*u5*u7*u9*x1**2 + u1*u6*
u7**2*u9 - u1*u7**2*u9*x1 - u2**2*u6*u7*u8 - u2**2*u6*u8**2*u9 + u2**2*u8**2*u9 
+ u2*u5*u7*u8*x1 + u2*u5*u8**2*u9*x1 - u2*u5*u8**2*u9 + u2*u6*u7**2*x1 + u2*u6*
u7*u8*u9*x1 + 2*u2*u6*u7*u8*u9 - u2*u6*u7*u9*x1 + u2*u6*u8**2*u9**2 - u2*u6*u8*
u9**2*x1 - 2*u2*u7*u8*u9*x1 - u2*u8**2*u9**2 + u2*u8*u9**2*x1 - u5*u7**2*x1**2 -
 u5*u7*u8*u9*x1**2 + u5*u7*u9*x1**2 - u5*u8**2*u9**2*x1 + u5*u8**2*u9**2 + u5*u8
*u9**2*x1**2 - u5*u8*u9**2*x1 - u6*u7**2*u9*x1 - u6*u7*u8*u9**2 + u6*u7*u9**2*x1
 + u7**2*u9*x1**2 + u7*u8*u9**2*x1 - u7*u9**2*x1**2))/(u1*u2*u5*u6*u7 - u1*u2*u5
*u6*u9 + u1*u5**2*u7*u8 - u1*u5**2*u7*x1 - u1*u5**2*u8*u9 + u1*u5**2*u9*x1 - u1*
u5*u6*u7**2 + u1*u5*u6*u7*u9 + u2**2*u6**2*u7 - u2**2*u6**2*u9 - u2**2*u6*u7 + 
u2**2*u6*u9 + u2*u5*u6*u7*u8 - 2*u2*u5*u6*u7*x1 - u2*u5*u6*u8*u9 + 2*u2*u5*u6*u9
*x1 - u2*u5*u7*u8 + u2*u5*u7*x1 + u2*u5*u8*u9 - u2*u5*u9*x1 - u2*u6**2*u7**2 + 
u2*u6**2*u9**2 + u2*u6*u7**2 - u2*u6*u9**2 - u5**2*u7*u8*x1 + u5**2*u7*x1**2 + 
u5**2*u8*u9*x1 - u5**2*u9*x1**2 + u5*u6*u7**2*x1 - u5*u6*u7*u8*u9 + u5*u6*u8*u9
**2 - u5*u6*u9**2*x1 + u5*u7*u8*u9 - u5*u7*u9*x1 - u5*u8*u9**2 + u5*u9**2*x1 + 
u6**2*u7**2*u9 - u6**2*u7*u9**2 - u6*u7**2*u9 + u6*u7*u9**2)$


con2:=concurrent(pp_line(A,R),pp_line(B,S),pp_line(C,T));


con2 := u1*u2*u6*u7 - u1*u5*u7*x1 - u2*u6*u7 - u2*u6*u8*u9 + u2*u8*u9 + u5*u7*x1
 + u5*u8*u9*x1 - u5*u8*u9 + u6*u7*u9 - u7*u9*x1$


sol:=solve(con2,x1);


sol := {x1=(u1*u2*u6*u7 - u2*u6*u7 - u2*u6*u8*u9 + u2*u8*u9 - u5*u8*u9 + u6*u7*
u9)/(u1*u5*u7 - u5*u7 - u5*u8*u9 + u7*u9)}$

sub(sol,con1);


0$


clear_ndg();


{}$
 clear(A,B,C,R,S,T);



% #################
%  Brocard points
% #################

A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 C:=Point(u1,u2);


c := {u1,u2}$


c1:=Circle(1,x1,x2,x3);


c1 := {1,x1,x2,x3}$

c2:=Circle(1,x4,x5,x6);


c2 := {1,x4,x5,x6}$

c3:=Circle(1,x7,x8,x9);


c3 := {1,x7,x8,x9}$


polys:={
	cl_tangent(c1,pp_line(A,C)), 
	point_on_circle(A,c1), 
	point_on_circle(B,c1), 
	cl_tangent(c2,pp_line(A,B)), 
	point_on_circle(B,c2), 
	point_on_circle(C,c2), 
	cl_tangent(c3,pp_line(B,C)), 
	point_on_circle(A,c3), 
	point_on_circle(C,c3)};


polys := {u1**2*x1**2 - 4*u1**2*x3 + 2*u1*u2*x1*x2 + u2**2*x2**2 - 4*u2**2*x3,
x3,
x1 + x3 + 1,
x4**2 - 4*x6,
x4 + x6 + 1,
u1**2 + u1*x4 + u2**2 + u2*x5 + x6,
u1**2*x7**2 - 4*u1**2*x9 + 2*u1*u2*x7*x8 + 4*u1*u2*x8 - 2*u1*x7**2 + 8*u1*x9 - 4
*u2**2*x7 + u2**2*x8**2 - 4*u2**2*x9 - 4*u2**2 - 2*u2*x7*x8 - 4*u2*x8 + x7**2 - 
4*x9,
x9,
u1**2 + u1*x7 + u2**2 + u2*x8 + x9}$

 
vars:={x1,x2,x3,x4,x5,x6,x7,x8,x9};


vars := {x1,
x2,
x3,
x4,
x5,
x6,
x7,
x8,
x9}$

sol:=solve(polys,vars);


sol := {{x6=1,
x8=( - u1**3 + u1**2 - u1*u2**2 - u2**2)/u2,
x2=u1/u2,
x1=-1,
x3=0,
x4=-2,
x5=( - u1**2 + 2*u1 - u2**2 - 1)/u2,
x7=u1**2 - 2*u1 + u2**2,
x9=0}}$


P:=other_cc_point(B,sub(sol,c1),sub(sol,c2));


p := {(u1**3 - u1**2 + u1*u2**2 + u1 + u2**2)/(u1**4 - 2*u1**3 + 2*u1**2*u2**2 +
 3*u1**2 - 2*u1*u2**2 - 2*u1 + u2**4 + 3*u2**2 + 1),
(u2*(u1**2 - 2*u1 + u2**2 + 1))/(u1**4 - 2*u1**3 + 2*u1**2*u2**2 + 3*u1**2 - 2*
u1*u2**2 - 2*u1 + u2**4 + 3*u2**2 + 1)}$

con:=point_on_circle(P,sub(sol,c3));


con := 0$


clear_ndg();


{}$
 clear A,B,C,c1,c2,c3;

	

% ##################
%  Simson's theorem
% ##################

% A constructive proof

        M:=Point(0,0);


m := {0,0}$

        A:=choose_pc(M,r,u1);


a := {(r*(u1**2 - 1))/(u1**2 + 1),(2*r*u1)/(u1**2 + 1)}$

        B:=choose_pc(M,r,u2);


b := {(r*(u2**2 - 1))/(u2**2 + 1),(2*r*u2)/(u2**2 + 1)}$

        C:=choose_pc(M,r,u3);


c := {(r*(u3**2 - 1))/(u3**2 + 1),(2*r*u3)/(u3**2 + 1)}$

        P:=choose_pc(M,r,u4);


p := {(r*(u4**2 - 1))/(u4**2 + 1),(2*r*u4)/(u4**2 + 1)}$

        X:=pedalpoint(P,pp_line(A,B))$


        Y:=pedalpoint(P,pp_line(B,C))$


        Z:=pedalpoint(P,pp_line(A,C))$


 
        collinear(X,Y,Z);


0$


clear_ndg();


{}$
 clear(M,A,B,C,P,X,Y,Z);



% Simson's theorem almost constructive

clear_ndg();


{}$


	A:=Point(0,0);


a := {0,0}$
 B:=Point(u1,u2);


b := {u1,u2}$
 
	C:=Point(u3,u4);


c := {u3,u4}$
 P:=Point(u5,x1);


p := {u5,x1}$

        X:=pedalpoint(P,pp_line(A,B));


x := {(u1*(u1*u5 + u2*x1))/(u1**2 + u2**2),
(u2*(u1*u5 + u2*x1))/(u1**2 + u2**2)}$

        Y:=pedalpoint(P,pp_line(B,C));


y := {(u1**2*u5 - u1*u2*u4 + u1*u2*x1 - 2*u1*u3*u5 + u1*u4**2 - u1*u4*x1 + u2**2
*u3 - u2*u3*u4 - u2*u3*x1 + u3**2*u5 + u3*u4*x1)/(u1**2 - 2*u1*u3 + u2**2 - 2*u2
*u4 + u3**2 + u4**2),
(u1**2*u4 - u1*u2*u3 + u1*u2*u5 - u1*u3*u4 - u1*u4*u5 + u2**2*x1 + u2*u3**2 - u2
*u3*u5 - 2*u2*u4*x1 + u3*u4*u5 + u4**2*x1)/(u1**2 - 2*u1*u3 + u2**2 - 2*u2*u4 + 
u3**2 + u4**2)}$

        Z:=pedalpoint(P,pp_line(A,C));


z := {(u3*(u3*u5 + u4*x1))/(u3**2 + u4**2),
(u4*(u3*u5 + u4*x1))/(u3**2 + u4**2)}$


	poly:=p4_circle(A,B,C,P);


poly := u1**2*u3*x1 - u1**2*u4*u5 - u1*u3**2*x1 - u1*u4**2*x1 + u1*u4*u5**2 + u1
*u4*x1**2 + u2**2*u3*x1 - u2**2*u4*u5 + u2*u3**2*u5 - u2*u3*u5**2 - u2*u3*x1**2 
+ u2*u4**2*u5$
 

        con:=collinear(X,Y,Z);


con := ( - u1**4*u3*u4**2*x1 + u1**4*u4**3*u5 + 2*u1**3*u2*u3**2*u4*x1 - 2*u1**3
*u2*u3*u4**2*u5 + u1**3*u3**2*u4**2*x1 + u1**3*u4**4*x1 - u1**3*u4**3*u5**2 - u1
**3*u4**3*x1**2 - u1**2*u2**2*u3**3*x1 + u1**2*u2**2*u3**2*u4*u5 - u1**2*u2**2*
u3*u4**2*x1 + u1**2*u2**2*u4**3*u5 - 2*u1**2*u2*u3**3*u4*x1 - u1**2*u2*u3**2*u4
**2*u5 - 2*u1**2*u2*u3*u4**3*x1 + 3*u1**2*u2*u3*u4**2*u5**2 + 3*u1**2*u2*u3*u4**
2*x1**2 - u1**2*u2*u4**4*u5 + 2*u1*u2**3*u3**2*u4*x1 - 2*u1*u2**3*u3*u4**2*u5 + 
u1*u2**2*u3**4*x1 + 2*u1*u2**2*u3**3*u4*u5 + u1*u2**2*u3**2*u4**2*x1 - 3*u1*u2**
2*u3**2*u4*u5**2 - 3*u1*u2**2*u3**2*u4*x1**2 + 2*u1*u2**2*u3*u4**3*u5 - u2**4*u3
**3*x1 + u2**4*u3**2*u4*u5 - u2**3*u3**4*u5 + u2**3*u3**3*u5**2 + u2**3*u3**3*x1
**2 - u2**3*u3**2*u4**2*u5)/(u1**4*u3**2 + u1**4*u4**2 - 2*u1**3*u3**3 - 2*u1**3
*u3*u4**2 + 2*u1**2*u2**2*u3**2 + 2*u1**2*u2**2*u4**2 - 2*u1**2*u2*u3**2*u4 - 2*
u1**2*u2*u4**3 + u1**2*u3**4 + 2*u1**2*u3**2*u4**2 + u1**2*u4**4 - 2*u1*u2**2*u3
**3 - 2*u1*u2**2*u3*u4**2 + u2**4*u3**2 + u2**4*u4**2 - 2*u2**3*u3**2*u4 - 2*u2
**3*u4**3 + u2**2*u3**4 + 2*u2**2*u3**2*u4**2 + u2**2*u4**4)$


	remainder(num con,poly);


0$


print_ndg();


{u3**2 + u4**2,
u1**2 - 2*u1*u3 + u2**2 - 2*u2*u4 + u3**2 + u4**2,
u1**2 + u2**2}$


% Equational proof, first version:

M:=Point(0,0);


m := {0,0}$
 A:=Point(0,1);


a := {0,1}$
 
B:=Point(u1,x1);


b := {u1,x1}$
 C:=Point(u2,x2);


c := {u2,x2}$
 P:=Point(u3,x3);


p := {u3,x3}$


X:=varpoint(A,B,x4);


x := {u1*( - x4 + 1), - x1*x4 + x1 + x4}$
 Y:=varpoint(B,C,x5);


y := {u1*x5 - u2*x5 + u2,x1*x5 - x2*x5 + x2}$
 Z:=varpoint(A,C,x6);


z := {u2*( - x6 + 1), - x2*x6 + x2 + x6}$


polys:={sqrdist(M,B)-1, sqrdist(M,C)-1, sqrdist(M,P)-1,
	orthogonal(pp_line(A,B),pp_line(P,X)),
	orthogonal(pp_line(A,C),pp_line(P,Z)),
	orthogonal(pp_line(B,C),pp_line(P,Y))};


polys := {u1**2 + x1**2 - 1,
u2**2 + x2**2 - 1,
u3**2 + x3**2 - 1,
 - u1**2*x4 + u1**2 - u1*u3 - x1**2*x4 + x1**2 - x1*x3 + 2*x1*x4 - x1 + x3 - x4,
 - u2**2*x6 + u2**2 - u2*u3 - x2**2*x6 + x2**2 - x2*x3 + 2*x2*x6 - x2 + x3 - x6,
 - u1**2*x5 + 2*u1*u2*x5 - u1*u2 + u1*u3 - u2**2*x5 + u2**2 - u2*u3 - x1**2*x5 +
 2*x1*x2*x5 - x1*x2 + x1*x3 - x2**2*x5 + x2**2 - x2*x3}$


con:=collinear(X,Y,Z);


con := u1*x2*x4*x5 - u1*x2*x4*x6 - u1*x2*x5*x6 + u1*x2*x6 - u1*x4*x5 + u1*x4*x6 
+ u1*x5*x6 - u1*x6 - u2*x1*x4*x5 + u2*x1*x4*x6 + u2*x1*x5*x6 - u2*x1*x6 + u2*x4*
x5 - u2*x4*x6 - u2*x5*x6 + u2*x6$


vars:={x4,x5,x6,x1,x2,x3};


vars := {x4,
x5,
x6,
x1,
x2,
x3}$

setring(vars,{},lex);


{{x4,x5,x6,x1,x2,x3},{},lex,{1,1,1,1,1,1}}$

setideal(polys,polys);


{x1**2 + (u1**2 - 1),
x2**2 + (u2**2 - 1),
x3**2 + (u3**2 - 1),
 - x4*x1**2 + 2*x4*x1 - (u1**2 + 1)*x4 + x1**2 - x1*x3 - x1 + x3 + (u1**2 - u1*
u3),
 - x6*x2**2 + 2*x6*x2 - (u2**2 + 1)*x6 + x2**2 - x2*x3 - x2 + x3 + (u2**2 - u2*
u3),
 - x5*x1**2 + 2*x5*x1*x2 - x5*x2**2 - (u1**2 - 2*u1*u2 + u2**2)*x5 - x1*x2 + x1*
x3 + x2**2 - x2*x3 - (u1*u2 - u1*u3 - u2**2 + u2*u3)}$

con mod gbasis polys;


0$


% Second version:

A:=Point(0,0);


a := {0,0}$

B:=Point(1,0);


b := {1,0}$

C:=Point(u1,u2);


c := {u1,u2}$

P:=Point(u3,x1);


p := {u3,x1}$

X:=Point(x2,0);


x := {x2,0}$
		% => on the line AB 
Y:=varpoint(B,C,x3);


y := { - u1*x3 + u1 + x3,u2*( - x3 + 1)}$

Z:=varpoint(A,C,x4);


z := {u1*( - x4 + 1),u2*( - x4 + 1)}$


polys:={orthogonal(pp_line(A,C),pp_line(P,Z)),
	orthogonal(pp_line(B,C),pp_line(P,Y)),
	orthogonal(pp_line(A,B),pp_line(P,X)),
       	p4_circle(A,B,C,P)};


polys := { - u1**2*x4 + u1**2 - u1*u3 - u2**2*x4 + u2**2 - u2*x1,
 - u1**2*x3 + u1**2 - u1*u3 + 2*u1*x3 - u1 - u2**2*x3 + u2**2 - u2*x1 + u3 - x3,
 - u3 + x2,
 - u1**2*x1 + u1*x1 - u2**2*x1 + u2*u3**2 - u2*u3 + u2*x1**2}$


con:=collinear(X,Y,Z);


con := u2*( - x2*x3 + x2*x4 - x3*x4 + x3)$


vars:={x2,x3,x4,x1};


vars := {x2,x3,x4,x1}$

setring(vars,{},lex);


{{x2,x3,x4,x1},{},lex,{1,1,1,1}}$

con mod interreduce polys;


0$


% The inverse theorem

polys:={orthogonal(pp_line(A,C),pp_line(P,Z)),
	orthogonal(pp_line(B,C),pp_line(P,Y)),
	orthogonal(pp_line(A,B),pp_line(P,X)),
       	collinear(X,Y,Z)};


polys := { - u1**2*x4 + u1**2 - u1*u3 - u2**2*x4 + u2**2 - u2*x1,
 - u1**2*x3 + u1**2 - u1*u3 + 2*u1*x3 - u1 - u2**2*x3 + u2**2 - u2*x1 + u3 - x3,
 - u3 + x2,
u2*( - x2*x3 + x2*x4 - x3*x4 + x3)}$


con:=p4_circle(A,B,C,P);


con :=  - u1**2*x1 + u1*x1 - u2**2*x1 + u2*u3**2 - u2*u3 + u2*x1**2$


con mod interreduce polys;


0$


clear_ndg();


{}$
 clear(M,A,B,C,P,Y,Z);



% ########################
%  The butterfly theorem
% ########################
 
% An equational proof with groebner factorizer and constraints. 

P:=Point(0,0);


p := {0,0}$

O:=Point(u1,0);


o := {u1,0}$

A:=Point(u2,u3);


a := {u2,u3}$
	
B:=Point(u4,x1);


b := {u4,x1}$

C:=Point(x2,x3);


c := {x2,x3}$
 
D:=Point(x4,x5);


d := {x4,x5}$
 
F:=Point(0,x6);


f := {0,x6}$

G:=Point(0,x7);


g := {0,x7}$


polys:={sqrdist(O,B)-sqrdist(O,A), 
	sqrdist(O,C)-sqrdist(O,A), 
	sqrdist(O,D)-sqrdist(O,A),
	point_on_line(P,pp_line(A,C)),
	point_on_line(P,pp_line(B,D)),
	point_on_line(F,pp_line(A,D)),
	point_on_line(G,pp_line(B,C))
};


polys := {2*u1*u2 - 2*u1*u4 - u2**2 - u3**2 + u4**2 + x1**2,
2*u1*u2 - 2*u1*x2 - u2**2 - u3**2 + x2**2 + x3**2,
2*u1*u2 - 2*u1*x4 - u2**2 - u3**2 + x4**2 + x5**2,
 - u2*x3 + u3*x2,
 - u4*x5 + x1*x4,
 - u2*x5 + u2*x6 + u3*x4 - x4*x6,
 - u4*x3 + u4*x7 + x1*x2 - x2*x7}$


con:=num sqrdist(P,midpoint(F,G));


con := x6**2 + 2*x6*x7 + x7**2$


vars:={x6,x7,x3,x5,x1,x2,x4};


vars := {x6,
x7,
x3,
x5,
x1,
x2,
x4}$

setring(vars,{},lex);


{{x6,x7,x3,x5,x1,x2,x4},{},lex,{1,1,1,1,1,1,1}}$


sol:=groebfactor(polys,{sqrdist(A,C),sqrdist(B,D)});


sol := {{x1**2 + (2*u1*u2 - 2*u1*u4 - u2**2 - u3**2 + u4**2),
(u2**2 + u3**2)*x3 - (2*u1*u2*u3 - u2**2*u3 - u3**3),
(2*u1*u2 - 2*u1*u4 - u2**2 - u3**2)*x5 + (2*u1*u2 - u2**2 - u3**2)*x1,
(2*u1*u2 - 2*u1*u4 - u2**2 - u3**2)*x4 + (2*u1*u2*u4 - u2**2*u4 - u3**2*u4),
(u2**2 + u3**2)*x2 - (2*u1*u2**2 - u2**3 - u2*u3**2),
(2*u1*u2**2 - u2**3 - u2**2*u4 - u2*u3**2 - u3**2*u4)*x7 - (2*u1*u2**2 - u2**3 -
 u2*u3**2)*x1 + (2*u1*u2*u3*u4 - u2**2*u3*u4 - u3**3*u4),
(2*u1*u2**2 - u2**3 - u2**2*u4 - u2*u3**2 - u3**2*u4)*x6 + (2*u1*u2**2 - u2**3 -
 u2*u3**2)*x1 - (2*u1*u2*u3*u4 - u2**2*u3*u4 - u3**3*u4)}}$


for each u in sol collect con mod u;


{0}$


% A constructive proof

on gcd;



O:=Point(0,0);


o := {0,0}$

A:=Point(1,0);


a := {1,0}$
	
B:=choose_pc(O,1,u1);


b := {(u1**2 - 1)/(u1**2 + 1),(2*u1)/(u1**2 + 1)}$

C:=choose_pc(O,1,u2);


c := {(u2**2 - 1)/(u2**2 + 1),(2*u2)/(u2**2 + 1)}$

D:=choose_pc(O,1,u3);


d := {(u3**2 - 1)/(u3**2 + 1),(2*u3)/(u3**2 + 1)}$

P:=intersection_point(pp_line(A,C),pp_line(B,D));


p := {(u1*u2 - u1*u3 + u2*u3 - 1)/(u1*u2 - u1*u3 + u2*u3 + 1),
(2*u2)/(u1*u2 - u1*u3 + u2*u3 + 1)}$


h:=lot(P,pp_line(O,P));


h := {( - u1*u2 + u1*u3 - u2*u3 + 1)/(u1*u2 - u1*u3 + u2*u3 + 1),
( - 2*u2)/(u1*u2 - u1*u3 + u2*u3 + 1),
(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**2*u3**2 + 2*u1*u2**2*u3 - 2*u1*u2*u3**2 - 2*
u1*u2 + 2*u1*u3 + u2**2*u3**2 + 4*u2**2 - 2*u2*u3 + 1)/(u1**2*u2**2 - 2*u1**2*u2
*u3 + u1**2*u3**2 + 2*u1*u2**2*u3 - 2*u1*u2*u3**2 + 2*u1*u2 - 2*u1*u3 + u2**2*u3
**2 + 2*u2*u3 + 1)}$


F:=intersection_point(h,pp_line(A,D));


f := {(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**2*u3**2 - 2*u1*u2 + 2*u1*u3 - u2**2*u3
**2 + 4*u2**2 - 4*u2*u3 + 1)/(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**2*u3**2 - u2**2*
u3**2 - 2*u2*u3 - 1),
(2*u3*(u1*u2 - u1*u3 - 2*u2**2 + u2*u3 - 1))/(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**
2*u3**2 - u2**2*u3**2 - 2*u2*u3 - 1)}$
 
G:=intersection_point(h,pp_line(B,C));


g := {(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**2*u3**2 - 2*u1*u2 + 2*u1*u3 - u2**2*u3
**2 - 4*u2**2 + 4*u2*u3 + 1)/(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**2*u3**2 - u2**2*
u3**2 - 2*u2*u3 - 1),
(2*(2*u1*u2**2 - 3*u1*u2*u3 + u1*u3**2 - u2*u3**2 - 2*u2 + u3))/(u1**2*u2**2 - 2
*u1**2*u2*u3 + u1**2*u3**2 - u2**2*u3**2 - 2*u2*u3 - 1)}$


con:=sqrdist(P,midpoint(F,G));


con := 0$


off gcd;


clear_ndg();


{}$
 clear(O,A,B,C,D,P,h,F,G);



% ################################
% Tangency of Feuerbach's circle
% ################################
 
A:=Point(0,0);


a := {0,0}$
 B:=Point(2,0);


b := {2,0}$
 C:=Point(u1,u2);


c := {u1,u2}$

M:=intersection_point(mp(A,B),mp(B,C));


m := {1,(u1**2 - 2*u1 + u2**2)/(2*u2)}$

H:=intersection_point(altitude(A,B,C),altitude(B,C,A));


h := {u1,(u1*( - u1 + 2))/u2}$

N:=midpoint(M,H);


n := {(u1 + 1)/2,( - u1**2 + 2*u1 + u2**2)/(4*u2)}$
	
c1:=c1_circle(N,sqrdist(N,midpoint(A,B)));


c1 := {1, - (u1 + 1),(u1**2 - 2*u1 - u2**2)/(2*u2),u1}$

			% Feuerbach's circle

P:=Point(x1,x2);


p := {x1,x2}$
	% => x2 is the radius of the inscribed circle. 

polys:={point_on_bisector(P,A,B,C), point_on_bisector(P,B,C,A)};


polys := {2*( - 2*u1*x1*x2 + 4*u1*x2 + u2*x1**2 - 4*u2*x1 - u2*x2**2 + 4*u2 + 4*
x1*x2 - 8*x2),
2*( - u1**3*x2 + u1**2*u2*x1 - u1**2*u2 + u1**2*x1*x2 + 2*u1**2*x2 - u1*u2**2*x2
 - u1*u2*x1**2 + u1*u2*x2**2 - 2*u1*x1*x2 + u2**3*x1 - u2**3 - u2**2*x1*x2 + 2*
u2**2*x2 + u2*x1**2 - u2*x2**2)}$


con:=cc_tangent(c1_circle(P,x2^2),c1);


con := (4*( - u1**3*x1*x2 + u1**3*x2 + u1**2*u2*x1**2 - 2*u1**2*u2*x1 - u1**2*u2
*x2**2 + u1**2*u2 + u1**2*x1**2*x2 + u1**2*x1*x2 - 2*u1**2*x2 + u1*u2**2*x1*x2 -
 u1*u2**2*x2 - 2*u1*u2*x1**3 + 4*u1*u2*x1**2 - 2*u1*u2*x1 + 2*u1*u2*x2**2 - 2*u1
*x1**2*x2 + 2*u1*x1*x2 - u2**2*x1**2*x2 + u2**2*x1*x2 + u2*x1**4 - 2*u2*x1**3 + 
u2*x1**2 - u2*x2**2))/u2$
 

vars:={x1,x2};


vars := {x1,x2}$

setring(vars,{},lex);


{{x1,x2},{},lex,{1,1}}$

setideal(polys,polys);


{(2*u2)*x1**2 - (4*u1 - 8)*x1*x2 - (8*u2)*x1 - (2*u2)*x2**2 + (8*u1 - 16)*x2 + 8
*u2,
 - (2*u1*u2 - 2*u2)*x1**2 + (2*u1**2 - 4*u1 - 2*u2**2)*x1*x2 + (2*u1**2*u2 + 2*
u2**3)*x1 + (2*u1*u2 - 2*u2)*x2**2 - (2*u1**3 - 4*u1**2 + 2*u1*u2**2 - 4*u2**2)*
x2 - (2*u1**2*u2 + 2*u2**3)}$

num con mod gbasis polys;


0$


% Now let P be the incenter of the triangle ABH

polys1:={point_on_bisector(P,A,B,H), point_on_bisector(P,B,H,A)};


polys1 := {(2*( - u1**2*x1**2 + 4*u1**2*x1 + u1**2*x2**2 - 4*u1**2 - 2*u1*u2*x1*
x2 + 4*u1*u2*x2 + 2*u1*x1**2 - 8*u1*x1 - 2*u1*x2**2 + 8*u1 + 4*u2*x1*x2 - 8*u2*
x2))/u2,
(2*u1*( - u1**5*x1 + u1**5 - u1**4*u2*x2 + 6*u1**4*x1 - 6*u1**4 - u1**3*u2**2*x1
 + u1**3*u2**2 - u1**3*u2*x1*x2 + 6*u1**3*u2*x2 - 12*u1**3*x1 + 12*u1**3 - u1**2
*u2**3*x2 + u1**2*u2**2*x1**2 + 2*u1**2*u2**2*x1 - u1**2*u2**2*x2**2 - 2*u1**2*
u2**2 + 4*u1**2*u2*x1*x2 - 12*u1**2*u2*x2 + 8*u1**2*x1 - 8*u1**2 + u1*u2**3*x1*
x2 + 2*u1*u2**3*x2 - 3*u1*u2**2*x1**2 + 3*u1*u2**2*x2**2 - 4*u1*u2*x1*x2 + 8*u1*
u2*x2 - 2*u2**3*x1*x2 + 2*u2**2*x1**2 - 2*u2**2*x2**2))/u2**3}$


con1:=cc_tangent(c1_circle(P,x2^2),c1);


con1 := (4*( - u1**3*x1*x2 + u1**3*x2 + u1**2*u2*x1**2 - 2*u1**2*u2*x1 - u1**2*
u2*x2**2 + u1**2*u2 + u1**2*x1**2*x2 + u1**2*x1*x2 - 2*u1**2*x2 + u1*u2**2*x1*x2
 - u1*u2**2*x2 - 2*u1*u2*x1**3 + 4*u1*u2*x1**2 - 2*u1*u2*x1 + 2*u1*u2*x2**2 - 2*
u1*x1**2*x2 + 2*u1*x1*x2 - u2**2*x1**2*x2 + u2**2*x1*x2 + u2*x1**4 - 2*u2*x1**3 
+ u2*x1**2 - u2*x2**2))/u2$
 
setideal(polys1,polys1);


{ - (2*u1**2 - 4*u1)*x1**2 - (4*u1*u2 - 8*u2)*x1*x2 + (8*u1**2 - 16*u1)*x1 + (2*
u1**2 - 4*u1)*x2**2 + (8*u1*u2 - 16*u2)*x2 - (8*u1**2 - 16*u1),
(2*u1**3*u2**2 - 6*u1**2*u2**2 + 4*u1*u2**2)*x1**2 - (2*u1**4*u2 - 8*u1**3*u2 - 
2*u1**2*u2**3 + 8*u1**2*u2 + 4*u1*u2**3)*x1*x2 - (2*u1**6 - 12*u1**5 + 2*u1**4*
u2**2 + 24*u1**4 - 4*u1**3*u2**2 - 16*u1**3)*x1 - (2*u1**3*u2**2 - 6*u1**2*u2**2
 + 4*u1*u2**2)*x2**2 - (2*u1**5*u2 - 12*u1**4*u2 + 2*u1**3*u2**3 + 24*u1**3*u2 -
 4*u1**2*u2**3 - 16*u1**2*u2)*x2 + (2*u1**6 - 12*u1**5 + 2*u1**4*u2**2 + 24*u1**
4 - 4*u1**3*u2**2 - 16*u1**3)}$

num con1 mod gbasis polys1;


0$


clear_ndg();


{}$
 clear A,B,C,P,M,N,H,c1;



% #############################
% Solutions to the exercises
% #############################

% 1)

A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 C:=Point(1,1);


c := {1,1}$
 D:=Point(0,1);


d := {0,1}$

P:=Point(x1,x2);


p := {x1,x2}$
 Q:=Point(x3,1);


q := {x3,1}$


polys:={point_on_line(P,par(C,pp_line(B,D))),
	sqrdist(B,D)-sqrdist(B,P),
	point_on_line(Q,pp_line(B,P))};


polys := {x1 + x2 - 2,
 - x1**2 + 2*x1 - x2**2 + 1,
 - x1 + x2*x3 - x2 + 1}$


con:=sqrdist(D,P)-sqrdist(D,Q);


con := x1**2 + x2**2 - 2*x2 - x3**2 + 1$


setring({x1,x2,x3},{},lex);


{{x1,x2,x3},{},lex,{1,1,1}}$

setideal(polys,polys);


{x1 + x2 - 2,
 - x1**2 + 2*x1 - x2**2 + 1,
 - x1 + x2*x3 - x2 + 1}$

con mod gbasis polys;


0$


clear_ndg();


{}$
 clear(A,B,C,D,P,Q);



% 2)

A:=Point(u1,0);


a := {u1,0}$
 B:=Point(u2,0);


b := {u2,0}$
 C:=Point(0,u3);


c := {0,u3}$
 
Q:=Point(0,0);


q := {0,0}$
		% the pedal point on AB
R:=pedalpoint(B,pp_line(A,C));


r := {(u1*(u1*u2 + u3**2))/(u1**2 + u3**2),
(u1*u3*(u1 - u2))/(u1**2 + u3**2)}$
 
P:=pedalpoint(A,pp_line(B,C));


p := {(u2*(u1*u2 + u3**2))/(u2**2 + u3**2),
(u2*u3*( - u1 + u2))/(u2**2 + u3**2)}$
 

con1:=point_on_bisector(C,P,Q,R);


con1 := 0$

con2:=angle_sum(p3_angle(P,Q,C),p3_angle(R,Q,C));


con2 := 0$


clear_ndg();


{}$
 clear(A,B,C,P,Q,R);



% 3)

A:=Point(u1,0);


a := {u1,0}$
 B:=Point(u2,0);


b := {u2,0}$
 C:=Point(0,u3);


c := {0,u3}$
 
P:=pedalpoint(A,pp_line(B,C));


p := {(u2*(u1*u2 + u3**2))/(u2**2 + u3**2),
(u2*u3*( - u1 + u2))/(u2**2 + u3**2)}$
 
Q:=pedalpoint(B,pp_line(A,C));


q := {(u1*(u1*u2 + u3**2))/(u1**2 + u3**2),
(u1*u3*(u1 - u2))/(u1**2 + u3**2)}$
 
R:=pedalpoint(C,pp_line(A,B));


r := {0,0}$


P1:=pedalpoint(P,pp_line(A,B));


p1 := {(u2*(u1*u2 + u3**2))/(u2**2 + u3**2),0}$

P2:=pedalpoint(P,pp_line(A,C));


p2 := {(u1*(u1**2*u2**2 + 2*u1*u2*u3**2 + u3**4))/(u1**2*u2**2 + u1**2*u3**2 + 
u2**2*u3**2 + u3**4),
(u3**3*(u1**2 - 2*u1*u2 + u2**2))/(u1**2*u2**2 + u1**2*u3**2 + u2**2*u3**2 + u3
**4)}$

Q1:=pedalpoint(Q,pp_line(A,B));


q1 := {(u1*(u1*u2 + u3**2))/(u1**2 + u3**2),0}$

Q2:=pedalpoint(Q,pp_line(B,C));


q2 := {(u2*(u1**2*u2**2 + 2*u1*u2*u3**2 + u3**4))/(u1**2*u2**2 + u1**2*u3**2 + 
u2**2*u3**2 + u3**4),
(u3**3*(u1**2 - 2*u1*u2 + u2**2))/(u1**2*u2**2 + u1**2*u3**2 + u2**2*u3**2 + u3
**4)}$

R1:=pedalpoint(R,pp_line(A,C));


r1 := {(u1*u3**2)/(u1**2 + u3**2),(u1**2*u3)/(u1**2 + u3**2)}$

R2:=pedalpoint(R,pp_line(B,C));


r2 := {(u2*u3**2)/(u2**2 + u3**2),(u2**2*u3)/(u2**2 + u3**2)}$


con:=for each X in {Q2,R1,R2} collect p4_circle(P1,P2,Q1,X);


con := {0,0,0}$


clear_ndg();


{}$
 clear(O,A,B,C,P,Q,R,P1,P2,Q1,Q2,R1,R2);



% 4) 

A:=Point(u1,0);


a := {u1,0}$
 B:=Point(u2,0);


b := {u2,0}$
 C:=Point(0,u3);


c := {0,u3}$
 
		% => Pedalpoint from C is (0,0)
M:=intersection_point(mp(A,B),mp(B,C));


m := {(u1 + u2)/2,(u1*u2 + u3**2)/(2*u3)}$


% Prove (2*h_c*R = a*b)^2

con:=4*u3^2*sqrdist(M,A)-sqrdist(C,B)*sqrdist(A,C);


con := 0$


clear_ndg();


{}$
 clear(A,B,C,M);



% 5. A solution of constructive type.

on gcd;


O:=Point(0,u1);


o := {0,u1}$
 A:=Point(0,0);


a := {0,0}$
	% hence k has radius u1.
B:=Point(u2,0);


b := {u2,0}$

M:=midpoint(A,B);


m := {u2/2,0}$

D:=choose_pc(O,u1,u3);


d := {(u1*(u3**2 - 1))/(u3**2 + 1),(u1*(u3**2 + 2*u3 + 1))/(u3**2 + 1)}$
 
k:=c1_circle(O,u1^2);


k := {1,0, - 2*u1,0}$

C:=other_cl_point(D,k,pp_line(M,D));


c := {(u1*u2*(4*u1*u3**2 + 8*u1*u3 + 4*u1 - u2*u3**2 + u2))/(8*u1**2*u3**2 + 16*
u1**2*u3 + 8*u1**2 - 4*u1*u2*u3**2 + 4*u1*u2 + u2**2*u3**2 + u2**2),
(u1*u2**2*(u3**2 + 2*u3 + 1))/(8*u1**2*u3**2 + 16*u1**2*u3 + 8*u1**2 - 4*u1*u2*
u3**2 + 4*u1*u2 + u2**2*u3**2 + u2**2)}$

Eh:=other_cl_point(D,k,pp_line(B,D));


eh := {(u1*u2*(2*u1*u3**2 + 4*u1*u3 + 2*u1 - u2*u3**2 + u2))/(2*u1**2*u3**2 + 4*
u1**2*u3 + 2*u1**2 - 2*u1*u2*u3**2 + 2*u1*u2 + u2**2*u3**2 + u2**2),
(u1*u2**2*(u3**2 + 2*u3 + 1))/(2*u1**2*u3**2 + 4*u1**2*u3 + 2*u1**2 - 2*u1*u2*u3
**2 + 2*u1*u2 + u2**2*u3**2 + u2**2)}$

F:=other_cl_point(C,k,pp_line(B,C));


f := {(u1*u2*( - 2*u1*u3**2 - 4*u1*u3 - 2*u1 + u2*u3**2 - u2))/(2*u1**2*u3**2 + 
4*u1**2*u3 + 2*u1**2 - 2*u1*u2*u3**2 + 2*u1*u2 + u2**2*u3**2 + u2**2),
(u1*u2**2*(u3**2 + 2*u3 + 1))/(2*u1**2*u3**2 + 4*u1**2*u3 + 2*u1**2 - 2*u1*u2*u3
**2 + 2*u1*u2 + u2**2*u3**2 + u2**2)}$


con:=parallel(pp_line(A,B),pp_line(Eh,F));


con := 0$


off gcd;


clear_ndg();


{}$
 clear(O,A,B,C,D,Eh,F,M,k);



% 6)

Z:=Point(0,0);


z := {0,0}$
 X:=Point(0,1);


x := {0,1}$
 Y:=Point(0,-1);


y := {0,-1}$
 
B:=Point(u1,0);


b := {u1,0}$
 C:=Point(u2,0);


c := {u2,0}$
 P:=Point(0,u3);


p := {0,u3}$

M:=Point(x1,x2);


m := {x1,x2}$
 N:=Point(x3,x4);


n := {x3,x4}$
 
A:=Point(x5,0);


a := {x5,0}$
 D:=Point(x6,0);


d := {x6,0}$


polys:={p4_circle(X,Y,B,N), p4_circle(X,Y,C,M),
	p4_circle(X,Y,B,D), p4_circle(X,Y,C,A),
	collinear(B,P,N), collinear(C,P,M)};


polys := {2*( - u1**2*x3 + u1*x3**2 + u1*x4**2 - u1 + x3),
2*( - u2**2*x1 + u2*x1**2 + u2*x2**2 - u2 + x1),
2*( - u1**2*x6 + u1*x6**2 - u1 + x6),
2*( - u2**2*x5 + u2*x5**2 - u2 + x5),
u1*u3 - u1*x4 - u3*x3,
u2*u3 - u2*x2 - u3*x1}$


con:=concurrent(pp_line(A,M),pp_line(D,N),pp_line(X,Y));


con := 2*( - x1*x4*x6 + x2*x3*x5 - x2*x5*x6 + x4*x5*x6)$


vars:={x1,x2,x3,x4,x5,x6};


vars := {x1,
x2,
x3,
x4,
x5,
x6}$

setring(vars,{},lex);


{{x1,x2,x3,x4,x5,x6},{},lex,{1,1,1,1,1,1}}$

res:=groebfactor(polys,{x5-u2,x1-u2,x6-u1,x3-u1});


res := {{u1*x6 + 1,
(u2**2 + u3**2)*x2 - (u2**2*u3 + u3),
(u2**2 + u3**2)*x1 - (u2*u3**2 - u2),
(u1**2 + u3**2)*x4 - (u1**2*u3 + u3),
(u1**2 + u3**2)*x3 - (u1*u3**2 - u1),
u2*x5 + 1}}$

	% constraints A\neq C, M\neq C, D\neq B, N\neq B
for each u in res collect con mod u;


{0}$


clear_ndg();


{}$
 clear(Z,X,Y,B,C,P,M,N,A,D);



% 7)

M:=Point(0,0);


m := {0,0}$

A:=Point(0,u1);


a := {0,u1}$
 B:=Point(-1,0);


b := {-1,0}$
 C:=Point(1,0);


c := {1,0}$
 
Eh:=varpoint(A,B,x1);


eh := {x1 - 1,u1*x1}$
 F:=varpoint(A,C,x2);


f := { - x2 + 1,u1*x2}$

O:=intersection_point(pp_line(A,M),lot(B,pp_line(A,B)));


o := {0,( - 1)/u1}$
 
Q:=intersection_point(pp_line(Eh,F),pp_line(B,C));


q := {( - 2*x1*x2 + x1 + x2)/(x1 - x2),0}$


con1:=num orthogonal(pp_line(O,Q),pp_line(Eh,Q));


con1 := 2*x1*(x1**2*x2 - x1**2 + x1*x2**2 - 2*x1*x2 + x1 - x2**2 + x2)$

con2:=num sqrdist(Q,midpoint(Eh,F));


con2 := u1**2*x1**4 - 2*u1**2*x1**2*x2**2 + u1**2*x2**4 + x1**4 + 4*x1**3*x2 - 4
*x1**3 + 6*x1**2*x2**2 - 12*x1**2*x2 + 4*x1**2 + 4*x1*x2**3 - 12*x1*x2**2 + 8*x1
*x2 + x2**4 - 4*x2**3 + 4*x2**2$


vars:={x1,x2};


vars := {x1,x2}$

setring(vars,{},lex);


{{x1,x2},{},lex,{1,1}}$

p1:=groebfactor({con1},{x1-1,x2-1,x1,x2});


p1 := {{x1 + x2}}$

p2:=groebfactor({con2},{x1-1,x2-1,x1,x2});


p2 := {{x1 + x2},
{(u1**2 + 1)*x1**2 - (2*u1**2 - 2)*x1*x2 - 4*x1 + (u1**2 + 1)*x2**2 - 4*x2 + 4}}
$

	% constraint A,C\neq Eh, B,C\neq F

for each u in p1 collect con2 mod u;


{0}$

for each u in p2 collect con1 mod u;


{0,
(2*(5*u1**4*x1*x2**3 - 8*u1**4*x1*x2**2 + 3*u1**4*x1*x2 - 3*u1**4*x2**4 + 4*u1**
4*x2**3 - u1**4*x2**2 - 10*u1**2*x1*x2**3 + 32*u1**2*x1*x2**2 - 30*u1**2*x1*x2 +
 8*u1**2*x1 - 2*u1**2*x2**4 + 12*u1**2*x2**3 - 26*u1**2*x2**2 + 20*u1**2*x2 - 4*
u1**2 + x1*x2**3 - 8*x1*x2**2 + 15*x1*x2 - 8*x1 + x2**4 - 8*x2**3 + 23*x2**2 - 
28*x2 + 12))/(u1**4 + 2*u1**2 + 1)}$


% Note that the second component of p2 has no relevant *real* roots,
% since it factors as u1^2 * (x1 - x2)^2 + (x1 + x2 -2)^2 :

u1^2 * (x1 - x2)^2 + (x1 + x2 -2)^2 mod second p2;


0$


clear_ndg();


{}$
 clear(M,A,B,C,O,Eh,F,Q);



% 8)

on gcd;

 

A:=Point(u1,0);


a := {u1,0}$
 B:=Point(u2,0);


b := {u2,0}$
 l1:=pp_line(A,B);


l1 := {0,u1 - u2,0}$

M:=Point(0,u3);


m := {0,u3}$
		% the incenter, hence u3 = incircle radius 

C:=intersection_point(symline(l1,pp_line(A,M)),
		symline(l1,pp_line(B,M)));


c := {(u3**2*(u1 + u2))/(u1*u2 + u3**2),
(2*u1*u2*u3)/(u1*u2 + u3**2)}$
  

N:=intersection_point(mp(A,B),mp(B,C));


n := {(u1 + u2)/2,
(u1**2*u2**2 - u1**2*u3**2 + 4*u1*u2*u3**2 - u2**2*u3**2 + u3**4)/(4*u3*(u1*u2 +
 u3**2))}$
 % the outcenter

sqr_rad:=sqrdist(A,N);


sqr_rad := (u1**4*u2**4 + 2*u1**4*u2**2*u3**2 + u1**4*u3**4 + 2*u1**2*u2**4*u3**
2 + 4*u1**2*u2**2*u3**4 + 2*u1**2*u3**6 + u2**4*u3**4 + 2*u2**2*u3**6 + u3**8)/(
16*u3**2*(u1**2*u2**2 + 2*u1*u2*u3**2 + u3**4))$
	% the outcircle sqradius.

(sqr_rad-sqrdist(M,N))^2-4*u3^2*sqr_rad;


0$


off gcd;


clear_ndg();


{}$
 clear A,B,C,M,N,l1,sqr_rad;



% 9)

on gcd;



A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 M:=Point(u1,0);


m := {u1,0}$

C:=Point(u1,u1);


c := {u1,u1}$
 F:=Point(u1,1-u1);


f := {u1, - u1 + 1}$


c1:=red_hom_coords p3_circle(A,M,C);


c1 := {1, - u1, - u1,0}$
 
c2:=red_hom_coords p3_circle(B,M,F);


c2 := {-1,u1 + 1, - u1 + 1, - u1}$

N:=other_cc_point(M,c1,c2);


n := {u1**2/(2*u1**2 - 2*u1 + 1),(u1*( - u1 + 1))/(2*u1**2 - 2*u1 + 1)}$


point_on_line(N,pp_line(A,F));


0$

point_on_line(N,pp_line(B,C));


0$


l1:=red_hom_coords pp_line(M,N);


l1 := {-1,2*u1 - 1,u1}$

l2:=sub(u1=u2,l1);


l2 := {-1,2*u2 - 1,u2}$


intersection_point(l1,l2);


{1/2,( - 1)/2}$
 % = (1/2,-1/2)

off gcd;


clear_ndg();


{}$
 clear A,B,C,F,M,N,c1,c2,l1,l2;



% ####################
% Some more examples
% ####################

% Origin: D. Wang at
%	http://cosmos.imag.fr/ATINF/Dongming.Wang/geother.html
% --------------------------
% Given triangle ABC, H orthocenter, O circumcenter, A1 circumcenter
% of BHC, B1 circumcenter of AHC.
%
% Claim: OH, AA1, BB1 are concurrent.
% --------------------------

A:=Point(u1,0);


a := {u1,0}$
 B:=Point(u2,0);


b := {u2,0}$
 C:=Point(0,u3);


c := {0,u3}$
 
H:=intersection_point(altitude(C,A,B),altitude(A,B,C));


h := {0,( - u1*u2)/u3}$

O:=circle_center(p3_circle(A,B,C));


o := {(u1 + u2)/2,(u1*u2 + u3**2)/(2*u3)}$
 
A1:=circle_center(p3_circle(H,B,C));


a1 := {( - u1 + u2)/2,( - u1*u2 + u3**2)/(2*u3)}$
 
B1:=circle_center(p3_circle(H,A,C));


b1 := {(u1 - u2)/2,( - u1*u2 + u3**2)/(2*u3)}$
 

con:=concurrent(pp_line(O,H),pp_line(A,A1),pp_line(B,B1));


con := 0$


end;

4: 4: 4: 4: 4: 4: 4: 4: 4: 

Time for test: 9680 ms, plus GC time: 880 ms

5: 5: 
Quitting
Thu Jan 28 23:38:39 MET 1999