Section Vect.
(* Our Field *)
Variable F: fparams.
Hypothesis FT:
@field_theory (Field.K F) (v0 F) (v1 F) (addK F) (multK F)
(fun x y => (addK F) x (oppK F y)) (oppK F)
(fun x y => (multK F) x (invK F y)) (invK F) (@Logic.eq F).
Add Field Kfth : FT.
(******************************************************************************)
(*   Instanciation of Grassman for n = 3                                      *)
(******************************************************************************)
Definition Pp: params :=  {| dim := 3; K := F |}.
Variable HP : fparamsProp Pp.
SubClass point := Kn Pp.
SubClass vect := Vect Pp.
Definition Vjoin (x y : vect): vect := Vjoin Pp x y.
Notation "x '∨' y" := (Vjoin x y) (at level 40, left associativity).
Definition Vadd (x y : vect): vect := Vadd Pp x y.
Notation "x + y" := (Vadd x y).
Definition Vsub (x y : vect): vect := sub Pp Pp x y.
Notation "x - y" := (Vsub x y).
Definition Vscal (k : F) (x : vect): vect := Vscal Pp k x.
Notation "k .* x" := (Vscal k x).
Definition Vmeet (x y : vect): vect := Vmeet Pp x y.
Notation "x '∧' y" := (Vmeet x y) (at level 45, left associativity).
Definition Vdual (x : vect): vect := Vdual Pp x.
Notation "'@  x" := (Vdual x) (at level 9).
Definition Veq (x y : vect): bool := Veq Pp x y.
Notation "x ?= y" := (Veq x y).
Definition Vgenk (k : F): vect := (Vgenk Pp k).
Notation "0" := (Vgenk 0%f).
Notation "1" := (Vgenk 1%f).
Definition hom (n: nat) (x : vect) := (hom Pp Pp n x).
Notation "'dC[ x ]" := (dconst Pp 3 x).
Notation "'C[ x ]" := (const Pp 3 x).
Notation "'E'" := (all Pp 3: vect).
Coercion p2v (x : point) := (K2G Pp x): vect.
Let scal0l x : 0%f .*  x = 0.
Let join_id: forall (x : point), x ∨ x = 0.
Let add_com x y : x + y = y + x.
(******************************************************************************)
(*   Definition of the bracket operator                                       *)
(******************************************************************************)
Definition bracket x y z : F := 'dC[x ∨ y ∨ z].
Notation "'E'" := (all Pp 3: vect).
Notation "'[ x , y , z ]" := (bracket x y z).
(******************************************************************************)
(* A tactic to prove homogeneity                                              *)
(******************************************************************************)
(* A tactic to normalize one specific bracket *)
Ltac normb a b c :=
generalize (bracket_norm a b c);
intros (Hn1, (Hn2, (Hn3, (Hn4, Hn5))));
rewrite ?Hn1, ?Hn2, ?Hn3, ?Hn4, ?Hn5;
clear Hn1 Hn2 Hn3 Hn4 Hn5.
Definition fbracket a b c:= '[a, b, c].
(* A tactic to globally normalize brackets *)
Ltac normbs :=
repeat match goal with |- context['[p2v ?a,p2v ?b,p2v ?c]] =>
generalize (fbracket_norm a b c);
intros (Hn1, (Hn2, (Hn3, (Hn4, (Hn5, Hn6)))));
rewrite ?Hn1, ?Hn2, ?Hn3, ?Hn4, ?Hn5, ?Hn6;
clear Hn1 Hn2 Hn3 Hn4 Hn5 Hn6
end; unfold fbracket.
(******************************************************************************)
(*   Some distributivity rules                                                *)
(******************************************************************************)
rewrite expand_meetl.
rewrite sub_add, meet_addl.
rewrite !meet_scall.
pattern (x2 ∧ x5 ∨ x6) at 1; rewrite <- join1l.
rewrite bracket_swapr, bracket_swapl; Krm1.
rewrite <-join_scall, <-bracket_defl.
pattern (x1 ∧ x5 ∨ x6) at 1; rewrite <- join1l.
rewrite bracket_swapr, bracket_swapl; Krm1.
rewrite <-join_scall, <-bracket_defl; auto.
Qed.
(*****************************************************************************)
(*                                                                           *)
(*                         Some plucker relations                            *)
(*                                                                           *)
(*****************************************************************************)
(*****************************************************************************)
(*                                                                           *)
(*                         Expansions                                        *)
(*                                                                           *)
(*****************************************************************************)
(******************************************************************************)
(*    Contraction                                                             *)
(******************************************************************************)
(******************************************************************************)
(*   Some standard geometry definitions                                       *)
(******************************************************************************)
Definition collinear x y z := x ∨ y ∨ z = 0.
Definition line (x y : point) := x ∨ y.
Definition intersection (x y : vect) := x ∧ y.
Definition concur (l1 l2 l3 : vect) := l1 ∧ l2 ∧ l3 = 0.
Definition online (x y z : point) := y ∨ z <> 0 /\ x ∨ y ∨ z = 0.
Definition online1 (x : point) k1 (y : point) k2 (z : point) :=
x = k1 .* y + k2 .* z :> vect.
Definition inter_lines (x a b c d : point) : Prop :=
x = (a ∨ b) ∧ (c ∨ d) :> vect.

Theorem Desargues (a b c a' b' c': point) :
let AB := line a b in
let A'B' := line a' b' in
let p := intersection AB A'B' in
let AC := line a c in
let A'C' := line a' c' in
let q := intersection AC A'C' in
let BC := line b c in
let B'C' := line b' c' in
let r := intersection BC B'C' in
let AA' := line a a' in
let BB' := line b b' in
let CC' := line c c' in
collinear p q r <-> collinear a b c \/ collinear a' b' c' \/ concur AA' BB' CC'.