Sindbad~EG File Manager

(* ========================================================================= *)
(*  ET Axioms for Proof-checking Euclid                                      *)
(* ========================================================================= *)
(*  M. Beeson, 9.13.17 to 9.14.17                                            *)

(* To use Flyspeck stuff:
load_path := "Formal_ineqs" :: !load_path;;
needs "verifier/m_verifier_main.hl";;
open M_verifier_main;;
let ineq = 
 `-- &1 / sqrt(&3) <= x /\ x <= sqrt(&2) /\
   -- sqrt(pi) <= y /\ y <= &1
   ==> x pow 2 * y - x * y pow 4 + y pow 6 - &6 + x pow 4
    > -- #7.17995`;;
*)

prioritize_real();;
parse_as_infix("cross2",(20,"right"));;
parse_as_infix("dot2",(20,"right"));;
needs "/Users/beeson/Dropbox/Provers/HOL-Light/Examples/sos.ml";;   (* To use REAL_SOS *) 



(*  First the definitions  *)

(* dot product *)
let dot2 = new_definition
  ` (a:real,b:real) dot2 (c:real,d:real) = (a*c + b*d)`;;
(* scalar cross product  *)
let cross2 = new_definition
 `(u1,u2) cross2 (v1,v2) =
   (u1 * v2 - u2 * v1)`;;

let vector_sum3 = new_definition
  ` vector_sum3 (u,v) (p,q) = (u+p,v+q)`;;

overload_interface("+", ` vector_sum3`);;

let vector_dif = new_definition
  ` vector_dif (u,v) (p,q) = (u-p,v-q)`;;

overload_interface("-", ` vector_dif`);;
prioritize_real();;

(*  twice the signed area of a triangle  *)
let tarea  = new_definition
  ` tarea(x,y,z) = (z-x) cross2 (y-x)`;;

(* signed area of a quadrilateral *)
let sarea4  = new_definition
 ` sarea4(a,b,c,d) = (c-a) cross2 (b-d)`;;

let square = new_definition
 ` square(x:real) = x * x : real`;;

(* distance squared *) 
let dsq = new_definition
 ` dsq((a1,a2),(b1,b2)) = square(a1-b1)+square(a2-b2)`;;

(* collinear   *)
let L = new_definition
 ` L(a,b,c) = (tarea(a,b,c) = &0)`;;

(* between   *)
let B = new_definition
` B (a,b,c) = 
   ( L(a,b,c) /\ (b-a) dot2 (c-a) > &0 /\ (b-c) dot2 (a-c) > &0)`;; 

(* Tarski betweenness, non-strict *)
let TT = new_definition
 ` TT(a,b,c) = (L(a,b,c) /\ (b-a) dot2 (c-a) >= &0 /\ (b-c) dot2 (a-c) > &0)`;;

(* Equal Triangles *)
let ET = new_definition
 ` ET(u,v,w,x,y,z) = 
     ( square(tarea(u,v,w)) = square(tarea(x,y,z)))`;;

(* congruent triangles  *)
let TC = new_definition
 ` TC(a,b,c,p,q,r) = (dsq(a,b) = dsq(p,q) /\ dsq(a,c) = dsq(p,r) /\ dsq(b,c) = dsq(q,r))`;;

(* Equal Figures, i.e. equal quadrilaterals *)
let EF = new_definition
 ` EF(a,b,c,d,p,q,r,s) = 
     (square(sarea4(a,b,c,d)) = square(sarea4(p,q,r,s)))`;;


(* twice the (unsigned) area of a triangle *)
let area3 = new_definition
 ` area3((x1,x2), (y1,y2), (z1,z2))  =  abs(tarea((x1,x2), (y1,y2), (z1,z2)))`;;

(* twice the (unsigned) area of a quadrilateral *)
let area4 = new_definition
 ` area4((a1,a2),(b1,b2),(c1,c2),(d1,d2)) = abs(sarea4((a1,a2),(b1,b2),(c1,c2),(d1,d2)))`;;

(*  That's all the definitions.  Now for the some preliminary theorems.  *)  

(* signed area is additive with linearity hypothesis, betweenness not needed *)
let tarea_additive = prove
 ( `!a b c d. L(b,d,c) ==> (tarea(a,b,d) + tarea(a,d,c) = tarea(a,b,c))`,
   REWRITE_TAC [FORALL_PAIR_THM;ET;square;tarea;cross2;vector_dif;L] THEN
   (CONV_TAC REAL_RING)
 );;

(* signed area is additive for triangle plus quadrilateral = quadrilateral *)
let additive3to4 = prove
( `!a b c d. (tarea(a,b,d) + tarea(d,b,c) =  sarea4(a,b,c,d))`,
  REWRITE_TAC [FORALL_PAIR_THM;square;tarea;sarea4;cross2;vector_dif] THEN
  (CONV_TAC REAL_RING)
);;

(* betweenness implies collinearity *)
let BimpliesL = prove
 ( `!a b c.(B(a,b,c) ==> L(a,b,c))`,
   MESON_TAC[B]
 );;

let posfactor = prove
( `!x y . (x > &0) ==> (((x * y) > &0) <=> (y > &0))`,
   (CONV_TAC REAL_SOS)
);;


let polyval = REWRITE_TAC[
   REAL_RING ` x*(--y) = --(x*y)`;
   REAL_RING ` x*(--y)*z = --(x*y*z)`;
   REAL_RING ` ( (--x)- (--y)) = y-x`;
   REAL_SOS ` -- x > &0 <=> x < &0`;
   posfactor];;


let ineq2 = prove 
 ( `!x1 x2 y1 y3 x3.
     (
     	((x1-x2) * y1 - (y2 - y1) * (x3 - x1) = &0) /\
		((x3 - x1) * (x2 - x1) - y1 * (y2-y1) > &0) /\
		((x3 - x2) * (x1-x2) - y2 * (y1-y2) > &0) /\
		 (x3 > &0 /\ y2 > &0) 
     )
     ==> (  y1 * (   --x3) > &0)`,
  polyval THEN
  CONV_TAC(REAL_SOS)  (* takes a minute but works! *) 
);;

let lemma33 = prove
 ( `(x3 > &0 /\ y2 > &0) /\ 
    (y1 * (   --x3) > &0)
    ==> ((x3 * y1) * (   --x3* y2) > &0)`,
    polyval THEN
	  CONV_TAC(REAL_SOS)   
 );;


let ineq1 = prove 
 ( `!x1 x2 y1 y3 x3.
     (
     	((x1-x2) * y1 - (y2 - y1) * (x3 - x1) = &0) /\
		((x3 - x1) * (x2 - x1) - y1 * (y2-y1) > &0) /\
		((x3 - x2) * (x1-x2) - y2 * (y1-y2) > &0) /\
		 (x3 > &0 /\ y2 > &0) 
     )
     ==> ((x3 * y1) * ( --x3* y2) > &0)`,
  MESON_TAC[ineq2; lemma33]
);;

let lemma34 = prove
 ( ` ! x3.  (x3 < &0 <=> --x3 > &0)`,
   CONV_TAC(REAL_SOS)
 );;

let ineq3 = 
  ISPECL [`--x1`; `--x2`; `y1:real`; `y3:real`; `--x3`] ineq1;;


let special_cancel = REAL_RING `--(a*b) + x + y + z + w + b*a = x + y + z + w`;;
let special_cancel2 = REAL_RING ` x + --(a*b) + y + z +  b*a + w = x + y + z + w`;;
let special_collect = REAL_RING `(a *b) * a * d = a pow 2 * b * d`;;

let myrules = 
  [REAL_RING `--(--x) = x`;
   REAL_RING `x-y = x + (--y)`;
   REAL_RING `--(x+y) = --x +(--y)`;
   REAL_RING `(--x - (--y)) = y-x`;
   REAL_RING `(x:real - (y:real - z:real)) = ((x:real -y:real)+z:real)`;
   REAL_RING `(x:real - (y:real - z:real - u:real)) = (((x:real -y:real)+z:real) + u:real)`;
   REAL_POLY_CONV(`x3*y1*x3*y2`);
   REAL_RING `(x-y)*z = x*z - y*z`;
   REAL_RING ` x *(y-z) = x*y - x*z`;
   REAL_RING `(--x *y) * z = --(x*y*z)`;
   REAL_RING `(--x) * y = --(x*y)`;
   REAL_RING ` x *(--y) = --(x*y)`;
   REAL_SOS `x3 pow 2 >= &0`;
   REAL_SOS `--x3 > &0 <=> x3 < &0`;
   REAL_RING ` ((x:real) +(y:real) )+(z:real)  = (x:real) + ((y:real) + (z:real))`;
   REAL_RING `x*x = x pow 2`;
   special_cancel;
   special_cancel2;
   special_collect
  ];;

let ineq4 = REWRITE_RULE myrules ineq3;;

let lemma1 = REAL_RING `x2 * y1 + --(y2 * x1) + y2 * x3 + --(y1 * x3) =
	                    x2 * y1 + y2 * x3 + --(y2 * x1) + --(y1 * x3)`;;

let lemma2 = REAL_RING ` x1 pow 2 + --(x1 * x2) + --(x3 * x1) + x3 * x2 + --(y1 * y2) + y1 pow 2
                       = x3 * x2 + --(x3 * x1) + --(x1 * x2) + x1 pow 2 + --(y1 * y2) + y1 pow 2`;;

let lemma3 = REAL_RING `x2 pow 2 + --(x2 * x1) + --(x3 * x2) + x3 * x1 + --(y2 * y1) + y2 pow 2 
                        = x3 * x1 + --(x3 * x2) + --(x2 * x1) + x2 pow 2 + --(y2 * y1) + y2 pow 2`;;

let ineq5 = prove 
 ( `!x1 x2 y1 y3 x3 y2.
     (
     	((x2-x1) * y1 - (y2 - y1) * (x1 - x3) = &0) /\
		((x1 - x3) * (x1 - x2) - y1 * (y2-y1) > &0) /\
		((x2 - x3) * (x2-x1) - y2 * (y1-y2) > &0) /\
		 (x3 < &0 /\ y2 > &0) 
     )
     ==> ((x3 * y1) * ( --x3* y2) > &0)`,
  REPEAT GEN_TAC THEN
  REWRITE_TAC myrules THEN
  MESON_TAC[lemma1;lemma2;lemma3;ineq4]
);;

let lemma35 = REAL_RING `((x2-x1) * y1 - (y2 - y1) * (x1 - x3) = &0) <=>
                  ((x1-x2) * y1 - (y2 - y1) * (x3 - x1) = &0)`;;

let lemma36 = REAL_RING `(x1 - x3) * (x1 - x2)  = (x3 - x1) * (x2 - x1)`;;

let lemma37 = REAL_RING `(x2 - x3) * (x2-x1) = (x3 - x2) * (x1-x2)`;;

let trichotomy = REAL_SOS `(x > &0 \/ x <  &0 \/ x = &0)`;;

let ineq6 = prove 
 ( `!x1 x2 y1 y3 x3.
     (
     	((x1-x2) * y1 - (y2 - y1) * (x3 - x1) = &0) /\
		((x3 - x1) * (x2 - x1) - y1 * (y2-y1) > &0) /\
		((x3 - x2) * (x1-x2) - y2 * (y1-y2) > &0) /\
		 (x3 < &0 /\ y2 > &0) 
     )
     ==> ((x3 * y1) * ( --x3* y2) > &0)`,
  MESON_TAC[ineq5; lemma35; lemma36;lemma37;trichotomy]
);;


(*  Now we've proved it with x3 > 0 and x3 < 0.  So it should be true with x3 nonzero 
We avoid  arguing  by cases, by appealing to trichotomy. *) 

let ineq7 = prove
 ( `!x1 x2 y1 y2 y3 x3.
     (
     	((x1-x2) * y1 - (y2 - y1) * (x3 - x1) = &0) /\
		((x3 - x1) * (x2 - x1) - y1 * (y2-y1) > &0) /\
		((x3 - x2) * (x1-x2) - y2 * (y1-y2) > &0) /\
		 (~(x3 = &0) /\ y2 > &0) 
     )
     ==> ((x3 * y1) * ( --x3* y2) > &0)`,
  REPEAT GEN_TAC THEN
  MESON_TAC[trichotomy; ineq1;ineq6]
);;

(* Next we want to remove the hypothesis y2 > &0 *)

let ineq8 =
  ISPECL [`x1:real`; `x2:real`; `--y1`; `--y2`; `--y3:real`; `x3:real`] ineq7;;

let lemma38 = REAL_RING `(x3 * y1) * ( --x3* y2) = (x3 * --y1) * --x3 * --y2`;;
let lemma39 = REAL_RING `((x1-x2) * y1 - (y2 - y1) * (x3 - x1) = &0)
                    <=> ( (x1 - x2) * --y1 - (--y2 - --y1) * (x3 - x1) = &0)`;;
let lemma40 = REAL_RING `y1 * (y2-y1) = --y1 * (--y2 - --y1)`;;
let lemma41 = REAL_RING `y2 * (y1-y2) = --y2 * (--y1 - --y2)`;;



let zero_rules = [
      REAL_RING `&0 * x = &0`;
      REAL_RING `x * &0 = &0`;
      REAL_RING `x + &0 = x`;
      REAL_RING `&0 + x = x`;
      REAL_RING `x - &0 = x`;
      REAL_RING `&0 -x = --x`;
      REAL_RING `x + (--y) = x-y`;
      REAL_RING `x + (--y *z) = x - y*z`;
      REAL_RING `--(y*z) = --y*z`;
      REAL_RING `-- (&0) = &0`
    ];;

let lemma42 = REAL_RING `(x2 - x1) * --y1 - (y2 - y1) * (x3 - x1) = (x1 - x2) * y1 - (y2 - y1) * (x3 - x1)`;;
let lemma43 = REAL_SOS `x > &0 ==> x >= &0`;;
let lemma44 =  REAL_RING `((x-y) - (z-y)) = x-z`;;

let lemma45 = prove
( `!a:real#real b:real#real d:real#real. ( (a-d)-(b-d) = a-b)`, 
  REWRITE_TAC [FORALL_PAIR_THM; vector_dif;lemma44] THEN
  (CONV_TAC REAL_RING) 
);;

(* Signed area is invariant under translation *)
let lemma46 = prove
( `!a b c d.  tarea(a-d,b-d,c-d) = tarea(a,b,c)`,
   REWRITE_TAC[tarea; lemma45]
);;

(* Signed area is additive for triangles with one vertex at origin and the 
   dividing line between the triangles on the x-axis *)
let lemma47 = prove 
( `!b d1 c. (L(b,(d1,&0),c) ==> 
         tarea((&0,&0),b,(d1,&0)) + tarea((&0,&0),(d1,&0),c) = tarea((&0,&0),b,c))`,
  REWRITE_TAC [tarea;FORALL_PAIR_THM; cross2; L; vector_dif] THEN
  REWRITE_TAC zero_rules THEN
  (CONV_TAC REAL_RING)
);;

(* Lemma47 with c set to (c1,c2) and b to (b1,b2)   *)
let lemma47A = prove 
( `!b1 b2 d1 c1 c2. (L((b1,b2),(d1,&0),(c1,c2)) ==> 
         tarea((&0,&0),(b1,b2),(d1,&0)) + tarea((&0,&0),(d1,&0),(c1,c2)) = tarea((&0,&0),(b1,b2),(c1,c2)))`,
  REWRITE_TAC [tarea;cross2; L; vector_dif] THEN
  REWRITE_TAC zero_rules THEN
  (CONV_TAC REAL_RING)
);;

(* Signed area is invariant under rotation, given by a matrix ((a b)(-b a)) with a^2 + b^2 = 1,
   in case one vertex is (0,0)
*)
let lemma48 = prove
( `!a b p1 p2 q1 q2. ( (a pow 2 + b pow 2 = &1) ==>
	     (tarea((&0,&0),(p1,p2),(q1,q2)) =  tarea((&0,&0), (a*p1 + b*p2, --b*p1 + a*p2),
	                                                      (a*q1 + b*q2, --b*q1 + a*q2))))`,
   REWRITE_TAC[tarea; cross2;vector_dif] THEN
   REWRITE_TAC zero_rules THEN
  (CONV_TAC REAL_RING)
);;

let lemma49 = prove
( `!c. tarea((&0,&0),(&0,&0),c) = &0`,
   REWRITE_TAC[tarea;FORALL_PAIR_THM; cross2;vector_dif] THEN
   REWRITE_TAC zero_rules THEN
  (CONV_TAC REAL_RING)
);;


(* A purely algebraic fact *)
let lemma50 = prove
( `!p1 p2 q1 q2 r1 r2 a m.((r1 - p1) * (q2 - p2) - (r2 - p2) * (q1 - p1) = &0 
   ==> ((a * r1 + m * r2) - (a * p1 + m * p2)) *
       ((--m * q1 + a * q2) - (--m * p1 + a * p2)) -
       ((--m * r1 + a * r2) - (--m * p1 + a * p2)) *
       ((a * q1 + m * q2) - (a * p1 + m * p2)) =
       &0)`,
 (CONV_TAC REAL_RING)  
);;

(*  L is invariant under any linear map.  Expanding the definitions we reduce to lemma50.  *)
let rotateL = prove
( `!p1 p2 q1 q2 r1 r2 a m. (L((p1,p2),(q1,q2),(r1,r2)) 
       ==> L((a*p1 + m*p2, --m*p1 + a*p2), (a*q1 + m*q2, --m*q1 + a*q2),(a*r1 + m*r2, --m*r1 + a*r2)))`,
   REPEAT GEN_TAC THEN
   REWRITE_TAC[L; tarea; cross2;vector_dif] THEN
   REWRITE_TAC zero_rules THEN
   MESON_TAC[lemma50]
);;