Section Geometry.
(* See the interactive pictures of Laurent Théry on http://www-sop.inria.fr/marelle/CertiGeo/ and research paper on https://docs.google.com/fileview?id=0ByhB3nPmbnjTYzFiZmIyNGMtYTkwNC00NWFiLWJiNzEtODM4NmVkYTc2NTVk&hl=fr *)
Record point:Type:={
X:R;
Y:R}.
Definition collinear(A B C:point):=
(X A - X B)*(Y C - Y B)-(Y A - Y B)*(X C - X B)=0.
Definition parallel (A B C D:point):=
((X A)-(X B))*((Y C)-(Y D))=((Y A)-(Y B))*((X C)-(X D)).
Definition notparallel (A B C D:point)(x:R):=
x*(((X A)-(X B))*((Y C)-(Y D))-((Y A)-(Y B))*((X C)-(X D)))=1.
Definition orthogonal (A B C D:point):=
((X A)-(X B))*((X C)-(X D))+((Y A)-(Y B))*((Y C)-(Y D))=0.
Definition equal2(A B:point):=
(X A)=(X B) /\ (Y A)=(Y B).
Definition equal3(A B:point):=
((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0.
Definition nequal2(A B:point):=
(X A)<>(X B) \/ (Y A)<>(Y B).
Definition nequal3(A B:point):=
not (((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0).
Definition middle(A B I:point):=
2%R*(X I)=(X A)+(X B) /\ 2%R*(Y I)=(Y A)+(Y B).
Definition distance2(A B:point):=
(X B - X A)^2%Z + (Y B - Y A)^2%Z.
(* AB = CD *)
Definition samedistance2(A B C D:point):=
(X B - X A)^2%Z + (Y B - Y A)^2%Z = (X D - X C)^2%Z + (Y D - Y C)^2%Z.
Definition determinant(A O B:point):=
(X A - X O)*(Y B - Y O) - (Y A - Y O)*(X B - X O).
Definition scalarproduct(A O B:point):=
(X A - X O)*(X B - X O) + (Y A - Y O)*(Y B - Y O).
Definition norm2(A O B:point):=
((X A - X O)^2%Z+(Y A - Y O)^2%Z)*((X B - X O)^2%Z+(Y B - Y O)^2%Z).
Definition equaldistance(A B C D:point):=
((X B) - (X A))^2%Z + ((Y B) - (Y A))^2%Z =
((X D) - (X C))^2%Z + ((Y D) - (Y C))^2%Z.
Definition equaltangente(A B C D E F:point):=
let s1:= determinant A B C in
let c1:= scalarproduct A B C in
let s2:= determinant D E F in
let c2:= scalarproduct D E F in
s1 * c2 = s2 * c1.
Ltac cnf2 f :=
match f with
| ?A \/ (?B /\ ?C) =>
let c1 := cnf2 (A\/B) in
let c2 := cnf2 (A\/C) in constr:(c1/\c2)
| (?B /\ ?C) \/ ?A =>
let c1 := cnf2 (B\/A) in
let c2 := cnf2 (C\/A) in constr:(c1/\c2)
| (?A \/ ?B) \/ ?C =>
let c1 := cnf2 (B\/C) in cnf2 (A \/ c1)
| _ => f
end
with cnf f :=
match f with
| ?A \/ ?B =>
let c1 := cnf A in
let c2 := cnf B in
cnf2 (c1 \/ c2)
| ?A /\ ?B =>
let c1 := cnf A in
let c2 := cnf B in
constr:(c1 /\ c2)
| _ => f
end.
Ltac scnf :=
match goal with
| |- ?f => let c := cnf f in
assert c;[repeat split| tauto]
end.
Ltac disj_to_pol f :=
match f with
| ?a = ?b \/ ?g => let p := disj_to_pol g in constr:((a - b)* p)
| ?a = ?b => constr:(a - b)
end.
nsatz.
Qed.
Ltac fastnsatz:=
try trivial; try apply fastnsatz1; try trivial; nsatz.
Ltac proof_pol_disj :=
match goal with
| |- ?g => let p := disj_to_pol g in
let h := fresh "hp" in
assert (h:p = 0);
[idtac|
prod_disj h p]
| _ => idtac
end
with prod_disj h p :=
match goal with
| |- ?a = ?b \/ ?g =>
match p with
| ?q * ?p1 =>
let h0 := fresh "hp" in
let h1 := fresh "hp" in
let h2 := fresh "hp" in
assert (h0:a - b = 0 \/ p1 = 0);
[apply Rmult_integral; exact h|
destruct h0 as [h1|h2];
[left; fastnsatz|
right; prod_disj h2 p1]]
end
| _ => fastnsatz
end.
(* Goal forall a b c d e f:R, a=b \/ c=d \/ e=f \/ e=a. intros. scnf; proof_pol_disj . admit.*)
Ltac geo_unfold :=
unfold collinear, parallel, notparallel, orthogonal,
equal2, equal3, nequal2, nequal3,
middle, samedistance2,
determinant, scalarproduct, norm2, distance2,
equaltangente, determinant, scalarproduct, equaldistance.
Ltac geo_rewrite_hyps:=
repeat (match goal with
| h:X _ = _ |- _ => rewrite h in *; clear h
| h:Y _ = _ |- _ => rewrite h in *; clear h
end).
Ltac geo_split_hyps:=
repeat (match goal with
| h:_ /\ _ |- _ => destruct h
end).
Ltac geo_begin:=
geo_unfold;
intros;
geo_rewrite_hyps;
geo_split_hyps;
scnf; proof_pol_disj.
(* Examples *)

Lemma Pappus: forall A B C A1 B1 C1 P Q S:point,
X A = 0 -> Y A = 0 -> Y B = 0 -> Y C = 0 ->
collinear A1 B1 C1 ->
collinear A B1 P -> collinear A1 B P ->
collinear A C1 Q -> collinear A1 C Q ->
collinear B C1 S -> collinear B1 C S ->
collinear P Q S
\/ (Y A1 - Y B1)^2%Z=0 \/ (X A = X B1)
\/ (X A1 = X C) \/ (X C = X B1)
\/ parallel A B1 A1 B \/ parallel A C1 A1 C \/ parallel B C1 B1 C.