(* Sets as A → Prop *)

Require Import Utf8 List Relations NPeano Compare_dec Setoid.
Require Import Misc.

Record set A := mkset { setp : A → Prop }.
Arguments mkset [A] _.
Arguments setp [A] _ _.

Definition empty_set {A} := mkset (λ _ : A, False).

Notation "x ∈ S" := (setp S x) (at level 60).
Notation "x ∉ S" := (¬ setp S x) (at level 60).
Notation "∅" := (empty_set).

Definition set_inter {A} (S₁ S₂ : set A) :=
  mkset (λ x, x ∈ S₁ ∧ x ∈ S₂).
Definition set_union {A} (S₁ S₂ : set A) :=
  mkset (λ x, x ∈ S₁ ∨ x ∈ S₂).
Definition set_union_list {A} (Si : list (set A)) :=
  fold_right set_union ∅ Si.
Definition set_sub {A} (S₁ S₂ : set A) :=
  mkset (λ x, x ∈ S₁ ∧ x ∉ S₂).
Definition set_incl {A} (S₁ S₂ : set A) :=
  ∀ x, x ∈ S₁ → x ∈ S₂.

Arguments set_inter : simpl never.
Arguments set_union : simpl never.
Arguments set_sub : simpl never.
Arguments set_incl : simpl never.

Declare Scope set_scope.
Delimit Scope set_scope with S.

Definition set_eq {A} (S₁ S₂ : set A) := ∀ x, x ∈ S₁ ↔ x ∈ S₂.

Notation "E₁ = E₂" := (set_eq E₁ E₂) : set_scope.
Notation "E₁ ≠ E₂" := (¬ set_eq E₁ E₂) : set_scope.
Notation "E₁ '∩' E₂" := (set_inter E₁ E₂) (at level 40).
Notation "E₁ '∪' E₂" := (set_union E₁ E₂) (at level 50).
Notation "E₁ '∖' E₂" := (set_sub E₁ E₂) (at level 50).
Notation "E₁ '⊂' E₂" := (set_incl E₁ E₂) (at level 60).
Notation "'⋃' Es" := (set_union_list Es) (at level 55).
Notation "E .[ i ]" := (List.nth i E ∅)
  (at level 1, format "'[' E '[' .[ i ] ']' ']'").

Definition set_map {A B} (f : A → B) s := mkset (λ v, ∃ u, u ∈ s ∧ f u = v).

Add Parametric Morphism {A B f} : (@set_map A B f)
  with signature set_eq ==> set_eq
  as set_map_morph.
Proof.
intros E F HEF b.
split; intros H.
 destruct H as (a & Ha & Hf).
 now exists a; split; [ apply HEF in Ha | ].

 destruct H as (a & Ha & Hf).
 now exists a; split; [ apply HEF in Ha | ].
Qed.

Theorem set_map_inter_distr : ∀ A B E F (f : A → B),
  FinFun.Injective f
  → (set_map f (E ∩ F) = set_map f E ∩ set_map f F)%S.
Proof.
intros * Hinj b.
split; intros H.
 destruct H as (a & (HaE & HaF) & Hf); simpl.
 split; exists a; easy.

 simpl in H; simpl.
 destruct H as ((ae & HE & Hae) & (af & HF & Haf)).
 rewrite <- Haf in Hae.
 specialize (Hinj _ _ Hae); subst af.
 now exists ae.
Qed.

Theorem set_map_union_distr : ∀ A B E F (f : A → B),
  (set_map f (E ∪ F) = set_map f E ∪ set_map f F)%S.
Proof.
intros; intros b.
split; intros H.
 now destruct H as (a & [Hae| Haf] & Hf); [ left | right ]; exists a.

 destruct H as [(a & Hae & Hf)| (a & Haf & Hf)].
  now exists a; split; [ left | ].
  now exists a; split; [ right | ].
Qed.

Theorem set_map_empty : ∀ A B (f : A → B), (set_map f ∅ = ∅)%S.
Proof.
intros; intros b.
now split; intros H; destruct H.
Qed.

Theorem in_set_map : ∀ A B x E (f : A → B),
  x ∈ E → f x ∈ set_map f E.
Proof. now intros * Hx; exists x. Qed.

Theorem set_map_in : ∀ A B x E (f : A → B),
  FinFun.Injective f
  → f x ∈ set_map f E
  → x ∈ E.
Proof.
intros * Hinj Hx.
destruct Hx as (a & Ha & Hfa).
now apply Hinj in Hfa; subst a.
Qed.

Theorem set_eq_refl A : reflexive (set A) set_eq.
Proof. now intros P x; split. Qed.

Theorem set_eq_sym A : symmetric (set A) set_eq.
Proof.
intros P₁ P₂ HPP x.
destruct (HPP x) as (H₁, H₂).
split; intros H; [ apply H₂, H | apply H₁, H ].
Qed.

Theorem set_eq_trans A : transitive (set A) set_eq.
Proof.
intros P₁ P₂ P₃ H₁₂ H₂₃ x.
destruct (H₁₂ x) as (H₁, H₂).
destruct (H₂₃ x) as (H₃, H₄).
split; intros H; [ apply H₃, H₁, H | apply H₂, H₄, H ].
Qed.

Add Parametric Relation A : (set A) (@set_eq A)
 reflexivity proved by (set_eq_refl A)
 symmetry proved by (set_eq_sym A)
 transitivity proved by (set_eq_trans A)
 as set_eq_rel.

Theorem eq_set_eq : ∀ A (x y : set A), x = y → (x = y)%S.
Proof. intros; now subst x. Qed.

Theorem included_trans A : transitive _ (@set_incl A).
Proof.
intros E F G HEF HFG x Hx.
apply HFG, HEF, Hx.
Qed.

Add Parametric Morphism {A} : (@set_inter A)
  with signature set_eq ==> set_eq ==> set_eq
  as set_inter_morph.
Proof.
intros E E' HE F F' HF.
unfold set_inter; intros p.
split; intros (H₁, H₂).
 now split; [ apply HE | apply HF ].
 now split; [ apply HE | apply HF ].
Qed.

Add Parametric Morphism {A} : (@set_union A)
  with signature set_eq ==> set_eq ==> set_eq
  as set_union_morph.
Proof.
intros E E' HE F F' HF.
intros p.
split.
 intros [H₁| H₂]; [ left; apply HE, H₁ | right; apply HF, H₂ ].
 intros [H₁| H₂]; [ left; apply HE, H₁ | right; apply HF, H₂ ].
Qed.

Add Parametric Morphism {A} : (@set_sub A)
  with signature set_eq ==> set_eq ==> set_eq
  as set_sub_morph.
Proof.
intros E E' HE F F' HF.
unfold set_sub; intros p.
split; intros (H₁, H₂).
 split; [ now apply HE | intros H; now apply H₂, HF ].
 split; [ now apply HE | intros H; now apply H₂, HF ].
Qed.

Add Parametric Morphism {A} : (@set_incl A)
  with signature set_eq ==> set_eq ==> iff
  as included_morph.
Proof.
intros E F HEF E' F' HE'F'.
split; intros HEE' x HF; apply HE'F', HEE', HEF, HF.
Qed.

Theorem set_eq_equiv {A} : ∀ (E F : set A),
  (E = F)%S
  → ∀ p, p ∈ E ↔ p ∈ F.
Proof. intros s * HEF; apply HEF. Qed.

Theorem set_union_empty_r : ∀ A (F : set A),
  (F ∪ ∅ = F)%S.
Proof.
intros * x.
split; intros H; [ | now left ].
now destruct H.
Qed.

Theorem set_inter_empty_l : ∀ A (F : set A),
  (∅ ∩ F = ∅)%S.
Proof.
intros * x.
split; intros H; [ now destruct H as (H, _) | easy ].
Qed.

Theorem set_inter_empty_r : ∀ A (F : set A),
  (F ∩ ∅ = ∅)%S.
Proof.
intros * x.
split; intros H; [ now destruct H as (_, H) | easy ].
Qed.

Theorem set_inter_comm : ∀ A (E F : set A),
  (E ∩ F = F ∩ E)%S.
Proof.
intros; intros x.
split; intros H; destruct H as (HE & HF); now split.
Qed.

Theorem set_union_comm : ∀ A (E F : set A),
  (E ∪ F = F ∪ E)%S.
Proof.
intros; intros x.
now split; intros [HE| HF]; [ right | left | right | left ] .
Qed.

Theorem set_inter_assoc : ∀ A (E F G : set A),
  (E ∩ (F ∩ G) = (E ∩ F) ∩ G)%S.
Proof.
intros; intros x.
split; intros H.
 destruct H as (HE & (HF & HG)).
 split; [ now split | easy ].

 destruct H as ((HE & HF) & HG).
 split; [ easy | now split ].
Qed.

Theorem set_union_assoc : ∀ A (E F G : set A),
  (E ∪ (F ∪ G) = (E ∪ F) ∪ G)%S.
Proof.
intros; intros x.
split; intros H.
 destruct H as [H| [H| H]].
  left; now left.
  left; now right.
  now right.

 destruct H as [[H| H]| H].
  now left.
  right; now left.
  right; now right.
Qed.

Theorem set_inter_shuffle0 : ∀ A (E F G : set A),
  (E ∩ F ∩ G = E ∩ G ∩ F)%S.
Proof.
intros; intros x.
split; intros H.
 destruct H as ((HE & HF) & HG).
 split; [ now split | easy ].

 destruct H as ((HE & HF) & HG).
 split; [ now split | easy ].
Qed.

Theorem set_union_list_app : ∀ A (P₁ P₂ : list (set A)),
  (⋃ (P₁ ++ P₂) = (⋃ P₁) ∪ (⋃ P₂))%S.
Proof.
intros.
revert P₁.
induction P₂ as [| Q]; intros.
 rewrite app_nil_r; simpl.
 now rewrite set_union_empty_r.

 rewrite cons_comm_app, app_assoc; simpl.
 rewrite IHP₂.
 unfold set_union_list; simpl; rewrite set_union_assoc.
 intros x.
 split; intros H.
  destruct H as [H| H]; [ left | now right ].
  unfold set_union_list in H.
  rewrite fold_right_app in H.
  simpl in H.
  clear - H.
  induction P₁ as [| R P₁].
   simpl in H; simpl.
   destruct H as [H| H]; [ now right | easy ].

   simpl in H.
   destruct H as [H| H]; [ simpl; left; now left | ].
   apply IHP₁ in H.
   destruct H as [H| H]; [ simpl; left; now right | ].
   now right.

  destruct H as [H| H]; [ left | now right ].
  unfold set_union_list.
  rewrite fold_right_app; simpl.
  clear - H.
  induction P₁ as [| R P₁].
   simpl in H; simpl; left.
   now destruct H.

   simpl in H; simpl.
   destruct H.
    destruct H; [ now left | right ].
    now apply IHP₁; left.

    now right; apply IHP₁; right.
Qed.

Theorem nth_set_union_list : ∀ A (P : list (set A)) i x,
  i < length P → x ∈ P.[i] → x ∈ ⋃ P.
Proof.
intros A P i x Hi H.
revert P H Hi.
induction i; intros P H Hi.
 destruct P as [| E P]; [ easy | now left ].

 destruct P as [| E P]; [ easy | simpl in Hi ].
 apply Nat.succ_lt_mono in Hi.
 right; now apply IHi.
Qed.

Theorem nth_set_app : ∀ A (P₁ P₂ : list (set A)) i,
  (P₁ ++ P₂).[i] =
  if lt_dec i (length P₁) then P₁.[i] else P₂.[i-length P₁].
Proof.
intros.
unfold set_union, set_eq; simpl; intros.
destruct (lt_dec i (length P₁)) as [H₁| H₁].
 now rewrite app_nth1.

 rewrite app_nth2; [ easy | now apply Nat.nlt_ge ].
Qed.

Theorem set_union_inter_self : ∀ A (E : set A) EL,
  E ⊂ ⋃ EL
  → (E = ⋃ map (set_inter E) EL)%S.
Proof.
intros * HEL x.
split; intros Hx.
 generalize Hx; intros Hxl.
 apply HEL in Hxl.
 clear -Hx Hxl.
 induction EL as [| E₁ EL]; intros; [ easy | ].
 destruct Hxl as [Hxl| Hxl]; [ left; now split | ].
 right; now apply IHEL.

 clear -Hx.
 induction EL as [| E₁ EL]; intros; [ easy | ].
 destruct Hx as [(Hx, _)| Hx]; [ easy | ].
 apply IHEL, Hx.
Qed.

Theorem set_inter_union_distr_r : ∀ A (E F G : set A),
  ((E ∪ F) ∩ G = (E ∩ G) ∪ (F ∩ G))%S.
Proof.
intros * x.
split; intros H.
 now destruct H as ([HE| HF] & HG); [ left | right ].

 destruct H as [(HE, HG)| (HF, HG)].
  now split; [ left | ].

  now split; [ right | ].
Qed.

Add Parametric Morphism {A} : (@setp A)
with signature set_eq ==> eq ==> iff
as setp_morph.
Proof.
intros E F HEF x.
apply HEF.
Qed.

Theorem set_map_union_list_distr : ∀ A B EL (f : A → B),
  (set_map f (⋃ EL) = ⋃ (map (set_map f) EL))%S.
Proof.
intros.
induction EL as [| E EL]; [ apply set_map_empty | simpl ].
now rewrite set_map_union_distr, IHEL.
Qed.

Theorem  set_sub_empty_l : ∀ A (E : set A), (∅ ∖ E = ∅)%S.
Proof.
intros; intros a; now simpl; split; intros H.
Qed.

Theorem set_sub_sub_swap : ∀ A (E F G : set A),
  (E ∖ F ∖ G = E ∖ G ∖ F)%S.
Proof.
intros; intros x; split; intros Hx.
 now destruct Hx as ((HE & HF) & HG).
 now destruct Hx as ((HE & HF) & HG).
Qed.


Require Export general_tactics.

(*****************************************************************************)
(** Fano plane PG23 **)

Module Type fano_plane_pg23.

Parameter Point:Set.
Parameter A B C D E F G H I J K L M: Point.

Parameter Line: Set.
Parameter ABCD AEFG AIJM AHKL BEHI BGJL BFKM CELM CFHJ CGIK DEJK DGHM DFIL : Line.

Parameter Incid : Point -> Line -> Prop.

Axiom is_only_13_pts : forall P:Point, {P=A}+{P=B}+{P=C}+{P=D}+{P=E}+{P=F}+{P=G}+{P=H}+{P=I}+{P=J}+{P=K}+{P=L}+{P=M}.

Axiom is_only_13_lines : forall P:Line, {P=ABCD}+{P=AEFG}+{P=AIJM}+{P=AHKL}+{P=BEHI}+{P=BGJL}+{P=BFKM}+{P=CELM}+{P=CFHJ}+{P=CGIK}+{P=DEJK}+{P=DGHM}+{P=DFIL}.

Definition is_fano_plane A B C D E F G H I J K L M ABCD AEFG AIJM AHKL BEHI BGJL BFKM CELM CFHJ CGIK DEJK DGHM DFIL :=
(~A=B /\ ~A=C /\ ~A=D /\ ~A=E /\ ~A=F /\ ~A=G /\ ~A=H /\ ~A=I /\ ~A=J /\ ~A=K /\ ~A=L /\ ~A=M /\
~B=C /\ ~B=D /\ ~B=E /\ ~B=F /\ ~B=G /\ ~B=H /\ ~B=I /\ ~B=J /\ ~B=K /\ ~B=L /\ ~B=M /\
~C=D /\ ~C=E /\ ~C=F /\ ~C=G /\ ~C=H /\ ~C=I /\ ~C=J /\ ~C=K /\ ~C=L /\ ~C=M /\
~D=E /\ ~D=F /\ ~D=G /\ ~D=H /\ ~D=I /\ ~D=J /\ ~D=K /\ ~D=L /\ ~D=M /\
~E=F /\ ~E=G /\ ~E=H /\ ~E=I /\ ~E=J /\ ~E=K /\ ~E=L /\ ~E=M /\
~F=G /\ ~F=H /\ ~F=I /\ ~F=J /\ ~F=K /\ ~F=L /\ ~F=M /\
~G=H /\ ~G=I /\ ~G=J /\ ~G=K /\ ~G=L /\ ~G=M /\
~H=I /\ ~H=J /\ ~H=K /\ ~H=L /\ ~H=M /\
~I=J /\ ~I=K /\ ~I=L /\ ~I=M /\
~J=K /\ ~J=L /\ ~J=M /\
~K=L /\ ~K=M /\
~L=M) /\
(ABCD<>AEFG /\ ABCD<>AIJM /\ ABCD<>AHKL /\ ABCD<>BEHI /\ ABCD<>BGJL /\ ABCD<>BFKM /\ ABCD<>CELM /\ ABCD<>CFHJ /\ ABCD<>CGIK /\ ABCD<>DEJK /\ ABCD<>DGHM /\ ABCD<>DFIL /\
AEFG<>AIJM /\ AEFG<>AHKL /\ AEFG<>BEHI /\ AEFG<>BGJL /\ AEFG<>BFKM /\ AEFG<>CELM /\ AEFG<>CFHJ /\ AEFG<>CGIK /\ AEFG<>DEJK /\ AEFG<>DGHM /\ AEFG<>DFIL /\
AIJM<>AHKL /\ AIJM<>BEHI /\ AIJM<>BGJL /\ AIJM<>BFKM /\ AIJM<>CELM /\ AIJM<>CFHJ /\ AIJM<>CGIK /\ AIJM<>DEJK /\ AIJM<>DGHM /\ AIJM<>DFIL /\
AHKL<>BEHI /\ AHKL<>BGJL /\ AHKL<>BFKM /\ AHKL<>CELM /\ AHKL<>CFHJ /\ AHKL<>CGIK /\ AHKL<>DEJK /\ AHKL<>DGHM /\ AHKL<>DFIL /\
BEHI<>BGJL /\ BEHI<>BFKM /\ BEHI<>CELM /\ BEHI<>CFHJ /\ BEHI<>CGIK /\ BEHI<>DEJK /\ BEHI<>DGHM /\ BEHI<>DFIL /\
BGJL<>BFKM /\ BGJL<>CELM /\ BGJL<>CFHJ /\ BGJL<>CGIK /\ BGJL<>DEJK /\ BGJL<>DGHM /\ BGJL<>DFIL /\
BFKM<>CELM /\ BFKM<>CFHJ /\ BFKM<>CGIK /\ BFKM<>DEJK /\ BFKM<>DGHM /\ BFKM<>DFIL /\
CELM<>CFHJ /\ CELM<>CGIK /\ CELM<>DEJK /\ CELM<>DGHM /\ CELM<>DFIL /\
CFHJ<>CGIK /\ CFHJ<>DEJK /\ CFHJ<>DGHM /\ CFHJ<>DFIL /\
CGIK<>DEJK /\ CGIK<>DGHM /\ CGIK<>DFIL /\
DEJK<>DGHM /\ DEJK<>DFIL /\
DGHM<>DFIL) /\
( Incid A ABCD /\ Incid A AEFG /\ Incid A AIJM /\ Incid A AHKL /\ ~Incid A BEHI /\ ~Incid A BGJL /\ ~Incid A BFKM /\ ~Incid A CELM /\ ~Incid A CFHJ /\ ~Incid A CGIK /\ ~Incid A DEJK /\ ~Incid A DGHM /\ ~Incid A DFIL /\
Incid B ABCD /\ ~Incid B AEFG /\ ~Incid B AIJM /\ ~Incid B AHKL /\ Incid B BEHI /\ Incid B BGJL /\ Incid B BFKM /\ ~Incid B CELM /\ ~Incid B CFHJ /\ ~Incid B CGIK /\ ~Incid B DEJK /\ ~Incid B DGHM /\ ~Incid B DFIL /\
Incid C ABCD /\ ~Incid C AEFG /\ ~Incid C AIJM /\ ~Incid C AHKL /\ ~Incid C BEHI /\ ~Incid C BGJL /\ ~Incid C BFKM /\ Incid C CELM /\ Incid C CFHJ /\ Incid C CGIK /\ ~Incid C DEJK /\ ~Incid C DGHM /\ ~Incid C DFIL /\
Incid D ABCD /\ ~Incid D AEFG /\ ~Incid D AIJM /\ ~Incid D AHKL /\ ~Incid D BEHI /\ ~Incid D BGJL /\ ~Incid D BFKM /\ ~Incid D CELM /\ ~Incid D CFHJ /\ ~Incid D CGIK /\ Incid D DEJK /\ Incid D DGHM /\ Incid D DFIL /\
~Incid E ABCD /\ Incid E AEFG /\ ~Incid E AIJM /\ ~Incid E AHKL /\ Incid E BEHI /\ ~Incid E BGJL /\ ~Incid E BFKM /\ Incid E CELM /\ ~Incid E CFHJ /\ ~Incid E CGIK /\ Incid E DEJK /\ ~Incid E DGHM /\ ~Incid E DFIL /\
~Incid F ABCD /\ Incid F AEFG /\ ~Incid F AIJM /\ ~Incid F AHKL /\ ~Incid F BEHI /\ ~Incid F BGJL /\ Incid F BFKM /\ ~Incid F CELM /\ Incid F CFHJ /\ ~Incid F CGIK /\ ~Incid F DEJK /\ ~Incid F DGHM /\ Incid F DFIL /\
~Incid G ABCD /\ Incid G AEFG /\ ~Incid G AIJM /\ ~Incid G AHKL /\ ~Incid G BEHI /\ Incid G BGJL /\ ~Incid G BFKM /\ ~Incid G CELM /\ ~Incid G CFHJ /\ Incid G CGIK /\ ~Incid G DEJK /\ Incid G DGHM /\ ~Incid G DFIL /\
~Incid H ABCD /\ ~Incid H AEFG /\ ~Incid H AIJM /\ Incid H AHKL /\ Incid H BEHI /\ ~Incid H BGJL /\ ~Incid H BFKM /\ ~Incid H CELM /\ Incid H CFHJ /\ ~Incid H CGIK /\ ~Incid H DEJK /\ Incid H DGHM /\ ~Incid H DFIL /\
~Incid I ABCD /\ ~Incid I AEFG /\ Incid I AIJM /\ ~Incid I AHKL /\ Incid I BEHI /\ ~Incid I BGJL /\ ~Incid I BFKM /\ ~Incid I CELM /\ ~Incid I CFHJ /\ Incid I CGIK /\ ~Incid I DEJK /\ ~Incid I DGHM /\ Incid I DFIL /\
~Incid J ABCD /\ ~Incid J AEFG /\ Incid J AIJM /\ ~Incid J AHKL /\ ~Incid J BEHI /\ Incid J BGJL /\ ~Incid J BFKM /\ ~Incid J CELM /\ Incid J CFHJ /\ ~Incid J CGIK /\ Incid J DEJK /\ ~Incid J DGHM /\ ~Incid J DFIL /\
~Incid K ABCD /\ ~Incid K AEFG /\ ~Incid K AIJM /\ Incid K AHKL /\ ~Incid K BEHI /\ ~Incid K BGJL /\ Incid K BFKM /\ ~Incid K CELM /\ ~Incid K CFHJ /\ Incid K CGIK /\ Incid K DEJK /\ ~Incid K DGHM /\ ~Incid K DFIL /\
~Incid L ABCD /\ ~Incid L AEFG /\ ~Incid L AIJM /\ Incid L AHKL /\ ~Incid L BEHI /\ Incid L BGJL /\ ~Incid L BFKM /\ Incid L CELM /\ ~Incid L CFHJ /\ ~Incid L CGIK /\ ~Incid L DEJK /\ ~Incid L DGHM /\ Incid L DFIL /\
~Incid M ABCD /\ ~Incid M AEFG /\ Incid M AIJM /\ ~Incid M AHKL /\ ~Incid M BEHI /\ ~Incid M BGJL /\ Incid M BFKM /\ Incid M CELM /\ ~Incid M CFHJ /\ ~Incid M CGIK /\ ~Incid M DEJK /\ Incid M DGHM /\ ~Incid M DFIL).

Axiom is_fano_plane_inst :  is_fano_plane A B C D E F G H I J K L M ABCD AEFG AIJM AHKL BEHI BGJL BFKM CELM CFHJ CGIK DEJK DGHM DFIL.

End fano_plane_pg23.

(*****************************************************************************)
(** Fano plane pg23 swap **)

Module swapf3 (M:fano_plane_pg23) : fano_plane_pg23
with Definition Point:=M.Point

with Definition A:=M.B
with Definition B:=M.E
with Definition C:=M.I
with Definition D:=M.H
with Definition E:=M.L
with Definition F:=M.G
with Definition G:=M.J
with Definition H:=M.C
with Definition I:=M.M
with Definition J:=M.K
with Definition K:=M.A
with Definition L:=M.D
with Definition M:=M.F

with Definition Line:=M.Line

with Definition ABCD:=M.BEHI
with Definition AEFG:=M.BGJL
with Definition AIJM:=M.BFKM
with Definition AHKL:=M.ABCD
with Definition BEHI:=M.CELM
with Definition BGJL:=M.DEJK
with Definition BFKM:=M.AEFG
with Definition CELM:=M.DFIL
with Definition CFHJ:=M.CGIK
with Definition CGIK:=M.AIJM
with Definition DEJK:=M.AHKL
with Definition DGHM:=M.CFHJ
with Definition DFIL:=M.DGHM

with Definition Incid :=M.Incid

with Definition is_fano_plane := M.is_fano_plane.

Definition Point:=M.Point.

Definition A:=M.B.
Definition B:=M.E.
Definition C:=M.I.
Definition D:=M.H.
Definition E:=M.L.
Definition F:=M.G.
Definition G:=M.J.
Definition H:=M.C.
Definition I:=M.M.
Definition J:=M.K.
Definition K:=M.A.
Definition L:=M.D.
Definition M:=M.F.

Definition Line:=M.Line.

Definition ABCD:=M.BEHI.
Definition AEFG:=M.BGJL.
Definition AIJM:=M.BFKM.
Definition AHKL:=M.ABCD.
Definition BEHI:=M.CELM.
Definition BGJL:=M.DEJK.
Definition BFKM:=M.AEFG.
Definition CELM:=M.DFIL.
Definition CFHJ:=M.CGIK.
Definition CGIK:=M.AIJM.
Definition DEJK:=M.AHKL.
Definition DGHM:=M.CFHJ.
Definition DFIL:=M.DGHM.

Definition Incid :=M.Incid.

Definition is_fano_plane := M.is_fano_plane.

Lemma is_only_13_pts : forall P:Point, {P=A}+{P=B}+{P=C}+{P=D}+{P=E}+{P=F}+{P=G}+{P=H}+{P=I}+{P=J}+{P=K}+{P=L}+{P=M}.
Proof.
generalize (M.is_only_13_pts).
unfold A, B,C, D, E, F, G, H, I, J, K, L, M.
intros H P; elim (H P).
intuition.
intuition.
Qed.

Lemma is_only_13_lines : forall P:Line, {P=ABCD}+{P=AEFG}+{P=AIJM}+{P=AHKL}+{P=BEHI}+{P=BGJL}+{P=BFKM}+{P=CELM}+{P=CFHJ}+{P=CGIK}+{P=DEJK}+{P=DGHM}+{P=DFIL}.
Proof.
generalize (M.is_only_13_lines).
unfold ABCD, AEFG, AIJM, AHKL, BEHI, BGJL, BFKM, CELM, CFHJ, CGIK, DEJK, DGHM, DFIL.
intros H P;
generalize (H P); intuition.
Qed.

Lemma is_fano_plane_inst : is_fano_plane A B C D E F G H I J K L M ABCD AEFG AIJM AHKL BEHI BGJL BFKM CELM CFHJ CGIK DEJK DGHM DFIL.
Proof.
generalize (M.is_fano_plane_inst).
unfold is_fano_plane, M.is_fano_plane.
intros H; decompose [and] H; clear H.
unfold A, B,C, D, E, F, G, H, I, J, K, L, M, ABCD, AEFG, AIJM, AHKL, BEHI, BGJL, BFKM, CELM, CFHJ, CGIK, DEJK, DGHM, DFIL.
repeat split;try assumption;try auto.
Qed.

End swapf3.

Module Desargues_from_A (M:fano_plane_pg23).

Import M.

Definition on_line := fun A B C l => M.Incid A l /\ Incid B l /\ Incid C l.
Definition collinear A B C :=  exists l, Incid A l /\ Incid B l /\ Incid C l.

Ltac use H := decompose [and ex] H; clear H.

Ltac solve_ex L := solve [exists L;auto].

(** A tactic which tries all possible lines **)

Ltac solve_ex_l := first [solve_ex ABCD
     |  solve_ex AEFG
     |  solve_ex AIJM
     |  solve_ex AHKL
     |  solve_ex BEHI
     |  solve_ex BGJL
     |  solve_ex BFKM
     |  solve_ex CELM
     |  solve_ex CFHJ
     |  solve_ex CGIK
     |  solve_ex DEJK
     |  solve_ex DGHM
     |  solve_ex DFIL
 ].

Ltac solve_ex_p := first [
        solve_ex A
     |  solve_ex B
     |  solve_ex C
     |  solve_ex D
     |  solve_ex E
     |  solve_ex F
     |  solve_ex G
     |  solve_ex H
     |  solve_ex I
     |  solve_ex J
     |  solve_ex K
     |  solve_ex L
     |  solve_ex M
 ].

Ltac new_case P :=
match (type of P) with
| Point => generalize (is_only_13_pts P) ; let Q := fresh in (intros Q; decompose [sumor sumbool] Q; clear Q; subst)
| Line => generalize (is_only_13_lines P) ; let Q := fresh in (intros Q; decompose [sumor sumbool] Q; clear Q; subst)
end.

Lemma col_degen_1 : forall P R, ~ collinear P P R -> False.
Proof.
intros.
apply H0.
unfold collinear in *.
generalize (is_fano_plane_inst); unfold is_fano_plane in *;
intro Hw ;use Hw;new_case P; new_case R;solve_ex_l.
Qed.

Lemma col_degen_2 : forall P R,
~ collinear P R P -> False.
Proof.
intros.
apply H0.
unfold collinear.
generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw;
new_case P;new_case R;solve_ex_l.
Qed.

Lemma col_degen_3 : forall P R,
~ collinear R P P -> False.
Proof.
intros.
apply H0.
unfold collinear.
generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw;
new_case P;new_case R;solve_ex_l.
Qed.

Lemma not_all_equal : forall P Q R : Point, ~(~P=P \/ ~Q=Q \/ ~R=R).
Proof.
intros P Q R H; intuition.
Qed.

Ltac degens :=
match goal with
| H: ~?A=?A \/ ~?B=?B \/ ~?C=?C |- _ => elim (not_all_equal A B C H)
| H:~collinear ?P ?P ?R |- _ => elim (col_degen_1 P R H)
| H:~collinear ?P ?R ?P |- _ => elim (col_degen_2 P R H)
| H:~collinear ?R ?P ?P |- _ => elim (col_degen_3 P R H)
| H:Incid ?P ?l, H2: ~ Incid ?P ?l |- _ => cut False; [let hf := fresh in (intro hf;elim hf)| apply (H2 H)]
end.

Ltac case_eq_s  O := new_case O.

Ltac case_clear P := case_eq_s P;try solve [degens].

Ltac fano_ctx := generalize (is_fano_plane_inst); unfold is_fano_plane in *; let Hw := fresh in (intro Hw ;use Hw).

Lemma collinearPPQ : forall P Q: Point, collinear P P Q.
Proof.
intros P; generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw; new_case P; intros Q; new_case Q;unfold collinear;
solve_ex_l.
Qed.

Lemma collinearPQQ : forall P Q: Point, collinear P Q Q.
Proof.
intros P; generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw; new_case P; intros Q; new_case Q; unfold collinear;
solve_ex_l.
Qed.

Lemma collinearPQP : forall P Q: Point, collinear P Q P.
Proof.
intros P; generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw;new_case P; intros Q; new_case Q; unfold collinear;
solve_ex_l.
Qed.

Ltac cols :=  apply collinearPPQ ||
              apply collinearPQQ ||
              apply collinearPQP ||
              (unfold collinear;solve_ex_l).

Ltac collinear_line :=
match goal with
H : ~collinear ?P ?Q ?R |- _ =>
  solve[assert (collinear P Q R) by (solve_ex_l);
cut False; [intros Hf; elim Hf | auto]]
end.

Ltac collinear_line_gen ABCD AEFG AIJM AHKL BEHI BGJL BFKM CELM CFHJ CGIK DEJK DGHM DFIL :=
match goal with
H : ~collinear ?P ?Q ?R |- _ =>
  solve [assert (collinear P Q R) by (solve_ex_l);
cut False; [intros Hf; elim Hf | auto]]
end.

End Desargues_from_A.

(** Combinatorial explosion by proving Desargues ! **)

(*

Lemma Desargues_from_A_spec :  forall P Q R P' Q' R' alpha beta gamma lPQ lPR lQR lP'Q' lP'R' lQ'R',
((on_line P Q gamma lPQ) /\ (on_line P' Q' gamma lP'Q')) /\
((on_line P R beta lPR) /\ (on_line P' R' beta lP'R')) /\
((on_line Q R alpha lQR) /\ (on_line Q' R' alpha lQ'R')) /\
((on_line A P P' ABCD) /\ (on_line A Q Q' AEFG) /\(on_line A R R' AIJM)) /\
~collinear A P Q /\  ~collinear A P R /\ ~collinear A Q R /\
~collinear P Q R /\ ~collinear P' Q' R' /\ ((~P=P')\/(~Q=Q')\/(~R=R')) ->
collinear alpha beta gamma.
Proof.
intros P Q R P' Q' R' alpha beta gamma lPQ lPR lQR lP'Q' lP'R' lQ'R'.
intros.
unfold on_line in  *;use H0.
generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw.

time(case_clear P;
case_clear Q;
case_clear R;
try collinear_line;
case_clear P';
case_clear Q';
case_clear R';
try collinear_line).
case_clear lPQ;
case_clear lP'Q';
case_clear lPR;
case_clear lP'R';
case_clear lQR;
case_clear lQ'R';
case_clear alpha;
case_clear beta;
try cols;
case_clear gamma;
try cols).
Qed.

Lemma col_1 : forall A B C,
 collinear A B C -> collinear B A C.
Proof.
intros.
unfold collinear in *.
decompose [ex and] H; clear H.
exists x.
intuition.
Qed.

Lemma col_2 : forall A B C,
 collinear A B C -> collinear A C B.
Proof.
intros.
unfold collinear in *.
decompose [ex and] H; clear H.
exists x.
intuition.
Qed.

Lemma col_3 : forall A B C,
 collinear A B C -> collinear B C A.
Proof.
intros.
unfold collinear in *.
decompose [ex and] H; clear H.
exists x.
intuition.
Qed.

Lemma col_4 : forall A B C,
 collinear A B C -> collinear C A B.
Proof.
intros.
unfold collinear in *.
decompose [ex and] H; clear H.
exists x.
intuition.
Qed.

Lemma col_5 : forall A B C,
 collinear A B C -> collinear C B A.
Proof.
intros.
unfold collinear in *.
decompose [ex and] H; clear H.
exists x.
intuition.
Qed.

Hint Resolve col_1 col_2 col_3 col_4 col_5 : Geom.

Lemma Desargues_from_A :  forall P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R',
((on_line P Q gamma lPQ) /\ (on_line P' Q' gamma lP'Q')) /\
((on_line P R beta lPR) /\ (on_line P' R' beta lP'R')) /\
((on_line Q R alpha lQR) /\ (on_line Q' R' alpha lQ'R')) /\
((on_line A P P' lP) /\ (on_line A Q Q' lQ) /\(on_line A R R' lR)) /\
~collinear A P Q /\  ~collinear A P R /\ ~collinear A Q R /\
~collinear P Q R /\ ~collinear P' Q' R' /\ ((~P=P')\/(~Q=Q')\/(~R=R')) ->
collinear alpha beta gamma.
Proof.
intros P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R'.
intros.
unfold on_line in  *;use H.
generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw.
case_clear lP;
case_clear lQ;
case_clear lR;
try collinear_line.

cut (collinear gamma beta alpha).
auto with Geom.
apply (Desargues_from_A_spec R Q P R' Q' P' gamma beta alpha
  lQR lPR lPQ lQ'R' lP'R' lP'Q').
repeat split; auto with Geom;
decompose [or] H33;auto.

cut (collinear beta gamma alpha).
auto with Geom.
eapply (Desargues_from_A_spec Q R P Q' R' P' beta gamma alpha
lQR lPQ lPR lQ'R' lP'Q' lP'R').
repeat split; auto with Geom;
decompose [or] H33;auto.

cut (collinear gamma alpha beta).
auto with Geom.
eapply (Desargues_from_A_spec R P Q R' P' Q' gamma alpha beta
 lPR lQR lPQ lP'R' lQ'R' lP'Q');
repeat split; auto with Geom;
decompose [or] H33;auto.

cut (collinear beta alpha gamma).
auto with Geom.
eapply (Desargues_from_A_spec Q P R Q' P' R' beta alpha gamma
 lPQ lQR lPR lP'Q' lQ'R' lP'R');
repeat split; auto with Geom;
decompose [or] H33;auto.

cut (collinear alpha gamma beta).
auto with Geom.
eapply (Desargues_from_A_spec P R Q P' R' Q' alpha gamma beta
lPR lPQ lQR lP'R' lP'Q' lQ'R');
repeat split; auto with Geom;
decompose [or] H33;auto.

apply (Desargues_from_A_spec P Q R P' Q' R' alpha beta gamma lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split; auto with Geom.
Qed.

End Desargues_from_A.

Module Desargues (M:fano_plane).

Import M.

Module Import M2:= Desargues_from_A M.

Module swaped_B := swapf3 M.
Module swaped_B' := Desargues_from_A swaped_B.
Module swaped_E := swapf3 swaped_B.
Module swaped_E' := Desargues_from_A swaped_E.
Module swaped_C := swapf3 swaped_E.
Module swaped_C' := Desargues_from_A swaped_C.
Module swaped_D := swapf3 swaped_C.
Module swaped_D' := Desargues_from_A swaped_D.
Module swaped_F := swapf3 swaped_D.
Module swaped_F' := Desargues_from_A swaped_F.
Module swaped_G := swapf3 swaped_F.
Module swaped_G' := Desargues_from_A swaped_G.

Theorem Desargues :
 forall O P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R',
((on_line P Q gamma lPQ) /\ (on_line P' Q' gamma lP'Q')) /\
((on_line P R beta lPR) /\ (on_line P' R' beta lP'R')) /\
((on_line Q R alpha lQR) /\ (on_line Q' R' alpha lQ'R')) /\
((on_line O P P' lP) /\ (on_line O Q Q' lQ) /\(on_line O R R' lR)) /\
~collinear O P Q /\  ~collinear O P R /\ ~collinear O Q R /\
~collinear P Q R /\ ~collinear P' Q' R' /\ ((~P=P')\/(~Q=Q')\/(~R=R')) ->
collinear alpha beta gamma.
Proof.
intros.
unfold on_line in *.
use H.
new_case O.

apply (Desargues_from_A  P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R');repeat split;eauto.

assert (T:=swaped_B'.Desargues_from_A).
unfold swaped_B'.on_line, swaped_B'.collinear,  swaped_B.A, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.

assert (T:=swaped_C'.Desargues_from_A).
unfold swaped_C'.on_line, swaped_C'.collinear,  swaped_C.A, swaped_C.Incid, swaped_C.Line, swaped_C.Point in *.
unfold swaped_E.A, swaped_E.Incid, swaped_E.Line, swaped_E.Point in *.
unfold  swaped_B.A, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.

assert (T:=swaped_D'.Desargues_from_A).
unfold swaped_D'.on_line, swaped_D'.collinear,  swaped_D.A, swaped_D.Incid, swaped_D.Line, swaped_D.Point in *.
unfold swaped_C.A, swaped_C.Incid, swaped_C.Line, swaped_C.Point in *.
unfold swaped_E.A, swaped_E.Incid, swaped_E.Line, swaped_E.Point in *.
unfold  swaped_B.A, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.

assert (T:=swaped_E'.Desargues_from_A).
unfold swaped_E'.on_line, swaped_E'.collinear,  swaped_E.A, swaped_E.Incid, swaped_E.Line, swaped_E.Point in *.
unfold   swaped_B.B, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.

assert (T:=swaped_F'.Desargues_from_A).
unfold swaped_F'.on_line, swaped_F'.collinear,  swaped_F.A, swaped_F.Incid, swaped_F.Line, swaped_F.Point in *.
unfold swaped_D.A, swaped_D.Incid, swaped_D.Line, swaped_D.Point in *.
unfold swaped_C.A, swaped_C.Incid, swaped_C.Line, swaped_C.Point in *.
unfold swaped_E.A, swaped_E.Incid, swaped_E.Line, swaped_E.Point in *.
unfold  swaped_B.A, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.

assert (T:=swaped_G'.Desargues_from_A).
unfold swaped_G'.on_line, swaped_G'.collinear in *.
unfold  swaped_G.A, swaped_G.Incid, swaped_G.Line, swaped_G.Point in *.
unfold swaped_F'.on_line, swaped_F'.collinear,  swaped_F.A, swaped_F.Incid, swaped_F.Line, swaped_F.Point in *.
unfold swaped_D.A, swaped_D.Incid, swaped_D.Line, swaped_D.Point in *.
unfold swaped_C.A, swaped_C.Incid, swaped_C.Line, swaped_C.Point in *.
unfold swaped_E.A, swaped_E.Incid, swaped_E.Line, swaped_E.Point in *.
unfold  swaped_B.A, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.
Qed.

End Desargues.

*)


Require
  MathClasses.implementations.stdlib_binary_integers Coq.setoid_ring.Field Coq.QArith.Qfield MathClasses.theory.rationals.
Require Import
  Coq.ZArith.ZArith
  Coq.setoid_ring.Ring Coq.QArith.QArith_base Coq.QArith.Qabs Coq.QArith.Qpower
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.rationals
  MathClasses.interfaces.orders MathClasses.interfaces.additional_operations
  MathClasses.implementations.field_of_fractions MathClasses.orders.integers.

(* canonical names for relations/operations/constants: *)
#[global]
Instance Q_eq: Equiv Q := Qeq.
#[global]
Instance Q_0 : Zero Q := 0%Q.
#[global]
Instance Q_1 : One Q := 1%Q.
#[global]
Instance Q_opp : Negate Q := Qopp.
#[global]
Instance Q_plus : Plus Q := Qplus.
#[global]
Instance Q_mult : Mult Q := Qmult.
#[global]
Instance Q_recip : DecRecip Q := Qinv.

(* properties: *)
#[global]
Instance: Setoid Q := {}.

#[global]
Instance: DecField Q.
Proof dec_fields.from_stdlib_field_theory Qfield.Qsft eq_refl.

(* misc: *)
#[global]
Instance: ∀ x y: Q, Decision (x = y) := Qeq_dec.

#[global]
Instance inject_Z_Q: Cast Z Q := inject_Z.

#[global]
Instance: Proper ((=) ==> (=)) inject_Z.
Proof. intros x y H. unfold inject_Z. repeat red. simpl. now rewrite H. Qed.

#[global]
Instance: SemiRing_Morphism inject_Z.
Proof.
  repeat (split; try apply _).
  intros x y. repeat red. simpl. now rewrite ?Zmult_1_r.
Qed.

#[global]
Instance: Injective inject_Z.
Proof.
 constructor. 2: apply _.
 intros x y. change (x * 1 = y * 1 → x = y). rewrite 2!rings.mult_1_r. intuition.
Qed.

#[global]
Program Instance Q_to_fracZ: Cast Q (Frac Z) := λ x, frac (Qnum x) (Zpos (Qden x)) _.

#[global]
Instance: Proper ((=) ==> (=)) Q_to_fracZ.
Proof. intros ? ? E. easy. Qed.

#[global]
Instance: SemiRing_Morphism Q_to_fracZ.
Proof. repeat (split; try apply _). Qed.

#[global]
Instance: Injective Q_to_fracZ.
Proof. split; try apply _. intros ? ? E. easy. Qed.

#[global]
Instance: RationalsToFrac Q := rationals.alt_to_frac Q_to_fracZ.
#[global]
Instance: Rationals Q := rationals.alt_Build_Rationals Q_to_fracZ inject_Z.

(* order: *)
#[global]
Instance Q_le: Le Q := Qle.
#[global]
Instance Q_lt: Lt Q := Qlt.

#[global]
Instance: SemiRingOrder Q_le.
Proof.
  assert (PartialOrder Q_le).
   repeat (split; try apply _).
      exact Qle_refl.
    exact Qle_trans.
   exact Qle_antisym.
  apply (rings.from_ring_order (Rle:=Q_le)).
   repeat (split; try apply _).
   intros. apply Qplus_le_compat. now apply Qle_refl. easy.
  intros. now apply Qmult_le_0_compat.
Qed.

#[global]
Instance: TotalRelation Q_le.
Proof.
  intros x y.
  destruct (Qlt_le_dec x y); auto.
  left. now apply Qlt_le_weak.
Qed.

#[global]
Instance: FullPseudoSemiRingOrder Q_le Q_lt.
Proof.
  rapply (semirings.dec_full_pseudo_srorder (R:=Q)).
  split.
   intro. split. now apply Zorder.Zlt_le_weak. now apply Zorder.Zlt_not_eq.
  intros [E1 E2]. destruct (Zorder.Zle_lt_or_eq _ _ E1). easy. now destruct E2.
Qed.

#[global]
Program Instance: ∀ x y: Q, Decision (x ≤ y) := λ y x,
  match Qlt_le_dec x y with
  | left _ => right _
  | right _ => left _
  end.
Next Obligation. now apply Qlt_not_le. Qed.

(* additional operations *)
#[global]
Program Instance: Abs Q := Qabs.
Next Obligation.
  split; intros E.
   now apply Qabs_pos.
  now apply Qabs_neg.
Qed.

#[global]
Instance Q_pow: Pow Q Z := Qpower.

#[global]
Instance: IntPowSpec Q Z Q_pow.
Proof.
  split.
     apply _.
    reflexivity.
   exact Qpower_0.
  intros. now apply Qpower_plus.
Qed.

#[global]
Instance Q_Npow: Pow Q N := λ x n, Qpower x (cast N Z n).

#[global]
Instance: NatPowSpec Q N Q_Npow.
Proof.
  split.
    unfold pow, Q_Npow. solve_proper.
   reflexivity.
  intros. unfold pow, Q_Npow.
  rewrite rings.preserves_plus.
  rewrite Qpower_plus'.
   reflexivity.
  change (1 + cast N Z n ≠ 0).
  apply orders.lt_ne_flip.
  apply nat_int.le_iff_lt_S.
  apply nat_int.to_semiring_nonneg.
Qed.

#[global]
Instance Q_shiftl: ShiftL Q Z := λ x k,
  match k with
  | Z0 => x
  | Zpos p => Qmake (Z.shiftl (Qnum x) (Zpos p)) (Qden x)
  | Zneg p => Qmake (Qnum x) (shift_pos p (Qden x))
  end.

#[global]
Instance: ShiftLSpec Q Z Q_shiftl.
Proof.
  apply shiftl_spec_from_int_pow.
  unfold shiftl, Q_shiftl.
  intros [n d] [|p|p].
    change ((n#d) = (n#d) * 1).
    now rewrite rings.mult_1_r.
   unfold Qnum, Qden.
   rewrite !Qmake_Qdiv. unfold Qdiv.
   rewrite Z.shiftl_mul_pow2 by auto with zarith.
   rewrite Zmult_comm, inject_Z_mult, Zpower_Qpower by now destruct p.
   now rewrite <-Qmult_assoc, Qmult_comm.
  unfold Qnum, Qden.
  rewrite !Qmake_Qdiv. unfold Qdiv.
  rewrite shift_pos_correct.
  change (Zpower_pos 2 p) with (2 ^ (Zpos p))%Z.
  rewrite Zmult_comm, inject_Z_mult, Zpower_Qpower by now destruct p.
  now rewrite Qinv_mult_distr, Qmult_assoc.
Qed.