Require Import Coq.Relations.Relations.

Require Export CatSem.CAT.Misc.
Require Export CatSem.CAT.product.
Require Export CatSem.CAT.initial_terminal.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.

Unset Automatic Introduction.

Section TYPE.

Section TYPE_data.

Variable A B:Type.
(*Definition TYPE_hom := A -> B.*)
(*Definition TYPE_hom_equiv:
   relation  := fun f g => forall x, f x = g x.*)

Lemma TYPE_hom_oid_prf:
    Equivalence (A:= A -> B) (fun f g => forall x, f x = g x).
Proof.
  constructor;
  unfold Reflexive;
  unfold Symmetric;
  unfold Transitive;
  intros;
  etransitivity;
  eauto.
Qed.

Definition TYPE_hom_oid := Build_Setoid TYPE_hom_oid_prf.

End TYPE_data.

Obligation Tactic := cat; try unf_Proper;
  intros; repeat rew_hyp; auto.

Program Instance TYPE_struct : Cat_struct (fun a b => a -> b) := {
   mor_oid a b := TYPE_hom_oid a b;
   id a := fun x: a => x;
   comp a b c := fun (f:a -> b) (g:b -> c) => fun x => g (f x)
}.

Definition TYPE: Cat := Build_Cat
   TYPE_struct.

End TYPE.

Canonical Structure TYPE.

Obligation Tactic := simpl; intros;
   try unf_Proper;
   intros; elim_conjs;
   repeat rew_hyp;
   cat.

Hint Extern 1 (_ = _ ) => apply injective_projections; simpl.

Program Instance TYPE_prod : Cat_Prod TYPE := {
  product := prod;
  prl a b := fst;
  prr a b := snd;
  prod_mor a b c f g := fun z => (f z, g z)
}.

Inductive TEMPTY : Type := .

Obligation Tactic := simpl; intros;
  repeat match goal with [H:TEMPTY |- _ ] => elim H end;
      cat.

Program Instance TYPE_init :  Initial TYPE := {
  Init := TEMPTY
}.

Hint Extern 3 (?a = ?b) => elim a.

Program Instance TYPE_term : Terminal TYPE := {
  Term := unit;
  TermMor a := fun x => tt
}.

Existing Instance TYPE_struct.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.saccheri.
Require Import GeoCoq.Tarski_dev.Annexes.perp_bisect.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section existential_playfair_rah.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma existential_playfair__rah :
  existential_playfair_s_postulate ->
  postulate_of_right_saccheri_quadrilaterals.
Proof.
intro HP; destruct HP as [A1 [A2 [P [HNC1 HP]]]].
destruct (l8_18_existence A1 A2 P) as [Q [HCcol1 HPerp1]]; Col.
assert (HA3 : exists A3, Col A1 A2 A3 /\ A3 <> Q).
{
  destruct (eq_dec_points A1 Q).
    subst; exists A2; assert_diffs; split; Col.
    exists A1; split; Col.
}
destruct HA3 as [A3 []].
destruct (ex_perp_cop P Q P A3) as [R [HPerp2 HCop]].
  assert_diffs; auto.
assert (HPar1 : Par A1 A2 P R).
{
  assert_diffs.
  apply l12_9 with P Q; Perp.
    Cop.
    apply coplanar_perm_3, col_cop__cop with A3; Cop; ColR.
    Cop.
    apply coplanar_perm_3, col_cop__cop with A3; Cop; ColR.
}
assert (HCop1 : Coplanar A1 A2 P R) by (apply par__coplanar, HPar1).
assert (HNC2 : Par_strict A1 A2 P R)
  by (apply par_not_col_strict with P; Col).
apply par_strict_not_col_4 in HNC2.
destruct (l8_18_existence A1 A2 R) as [S [HCcol2 HPerp3]]; Col.
assert (HPar2 : Par P Q R S) by (apply l12_9 with A1 A2; Perp; Cop).
assert (HNC3 : ~ Col P Q R) by (apply perp_not_col; Perp).
assert (HNC4 : Par_strict P Q R S) by (apply par_not_col_strict with R; Col).
apply par_strict_not_col_3 in HNC4.
destruct (l8_18_existence R S P) as [R' [HCcol3 HPerp4]]; Col.
assert (HPar3 : Par A1 A2 P R').
{
  assert_diffs.
  apply l12_9 with R S; Perp.
    apply coplanar_perm_5, col_cop__cop with A2; Col; Cop.
    exists R'; left; split; Col.
    apply coplanar_perm_5, col_cop__cop with A1; Col; Cop.
    exists R'; left; split; Col.
}
destruct (HP P R P R') as [_ HCol4]; Col.
assert (R = R') by (apply l6_21 with P R S R; assert_diffs; Col).
treat_equalities; rewrite <- (lam_per__rah P Q S R).

  {
  apply perp_in_per_1 with S S; apply l8_14_2_1b_bis; Col.
  apply perp_sym; apply perp_col0 with A1 A2; Col.
  assert (HPs : Par_strict P Q R S) by (apply par_not_col_strict with R; Col).
  apply par_strict_not_col_2 in HPs; assert_diffs; auto.
  }

  {
  assert (HPs : Par_strict P Q R S) by (apply par_not_col_strict with R; Col).
  apply par_strict_not_col_2 in HPs.
  repeat try (split; [intro; treat_equalities; assert_diffs; intuition|]).
  apply par__coplanar in HPar2.
  repeat split; Cop.
  - apply perp_in_per_1 with P P; apply l8_14_2_1b_bis; Col; Perp.
  - apply perp_in_per_1 with R R; apply l8_14_2_1b_bis; Col; Perp.
  - apply perp_in_per_1 with Q Q; apply l8_14_2_1b_bis; Col.
    apply perp_col0 with A1 A2; assert_diffs; Col.
  }
Qed.

End existential_playfair_rah.


From Tuto0 Require Export Loader.
Require Import Ltac_utils.

(* Pappus -> DG *)

Lemma Pappus2DG :
forall Oo A B C Ap Bp Cp X Y Z M N Sp T U V R,
 rk(Oo :: A :: nil) = 2 -> rk(Oo :: B :: nil) = 2
-> rk(A :: B :: nil) = 2 -> rk(Oo :: C :: nil) = 2
-> rk(A :: C :: nil) = 2 -> rk(B :: C :: nil) = 2
-> rk(Oo :: A :: B :: C :: nil) = 2     (* line a*)
-> rk(Oo :: Ap :: nil) = 2
-> rk(Oo :: A :: Ap :: nil) = 3         (* a != e*)
-> rk(Oo :: Bp :: nil) = 2
-> rk(Ap :: Bp :: nil) = 2
-> rk(Oo :: Cp :: nil) = 2
-> rk(Ap :: Cp :: nil) = 2
-> rk(Bp :: Cp :: nil) = 2 ->
rk(Oo :: Ap :: Bp :: Cp :: nil) = 2     (* line e*)
-> rk(B :: Ap :: X :: nil) = 2 (* Pappus point X *)
-> rk(A :: Bp :: X :: nil) = 2
-> rk(C :: Ap :: Y :: nil) = 2 (* Pappus point Y *)
-> rk(A :: Cp :: Y :: nil) = 2
-> rk(C :: Bp :: Z :: nil) = 2 (* Pappus point Z *)
-> rk(B :: Cp :: Z :: nil) = 2
-> rk(X :: Y :: Z :: nil) = 2    (* Pappus prop. *)
-> rk(Ap :: M :: Sp :: nil) = 2 ->     (* line b *)
rk(Oo :: A :: B :: C :: Ap :: M :: Sp :: nil) = 4
-> rk(Bp :: N :: T :: nil) = 2 ->      (* line c *)
rk(Oo :: A :: B :: C :: Bp :: N :: T :: nil) = 4
-> rk(C :: Sp :: T :: nil) = 2 ->      (* line d *)
rk(Oo :: C :: Ap :: Bp :: Cp :: Sp :: T :: nil) = 4
-> rk(Ap :: Bp :: M :: N :: Sp :: T :: nil) = 4
-> rk(A :: M :: U :: nil) = 2 ->       (* line f *)
rk(Oo :: A :: Ap :: Bp :: Cp :: M :: U :: nil) = 4
-> rk(A :: C :: M :: Sp :: T :: U :: nil) = 4
-> rk(B :: N :: V :: nil) = 2 ->       (* line g *)
rk(Oo :: B :: Ap :: Bp :: Cp :: N :: V :: nil) = 4
-> rk(B :: C :: N :: Sp :: T :: V :: nil) = 4
-> rk(Cp :: U :: V :: nil) = 2         (* line h *)
-> rk(Oo :: A :: B :: C :: Cp :: U :: V :: nil) = 4
-> rk(A :: B :: M :: N :: U :: V :: nil) = 4
-> rk(Ap :: Cp :: M :: Sp :: U :: V :: nil) = 4
-> rk(Bp :: Cp :: N :: T :: U :: V :: nil) = 4
-> rk(Y :: M :: R :: nil) = 2         (* point R *)
-> rk(Z :: N :: R :: nil) = 2
->                                  (*coplanarity*)
rk(C :: Cp :: Sp :: T :: U :: V :: nil) = 3.
Proof.
  intros.
(*  pprove.*)
  Require Import pprove_Pappus2DG_347.
  solve_using LP4P7P13P14P15P16.
Qed.
Check Pappus2DG.

Lemma Pappus2DG_noXYZ :
forall Oo A B C Ap Bp Cp M N Sp T U V,
 rk(Oo :: A :: nil) = 2 -> rk(Oo :: B :: nil) = 2
-> rk(A :: B :: nil) = 2 -> rk(Oo :: C :: nil) = 2
-> rk(A :: C :: nil) = 2 -> rk(B :: C :: nil) = 2
-> rk(Oo :: A :: B :: C :: nil) = 2     (* line a*)
-> rk(Oo :: Ap :: nil) = 2
-> rk(Oo :: A :: Ap :: nil) = 3         (* a != e*)
-> rk(Oo :: Bp :: nil) = 2
-> rk(Ap :: Bp :: nil) = 2
-> rk(Oo :: Cp :: nil) = 2
-> rk(Ap :: Cp :: nil) = 2
-> rk(Bp :: Cp :: nil) = 2 ->
rk(Oo :: Ap :: Bp :: Cp :: nil) = 2     (* line e*)
(*-> rk(B :: Ap :: X :: nil) = 2 (* Pappus point X *)
-> rk(A :: Bp :: X :: nil) = 2
-> rk(C :: Ap :: Y :: nil) = 2 (* Pappus point Y *)
-> rk(A :: Cp :: Y :: nil) = 2
-> rk(C :: Bp :: Z :: nil) = 2 (* Pappus point Z *)
-> rk(B :: Cp :: Z :: nil) = 2
-> rk(X :: Y :: Z :: nil) = 2    (* Pappus prop. *)*)
-> rk(Ap :: M :: Sp :: nil) = 2 ->     (* line b *)
rk(Oo :: A :: B :: C :: Ap :: M :: Sp :: nil) = 4
-> rk(Bp :: N :: T :: nil) = 2 ->      (* line c *)
rk(Oo :: A :: B :: C :: Bp :: N :: T :: nil) = 4
-> rk(C :: Sp :: T :: nil) = 2 ->      (* line d *)
rk(Oo :: C :: Ap :: Bp :: Cp :: Sp :: T :: nil) = 4
-> rk(Ap :: Bp :: M :: N :: Sp :: T :: nil) = 4
-> rk(A :: M :: U :: nil) = 2 ->       (* line f *)
rk(Oo :: A :: Ap :: Bp :: Cp :: M :: U :: nil) = 4
-> rk(A :: C :: M :: Sp :: T :: U :: nil) = 4
-> rk(B :: N :: V :: nil) = 2 ->       (* line g *)
rk(Oo :: B :: Ap :: Bp :: Cp :: N :: V :: nil) = 4
-> rk(B :: C :: N :: Sp :: T :: V :: nil) = 4
-> rk(Cp :: U :: V :: nil) = 2         (* line h *)
-> rk(Oo :: A :: B :: C :: Cp :: U :: V :: nil) = 4
-> rk(A :: B :: M :: N :: U :: V :: nil) = 4
-> rk(Ap :: Cp :: M :: Sp :: U :: V :: nil) = 4
-> rk(Bp :: Cp :: N :: T :: U :: V :: nil) = 4
(*-> rk(Y :: M :: R :: nil) = 2         (* point R *)
-> rk(Z :: N :: R :: nil) = 2 *)
->                                  (*coplanarity*)
rk(C :: Cp :: Sp :: T :: U :: V :: nil) = 3.
Proof.
intros.
Check rk_pappus.
Check rk_inter.
assert (HX:rk (B :: Ap :: A :: Bp :: nil) <= 3).
assert (rk (B :: Ap :: A :: Bp :: nil) = 3).
Require Import pprove_Pappus2DG_noXYZ_576.
solve_using LP2P3P5P6.
lia.
destruct (rk_inter B Ap A Bp HX) as [X [HX1 HX2]].

assert (HY:rk (C :: Ap :: A :: Cp :: nil) <= 3).
assert (rk (C :: Ap :: A :: Cp :: nil) = 3).
Require Import pprove_Pappus2DG_noXYZ_18969.
 solve_using LP2P4P5P7.
lia.
destruct (rk_inter C Ap A Cp HY) as [Y [HY1 HY2]].

assert (HZ:rk (B :: Cp :: C :: Bp :: nil) <= 3).
assert (rk (B :: Cp :: C :: Bp :: nil) = 3).
Require Import pprove_Pappus2DG_noXYZ_39020.
solve_using LP3P4P6P7.
lia.
destruct (rk_inter B Cp C Bp HZ) as [Z [HZ1 HZ2]].
assert (Hpappus : rk (X :: Y :: Z :: nil) = 2).

(*
rk_pappus
     : forall A B C D E F G H I : Point,
       rk (A :: B :: nil) = 2 ->
       rk (A :: C :: nil) = 2 ->
       rk (A :: D :: nil) = 2 ->
       rk (A :: E :: nil) = 2 ->
       rk (A :: F :: nil) = 2 ->
       rk (B :: C :: nil) = 2 ->
       rk (B :: D :: nil) = 2 ->
       rk (B :: E :: nil) = 2 ->
       rk (B :: F :: nil) = 2 ->
       rk (C :: D :: nil) = 2 ->
       rk (C :: E :: nil) = 2 ->
       rk (C :: F :: nil) = 2 ->
       rk (D :: E :: nil) = 2 ->
       rk (D :: F :: nil) = 2 ->
       rk (E :: F :: nil) = 2 ->
       rk (A :: B :: C :: nil) = 2 ->
       rk (D :: E :: F :: nil) = 2 ->
       rk (A :: E :: G :: nil) = 2 ->
       rk (B :: D :: G :: nil) = 2 ->
       rk (A :: F :: H :: nil) = 2 ->
       rk (C :: D :: H :: nil) = 2 ->
       rk (B :: F :: I :: nil) = 2 -> rk (C :: E :: I :: nil) = 2 -> rk (G :: H :: I :: nil) = 2
*)

eapply (rk_pappus) with (A:=A) (B:=B) (C:=C) (D:=Ap) (E:=Bp) (F:=Cp); try assumption.
Require Import pprove_Pappus2DG_noXYZ_60841.
solve_using LP2P5.
Require Import pprove_Pappus2DG_noXYZ_60842.
solve_using LP2P6.
Require Import pprove_Pappus2DG_noXYZ_60843.
 solve_using LP2P7.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.

assert (HR:rk (Y :: M :: Z :: N :: nil) <= 3).
assert (rk (Y :: M :: Z :: N :: nil) = 3).
pprove.
Require Import pprove_Pappus2DG_noXYZ_129851.
 solve_using LP1P5P8P9P11P15P16.
admit. (*
pprove.
Require Import pprove_Pappus2DG_noXYZ_39020.
solve_using LP3P4P6P7.*)
lia.
destruct (rk_inter Y M Z N HR) as [R [HR1 HR2]].
apply Pappus2DG with (Oo:=Oo) (A:=A) (B:=B) (Ap:=Ap) (Bp:=Bp) (X:=X) (Y:=Y) (Z:=Z) (M:=M) (N:=N) (R:=R); assumption.
Qed.

Ltac revert_all_relevant_hyps P1 P2 :=

  repeat match goal with H:(rk (P1::_)= ?a) |- _ => revert H
| H:(rk (_::P1::_)= ?a) |- _ => revert H
| H:(rk (_::_::P1::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::P1::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::_::P1::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::_::_::P1::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::_::_::_::P1::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::_::_::_::_::P1::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::_::_::_::_::_::P1::_)= ?a) |- _ => revert H
         end;

  repeat match goal with H:(rk (P2::_)= ?a) |- _ => revert H
| H:(rk (_::P2::_)= ?a) |- _ => revert H
| H:(rk (_::_::P2::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::P2::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::_::P2::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::_::_::P2::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::_::_::_::P2::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::_::_::_::_::P2::_)= ?a) |- _ => revert H
| H:(rk (_::_::_::_::_::_::_::_::P2::_)= ?a) |- _ => revert H
         end.

revert_all_relevant_hyps A Bp.
Ltac clear_rk_hyps := match goal with
                        H:rk(_)=_ |- _ => clear H
                      | H:rk(_)<=_ |- _ => clear H

                      end.
repeat clear_rk_hyps.
Ltac clear_useless_points := repeat match goal with X:Point |- _ => clear X end.
clear_useless_points.
clear Z.
pprove.

(*

Lemma dg : forall A A' B B' C C' R P Q
                  N M L N' M' L' O : Point,
rk(B ::  C' ::  P ::  L :: nil) = 2 -> (* line a *)
rk(B' ::  C ::  P ::  L' :: nil) = 2 -> (* line a' *)
rk(A' ::  Q ::  C ::  M :: nil) = 2 -> (* line b *)
rk(A ::  Q ::  C' ::  M' :: nil) = 2 -> (* line b' *)
rk(R ::  A ::  B' ::  N :: nil) = 2 -> (* line c *)
rk(R ::  A' ::  B ::  N' :: nil) = 2 -> (* line c' *)
rk(A' ::  B ::  C ::  C' ::  P ::  Q :: nil) = 4 -> (* a & b *)
rk(A ::  B ::  B' ::  C' ::  P ::  R :: nil) = 4 -> (* a & c *)
rk(A ::  A' ::  B' ::  C  ::  Q ::  R :: nil) = 4 -> (* b & c *)
rk(A ::  B' ::  C ::  C' ::  P ::  Q :: nil) = 4 -> (* a' & b' *)
rk(A' ::  B ::  B' ::  C ::  P ::  R :: nil) = 4 -> (* a' & c' *)
rk(A ::  A' ::  B ::  C' ::  Q ::  R :: nil) = 4 -> (* b' & c' *)
rk(N ::  M ::  L ::  O :: nil) = 2 -> (* line e *)
rk(N' ::  M' ::  L' ::  O :: nil) = 2 -> (* line e' *)
rk(A ::  C' ::  P ::  Q ::  B ::  M' :: nil) = 3 -> (* plane [a & b'] & M' *)
rk(B ::  C' ::  P ::  N' ::  M' ::  L' :: nil) = 4 -> (* a & e' *)
rk(A' ::  C ::  Q ::  N' ::  M' ::  L' :: nil) = 4 -> (* b & e' *)
rk(A ::  B' ::  R ::  N' ::  M' ::  L' :: nil) = 4 -> (* c & e' *)
rk(B' ::  C ::  P ::  N ::  M ::  L :: nil) = 4 -> (* a' & e *)
rk(A ::  C' ::  Q ::  N ::  M ::  L :: nil) = 4 -> (* b' & e *)
rk(A' ::  B ::  R ::  N ::  M ::  L :: nil) = 4 -> (* c' & e *)
rk(A ::  C' ::  Q :: M' :: nil) = 2. (* M' belongs to b' *) *)

Require Import lemma00.

Require Import lemmaXX.
Require Import lemmaYY.

Require Import lemma1.
Require Import lemma2.
Require Import lemma3.
Require Import lemma4.
Require Import lemma5.
Require Import lemma6.
Require Import lemma7.
Require Import lemma8.
Require Import lemma9.
Require Import lemma10.
Require Import lemma11.
Require Import lemma12.
Require Import lemma13.
Require Import lemma14.
Require Import lemma15.
Require Import lemma16.
Require Import lemma17.
Require Import lemma18.
Require Import lemma19.

Lemma eq_le_ge : forall x y : nat, x<=y<=x -> x=y.
Proof.
  intros; omega.
Qed.

Check rk_pappus.
(* Lemma dg : forall A A' B B' C C' R P Q
                  N M L N' M' L' O : Point,
rk(B, C', P, L) = 2 -> */ line a */
rk(B', C, P, L') = 2 -> */ line a' */
rk(A', Q, C, M) = 2 -> /* line b */
rk(A, Q, C', M') = 2 -> /* line b' */
rk(R, A, B', N) = 2 -> /* line c */
rk(R, A', B, N') = 2 -> /* line c' */
rk(A', B, C, C', P, Q) = 4 -> /* a & b */
rk(A, B, B', C', P, R) = 4 -> /* a & c */
rk(A, A', B', C , Q, R) = 4 -> /* b & c */
rk(A, B', C, C', P, Q) = 4 -> /* a' & b' */
rk(A', B, B', C, P, R) = 4 -> /* a' & c' */
rk(A, A', B, C', Q, R) = 4 -> /* b' & c' */
rk(N, M, L, O) = 2 -> /* line e */
rk(N', M', L', O) = 2 -> /* line e' */
rk(A, C', P, Q, B, M') = 3 -> /* plane [a & b'] & M' */
rk(B, C', P, N', M', L') = 4 -> /* a & e' */
rk(A', C, Q, N', M', L') = 4 -> /* b & e' */
rk(A, B', R, N', M', L') = 4 -> /* c & e' */
rk(B', C, P, N, M, L) = 4 -> /* a' & e */
rk(A, C', Q, N, M, L) = 4 -> /* b' & e */
rk(A', B, R, N, M, L) = 4 -> /* c' & e */
rk(A, C', Q, M') = 2. /* M' belongs to b' */ *)

Axiom rk_DG : forall A A' B B' C C'
                     D D' E E' F F'
                     T U V W,

    (* 3 skew lines *)
    rk(A::A'::nil)=2 -> (* a *)
    rk(B::B'::nil)=2 -> (* b *)
    rk(C::C'::nil)=2 -> (* c *)
    rk(A::A'::B::B'::nil)=4 -> (* skew a b *)
    rk(A::A'::C::C'::nil)=4 -> (* skew a c *)
    rk(B::B'::C::C'::nil)=4 -> (* skew b c *)

    (* 3 other skew lines *)
    rk(D::D'::nil)=2 ->
    rk(E::E'::nil)=2 ->
    rk(F::F'::nil)=2 ->
    rk(D::D'::E::E'::nil)=4 ->
    rk(D::D'::F::F'::nil)=4 ->
    rk(E::E'::F::F'::nil)=4 ->

    (* all 3 lines meet all 3 other lines *)
    rk(A::A'::D::D'::nil)=3 ->
    rk(A::A'::E::E'::nil)=3 ->
    rk(A::A'::F::F'::nil)=3 ->

    rk(B::B'::D::D'::nil)=3 ->
    rk(B::B'::E::E'::nil)=3 ->
    rk(B::B'::F::F'::nil)=3 ->

    rk(C::C'::D::D'::nil)=3 ->
    rk(C::C'::E::E'::nil)=3 ->
    rk(C::C'::F::F'::nil)=3 ->

    (* any traversal of the first set *)
    rk(T::U::nil)=2 ->
    rk(T::U::A::A'::nil)=3 ->
    rk(T::U::B::B'::nil)=3 ->
    rk(T::U::C::C'::nil)=3 ->

    (* any traversal of the second set *)
    rk(V::W::nil)=2 ->
    rk(V::W::D::D'::nil)=3 ->
    rk(V::W::E::E'::nil)=3 ->
    rk(V::W::F::F'::nil)=3 ->

    (* meets = are coplanar *)
    rk(V::W::T::U::nil)=3.

Lemma plane_of_2_lines : forall T U V X Y Z,
    rk(T::U::nil)=2 -> rk(T::V::nil)=2 -> rk(U::V::nil)=2 -> rk(T::U::V::nil)=2 ->
    rk(X::Y::nil)=2 -> rk(X::Z::nil)=2 -> rk(Y::Z::nil)=2 -> rk(X::Y::Z::nil)=2 ->
    rk(T::U::X::Y::nil)=3 ->
    exists R:Point, rk(T::U::V::R::nil)=2 /\ rk(X::Y::Z::R::nil)=2.
Proof.
  intros.
  assert (H1': rk (T :: U :: X :: Y :: nil) <=3) by omega.
  destruct (rk_inter _ _ _ _ H1') as [R [Hi1 Hi2]].
  exists R; split.
  apply (LP1P2P3P7 T U V X Y Z R); assumption.
  apply (LP1P2P3P7 X Y Z T U V R); try assumption.
  assert (Hrk:rk(X::Y::T::U::nil)=rk(T::U::X::Y::nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.
  assumption.
Qed.

(*Lemma LP8P9P10 : forall P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 P11 P12 P13 P14 P15 P16 P17 ,
rk(P1 :: P2 ::  nil) = 2 -> rk(P1 :: P3 ::  nil) = 2 -> rk(P2 :: P3 ::  nil) = 2 ->
rk(P1 :: P4 ::  nil) = 2 -> rk(P2 :: P4 ::  nil) = 2 -> rk(P3 :: P4 ::  nil) = 2 ->
rk(P1 :: P2 :: P3 :: P4 ::  nil) = 2 -> rk(P1 :: P5 ::  nil) = 2 -> rk(P1 :: P6 ::  nil) = 2 ->
rk(P5 :: P6 ::  nil) = 2 -> rk(P1 :: P7 ::  nil) = 2 -> rk(P5 :: P7 ::  nil) = 2 ->
rk(P6 :: P7 ::  nil) = 2 -> rk(P1 :: P5 :: P6 :: P7 ::  nil) = 2 -> rk(P2 :: P3 :: P4 :: P5 :: P6 :: P7 ::  nil) = 3 ->
rk(P3 :: P5 :: P8 ::  nil) = 2 -> rk(P2 :: P6 :: P8 ::  nil) = 2 -> rk(P4 :: P5 :: P9 ::  nil) = 2 ->
rk(P2 :: P7 :: P9 ::  nil) = 2 -> rk(P4 :: P6 :: P10 ::  nil) = 2 -> rk(P3 :: P7 :: P10 ::  nil) = 2 ->
rk(P1 :: P2 :: P5 :: P11 ::  nil) = 4 -> rk(P8 :: P12 ::  nil) = 2 -> rk(P11 :: P12 ::  nil) = 2 ->
rk(P8 :: P11 :: P12 ::  nil) = 2 -> rk(P5 :: P11 :: P13 ::  nil) = 2 -> rk(P6 :: P12 :: P14 ::  nil) = 2 ->
rk(P2 :: P11 :: P15 ::  nil) = 2 -> rk(P3 :: P12 :: P16 ::  nil) = 2 -> rk(P4 :: P13 :: P14 :: P17 ::  nil) = 2 ->
rk(P7 :: P15 :: P16 :: P17 ::  nil) = 2 -> rk(P8 :: P9 :: P10 ::  nil) = 2.
Proof.
Admitted.*)

Lemma rk_3_to_4 :  forall A B C:Point, rk(A::B::C::nil)=3 -> exists P:Point, rk(A::B::C::P::nil)=4.
Proof.
intros A B C HABC.
destruct (rk_lower_dim) as [P1 [P2 [P3 [P4 HP1P2P3P4]]]].
assert (HP1:rk(A::B::C::P1::nil)=3\/rk(A::B::C::P1::nil)=4).
assert (3<=rk(A::B::C::P1::nil)<=4).
split.
rewrite <- HABC.
apply matroid2; my_inO.
apply rk_upper_dim.
omega.
destruct HP1 as [HP13 | HP14].

assert (HP2:rk(A::B::C::P1::P2::nil)=3\/rk(A::B::C::P1::P2::nil)=4).
assert (3<=rk(A::B::C::P1::P2::nil)<=4).
split.
rewrite <- HP13.
apply matroid2; my_inO.
apply rk_upper_dim.
omega.
destruct HP2 as [HP23 | HP24].

assert (HP3:rk(A::B::C::P1::P2::P3::nil)=3\/rk(A::B::C::P1::P2::P3::nil)=4).
assert (3<=rk(A::B::C::P1::P2::P3::nil)<=4).
split.
rewrite <- HP23.
apply matroid2; my_inO.
apply rk_upper_dim.
omega.
destruct HP3 as [HP33 | HP34].

assert (HP4:rk(A::B::C::P1::P2::P3::P4::nil)=4).
assert (4<=rk(A::B::C::P1::P2::P3::P4::nil)<=4).
split.
rewrite <- HP1P2P3P4.
apply matroid2; my_inO.
apply rk_upper_dim.
omega.
(* case P4 *)
destruct (eq_dec P1 P4).
subst; replace (rk (A :: B :: C :: P4 :: P2::P3::P4 :: nil)) with (rk (A :: B :: C :: P4::P2 ::P3:: nil)) in * by (apply eq_le_ge; split; apply matroid2; my_inO);rewrite HP4 in HP33; omega.
destruct (eq_dec P2 P4).
subst; replace (rk (A :: B :: C :: P1 :: P4::P3::P4 :: nil)) with (rk (A :: B :: C :: P1::P4 ::P3:: nil)) in * by (apply eq_le_ge; split; apply matroid2; my_inO);rewrite HP4 in HP33; omega.
destruct (eq_dec P3 P4).
subst; replace (rk (A :: B :: C :: P1 :: P2::P4::P4 :: nil)) with (rk (A :: B :: C :: P1::P2 ::P4:: nil)) in * by (apply eq_le_ge; split; apply matroid2; my_inO);rewrite HP4 in HP33; omega.

exists P4.
assert (4<=rk(A::B::C::P4::nil)<=4).
split.
assert (Hm3:rk((A::B::C::P1::P2::P3::nil) ++ (A::B::C::P4::nil)) +
        rk(list_inter (A::B::C::P1::P2::P3::nil) (A::B::C::P4::nil)) <= rk (A::B::C::P1::P2::P3::nil) + rk  (A::B::C::P4::nil)).
apply matroid3.
replace (rk
          ((A :: B :: C :: P1 :: P2 :: P3::nil) ++
           A :: B :: C :: P4 :: nil)) with (rk (A::B::C::P1::P2::P3::P4::nil)) in Hm3 by (apply eq_le_ge; split; apply matroid2; my_inO).
replace (rk
          (list_inter
             (A :: B :: C :: P1 :: P2 ::P3:: nil)
             (A :: B :: C :: P4 :: nil))) with (rk (A::B::C::nil)) in Hm3 by (apply eq_le_ge; split;apply matroid2; my_inO).

omega.
apply rk_upper_dim.
omega.

(* case P3 *)
destruct (eq_dec P1 P3).
subst; replace (rk (A :: B :: C :: P3 :: P2::P3:: nil)) with (rk (A :: B :: C ::P3 ::P2:: nil)) in * by (apply eq_le_ge; split; apply matroid2; my_inO); rewrite HP23 in *; omega.
destruct (eq_dec P2 P3).
subst; replace (rk (A :: B :: C :: P1 :: P3::P3 :: nil)) with (rk (A :: B :: C ::P1 ::P3:: nil)) in * by (apply eq_le_ge; split; apply matroid2; my_inO); rewrite HP34 in *; omega.
exists P3.
assert (4<=rk(A::B::C::P3::nil)<=4).
split.
assert (Hm3:rk((A::B::C::P1::P2::nil) ++ (A::B::C::P3::nil)) +
        rk(list_inter (A::B::C::P1::P2::nil) (A::B::C::P3::nil)) <= rk (A::B::C::P1::P2::nil) + rk  (A::B::C::P3::nil)).
apply matroid3.
replace (rk
          ((A :: B :: C :: P1 :: P2 :: nil) ++
           A :: B :: C :: P3 :: nil)) with (rk (A::B::C::P1::P2::P3::nil)) in Hm3 by (apply eq_le_ge; split; apply matroid2; my_inO).
replace (rk
          (list_inter
             (A :: B :: C :: P1 :: P2 :: nil)
             (A :: B :: C :: P3 :: nil))) with (rk (A::B::C::nil)) in Hm3 by (apply eq_le_ge; split;apply matroid2; my_inO).
omega.
apply rk_upper_dim.
omega.

destruct (eq_dec P1 P2).
subst; replace (rk (A :: B :: C :: P2 :: P2 :: nil)) with (rk (A :: B :: C :: P2 :: nil)) in HP24 by (apply eq_le_ge; split; apply matroid2; my_inO);rewrite HP24 in HP13; omega.
exists P2.
assert (4<=rk(A::B::C::P2::nil)<=4).
split.
assert (Hm3:rk((A::B::C::P1::nil) ++ (A::B::C::P2::nil)) +
        rk(list_inter (A::B::C::P1::nil) (A::B::C::P2::nil)) <= rk (A::B::C::P1::nil) + rk  (A::B::C::P2::nil)).
apply matroid3.
replace (rk((A :: B :: C :: P1 :: nil) ++ A :: B :: C :: P2 :: nil)) with  (rk(A :: B :: C :: P1 :: P2 :: nil)) in Hm3 by (apply eq_le_ge; split; apply matroid2; my_inO).
replace  (rk (list_inter (A :: B :: C :: P1 :: nil) (A :: B :: C :: P2 :: nil))) with (rk (A::B::C::nil)) in Hm3 by (apply eq_le_ge; split;apply matroid2; my_inO).
omega.
apply rk_upper_dim.
omega.

exists P1; assumption.
Qed.

Lemma traversal : forall C B Q A P,
    rk(B::Q::nil)=2 -> rk(A::P::nil)=2 -> rk(B::Q::A::P::nil)=4 ->
    rk(C::A::P::nil)=3 -> rk(C::B::Q::nil)=3 ->
    exists Idf, exists Idg,  rk(Idf::Idg::nil)=2/\
                             rk(C::Idf::nil)=2/\
                             rk(C::Idg::nil)=2/\

                             rk(A::P::Idf::nil)=2 /\
                             rk(B::Q::Idg::nil)=2 /\
                             rk(C::Idf::Idg::nil)=2.
Admitted.

Lemma traversal_specific : forall O A B C A' C' P Q,
    rk(O::A::A'::nil)=3 -> rk(O::A::A'::P::nil)=4 -> rk(O::A::A'::C'::nil)=3 ->
    rk(O::A::A'::Q::nil)=4 ->  rk(P::Q::nil)=2 ->
    exists Idf, exists Idg, rk(A::P::Idf::nil)=2 /\
                            rk(B::Q::Idg::nil)=2 /\
                            rk(C::Idf::Idg::nil)=2.
Admitted.

Lemma DG_wo_extra_points : forall O A B C A2 B2 C2 X Y Z: Point,
  rk(A::B::nil)=2 ->
  rk(A::C::nil)=2 ->
  rk(B::C::nil)=2 ->

  rk(A2::B2::nil)=2 ->
  rk(A2::C2::nil)=2 ->
  rk(B2::C2::nil)=2 ->

  rk(O::A::nil)=2 ->
  rk(O::B::nil)=2 ->
  rk(O::C::nil)=2 ->
  rk(O::A2::nil)=2 ->
  rk(O::B2::nil)=2 ->
  rk(O::C2::nil)=2 ->

  rk(A::B2::X::nil)=2 ->
  rk(B::A2::X::nil)=2 ->
  rk(A::C2::Y::nil)=2 ->
  rk(C::A2::Y::nil)=2 ->
  rk(B::C2::Z::nil)=2 ->
  rk(C::B2::Z::nil)=2 ->

  rk(O::A::B::C::nil)=2 ->  (* line a *)
  rk(O::A2::B2::C2::nil)=2 ->  (* line e *)

  rk(O::A::A2::nil)=3 -> (* plane (a,e) *)

(*  rk(A2::P::Ihb::nil)=2 ->  // line b
  rk(Q::B2::Ihc::nil)=2 ->  // line c
  rk(C2::Idg::Idf::R::nil)=2 ->  // line d *)

(*  rk(A::P::Idf::nil)=2 ->  // line f
  rk(B::Q::Idg::nil)=2 ->  // line g
  rk(C::Ihb::Ihc::R::nil)=2 ->  // line h *)

(*  rk(O::A::A2::P::nil) = 4 -> // P is outside plane (a,e) *)
(*
  rk(Q::X::P::nil)=2 ->
  rk(Q::X::nil)=2 ->
  rk(Q::P::nil)=2 ->
  *)
  rk(X::Y::Z::nil)=2.
Proof.
  intros.
  Check (LP1P2P5 O A B C A2 B2 C2).
  assert (H19':rk (O ::A :: A2 :: nil) = 3) by (eapply (LP1P2P5 O A B C A2 B2 C2); assumption).
  elim (rk_3_to_4 O A A2 H19'); intros P HP.
  elim (rk_three_points_on_lines X P).
  intros Q [HQ1 [HQ2 HQ3]].
  (* let d be the unique transversal from C′ to the skew lines f and g *)
  (* let h be the unique transversal from C to the skew lines b and c*)
  (*assert (HBQ:rk (B :: Q :: nil) = 2) by (apply (LP3P12 O A B C A2 B2 C2 X Y Z P Q); assumption).
  assert (HAP:rk(A :: P ::nil)=2) by (apply (LP2P11 O A B C A2 B2 C2 X Y Z P Q); assumption).
  assert (HBQAP:rk (B :: Q :: A :: P :: nil) = 4).

  assert (HBQAP':rk (A :: B :: P :: Q :: nil) = 4)
    by (apply (LP2P3P11P12 O A B C A2 B2 C2 X Y Z P Q); assumption).
  assert (Hrk : rk (B :: Q :: A :: P :: nil) = rk (A :: B :: P :: Q :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk; assumption.
  assert (HA2B2PQ:rk (C2 :: A :: P :: nil) = 3).
  assert (Hrk:rk (C2 :: A :: P :: nil) = rk (A::C2::P::nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.
  (*apply (LP2P7P11 O A B C A2 B2 C2 X Y Z P Q); admit.*)
  admit.
  assert (HC2BQ:rk(C2::B::Q::nil)=3) by admit.*)

  Check (traversal_specific O A B C A2 C2 P Q).
  assert (HOAA2 : rk (O :: A :: A2 :: nil) = 3).
  admit.
  assert (HOAA2Q : rk (O :: A :: A2 :: P :: nil) = 4).
  admit.
  assert (HOAA2C2: rk (O :: A :: A2 :: C2 :: nil) = 3).
  admit.
  assert (HOAA2P:rk (O :: A :: A2 :: Q :: nil) = 4).
  admit.
  assert(HPQ: rk (P :: Q :: nil) = 2).
  admit.

  destruct (traversal_specific O A B C A2 C2 P Q HOAA2 HOAA2Q HOAA2C2 HOAA2P HPQ) as [Idf [Idg [Hd1 [Hd2 Hd3 ]]]].
(*
                               traversal_specific C2 B Q A P HBQ HAP HBQAP HA2B2PQ HC2BQ) as [Idf [Idg [Hd1 [Hd2 [Hd3 [Hd4 [Hd5 Hd6]]]]]]].
  assert (HA2P: rk (A2 :: P :: nil) = 2) by (apply (LP5P11 O A B C A2 B2 C2 X Y Z P Q); assumption).
  assert (HQB2: rk (B2 :: Q :: nil) = 2) by (apply (LP6P12 O A B C A2 B2 C2 X Y Z P Q); assumption).
  assert (HQB2A2P : rk (B2 :: Q :: A2 :: P :: nil) = 4).
  assert (HQB2A2P' : rk (A2 :: B2 :: P :: Q :: nil) = 4)
    by (apply (LP5P6P11P12 O A B C A2 B2 C2 X Y Z P Q); assumption).
  assert (Hrk: rk (B2 :: Q :: A2 :: P :: nil) = rk (A2 :: B2 :: P :: Q :: nil) )
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk; assumption.
  (*apply (LP2P7P11 O A B C A2 B2 C2 X Y Z P Q); try assumption.
  assert (Hrk2:rk (A2 :: B2 :: P :: Q :: nil) = rk (B2 :: Q :: A2 :: P :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk2; assumption.
  assert (Hrk:rk (C2 :: B :: Q :: nil) = rk (B :: C2 :: Q :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.*)
(*  apply (LP3P7P12 O A B C A2 B2 C2 X Y Z P Q);  assumption. *)
(*  assert (HQB2:rk(B2::Q::nil)=2) by admit.*)
(*  assert (HA2P:rk(A2::P::nil)=2) by admit.*)
(*  assert (HQB2A2P:rk(B2::Q::A2::P::nil)=4) by admit.*)
  assert (HCA2P: rk (C :: A2 :: P :: nil) = 3) by admit.
  assert (HCB2Q: rk (C :: B2 :: Q :: nil) = 3) by admit. *)
  Check (traversal_specific O A2 B2 C2 A C P Q ).
  assert (HOA2A : rk (O :: A2 :: A :: nil) = 3).
  admit.
  assert (HA2AQ : rk (O :: A2 :: A :: P :: nil) = 4).
  admit.
  assert (HOA2AC : rk (O :: A2 :: A :: C :: nil) = 3).
  admit.
  assert (HOA2AP : rk (O :: A2 :: A :: Q :: nil) = 4).
  admit.
  assert (HQP: rk (P::Q::nil)=2).
  admit.
  destruct (traversal_specific O A2 B2 C2 A C P Q HOA2A HA2AQ HOA2AC HOA2AP HQP) as [Ihb [Ihc [Hh1 [Hh2 Hh3]]]].
  assert (rk (C :: Ihb :: C2 :: Idg :: nil) = 3).
  Check (rk_DG A B A2 P B2 Q A2 B2 A P B Q C2 Idg C Ihb).
  (*
       rk (A :: B :: nil) = 2 ->
       rk (A2 :: P :: nil) = 2 ->
       rk (B2 :: Q :: nil) = 2 ->
       rk (A :: B :: A2 :: P :: nil) = 4 ->
       rk (A :: B :: B2 :: Q :: nil) = 4 ->
       rk (A2 :: P :: B2 :: Q :: nil) = 4 ->
       rk (A2 :: B2 :: nil) = 2 ->
       rk (A :: P :: nil) = 2 ->
       rk (B :: Q :: nil) = 2 ->
       rk (A2 :: B2 :: A :: P :: nil) = 4 ->
       rk (A2 :: B2 :: B :: Q :: nil) = 4 ->
       rk (A :: P :: B :: Q :: nil) = 4 ->
       rk (A :: B :: A2 :: B2 :: nil) = 3 ->
       rk (A :: B :: A :: P :: nil) = 3 ->
       rk (A :: B :: B :: Q :: nil) = 3 ->
       rk (A2 :: P :: A2 :: B2 :: nil) = 3 ->
       rk (A2 :: P :: A :: P :: nil) = 3 ->
       rk (A2 :: P :: B :: Q :: nil) = 3 ->
       rk (B2 :: Q :: A2 :: B2 :: nil) = 3 ->
       rk (B2 :: Q :: A :: P :: nil) = 3 ->
       rk (B2 :: Q :: B :: Q :: nil) = 3 ->
       rk (C2 :: Idg :: nil) = 2 ->
       rk (C2 :: Idg :: A :: B :: nil) = 3 ->
       rk (C2 :: Idg :: A2 :: P :: nil) = 3 ->
       rk (C2 :: Idg :: B2 :: Q :: nil) = 3 ->
       rk (C :: Ihb :: nil) = 2 ->
       rk (C :: Ihb :: A2 :: B2 :: nil) = 3 ->
       rk (C :: Ihb :: A :: P :: nil) = 3 ->
       rk (C :: Ihb :: B :: Q :: nil) = 3 ->
       rk (C :: Ihb :: C2 :: Idg :: nil) = 3
   *)
  apply (rk_DG A B A2 P B2 Q A2 B2 A P B Q C2 Idg C Ihb); try assumption.
  admit. (* trivial*)
  admit. (* trivial*)
  apply (LP2P3P5P11 O A B C A2 B2 C2 X Y Z P Q); assumption.
  apply (LP2P3P6P12 O A B C A2 B2 C2 X Y Z P Q); assumption.
  assert (Hrk:rk (A2 :: P :: B2 :: Q :: nil) = rk (A2 :: B2 :: P :: Q :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.
  apply (LP5P6P11P12 O A B C A2 B2 C2 X Y Z P Q); assumption.
  admit. (* trivial*)
  admit. (* trivial*)
  assert (Hrk:rk (A2 :: B2 :: A :: P :: nil) = rk (A :: A2 :: B2 :: P :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.
  apply (LP2P5P6P11 O A B C A2 B2 C2 X Y Z P Q); assumption.
  assert (Hrk:rk (A2 :: B2 :: B :: Q :: nil) = rk (B :: A2 :: B2 :: Q :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.
  apply (LP3P5P6P12 O A B C A2 B2 C2 X Y Z P Q); assumption.
  assert (Hrk:rk (A :: P :: B :: Q :: nil) = rk (A :: B :: P :: Q :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.
  apply (LP2P3P11P12 O A B C A2 B2 C2 X Y Z P Q); assumption.
  admit. (* trivial *)
  admit. (* trivial - to be checked *)
  admit. (* trivial - to be checked *)
  admit. (* trivial - to be checked *)
  admit. (* trivial - to be checked *)
  admit. (* trivial - to be checked *)
  admit.
  admit.
  admit.
admit. (* a verifier en premier : C2 Idg = 2 *)
admit. (*rk (C2 :: Idg :: A :: B :: nil) = 3*)
admit. (*rk (C2 :: Idg :: A2 :: P :: nil) = 3*)
admit. (* rk (C2 :: Idg :: B2 :: Q :: nil) = 3*)

  admit.
  admit.
  assert (Hrk:rk (A2 :: P :: B :: Q :: nil) = rk (B :: A2 :: P :: Q :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.
  apply (LP3P5P11P12 O A B C A2 B2 C2 X Y Z P Q); assumption.
  assert (Hrk:rk (B2 :: Q :: A2 :: B2 :: nil) = rk (A2 :: B2 :: Q :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.
  apply (LP5P6P12 O A B C A2 B2 C2 X Y Z P Q); assumption.
  assert (Hrk:rk (B2 :: Q :: A :: P :: nil) = rk (A :: B2 :: P :: Q :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.
  apply (LP2P6P11P12 O A B C A2 B2 C2 X Y Z P Q); assumption.
  assert (Hrk:rk (B2 :: Q :: B :: Q :: nil) = rk (B :: B2 :: Q :: nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk.
  apply (LP3P6P12 O A B C A2 B2 C2 X Y Z P Q); assumption.
  admit.
  admit.
  admit.
  admit.
  admit.
  admit.
(*  apply (LP7P16 O A B C A2 B2 C2 X Y Z P Q Ihb Ihc Idf Idg); assumption.
  admit. (* pb *)
  admit. (* ? *)
  admit. (* ? *)
  apply (LP4P13 O A B C A2 B2 C2 X Y Z P Q Ihb Ihc Idf Idg); assumption.
  admit. (* pb *)
  admit.
  admit.*)
  Check plane_of_2_lines.
  destruct (plane_of_2_lines C Ihb Ihc C2 Idg Idf) as [R [HR1 HR2]]; try assumption.
  assert (Hrk:rk (Idg :: Idf :: nil) = rk (Idf::Idg::nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk; assumption.
  assert (Hrk:rk (C2:: Idg :: Idf :: nil) = rk (C2::Idf::Idg::nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk; assumption.

  eapply LP8P9P10 with (P1:=O) (P2:=A) (P3:=B) (P4:=C) (P5:=A2) (P6:=B2) (P7:=C2)
  (* P8 P9 P10 are in the conclusion *)
  (P11:=P) (P12:=Q) (P13:=Ihb) (P14:=Ihc) (P15:=Idf) (P16:=Idg) (P17:=R); try assumption.

  assert (Hrk:rk (C2:: Idf :: Idg :: R :: nil) = rk (C2::Idg::Idf::R::nil))
    by (apply eq_le_ge; split; apply matroid2; my_inO).
  rewrite Hrk; assumption.
Qed.


Require Import SfLib Ty.

(** definition of ordering between types **)

Inductive sec_ordering : secty -> secty -> Prop :=
  | so_untrustdontcare : sec_ordering Untrust DontCare
  | so_trustuntrust : sec_ordering Trust Untrust
  | so_trustdontcare : sec_ordering Trust DontCare
  | so_refl : forall t, sec_ordering t t.

Inductive subtype : ty -> ty -> Prop :=
  | s_base : forall s s', sec_ordering s s' -> subtype (ty_bool s) (ty_bool s')
  | s_arrow : forall T1 T2 T1' T2' s1 s2,
              subtype T1' T1 ->
              subtype T2 T2' ->
              sec_ordering s1 s2 ->
              subtype (arrow T1 T2 s1) (arrow T1' T2' s2).

Tactic Notation "subtype_cases" tactic(first) ident(c) :=
  first ; [Case_aux c "s_base" | Case_aux c "s_arrow"].

Hint Constructors sec_ordering subtype.

Definition sectyof (t : ty) : secty :=
  match t with
    | ty_bool s => s
    | arrow _ _ s => s
  end.

(** least upper bound on sec types **)

Definition lub_secty (x y : secty) : secty :=
  match x with
    | DontCare => DontCare
    | Trust    => y
    | Untrust  => match y with
                    | DontCare => DontCare
                    | Untrust  => Untrust
                    | Trust    => Untrust
                  end
  end.

Definition update_secty (t : ty) (s : secty) : ty :=
  match t with
    | ty_bool s' => ty_bool (lub_secty s s')
    | arrow l r s' => arrow l r (lub_secty s s')
  end.

Remark sec_ordering_trans : forall s1 s2 s3, sec_ordering s1 s2 -> sec_ordering s2 s3 -> sec_ordering s1 s3.
Proof.
intros.
inversion H; subst.
inversion H0; subst.
constructor.
destruct s3.
constructor.
constructor.
constructor.
destruct s3.
constructor.
constructor.
constructor.
auto.
Qed.

Remark subtype_refl : forall T, subtype T T.
Proof.
intros.
induction T.
constructor.
constructor.
constructor.
auto.
auto.
constructor.
Qed.

Remark subtype_trans : forall T1 T2 T3, subtype T1 T2 -> subtype T2 T3 -> subtype T1 T3.
Proof.
intros T1 T2 T3.
  generalize dependent T1 ; generalize dependent T3.
  induction T2.
  intros.
  inversion H; subst; clear H.
  inversion H0; subst; clear H0.
  inversion H3; subst; clear H3.
  inversion H1; subst; clear H1.
  constructor. constructor.
  inversion H1; subst; clear H1.
  constructor. constructor.
  constructor. constructor.
  inversion H1; subst; clear H1.
  constructor. constructor.
  inversion H1; subst; clear H1.
  constructor. constructor.
  constructor. constructor.
  constructor. constructor.
  constructor. constructor.
  intros.
  inversion H; subst; clear H.
  inversion H0; subst; clear H0.
  constructor.
  apply IHT2_1.
  assumption. assumption.
  apply IHT2_2.
  assumption. assumption.
  inversion H9; subst; clear H9.
  inversion H7; subst; clear H7.
  constructor. constructor.
  inversion H7; subst; clear H7.
  constructor.
 inversion H7; subst; clear H7.
  constructor.
  assumption.
Qed.

Remark sec_ordering_lub : forall s s', sec_ordering s (lub_secty s' s).
Proof with eauto.
intros.
destruct s. destruct s'.
constructor. constructor.
constructor. destruct s'.
constructor. constructor.
constructor. destruct s'.
constructor. constructor.
constructor.
Qed.

Remark update_secty__subtype : forall T s, subtype T (update_secty T s).
Proof with eauto.
intros.
destruct s. destruct T. destruct s.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. apply subtype_refl.
apply subtype_refl. destruct s. constructor. constructor.
constructor. destruct T. destruct s. constructor.
constructor. constructor. constructor. constructor.
constructor. destruct T1. destruct T2. destruct s.
destruct s0. destruct s1. constructor. constructor.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. constructor.
apply subtype_refl. apply subtype_refl. constructor.
destruct s. constructor. constructor. constructor.
constructor. constructor. apply subtype_refl. apply subtype_refl.
constructor. apply subtype_refl. destruct s. constructor.
constructor. constructor. destruct T. destruct s.
constructor. constructor. constructor. constructor.
constructor. constructor. constructor. apply subtype_refl.
apply subtype_refl. destruct s. constructor. constructor.
constructor.
Qed.

Remark update_secty_ident : forall T s, update_secty T s = update_secty (update_secty T s) s.
Proof.
intros.
induction s. destruct T.
destruct s. reflexivity.
reflexivity. reflexivity.
reflexivity. destruct T.
destruct s. reflexivity.
reflexivity. reflexivity.
destruct s. reflexivity.
reflexivity. reflexivity.
destruct T. reflexivity.
reflexivity.
Qed.

Remark secty_update_eq :forall T T' s, subtype T T' -> sectyof T = sectyof (update_secty T s) -> sectyof T' = sectyof (update_secty T' s).
Proof.
intros.
inversion H; subst.
inversion H1; subst.
destruct s. reflexivity.
reflexivity. reflexivity.
destruct s. reflexivity.
reflexivity. simpl in *.
rewrite H0 in H. inversion H; subst.
inversion H4. destruct s.
reflexivity. reflexivity.
reflexivity. assumption.
inversion H3; subst.
destruct s. reflexivity.
reflexivity. reflexivity.
subst. destruct s.
reflexivity. reflexivity.
simpl in *. rewrite H0 in H.
inversion H; subst.
inversion H12; subst.
destruct s. reflexivity.
reflexivity. reflexivity.
assumption.
Qed.

Remark update_secty_mono : forall T T' s s', subtype T T' -> sec_ordering s s' -> subtype (update_secty T s) (update_secty T' s').
Proof.
intros.
inversion H0; subst; clear H0.
inversion H; subst; clear H.
inversion H0; subst; clear H0.
constructor. constructor.
constructor. constructor.
constructor. constructor.
constructor. destruct s'.
constructor. constructor.
constructor. constructor.
assumption. assumption.
inversion H2; subst; clear H2.
constructor. constructor.
constructor. destruct s2.
constructor. constructor.
constructor. inversion H; subst; clear H.
inversion H0; subst; clear H0.
constructor. constructor.
constructor. constructor.
constructor. constructor.
constructor. destruct s'.
constructor. constructor.
constructor. constructor.
assumption. assumption.
inversion H2; subst; clear H2.
constructor. constructor.
constructor. destruct s2.
constructor. constructor.
constructor. inversion H; subst; clear H.
inversion H0; subst; clear H0.
constructor. constructor.
constructor. constructor.
constructor. constructor.
constructor. destruct s'.
constructor. constructor.
constructor. constructor.
assumption. assumption.
inversion H2; subst; clear H2.
constructor. constructor.
constructor. destruct s2.
constructor. constructor.
constructor. inversion H; subst; clear H.
inversion H0; subst; clear H0.
constructor. destruct s'.
constructor. constructor.
constructor. constructor.
destruct s'. constructor.
constructor. constructor.
constructor. destruct s'.
constructor. constructor.
constructor. constructor.
destruct s'. destruct s'0.
constructor. constructor.
constructor. constructor.
destruct s'0. constructor.
constructor. constructor.
constructor. assumption.
assumption. inversion H2; subst; clear H2.
destruct s'. constructor.
constructor. constructor.
destruct s'. constructor.
constructor. constructor.
destruct s'. constructor.
constructor. constructor.
constructor.
Qed.

Remark lub_secty_sym : forall s s', lub_secty s s' = lub_secty s' s.
Proof.
intros.
destruct s.
destruct s'.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
destruct s'.
reflexivity.
reflexivity.
reflexivity.
Qed.

Remark subtype_bool_lub_secty : forall s s', subtype (ty_bool s) (ty_bool (lub_secty s s')).
Proof.
intros.
constructor.
destruct s.
destruct s'.
constructor.
constructor.
constructor.
destruct s'.
constructor.
constructor.
constructor.
constructor.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.Rbasic_fun.
Require BuiltIn.
Require int.Int.
Require real.Real.
Require real.Abs.
Require real.FromInt.
Require floating_point.Rounding.
Require floating_point.DoubleFormat.

Require Import floating_point.GenFloat.

(* Why3 goal *)
Definition round: floating_point.Rounding.mode -> R -> R.
exact (round 53 1024).
Defined.

(* Why3 goal *)
Definition value: floating_point.DoubleFormat.double -> R.
exact (value 53 1024).
Defined.

(* Why3 goal *)
Definition exact: floating_point.DoubleFormat.double -> R.
exact (exact 53 1024).
Defined.

(* Why3 goal *)
Definition model: floating_point.DoubleFormat.double -> R.
exact (model 53 1024).
Defined.

(* Why3 assumption *)
Definition round_error (x:floating_point.DoubleFormat.double): R :=
  (Reals.Rbasic_fun.Rabs ((value x) - (exact x))%R).

(* Why3 assumption *)
Definition total_error (x:floating_point.DoubleFormat.double): R :=
  (Reals.Rbasic_fun.Rabs ((value x) - (model x))%R).

(* Why3 assumption *)
Definition no_overflow (m:floating_point.Rounding.mode) (x:R): Prop :=
  ((Reals.Rbasic_fun.Rabs (round m
  x)) <= (9007199254740991 * 19958403095347198116563727130368385660674512604354575415025472424372118918689640657849579654926357010893424468441924952439724379883935936607391717982848314203200056729510856765175377214443629871826533567445439239933308104551208703888888552684480441575071209068757560416423584952303440099278848)%R)%R.

(* Why3 goal *)
Lemma Bounded_real_no_overflow : forall (m:floating_point.Rounding.mode)
  (x:R),
  ((Reals.Rbasic_fun.Rabs x) <= (9007199254740991 * 19958403095347198116563727130368385660674512604354575415025472424372118918689640657849579654926357010893424468441924952439724379883935936607391717982848314203200056729510856765175377214443629871826533567445439239933308104551208703888888552684480441575071209068757560416423584952303440099278848)%R)%R ->
  (no_overflow m x).
exact (Bounded_real_no_overflow 53 1024 (refl_equal true) (refl_equal true)).
Qed.

(* Why3 goal *)
Lemma Round_monotonic : forall (m:floating_point.Rounding.mode) (x:R) (y:R),
  (x <= y)%R -> ((round m x) <= (round m y))%R.
now apply Round_monotonic.
Qed.

(* Why3 goal *)
Lemma Round_idempotent : forall (m1:floating_point.Rounding.mode)
  (m2:floating_point.Rounding.mode) (x:R), ((round m1 (round m2
  x)) = (round m2 x)).
now apply Round_idempotent.
Qed.

(* Why3 goal *)
Lemma Round_value : forall (m:floating_point.Rounding.mode)
  (x:floating_point.DoubleFormat.double), ((round m (value x)) = (value x)).
now apply Round_value.
Qed.

(* Why3 goal *)
Lemma Bounded_value : forall (x:floating_point.DoubleFormat.double),
  ((Reals.Rbasic_fun.Rabs (value x)) <= (9007199254740991 * 19958403095347198116563727130368385660674512604354575415025472424372118918689640657849579654926357010893424468441924952439724379883935936607391717982848314203200056729510856765175377214443629871826533567445439239933308104551208703888888552684480441575071209068757560416423584952303440099278848)%R)%R.
now apply Bounded_value.
Qed.

(* Why3 goal *)
Lemma Exact_rounding_for_integers : forall (m:floating_point.Rounding.mode)
  (i:Z), (((-9007199254740992%Z)%Z <= i)%Z /\ (i <= 9007199254740992%Z)%Z) ->
  ((round m (Reals.Raxioms.IZR i)) = (Reals.Raxioms.IZR i)).
intros m i Hi.
now apply Exact_rounding_for_integers.
Qed.

(* Why3 goal *)
Lemma Round_down_le : forall (x:R), ((round floating_point.Rounding.Down
  x) <= x)%R.
now apply Round_down_le.
Qed.

(* Why3 goal *)
Lemma Round_up_ge : forall (x:R), (x <= (round floating_point.Rounding.Up
  x))%R.
now apply Round_up_ge.
Qed.

(* Why3 goal *)
Lemma Round_down_neg : forall (x:R), ((round floating_point.Rounding.Down
  (-x)%R) = (-(round floating_point.Rounding.Up x))%R).
now apply Round_down_neg.
Qed.

(* Why3 goal *)
Lemma Round_up_neg : forall (x:R), ((round floating_point.Rounding.Up
  (-x)%R) = (-(round floating_point.Rounding.Down x))%R).
now apply Round_up_neg.
Qed.

(* Why3 goal *)
Definition round_logic: floating_point.Rounding.mode -> R ->
  floating_point.DoubleFormat.double.
exact (round_logic 53 1024 (refl_equal true) (refl_equal true)).
Defined.

(* Why3 goal *)
Lemma Round_logic_def : forall (m:floating_point.Rounding.mode) (x:R),
  (no_overflow m x) -> ((value (round_logic m x)) = (round m x)).
Proof.
exact (Round_logic_def 53 1024 (refl_equal true) (refl_equal true)).
Qed.

(* Why3 assumption *)
Definition of_real_post (m:floating_point.Rounding.mode) (x:R)
  (res:floating_point.DoubleFormat.double): Prop := ((value res) = (round m
  x)) /\ (((exact res) = x) /\ ((model res) = x)).

(* Why3 assumption *)
Definition add_post (m:floating_point.Rounding.mode)
  (x:floating_point.DoubleFormat.double)
  (y:floating_point.DoubleFormat.double)
  (res:floating_point.DoubleFormat.double): Prop := ((value res) = (round m
  ((value x) + (value y))%R)) /\
  (((exact res) = ((exact x) + (exact y))%R) /\
  ((model res) = ((model x) + (model y))%R)).

(* Why3 assumption *)
Definition sub_post (m:floating_point.Rounding.mode)
  (x:floating_point.DoubleFormat.double)
  (y:floating_point.DoubleFormat.double)
  (res:floating_point.DoubleFormat.double): Prop := ((value res) = (round m
  ((value x) - (value y))%R)) /\
  (((exact res) = ((exact x) - (exact y))%R) /\
  ((model res) = ((model x) - (model y))%R)).

(* Why3 assumption *)
Definition mul_post (m:floating_point.Rounding.mode)
  (x:floating_point.DoubleFormat.double)
  (y:floating_point.DoubleFormat.double)
  (res:floating_point.DoubleFormat.double): Prop := ((value res) = (round m
  ((value x) * (value y))%R)) /\
  (((exact res) = ((exact x) * (exact y))%R) /\
  ((model res) = ((model x) * (model y))%R)).

(* Why3 assumption *)
Definition div_post (m:floating_point.Rounding.mode)
  (x:floating_point.DoubleFormat.double)
  (y:floating_point.DoubleFormat.double)
  (res:floating_point.DoubleFormat.double): Prop := ((value res) = (round m
  ((value x) / (value y))%R)) /\
  (((exact res) = ((exact x) / (exact y))%R) /\
  ((model res) = ((model x) / (model y))%R)).

(* Why3 assumption *)
Definition neg_post (x:floating_point.DoubleFormat.double)
  (res:floating_point.DoubleFormat.double): Prop :=
  ((value res) = (-(value x))%R) /\ (((exact res) = (-(exact x))%R) /\
  ((model res) = (-(model x))%R)).

(* Why3 assumption *)
Definition lt (x:floating_point.DoubleFormat.double)
  (y:floating_point.DoubleFormat.double): Prop := ((value x) < (value y))%R.

(* Why3 assumption *)
Definition gt (x:floating_point.DoubleFormat.double)
  (y:floating_point.DoubleFormat.double): Prop := ((value y) < (value x))%R.


(*
 * Module: MMU
 *
 * Description:
 *  This module defines data types, functions, lemma, and theorems to describe
 *  the basic architecture of the virtual machine that the formalism describes.
 *
 * Note:
 *  Some of the code for MMU and MMUSet comes from "Software Foundations" by
 *  Benjamin Pierce et. al.
 *)

(* Load Coq Standard Library modules *)
Require Import Arith.
Require Import List.

(* Load SVAOS specific modules *)
Require Export Memory.
Require Export TLB.

(*
 * Define an MMU.  An MMU maps virtual addresses to physical address; it also
 * defines permissions for access through the virtual address.   For
 * simplicity, I will have the MMU map addresses at byte granularity.
 *)
Definition MMU := list TLBTy.
Definition emptyMMU := nil : list TLBTy.
Definition getTLB (n : nat) (mmu : MMU) := nth n mmu emptyTLB.
Fixpoint updateTLB (virt:nat) (tlb:TLBTy) (mmu:MMU) : MMU :=
  match mmu with
  | nil => nil
  | h :: t =>
    match virt with
    | O => tlb :: t
    | S n' => h :: updateTLB n' tlb t
    end
  end.

(*
 * Define a set of MMUs indexed by address space identifier (ASID).  This maps
 * an ASID to an MMU.
 *)
Definition MMUSet := list MMU.
Definition emptyMMUSet := nil : MMUSet.
Definition getMMU (asid : nat) (mmu : MMUSet) := nth asid mmu emptyMMU.
Fixpoint updateMMU (virt:nat) (asid : nat) (tlb:TLBTy) (mmus:MMUSet) : MMUSet :=
  match mmus with
  | nil => nil
  | h :: t =>
    match asid with
    | O => (updateTLB virt tlb h) :: t
    | S n' => h :: updateMMU virt n' tlb t
    end
  end.

(*
 * Function: can[Read|Write|Exec]
 *
 * Description:
 *   This function takes an MMU and a virtual address and determines if the
 *   virtual address permits read/write/execute permission.
 *
 * Inputs:
 *   va  - The virtual address that is being accessed.
 *   mmu - The MMU.
 *)
Definition canRead  (va : nat) (mmu : MMU) : Prop := TLBPermitsRead  (getTLB va mmu).
Definition canWrite (va : nat) (mmu : MMU) : Prop := TLBPermitsWrite (getTLB va mmu).
Definition canExec  (va : nat) (mmu : MMU) : Prop := TLBPermitsExec  (getTLB va mmu).

(*
 * Function: vLookup
 *
 * Description:
 *   Lookup the specified value via the MMU.
 *)
Definition vLookup (va : nat) (mmu : MMU) (st : store) :=
  lookup (getPhysical (getTLB va mmu)) st.

Definition vaLookup (va : nat) (asid : nat) (mmu : MMU) (st : store) :=
  lookup (getPhysical (getTLB va mmu)) st.

(*
Definition vaLookup (va : nat) (asid : nat) (mmus : MMUSet) (st : store) :=
  lookup (getPhysical (getTLB va (getMMU asid mmus))) st.
*)

(*
 * Lemma: noTLBinMMU
 *
 * Description:
 *  Prove that getting any value out of an empty TLB generates emptyTLB.
 *)
Lemma noTLBinMMU : forall (v : nat),
(getTLB v nil) = emptyTLB.
Proof.
intros.
induction v.
auto.
unfold getTLB.
simpl.
auto.
Qed.

(*
 * Lemma: updateEmptyMMU
 *
 * Description:
 *   Updating an empty MMU is the same as doing nothing.
 *)
Lemma updateEmptyMMU: forall (v : nat) (tlb : TLBTy), updateTLB v tlb nil = nil.
intros.
induction v.
auto.
auto.
Qed.

Lemma oneOrAnother : forall (v : nat) (tlb a : TLBTy) (mmu : MMU),
(updateTLB v tlb (a :: mmu) = tlb :: mmu) \/
(updateTLB v tlb (a :: mmu) = a :: (updateTLB (pred v) tlb mmu)).
Proof.
intros.
destruct v.

(* Handle the case when the virtual address is zero *)
left.
auto.

(* Handle the case in which the virtual address is non-zero *)
right.
simpl.
auto.
Qed.

Lemma skipTLB: forall (n : nat) (tlb : TLBTy) (mmu : MMU),
(getTLB (S n) (tlb :: mmu)) = (getTLB n (mmu)).
Proof.
intros.
unfold getTLB.
simpl.
reflexivity.
Qed.

Theorem sameMMULookup : forall (mmu : MMU) (n m : nat) (tlb : TLBTy),
 n <> m -> getTLB (n) (mmu) = getTLB (n) (updateTLB m tlb mmu).
Proof.
intro.
induction mmu.

(* Induction case 1 *)
intros.
rewrite -> updateEmptyMMU.
auto.

(* Induction case 2 *)
intros.
destruct n.
destruct m.

(* Destruct case 1 *)
contradiction H.
auto.

(* Destruct case 2 *)
simpl.
unfold getTLB.
simpl.
auto.

(* Destruct case 3 *)
destruct m.
unfold getTLB.
simpl.
auto.

rewrite -> skipTLB.
simpl.
rewrite -> skipTLB.
apply IHmmu.
auto.
Qed.

(*
 * Theorem: sameMMURead
 *
 * Description:
 *   Prove that looking up a value in the virtual memory does not depend on
 *   whether the TLB for another virtual address has been modified.
 *)
Theorem sameMMURead : forall (n m : nat) (tlb : TLBTy) (mmu : MMU) (ds : store),
 n <> m -> vLookup (n) mmu ds = vLookup (n) (updateTLB m tlb mmu) ds.
Proof.
intros.
unfold vLookup.
rewrite <- sameMMULookup.
auto.
apply H.
Qed.

Theorem diffTLBImpliesDiffVAs : forall (v1 v2 : nat) (mmu : MMU),
((getTLB v1 mmu) <> (getTLB v2 mmu)) -> v1 <> v2.
Proof.
intros.
contradict H.
rewrite -> H.
reflexivity.
Qed.

Theorem sameMMUPerms : forall (n m : nat) (tlb : TLBTy) (mmu : MMU),
 n <> m -> canWrite n mmu = canWrite n (updateTLB m tlb mmu).
Proof.
intros.
induction mmu.
unfold updateTLB.
simpl.
rewrite -> updateEmptyMMU.
auto.
destruct n.
destruct m.
contradiction H.
reflexivity.
simpl.
unfold canWrite.
unfold getTLB.
simpl.
auto.

destruct m.
simpl.
unfold canWrite.
unfold getTLB.
simpl.
auto.

unfold canWrite.
simpl.

rewrite -> skipTLB.
rewrite -> skipTLB.
assert (n <> m).
contradict H.
auto.
rewrite <- sameMMULookup.
auto.
auto.
Qed.

(*
 * Theorem: tlbSet
 *
 * Description:
 *  Prove that if there is a mapping for a virtual address in a TLB, then
 *  updating the MMU with the same virtual to physical mapping does not change
 *  the value of the TLB in the MMU.
 *)
Theorem tlbSet : forall (v : nat) (tlb : TLBTy) (mmu : MMU),
definedTLB (getTLB v mmu) -> getTLB v (updateTLB v tlb mmu) = tlb.
Proof.
intros.
generalize dependent tlb.
generalize dependent v.
induction mmu.

(* Induction case 1 *)
intros.
rewrite -> noTLBinMMU in H.
contradiction H.

(* Induction case 2 *)
intros.
destruct v.
auto.
simpl.
unfold getTLB.
simpl.
unfold getTLB in IHmmu.
apply IHmmu.
apply H.
Qed.

Lemma updateEmptyMMUS: forall (v asid : nat) (tlb : TLBTy), updateMMU v asid tlb nil = nil.
intros.
induction asid.
auto.
auto.
Qed.

Lemma noMMUinMMUS : forall (asid : nat),
(getMMU asid nil) = emptyMMU.
Proof.
intros.
induction asid.
auto.
unfold getMMU.
simpl.
auto.
Qed.

Lemma skipMMU: forall (asid : nat) (mmu : MMU) (mmus : MMUSet),
(getMMU (S asid) (mmu :: mmus)) = (getMMU asid mmus).
Proof.
intros.
unfold getTLB.
simpl.
reflexivity.
Qed.

Theorem sameMMUSet : forall (mmus : MMUSet) (v asid : nat) (tlb : TLBTy),
updateTLB v tlb (getMMU asid mmus) = getMMU asid (updateMMU v asid tlb mmus).
Proof.
intro.
induction mmus.

(* Case 1 *)
intros.
rewrite -> updateEmptyMMUS.
rewrite -> noMMUinMMUS.
rewrite -> updateEmptyMMU.
auto.

(* Case 2 *)
intros.
destruct asid.

(* Case 2a *)
auto.

(* Case 2b *)
rewrite -> skipMMU.
simpl.
rewrite -> skipMMU.
apply IHmmus.
Qed.

(*
 * Theorem: sameVALookup
 *
 * Description:
 *  This theorem shows that changing a mapping for one virtual address in a set
 *  of MMUs does not change the value returned for other virtual addresses
 *  within the same address space.
 *)
Theorem sameVALookup : forall (mmus : MMUSet) (v v0 asid : nat) (tlb : TLBTy),
v <> v0 -> (getTLB v (getMMU asid mmus)) = getTLB v (getMMU asid (updateMMU v0 asid tlb mmus)).
Proof.
intro.
induction mmus.

(* Case 1 *)
intros.
rewrite -> updateEmptyMMUS.
auto.

(* Case 2 *)
intros.
destruct asid.

(* Case 2a *)
unfold getMMU.
simpl.
apply sameMMULookup.
auto.

(* Case 2b *)
rewrite -> skipMMU.
simpl.
rewrite -> skipMMU.
apply IHmmus.
auto.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Sumbool.

Require Import BinInt.
Require Import Zorder.
Require Import Zcompare.
Local Open Scope Z_scope.

(* begin hide *)
(* Trivial, to deprecate? *)
Lemma Dcompare_inf : forall r:comparison, {r = Eq} + {r = Lt} + {r = Gt}.
Proof.
  induction r; auto.
Defined.
(* end hide *)

Lemma Zcompare_rect (P:Type) (n m:Z) :
  ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
Proof.
  intros H1 H2 H3.
  destruct (n ?= m); auto.
Defined.

Lemma Zcompare_rec (P:Set) (n m:Z) :
  ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
Proof. apply Zcompare_rect. Defined.

Notation Z_eq_dec := Z.eq_dec (compat "8.6").

Section decidability.

  Variables x y : Z.

  (** * Decidability of order on binary integers *)

  Definition Z_lt_dec : {x < y} + {~ x < y}.
  Proof.
    unfold Z.lt; case Z.compare; (now left) || (now right).
  Defined.

  Definition Z_le_dec : {x <= y} + {~ x <= y}.
  Proof.
    unfold Z.le; case Z.compare; (now left) || (right; tauto).
  Defined.

  Definition Z_gt_dec : {x > y} + {~ x > y}.
  Proof.
    unfold Z.gt; case Z.compare; (now left) || (now right).
  Defined.

  Definition Z_ge_dec : {x >= y} + {~ x >= y}.
  Proof.
    unfold Z.ge; case Z.compare; (now left) || (right; tauto).
  Defined.

  Definition Z_lt_ge_dec : {x < y} + {x >= y}.
  Proof.
    exact Z_lt_dec.
  Defined.

  Lemma Z_lt_le_dec : {x < y} + {y <= x}.
  Proof.
    elim Z_lt_ge_dec.
    * now left.
    * right; now apply Z.ge_le.
  Defined.

  Definition Z_le_gt_dec : {x <= y} + {x > y}.
  Proof.
    elim Z_le_dec; auto with arith.
    intro. right. Z.swap_greater. now apply Z.nle_gt.
  Defined.

  Definition Z_gt_le_dec : {x > y} + {x <= y}.
  Proof.
    exact Z_gt_dec.
  Defined.

  Definition Z_ge_lt_dec : {x >= y} + {x < y}.
  Proof.
    elim Z_ge_dec; auto with arith.
    intro. right. Z.swap_greater. now apply Z.lt_nge.
  Defined.

  Definition Z_le_lt_eq_dec : x <= y -> {x < y} + {x = y}.
  Proof.
    intro H.
    apply Zcompare_rec with (n := x) (m := y).
    intro. right. elim (Z.compare_eq_iff x y); auto with arith.
    intro. left. elim (Z.compare_eq_iff x y); auto with arith.
    intro H1. absurd (x > y); auto with arith.
  Defined.

End decidability.

(** * Cotransitivity of order on binary integers *)

Lemma Zlt_cotrans : forall n m:Z, n < m -> forall p:Z, {n < p} + {p < m}.
Proof.
  intros x y H z.
  case (Z_lt_ge_dec x z).
  intro.
  left.
  assumption.
  intro.
  right.
  apply Z.le_lt_trans with (m := x).
  apply Z.ge_le.
  assumption.
  assumption.
Defined.

Lemma Zlt_cotrans_pos : forall n m:Z, 0 < n + m -> {0 < n} + {0 < m}.
Proof.
  intros x y H.
  case (Zlt_cotrans 0 (x + y) H x).
  - now left.
  - right.
    apply Z.add_lt_mono_l with (p := x).
    now rewrite Z.add_0_r.
Defined.

Lemma Zlt_cotrans_neg : forall n m:Z, n + m < 0 -> {n < 0} + {m < 0}.
Proof.
  intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy;
    [ right; apply Z.add_lt_mono_l with (p := x); rewrite Z.add_0_r | left ];
    assumption.
Defined.

Lemma not_Zeq_inf : forall n m:Z, n <> m -> {n < m} + {m < n}.
Proof.
  intros x y H.
  case Z_lt_ge_dec with x y.
  intro.
  left.
  assumption.
  intro H0.
  generalize (Z.ge_le _ _ H0).
  intro.
  case (Z_le_lt_eq_dec _ _ H1).
  intro.
  right.
  assumption.
  intro.
  apply False_rec.
  apply H.
  symmetry .
  assumption.
Defined.

Lemma Z_dec : forall n m:Z, {n < m} + {n > m} + {n = m}.
Proof.
  intros x y.
  case (Z_lt_ge_dec x y).
  intro H.
  left.
  left.
  assumption.
  intro H.
  generalize (Z.ge_le _ _ H).
  intro H0.
  case (Z_le_lt_eq_dec y x H0).
  intro H1.
  left.
  right.
  apply Z.lt_gt.
  assumption.
  intro.
  right.
  symmetry .
  assumption.
Defined.

Lemma Z_dec' : forall n m:Z, {n < m} + {m < n} + {n = m}.
Proof.
  intros x y.
  case (Z.eq_dec x y); intro H;
    [ right; assumption | left; apply (not_Zeq_inf _ _ H) ].
Defined.

(* begin hide *)
(* To deprecate ? *)
Corollary Z_zerop : forall x:Z, {x = 0} + {x <> 0}.
Proof.
  exact (fun x:Z => Z.eq_dec x 0).
Defined.

Corollary Z_notzerop : forall (x:Z), {x <> 0} + {x = 0}.
Proof (fun x => sumbool_not _ _ (Z_zerop x)).

Corollary Z_noteq_dec : forall (x y:Z), {x <> y} + {x = y}.
Proof (fun x y => sumbool_not _ _ (Z.eq_dec x y)).
(* end hide *)


Arguments fst {A B} _.
Arguments snd {A B} _.

Definition firstf {A B C} (f:A -> C) (p:A*B) : C*B :=
  let (a,b) := p in (f a,b).

Definition secondf {A B C} (f:B -> C) (p:A*B) : A*C :=
  let (a,b) := p in (a, f b).


Require Import Coq.omega.Omega.
Require Import Bedrock.Examples.AutoSep.

(** * A trivial example to make sure the array proof automation isn't completely borked *)

Definition readS : spec := SPEC("x") reserving 0
  Al ls,
  PRE[V] [| $3 < natToW (length ls) |] * array ls (V "x")
  POST[R] [| R = selN ls 3 |] * array ls (V "x").

Definition writeS : spec := SPEC("x") reserving 0
  Al ls,
  PRE[V] [| $3 < natToW (length ls) |] * array ls (V "x")
  POST[_] array (updN ls 3 11) (V "x").

Definition bump := map (fun w : W => w ^+ $1).

Definition bumpS : spec := SPEC("arr", "len") reserving 3
  Al ls,
  PRE[V] [| V "len" = $ (length ls) |] * array ls (V "arr")
  POST[_] array (bump ls) (V "arr").

Open Scope list_scope.

Definition arrays := bmodule "read" {{
  bfunction "read"("x") [readS]
    "x" <- "x" + 12;;
    "x" <-* "x";;
    Return "x"
  end with bfunction "write"("x") [writeS]
    "x" <- "x" + 12;;
    "x" *<- 11;;
    Return 0
  end with bfunction "bump"("arr", "len", "i", "tmp", "tmp2") [bumpS]
    "i" <- 0;;
    [Al ls, Al done, Al pending,
      PRE[V] [| V "len" = $ (length ls) |] * [| V "i" = $ (length done) |] * [| ls = done ++ pending |]
        * array ls (V "arr")
      POST[_] Ex ls', [| ls' = done ++ bump pending |] * array ls' (V "arr") ]
    While ("i" < "len") {
      "tmp" <- 4 * "i";;
      "tmp" <- "arr" + "tmp";;
      "tmp2" <-* "tmp";;
      "tmp" *<- "tmp2" + 1;;
      "i" <- "i" + 1
    };;
    Return 0
  end
}}.

Hint Rewrite app_length : sepFormula.

Lemma shift_pos : forall (ls1 ls2 : list W),
  (length ls1 < length (ls1 ++ ls2))%nat
  -> length ls1 + length ls2 = length (ls1 ++ hd (natToW 0) ls2 ^+ natToW 1 :: nil) + length (tl ls2).
  intros; autorewrite with sepFormula in *;
    destruct ls2; simpl in *; unfold W; omega.
Qed.

Ltac pure' := intros; repeat match goal with
                               | [ H : sel _ _ = _ |- _ ] => rewrite H in *
                             end;
  try match goal with
        | [ _ : context[length (?A ++ ?B)] |- _ ] =>
          assert (goodSize (length (A ++ B))) by (eapply containsArray_goodSize; eauto)
      end;
  autorewrite with sepFormula in *; simpl length in *; autorewrite with sepFormula.

Ltac pure := pure'; try (apply f_equal; apply shift_pos; pure'); eauto 7.

Lemma nil_front : forall A n,
  n = @length A nil + n.
  reflexivity.
Qed.

Hint Immediate nil_front.

Lemma shift_updN : forall v pending done,
  (length pending > 0)%nat
  -> updN (done ++ pending) (length done) v = done ++ v :: tl pending.
  induction done; simpl; intuition;
    destruct pending; simpl in *; auto; omega.
Qed.

Theorem selN_hd : forall pending done,
  selN (done ++ pending) (length done) = hd $0 pending.
  induction done; simpl; intuition;
    destruct pending; reflexivity.
Qed.

Hint Rewrite shift_updN selN_hd using solve [ eauto ] : sepFormula.

Hint Rewrite DepList.pf_list_simpl : sepFormula.

Hint Rewrite sel_selN upd_updN using solve [ eauto 6 ] : sepFormula.

Hint Resolve shift_pos.

Lemma not_done_yet : forall A (done pending : list A),
  natToW (length done) < $ (length done + length pending)
  -> (length pending > 0)%nat.
  destruct pending; simpl; intuition;
    rewrite <- plus_n_O in *; unfold natToW in *; nomega.
Qed.

Hint Immediate not_done_yet.

Lemma shift_reorg : forall pending,
  (length pending > 0)%nat
  -> hd $0 pending ^+ $1 :: bump (tl pending)
  = bump pending.
  intros; autorewrite with sepFormula in *; destruct pending; simpl in *; auto; omega.
Qed.

Hint Rewrite shift_reorg using solve [ eauto ] : sepFormula.

Hint Rewrite Npow2_nat wordToN_nat wordToNat_natToWord_idempotent
  using nomega : N.

Lemma now_done : forall A (done pending : list A),
  natToW (length done + length pending) <= $ (length done)
  -> goodSize (length done + length pending)
  -> pending = nil.
  destruct pending; simpl; intuition; elimtype False; eauto.
Qed.

Hint Resolve now_done.

Lemma unbump : forall done pending,
  pending = nil
  -> done ++ pending = done ++ bump pending.
  intros; subst; reflexivity.
Qed.

Hint Resolve unbump.

Hint Rewrite wordToNat_natToW_goodSize using solve [ eauto ] : N.

Lemma bound_nat : forall (done pending : list W),
  natToW (length done) < natToW (length done + length pending)
  -> goodSize (length (done ++ hd $0 pending ^+ $1 :: tl pending))
  -> (length done < length done + length pending)%nat.
  intros; autorewrite with sepFormula N in *; simpl in *;
    apply lt_goodSize'; eauto; destruct pending; simpl in *; eauto using goodSize_weaken.
Qed.

Hint Resolve bound_nat.

Hint Extern 1 (himp _ _ _) => reflexivity.

Lemma goodSize_prefix : forall a b : list W,
  goodSize (length (a ++ b))
  -> goodSize (length a).
  intros; autorewrite with sepFormula in *; eapply goodSize_weaken; eauto.
Qed.

Lemma goodSize_full : forall a b : list W,
  goodSize (length (a ++ b))
  -> goodSize (length a + length b).
  intros; autorewrite with sepFormula in *; eapply goodSize_weaken; eauto.
Qed.

Hint Extern 1 (goodSize (length _)) => eapply goodSize_prefix; eapply containsArray_goodSize.
Hint Extern 1 (goodSize (length _ + length _)) => eapply goodSize_full; eapply containsArray_goodSize.

Hint Extern 1 (_ < _)%nat => apply lt_goodSize'; [ assumption | | ].

Theorem arraysOk : moduleOk arrays.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract (sep_auto; [ pure.. ]).
(*TIME  Print Timing Profile. *)
Qed.


Require Export PredMonad.Reflection2.Monad.

(***
 *** The Predicate Monad Class
 ***)

Class PredMonadOps M PM `{OTypeF1 M} `{OTypeF1 PM} : Type :=
  { forallP: forall {A B} `{OType A} `{OType B}, (A -o> PM B _) -o> PM B _;
    existsP: forall {A B} `{OType A} `{OType B}, (A -o> PM B _) -o> PM B _;
    liftP: forall {A} `{OType A}, M A _ -o> PM A _;
  }.

Class PredMonad M PM {FOM: OTypeF1 M} {FOPM: OTypeF1 PM}
      `{@MonadOps M FOM} `{@MonadOps PM FOPM}
      `{@PredMonadOps M PM FOM FOPM} : Prop :=
  {
    (* M and PM must be monads *)
    predmonad_monad_M :> Monad M;
    predmonad_monad_PM :> Monad PM;

    (* forallP is a complete meet operator. The laws for it being a lower bound
    and the greatest lower bound actually correspond to forall-elimination and
    forall-introduction rules, respectively. *)
    predmonad_forallP_elim :
      forall {A B} `{OType A} `{OType B} (f: A -o> PM B _) a,
        forallP @o@ f <o= f @o@ a;
    predmonad_forallP_intro :
      forall {A B} `{OType A} `{OType B} (f: A -o> PM B _) P,
        (forall a, P <o= f @o@ a) -> P <o= forallP @o@ f;

    (* existsP is a complete join operator. The laws for it being an upper bound
    and the least upper bound actually correspond to exists-introduction and
    exists-elimination rules, respectively. *)
    predmonad_existsP_intro :
      forall {A B} `{OType A} `{OType B} (f: A -o> PM B _) a,
        f @o@ a <o= existsP @o@ f;
    predmonad_existsP_elim :
      forall {A B} `{OType A} `{OType B} (f: A -o> PM B _) P,
        (forall a, f @o@ a <o= P) -> existsP @o@ f <o= P;

    (* Laws about liftP *)
    predmonad_liftP_return :
      forall {A} `{OType A} (a:A),
        liftP @o@ (returnM @o@ a) =o= returnM @o@ a;
    predmonad_liftP_bind :
      forall {A B} `{OType A} `{OType B} m f prp,
        liftP @o@ (bindM @o@ m @o@ f)
        =o= bindM @o@ (liftP @o@ m) @o@
                  (mk_ofun (fun x => liftP @o@ (f @o@ x)) (prp:=prp));

    (* FIXME: need laws about how the combinators interact *)
  }.

(***
 *** Defined Predicate Monad Operators
 ***)

(* We define m |= P as holding iff (liftP m) entails P *)
Definition satisfiesP `{PredMonadOps} `{OType} (m:M A _) (P:PM A _) :=
  liftP @o@ m <o= P.

(* Notation for satisfaction *)
Infix "|=" := satisfiesP (at level 80).

(* Disjunction is definable in terms of the existential *)
Definition orP `{PredMonadOps} `{OType} : PM A _ -o> PM A _ -o> PM A _ :=
  ofun P1 => ofun P2 =>
  existsP @o@ (ofun (b:bool) => oif @o@ b @o@ P1 @o@ P2).

(* True and false, which correspond to top and bottom, respectively *)
Definition trueP `{PredMonadOps} `{OType} : PM A _ :=
  existsP @o@ (ofun pm => pm).
Definition falseP `{PredMonadOps} `{OType} : PM A _ :=
  forallP @o@ (ofun pm => pm).

(* An assertion inside a predicate monad *)
Program Definition assertP `{PredMonad} : Prop -o> PM unit _ :=
  mk_ofun (fun (P:Prop) => existsP @o@ (ofun (pf:P) => trueP)) (prp:=_).
Next Obligation.
  intros P1 P2 RP. apply predmonad_existsP_elim; intro pf1.
  assert P2 as pf2; [ apply RP; assumption | ].
  etransitivity; [ | apply (predmonad_existsP_intro _ pf2) ].
  reflexivity.
Defined.

(* An assumption made for the duration of a predicate monad *)
Program Definition assumingP `{PredMonad} `{OType} :
  Flip Prop -o> PM A _ -o> PM A _ :=
  mk_ofun
    (fun (P:Flip Prop) =>
       mk_ofun (fun (Q:PM A _) =>
                  forallP @o@ (ofun (pf:unflip P) => Q)) (prp:=_))
       (prp:=_).
Next Obligation.
  intros Q1 Q2 RQ.
  apply predmonad_forallP_intro; intro pf. simpl.
  etransitivity; [ apply (predmonad_forallP_elim _ pf) | eassumption ].
Defined.
Next Obligation.
  intros P1 P2 RP Q1 Q2 RQ.
  apply predmonad_forallP_intro; intro pf2.
  assert (unflip P1) as pf1; [ apply RP; assumption | ].
  etransitivity; [ apply (predmonad_forallP_elim _ pf1) | eassumption ].
Defined.

(***
 *** The Downward-Closed Set Predicate Monad
 ***)

(* The type of downward-closed sets *)
Definition DownSetM A `{OType A} := Flip A -o> Prop.

Instance OTypeF1_DownSetM : OTypeF1 DownSetM := fun _ _ => _.

(*
Instance FindOTypeF1_DownSetM : FindOTypeF1 DownSetM (fun _ _ => _) := I.
*)

(* An existential with both a positive and a negative component *)
Program Definition oexists2' `{OType} : (A -o> Prop) -o>
                                        (Flip A -o> Prop) -o> Prop :=
  mk_ofun
    (fun P1 =>
       mk_ofun
         (fun P2 =>
            exists2 x, P1 @o@ x & P2 @o@ flip x) (prp:=_)) (prp:=_).
Next Obligation.
  unfold OFunProper, ProperPair; simpl; intros. intro pf.
  destruct pf as [z pf1 pf2].
  exists z; try assumption. apply (H0 _ _ (reflexivity _)). assumption.
Defined.
Next Obligation.
  unfold OFunProper, ProperPair; simpl; intros. intro pf.
  destruct pf as [z pf1 pf2].
  exists z; [ apply (H0 _ _ (reflexivity _)) |
              apply (H1 _ _ (reflexivity _)) ]; assumption.
Defined.

(* The Monad operations for downward-closed sets *)
Instance MonadOps_DownSetM : MonadOps DownSetM :=
  {| returnM :=
       fun A _ =>
         ofun (x:A) => ofun (y:Flip A) => oR @o@ y @o@ x;
     bindM :=
       fun A B _ _ =>
         (ofun m => ofun f => ofun (y:Flip B) =>
          oexists2' @o@ (ofun x => f @o@ x @o@ y) @o@ m)
  |}.

Instance Monad_DownSetM : Monad DownSetM.
Proof.
  constructor; intros.
  - split; intros a1 a2 Ra pf.
    + destruct pf as [ z pf1 pf2].
      rewrite <- Ra. rewrite <- pf2. assumption.
    + simpl. exists x; try reflexivity. rewrite <- Ra. assumption.
  - simpl; split; intros a1 a2 Ra pf.
    + destruct pf as [ z pf1 pf2].
      refine (ofun_Proper m _ _ _ _); [ | eassumption ].
      etransitivity; try eassumption. apply pf1.
    + exists (unflip a1); try assumption.
      destruct a1. simpl. assumption.
  - split; intros c1 c2 Rc pf.
    + destruct pf as [b pfB pf]. destruct pf as [a pfA pf].
      exists a; try assumption.
      exists b; try assumption.
      simpl. rewrite <- Rc. assumption.
    + destruct pf as [a pf pfA]. destruct pf as [b pfB pf].
      exists b; [ simpl; rewrite <- Rc; assumption | ].
      exists a; assumption.
Qed.

Instance PredMonadOps_DownSetM : PredMonadOps Identity DownSetM :=
  {|
    forallP :=
      fun A B _ _ =>
        ofun P => ofun b => oforall @o@ (ofun a => P @o@ a @o@ b);
    existsP :=
      fun A B _ _ =>
        ofun P => ofun b => oexists @o@ (ofun a => P @o@ a @o@ b);
    liftP :=
      fun A _ => returnM
  |}.

Instance PredMonad_DownSetM : PredMonad Identity DownSetM.
Proof.
  constructor; intros; try typeclasses eauto.
  - intros b1 b2 Rb pf. rewrite <- Rb. apply pf.
  - intros b1 b2 Rb pf a. apply (H a b1 b2 Rb); assumption.
  - intros b1 b2 Rb pf. rewrite <- Rb. exists a; assumption.
  - intros b1 b2 Rb [a pf]. apply (H a b1 b2 Rb); assumption.
  - reflexivity.
  - split; intros b1 b2 Rb pf.
    + simpl. exists m; [ | reflexivity ].
      etransitivity; [ apply Rb | apply pf ].
    + destruct pf. simpl in * |- *. etransitivity; try eassumption.
      etransitivity; try eassumption.
      apply ofun_Proper; assumption.
Qed.


(*|
################################
Proof leaking in Coq extraction?
################################

:Link: https://stackoverflow.com/q/51844640
|*)

(*|
Question
********

In order to understand how general recursive ``Function`` definitions
works, and how they comply with Coq's structural recursion constraint,
I tried to reimplement it on the Peano natural numbers. I want to
define recursive ``nat -> nat`` functions that can use any previous
values, not just the predecessor. Here is what I did:
|*)

Require Import Coq.Arith.PeanoNat. (* .none *)
Definition nat_strong_induction_set
           (* erased at extraction, type specification *)
           (P : nat -> Set)
           (* The strong induction step. To build the P n it can, but
              does not have to, recursively query the construction of
              any previous P k's. *)
           (ind_step : forall n : nat, (forall k : nat, (lt k n -> P k)) -> P n)
           (n : nat) :
  P n.
Proof.
  (* Force the hypothesis of ind_step as a standard induction
     hypothesis *)
  assert (forall m k : nat, lt k m -> P k) as partial_build.
  { induction m.
    - intros k H. now apply Nat.nlt_0_r in H.
    - intros k H. apply ind_step. intros k0 H0.
      apply IHm. apply Nat.lt_le_trans with k.
      + assumption.
      + apply Nat.lt_succ_r. assumption. }
  { apply (partial_build (S n) n). apply Nat.lt_succ_diag_r. }
Defined.

(*|
I used some custom lemmas on ``nat``\ s that I didn't paste here. It
works, I managed to define the euclidean division ``div a b`` with it,
which recursively uses ``div (a-b) b``. The extraction is almost what
I expected:
|*)

Require Extraction. (* .none *)
Extraction nat_strong_induction_set. (* .unfold .messages *)

(*|
Except for the ``n0`` parameter. We see that the only effect of this
parameter is to stop the recursion at the ``S n``-nth step. The
extraction also mentions that this ``assert false`` should not happen.
So why is it extracted? This seems better

.. code-block:: ocaml

    let nat_strong_induction_set ind_step n =
      let rec f k = ind_step k (fun k0 _ -> f k0)
      in f n

It looks like a glitch of Coq's structural recursion constraint, to
ensure the termination of all recursions. The Coq definition of
``nat_strong_induction_set`` writes ``lt k n``, so Coq knows only
previous ``P k``'s will be queried. This makes a decreasing chain in
the nats, which is forced to terminate in less than ``S n`` steps.
This allows a structural recursive definition on an additional fuel
parameter ``n0`` starting at ``S n``, it won't affect the result. So
if it is only a part of the termination proof, why is it not erased by
the extraction?
|*)

(*|
Answer
******

Your match is not erased because your definition mixes two things: the
termination argument, where the match is needed, and the
computationally relevant recursive call, where it isn't.

To force erasure, you need to convince Coq that the match is
computationally irrelevant. You can do so by making the termination
argument -- that is, the induction on ``m`` -- produce the proof of a
proposition instead of a function of type ``forall m k, lt k m -> P
k``. Luckily, the standard library provides an easy way of doing so,
with the ``Fix`` combined:
|*)

Reset Initial. (* .none *)
Require Import Coq.Arith.PeanoNat. (* .none *)
Require Import Coq.Arith.Wf_nat.

Definition nat_strong_induction_set
           (P : nat -> Set)
           (ind_step : forall n : nat, (forall k : nat, (lt k n -> P k)) -> P n)
           (n : nat) :
  P n :=
  Fix Nat.lt_wf_0 P ind_step n.

(*|
Here, ``Nat.lt_wf_0`` is a proof that ``lt`` is well-founded. When you
extract this function, you get
|*)

Extraction nat_strong_induction_set. (* .unfold .messages *)

(*|
which is exactly what you wanted.

(As an aside, note that you don't need well-founded recursion to
define division -- check for instance how it is defined in the
`Mathematical Components library
<http://ssr.msr-inria.inria.fr/doc/mathcomp-1.5/MathComp.div.html>`__.)
|*)


(* BEGIN FIX *)
Inductive Bool : Type :=
  | true  : Bool
  | false : Bool.

Definition notb (b : Bool) : Bool :=
  match b with
  | true => false
  | false => true
  end.

Lemma notnot : forall (a : Bool), notb a = (notb (notb (notb a))).
(* END FIX *)
Proof.
  intros a.
  destruct a.
  all: simpl.
  all: reflexivity.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Crypto.Algebra.Ring. (* for ring_simplify_subterms *)
Require Import Crypto.Fancy.Spec. Import Spec.Registers.
Require Import Crypto.Fancy.Compiler.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.
Local Open Scope Z_scope.

Module Z.
(* TODO: move to Div *)
Lemma div_add_mod_cond_l' x y d :
  d <> 0 ->
  (x mod d + y) / d = (x + y) / d - x / d.
Proof.
  intros.
  rewrite (Div.Z.div_add_mod_cond_l x y d) by lia.
  ring.
Qed.
Lemma div_add_mod_cond_r' x y d :
  d <> 0 ->
  (x + y mod d) / d = (x + y) / d - y / d.
Proof.
  intros.
  rewrite (Div.Z.div_add_mod_cond_r x y d) by lia.
  ring.
Qed.
End Z.

Section Prod.
  Definition Mul256 (out src1 src2 tmp : register) (cont : expr) : expr :=
    Instr MUL128LL out (src1, src2)
          (Instr MUL128UL tmp (src1, src2)
                 (Instr (ADD 128) out (out, tmp)
                        (Instr MUL128LU tmp (src1, src2)
                               (Instr (ADD 128) out (out, tmp) cont)))).
  Definition Mul256x256 (out outHigh src1 src2 tmp : register) (cont : expr) : expr :=
    Instr MUL128LL out (src1, src2)
          (Instr MUL128UU outHigh (src1, src2)
                 (Instr MUL128UL tmp (src1, src2)
                        (Instr (ADD 128) out (out, tmp)
                               (Instr (ADDC (-128)) outHigh (outHigh, tmp)
                                      (Instr MUL128LU tmp (src1, src2)
                                             (Instr (ADD 128) out (out, tmp)
                                                    (Instr (ADDC (-128)) outHigh (outHigh, tmp) cont))))))).

  Definition MontRed256 lo hi y t1 t2 scratch RegPInv : @expr register :=
    Mul256 y lo RegPInv t1
           (Mul256x256 t1 t2 y RegMod scratch
                       (Instr (ADD 0) lo (lo, t1)
                              (Instr (ADDC 0) hi (hi, t2)
                                     (Instr SELC y (RegMod, RegZero)
                                            (Instr (SUB 0) lo (hi, y)
                                                   (Instr ADDM lo (lo, RegZero, RegMod)
                                                          (Ret lo))))))).

  (* Barrett reduction -- this is only the "reduce" part, excluding the initial multiplication. *)
  Definition MulMod x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5 : @expr register :=
    let q1Bottom256 := scratchp1 in
    let muSelect := scratchp2 in
    let q2 := scratchp3 in
    let q2High := scratchp4 in
    let q2High2 := scratchp5 in
    let q3 := scratchp1 in
    let r2 := scratchp2 in
    let r2High := scratchp3 in
    let maybeM := scratchp1 in
    Instr SELM muSelect (RegMuLow, RegZero)
          (Instr (RSHI 255) q1Bottom256 (xHigh, x)
                 (Mul256x256 q2 q2High q1Bottom256 RegMuLow scratchp5
                             (Instr (RSHI 255) q2High2 (RegZero, xHigh)
                                    (Instr (ADD 0) q2High (q2High, q1Bottom256)
                                           (Instr (ADDC 0) q2High2 (q2High2, RegZero)
                                                  (Instr (ADD 0) q2High (q2High, muSelect)
                                                         (Instr (ADDC 0) q2High2 (q2High2, RegZero)
                                                                (Instr (RSHI 1) q3 (q2High2, q2High)
                                                                       (Mul256x256 r2 r2High RegMod q3 scratchp4
                                                                                (Instr (SUB 0) muSelect (x, r2)
                                                                                (Instr (SUBC 0) xHigh (xHigh, r2High)
                                                                                (Instr SELL maybeM (RegMod, RegZero)
                                                                                (Instr (SUB 0) q3 (muSelect, maybeM)
                                                                                (Instr ADDM x (q3, RegZero, RegMod)
                                                                                (Ret x))))))))))))))).
End Prod.

(* Solves subgoals for commutativity proofs and simplifies register
lookup expressions *)
Ltac simplify_with_register_properties :=
  repeat
    match goal with
    | _ => rewrite reg_eqb_refl
    | _ => rewrite reg_eqb_neq by (assumption || congruence)
    | H:?y = _ mod ?m |- 0 <= ?y < _ => rewrite H; apply Z.mod_pos_bound; lia
    | _ => assumption
    end.
Ltac cleanup :=
  cbn - [interp spec cc_spec];
  simplify_with_register_properties;
  cbv [CC.update in_dec list_rec list_rect
                 CC.code_dec];
  cbn [CC.cc_c CC.cc_m CC.cc_z CC.cc_l].
Ltac step_and_remember :=
  rewrite interp_step; cleanup;
  remember_single_result.
Ltac step_lhs :=
  match goal with
  | |- Spec.interp _ _ _ (Instr _ _ _ _) _ _ = _ =>
    step_and_remember
  end.
Ltac step_rhs :=
  rewrite interp_step; cleanup;
  match goal with
  | H: ?x = spec ?i ?args _
    |- context [spec ?i ?args ?cc] =>
    replace (spec i args cc) with x by idtac
  end;
  match goal with
  | H : ?y = (?x mod ?m)%Z |- context [(?x mod ?m)%Z] =>
    rewrite <-H
  end.
Ltac prove_programs_equivalent :=
  repeat step_lhs; (* remember the results of each step on the LHS *)
  repeat match goal with
         | _ => step_rhs
         | |- ?x = ?x => reflexivity
         | _ => rewrite mulhh_comm by simplify_with_register_properties; step_rhs
         | _ => rewrite mulll_comm by simplify_with_register_properties; step_rhs
         | _ => rewrite add_comm by simplify_with_register_properties; step_rhs
         | _ => rewrite addc_comm by simplify_with_register_properties; step_rhs
         | _ => rewrite mullh_mulhl; step_rhs
         | _ => rewrite <-mullh_mulhl; step_rhs
         end.

Section ProdEquiv.
  Context (wordmax : Z).

  Let interp256 := interp reg_eqb wordmax cc_spec.
  Lemma cc_overwrite_full x1 x2 l1 cc :
    CC.update [CC.C; CC.M; CC.L; CC.Z] x2 cc_spec (CC.update l1 x1 cc_spec cc) = CC.update [CC.C; CC.M; CC.L; CC.Z] x2 cc_spec cc.
  Proof.
    cbv [CC.update]. cbn [CC.cc_c CC.cc_m CC.cc_l CC.cc_z].
    break_match; try match goal with H : ~ In _ _ |- _ => cbv [In] in H; tauto end.
    reflexivity.
  Qed.

  Definition value_unused r e : Prop :=
    forall x cc ctx, interp256 e cc ctx = interp256 e cc (fun r' => if reg_eqb r' r then x else ctx r').

  Lemma value_unused_skip r i rd args cont (Hcont: value_unused r cont) :
    r <> rd ->
    (~ In r (Tuple.to_list _ args)) ->
    value_unused r (Instr i rd args cont).
  Proof.
    cbv [value_unused interp256] in *; intros.
    rewrite !interp_step; cbv zeta.
    rewrite Hcont with (x:=x).
    match goal with |- ?lhs = ?rhs =>
                    match lhs with context [Tuple.map ?f ?t] =>
                                   match rhs with context [Tuple.map ?g ?t] =>
                                                  rewrite (Tuple.map_ext_In f g) by (intros; cbv [reg_eqb]; break_match; congruence)
                                   end end end.
    apply interp_state_equiv; [ congruence | ].
    { intros; cbv [reg_eqb] in *; break_match; congruence. }
  Qed.

  Lemma value_unused_overwrite r i args cont :
    (~ In r (Tuple.to_list _ args)) ->
    value_unused r (Instr i r args cont).
  Proof.
    cbv [value_unused interp256]; intros; rewrite !interp_step; cbv zeta.
    match goal with |- ?lhs = ?rhs =>
                    match lhs with context [Tuple.map ?f ?t] =>
                                   match rhs with context [Tuple.map ?g ?t] =>
                                                  rewrite (Tuple.map_ext_In f g) by (intros; cbv [reg_eqb]; break_match; congruence)
                                   end end end.
    apply interp_state_equiv; [ congruence | ].
    { intros; cbv [reg_eqb] in *; break_match; congruence. }
  Qed.

  Lemma value_unused_ret r r' :
    r <> r' ->
    value_unused r (Ret r').
  Proof.
    cbv - [reg_dec]; intros.
    break_match; congruence.
  Qed.

  Lemma interp_Mul256 out src1 src2 tmp tmp2 cont cc ctx:
    out <> src1 ->
    out <> src2 ->
    out <> tmp ->
    out <> tmp2 ->
    src1 <> src2 ->
    src1 <> tmp ->
    src1 <> tmp2 ->
    src2 <> tmp ->
    src2 <> tmp2 ->
    tmp <> tmp2 ->
    value_unused tmp cont ->
    value_unused tmp2 cont ->
    interp256 (Mul256 out src1 src2 tmp cont) cc ctx =
    interp256 (
        Instr MUL128LU tmp (src1, src2)
              (Instr MUL128UL tmp2 (src1, src2)
                     (Instr MUL128LL out (src1, src2)
                                 (Instr (ADD 128) out (out, tmp2)
                                        (Instr (ADD 128) out (out, tmp) cont))))) cc ctx.
  Proof.
    intros; cbv [Mul256 interp256].
    repeat step_lhs.
    repeat step_rhs.

    match goal with H : value_unused tmp _ |- _ => erewrite H end.
    match goal with H : value_unused tmp2 _ |- _ => erewrite H end.
    apply interp_state_equiv.
    { reflexivity. }
    { intros; cbv [reg_eqb].
      break_innermost_match; try congruence; reflexivity. }
  Qed.

  Lemma interp_Mul256x256 out outHigh src1 src2 tmp tmp2 cont cc ctx:
    out <> src1 ->
    out <> outHigh ->
    out <> src2 ->
    out <> tmp ->
    out <> tmp2 ->
    outHigh <> src1 ->
    outHigh <> src2 ->
    outHigh <> tmp ->
    outHigh <> tmp2 ->
    src1 <> src2 ->
    src1 <> tmp ->
    src1 <> tmp2 ->
    src2 <> tmp ->
    src2 <> tmp2 ->
    tmp <> tmp2 ->
    value_unused tmp cont ->
    value_unused tmp2 cont ->
    interp256 (Mul256x256 out outHigh src1 src2 tmp cont) cc ctx =
    interp256 (
        Instr MUL128UU outHigh (src1, src2)
              (Instr MUL128LU tmp (src1, src2)
                     (Instr MUL128UL tmp2 (src1, src2)
                            (Instr MUL128LL out (src1, src2)
                                   (Instr (ADD 128) out (out, tmp2)
                                          (Instr (ADDC (-128)) outHigh (outHigh, tmp2)
                                                 (Instr (ADD 128) out (out, tmp)
                                                        (Instr (ADDC (-128)) outHigh (outHigh, tmp) cont)))))))) cc ctx.
  Proof.
    intros; cbv [Mul256x256 interp256].
    repeat step_lhs.
    repeat step_rhs.

    match goal with H : value_unused tmp _ |- _ => erewrite H end.
    match goal with H : value_unused tmp2 _ |- _ => erewrite H end.
    apply interp_state_equiv; [ reflexivity | ].
    intros; cbv [reg_eqb].
    break_innermost_match; try congruence; reflexivity.
  Qed.

  Lemma interp_add_chain a b c cont cc ctx:
    a <> b ->
    a <> c ->
    b <> c ->
    (0 <= ctx a < wordmax)%Z ->
    (0 <= ctx b < wordmax)%Z ->
    (0 <= ctx c < wordmax)%Z ->
    (wordmax = 2 ^ 256)%Z ->
    let result := (ctx a + Z.shiftl (ctx c) 128 + ctx b * wordmax)%Z in
    interp256 (
        Instr (ADD 128) a (a, c)
              (Instr (ADDC (-128)) b (b, c) cont))
              cc ctx =
    interp256 cont
              (CC.update [CC.C; CC.M; CC.L; CC.Z]
                         (result / wordmax) cc_spec cc)
              (fun r =>
                 if reg_eqb r a
                 then (result mod wordmax)%Z
                 else
                   if reg_eqb r b
                   then ((result / wordmax) mod wordmax)%Z
                   else ctx r).
  Proof.
    intros; cbv [interp256].
    repeat step_and_remember.
    cbn [spec ADD ADDC CC.cc_c] in *.
    replace x0 with (result / wordmax)%Z in *.

    { apply interp_state_equiv; [ reflexivity | ].
      intros; cbv [reg_eqb].
      break_innermost_match; try congruence; try reflexivity.
      { subst. subst result.
        autorewrite with zsimplify.
        pull_Zmod. reflexivity. } }

    (* TODO: this is a stupidly ugly arithmetic proof *)
    { subst. subst result.
      rewrite Z.shiftl_mul_pow2 by lia.
      rewrite Z.shiftl_div_pow2 by lia.
      rewrite Pos2Z.opp_neg. (* TODO : add to zsimplify? *)
      autorewrite with zsimplify.

      match goal with
        |- context [if ?x then 1 else 0] =>
        change (if x then 1 else 0) with (Z.b2z x)
      end.
      cbv [cc_spec].
      rewrite Z.testbit_spec' by lia.

      rewrite Z.mod_small with (b:=2) by
          (split; [ Z.zero_bounds | ];
            apply Z.div_lt_upper_bound; try lia;
            match goal with
              |- context [ ?x mod ?y ] =>
              pose proof (Z.mod_pos_bound x y ltac:(lia))
            end; lia).

      autorewrite with zsimplify.

      rewrite Z.div_add_mod_cond_r' by lia.
      rewrite Z.mod_small with (a := ctx c / 2 ^ 128)
        by (split; [ Z.zero_bounds | apply Z.div_lt_upper_bound; lia ]).
      assert (0 < 2 ^ 128) by (cbn; lia).
      change (2 ^ 256)%Z with (2 ^ 128 * 2 ^ 128)%Z.
      rewrite Z.div_mul_cancel_r by lia.
      ring. }
  Qed.

  Definition flags_unused e wordmax : Prop :=
    forall cc x ctx,
      interp reg_eqb wordmax cc_spec e cc ctx =
      interp reg_eqb wordmax cc_spec e (CC.update [CC.C; CC.M; CC.L; CC.Z] x cc_spec cc) ctx.

  Lemma swap_add_chain a b c d cont cc ctx:
    a <> b ->
    a <> c ->
    a <> d ->
    b <> c ->
    b <> d ->
    c <> d ->
    0 <= ctx a < wordmax ->
    0 <= ctx b < wordmax ->
    0 <= ctx c < wordmax ->
    0 <= ctx d < wordmax ->
    wordmax = 2 ^ 256 ->
    flags_unused cont wordmax ->
    interp256 (
        Instr (ADD 128) a (a, c)
              (Instr (ADDC (-128)) b (b, c)
                     (Instr (ADD 128) a (a, d)
                            (Instr (ADDC (-128)) b (b, d) cont))))
              cc ctx =
    interp256 (
        Instr (ADD 128) a (a, d)
              (Instr (ADDC (-128)) b (b, d)
                     (Instr (ADD 128) a (a, c)
                            (Instr (ADDC (-128)) b (b, c) cont))))
              cc ctx.
  Proof.
    intros.
    assert (0 < wordmax) by lia.
    repeat (rewrite interp_add_chain by (rewrite ?reg_eqb_refl, ?reg_eqb_neq by congruence; try assumption; auto using Z.mod_pos_bound with lia)).
    rewrite ?reg_eqb_refl, ?reg_eqb_neq by congruence.
    match goal with
    | H : flags_unused ?e _
      |- interp256 ?e ?ccl _ = interp256 ?e ?ccr _ =>
      rewrite H with (cc:=ccl) (x:=0);
        rewrite H with (cc:=ccr) (x:=0)
    end.
    rewrite !cc_overwrite_full.
    apply interp_state_equiv; [ reflexivity | ].
    intros; cbv [reg_eqb].
    break_innermost_match; try congruence; try reflexivity.
    { autorewrite with zsimplify. pull_Zmod.
      f_equal; ring. }
    { autorewrite with zsimplify. pull_Zmod.
      rewrite !Z.div_add_mod_cond_l' by (subst; cbn; lia).
      ring_simplify.
      (* This is really annoying, can't a tactic do this? *)
      match goal with |- context [?a + ?b + ?c] =>
                      match goal with |- context [?a + ?c + ?b] =>
                                      replace (a + b + c) with (a + c + b) by ring
                      end end.
      f_equal. ring. }
  Qed.

End ProdEquiv.

Ltac push_value_unused :=
  repeat match goal with
         | _ => apply value_unused_skip; [ | assumption | ]
         | _ => apply value_unused_overwrite
         | _ => apply value_unused_ret; congruence
         | _ => apply not_in_cons; split;
                [ try assumption; symmetry; assumption | ]
         | _ => apply in_nil
         end.


(* Author: Masaki Hara, 2014 *)
(* Linear Logic Toy for Coq *)
Require Import LWeight LType_base LGoal.

(*************************************************)
(*              Additive Disjunction             *)
(*************************************************)

Definition LPlus{E:LEnv} (A B:LType) : LType := {|
  ltype := ltype A + ltype B;
  lweight x :=
    match x with
    | inl xl => lweight xl
    | inr xr => lweight xr
    end
|}.
Definition LZero{E:LEnv} : LType := {|
  ltype := Empty_set;
  lweight x := match x with end
|}.
Notation "A + B" := (LPlus A%LL B%LL) : LL_scope.
Notation "0" := LZero : LL_scope.

Definition LPlusConstructorL{E:LEnv} {A B:LType} {W:LWeight}
    (H0 : LGoal A W) : LGoal (A + B) W.
Proof.
  refine {|
    lgoal_proof := inl (lgoal_proof H0) : ltype (A + B)
  |}.
Defined.
Definition LPlusConstructorR{E:LEnv} {A B:LType} {W:LWeight}
    (H1 : LGoal B W) : LGoal (A + B) W.
Proof.
  refine {|
    lgoal_proof := inr (lgoal_proof H1) : ltype (A + B)
  |}.
Defined.

Definition LPlusDestructor{E:LEnv} {A B C:LType} {W:LWeight}
    (H0 : LGoal (A -o C) W) (H1 : LGoal (B -o C) W) : LGoal (A + B -o C) W.
Proof.
  refine {|
    lgoal_proof := {|
      lfun_val := fun (x:ltype (A + B)) =>
        match x with
        | inl xl => lfun_val (lgoal_proof H0) xl
        | inr xr => lfun_val (lgoal_proof H1) xr
        end;
      lfun_weight := W
    |} : ltype (A + B -o C)
  |}.
Grab Existential Variables.
  intros [xl|xr]; simpl.
  - refine (lweight_eqn _).
  - refine (lweight_eqn _).
Defined.

Definition LZeroDestructor{E:LEnv} {A:LType} {W:LWeight}
    : LGoal (0 -o A) W.
Proof.
  refine {|
    lgoal_proof := {|
      lfun_val := fun (x:ltype 0) =>
        match x with end;
      lfun_weight := W
    |} : ltype (0 -o A)
  |}.
Grab Existential Variables.
  intros [].
Defined.

Local Ltac leftll_base ::=
  apply LPlusConstructorL ||
  fail "Constructor not found".
Local Ltac rightll_base ::=
  apply LPlusConstructorR ||
  fail "Constructor not found".
Local Ltac destructll_base ::=
  apply LPlusDestructor ||
  apply LZeroDestructor ||
  fail "Destructor not found".

Local Open Scope LL_goal_scope.
Example LPlusComm{E:LEnv} (A B:LType) :
  (ILL |- A + B -o B + A).
Proof.
  introsll x.
  destructll x as [y | z].
  - rightll.
    applyll y.
  - leftll.
    applyll z.
Defined.
Local Close Scope LL_goal_scope.