(*****************************)
(*****************************)
(****                     ****)
(****   Typing contexts   ****)
(****                     ****)
(*****************************)
(*****************************)

Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Main.SystemF.FreeVar.
Require Import Main.SystemF.LocalClosure.
Require Import Main.SystemF.Name.
Require Import Main.SystemF.Substitution.
Require Import Main.SystemF.Syntax.
Require Import Main.Tactics.

Import Coq.Lists.List.ListNotations.

Inductive context :=
| cEmpty : context
| cEExtend : context -> name -> type -> context
| cTExtend : context -> name -> context.

(*******************)
(* Variable lookup *)
(*******************)

Fixpoint eLookup c1 x1 :=
  match c1 with
  | cEmpty => None
  | cEExtend c2 x2 t => if nameEq x1 x2 then Some t else eLookup c2 x1
  | cTExtend c2 _ => eLookup c2 x1
  end.

Fixpoint tLookup c1 x1 :=
  match c1 with
  | cEmpty => false
  | cEExtend c2 _ _ => tLookup c2 x1
  | cTExtend c2 x2 => if nameEq x1 x2 then true else tLookup c2 x1
  end.

(***********)
(* Domains *)
(***********)

Fixpoint eDomain c1 :=
  match c1 with
  | cEmpty => []
  | cEExtend c2 x t => x :: eDomain c2
  | cTExtend c2 _ => eDomain c2
  end.

Fixpoint tDomain c1 :=
  match c1 with
  | cEmpty => []
  | cEExtend c2 _ _ => tDomain c2
  | cTExtend c2 x => x :: tDomain c2
  end.

(************************)
(* Type well-formedness *)
(************************)

Definition tWellFormed c t :=
  tLocallyClosed t 0 /\
  incl (tFreeVars t) (tDomain c).

(***************************)
(* Context well-formedness *)
(***************************)

Inductive cWellFormed : context -> Prop :=
| cwfEmpty :
  cWellFormed cEmpty
| cwfEExtend :
  forall c t x,
  ~ In x (eDomain c) ->
  tWellFormed c t ->
  cWellFormed c ->
  cWellFormed (cEExtend c x t)
| cwfTExtend :
  forall c x,
  ~ In x (tDomain c) ->
  cWellFormed c ->
  cWellFormed (cTExtend c x).

#[export] Hint Constructors cWellFormed : main.

(*****************************)
(* Concatenation of contexts *)
(*****************************)

Fixpoint cConcat c1 c2 :=
  match c2 with
  | cEmpty => c1
  | cEExtend c3 x t2 => cEExtend (cConcat c1 c3) x t2
  | cTExtend c3 x => cTExtend (cConcat c1 c3) x
  end.

(****************************)
(* Substitution on contexts *)
(****************************)

Fixpoint cSub c1 x1 t1 :=
  match c1 with
  | cEmpty => cEmpty
  | cEExtend c2 x2 t2 => cEExtend (cSub c2 x1 t1) x2 (ttSub t2 x1 t1)
  | cTExtend c2 x2 => cTExtend (cSub c2 x1 t1) x2
  end.

(***********************************)
(* Facts about domains and lookups *)
(***********************************)

Theorem eDomainLookup :
  forall c x,
  In x (eDomain c) <-> exists t, eLookup c x = Some t.
Proof.
  clean. split; induction c; eSearch. clean. destruct H; eSearch.
Qed.

#[export] Hint Resolve -> eDomainLookup : main.
#[export] Hint Resolve <- eDomainLookup : main.

Theorem tDomainLookup :
  forall c x,
  In x (tDomain c) <-> tLookup c x = true.
Proof.
  clean. induction c; search.
Qed.

#[export] Hint Resolve -> tDomainLookup : main.
#[export] Hint Resolve <- tDomainLookup : main.

(************************************)
(* Facts about type well-formedness *)
(************************************)

Theorem tWellFormedClosed :
  forall c t x,
  tWellFormed c t ->
  In x (tFreeVars t) ->
  In x (tDomain c).
Proof.
  clean. apply tDomainLookup. invert H. search.
Qed.

#[export] Hint Resolve tWellFormedClosed : main.

Theorem tLookupWellFormed :
  forall c x t,
  cWellFormed c ->
  eLookup c x = Some t ->
  tWellFormed c t.
Proof.
  clean. unfold tWellFormed. induction H; search. clean.
  destruct (nameEq x x0); search. clean. invert H0. search.
Qed.

#[export] Hint Resolve tLookupWellFormed : main.

(****************************)
(* Facts about substitution *)
(****************************)

Theorem cSubEDomain :
  forall c x t,
  eDomain (cSub c x t) = eDomain c.
Proof.
  induction c; search.
Qed.

#[export] Hint Resolve cSubEDomain : main.

Theorem cSubTDomain :
  forall c x t,
  tDomain (cSub c x t) = tDomain c.
Proof.
  induction c; search.
Qed.

#[export] Hint Resolve cSubTDomain : main.

(*****************************************)
(* Facts about concatenation of contexts *)
(*****************************************)

Theorem cConcatEmpty : forall c, cConcat cEmpty c = c.
Proof.
  induction c; search.
Qed.

#[export] Hint Resolve cConcatEmpty : main.

Theorem cConcatAssoc :
  forall c1 c2 c3,
  cConcat (cConcat c1 c2) c3 = cConcat c1 (cConcat c2 c3).
Proof.
  induction c2; induction c3; search.
Qed.

#[export] Hint Resolve cConcatAssoc : main.

(*****************************************)
(* Facts about concatenation and domains *)
(*****************************************)

Theorem eDomainConcat :
  forall c1 c2,
  eDomain (cConcat c1 c2) = eDomain c2 ++ eDomain c1.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve eDomainConcat : main.

Theorem tDomainConcat :
  forall c1 c2,
  tDomain (cConcat c1 c2) = tDomain c2 ++ tDomain c1.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve tDomainConcat : main.

(****************************************)
(* Facts about concatenation and lookup *)
(****************************************)

Theorem cConcatELookup :
  forall c1 c2 t x,
  eLookup (cConcat c1 c2) x = Some t ->
  eLookup c1 x = Some t \/ eLookup c2 x = Some t.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cConcatELookup : main.

Theorem cConcatTLookup :
  forall c1 c2 x,
  tLookup (cConcat c1 c2) x = true ->
  tLookup c1 x = true \/ tLookup c2 x = true.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cConcatTLookup : main.

Theorem cELookupConcatRight :
  forall c1 c2 t x,
  eLookup c2 x = Some t ->
  eLookup (cConcat c1 c2) x = Some t.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cELookupConcatRight : main.

Theorem cELookupConcatLeft :
  forall c1 c2 t x,
  eLookup c1 x = Some t ->
  eLookup c2 x = None ->
  eLookup (cConcat c1 c2) x = Some t.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cELookupConcatLeft : main.

Theorem cTLookupConcatRight :
  forall c1 c2 x,
  tLookup c2 x = true ->
  tLookup (cConcat c1 c2) x = true.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cTLookupConcatRight : main.

Theorem cTLookupConcatLeft :
  forall c1 c2 x,
  tLookup c1 x = true ->
  tLookup (cConcat c1 c2) x = true.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cTLookupConcatLeft : main.

Theorem cELookupNone :
  forall c1 c2 t x,
  eLookup c1 x = Some t ->
  cWellFormed (cConcat c1 c2) ->
  eLookup c2 x = None.
Proof.
  clean. induction c2; search; invert H0; feed IHc2; clean.
  destruct (nameEq x n); search. clean.
  assert (In n (eDomain c1)); eSearch.
  rewrite eDomainConcat in H4.
  unfold not in H4. search.
Qed.

#[export] Hint Resolve cELookupNone : main.

Theorem cTLookupNone :
  forall c1 c2 x,
  tLookup c1 x = true ->
  cWellFormed (cConcat c1 c2) ->
  tLookup c2 x = false.
Proof.
  clean. induction c2; search; invert H0; feed IHc2; clean.
  destruct (nameEq x n); search. clean.
  assert (In n (tDomain c1)); [eSearch | idtac].
  rewrite tDomainConcat in H3.
  unfold not in H3. search.
Qed.

#[export] Hint Resolve cTLookupNone : main.

(***************************************)
(* Facts about context well-formedness *)
(***************************************)

Theorem cWellFormedESkip :
  forall c1 c2 t x,
  cWellFormed (cConcat (cEExtend c1 x t) c2) ->
  cWellFormed (cConcat c1 c2).
Proof.
  clean. induction c2; invert H; search; clean; constructor; search.
  - rewrite eDomainConcat in *. clean.
    unfold not in *. clean.
    pose proof (in_app_or (eDomain c2) (eDomain c1) n H).
    destruct H0; search.
  - unfold tWellFormed in *. split; search. clean.
    rewrite tDomainConcat in *. search.
  - rewrite tDomainConcat in *. search.
Qed.

#[export] Hint Resolve cWellFormedESkip : main.

Theorem cWellFormedTSkip :
  forall c1 c2 t x,
  cWellFormed (cConcat (cTExtend c1 x) c2) ->
  tWellFormed c1 t ->
  cWellFormed (cConcat c1 (cSub c2 x t)).
Proof.
  clean. induction c2; invert H; search; clean; constructor; search.
  - unfold tWellFormed in H5.
    rewrite eDomainConcat in *. rewrite cSubEDomain.
    unfold not in *. clean.
    assert (In n (eDomain c2) \/ In n (eDomain c1)); search.
  - unfold tWellFormed in *. split; search. clean.
    apply incl_tran with (
      m := tFreeVars t ++ remove nameEq x (tFreeVars t0)
    ); search.
    rewrite tDomainConcat. rewrite tDomainConcat in H1.
    assert (
      incl
        (remove nameEq x (tFreeVars t0))
        (tDomain (cSub c2 x t) ++ tDomain c1)
    ); search.
    rewrite cSubTDomain.
    unfold incl in *. clean.
    specialize (H1 a). feed H1.
    + pose proof (nameInRemove (tFreeVars t0) a x H3). search.
    + pose proof (remove_In nameEq (tFreeVars t0) x).
      assert (a <> x); search. clear H5.
      pose proof (in_app_or (tDomain c2) (x :: tDomain c1) a H1).
      destruct H5; search.
  - rewrite tDomainConcat in *.
    unfold not in *. clean.
    assert (In n (tDomain (cSub c2 x t)) \/ In n (tDomain c1)); search.
    destruct H1; search.
    rewrite cSubTDomain in H1. search.
Qed.

#[export] Hint Resolve cWellFormedTSkip : main.


Require Import Semigroup.
Set Implicit Arguments.

Section Sample.
  Variable A : Type.
  Variable bot : A.
  Variable Aplus : A -> A -> A.
  Infix "+!" := Aplus (at level 50, left associativity).
  Variable Aplus_assoc : forall x y z : A, (x +! y) +! z = x +! (y +! z).
  Variable Aplus_comm : forall x y, x +! y = y +! x.

  Definition Acsg :=
    {| CSelem := bot;
       CSplus := Aplus;
       CSplus_assoc := Aplus_assoc;
       CSplus_comm := Aplus_comm; |}.

  Goal forall x y z, (x +! y) +! z = y +! (z +! x).
  Proof.
    intros.
    semigroup Acsg.
  Qed.

  Goal forall x y z w, (x +! y) +! (z +! w) = w +! (x +! z) +! y.
  Proof.
    intros.
    semigroup Acsg.
  Qed.

  Goal forall x y z, x +! y +! x +! z = x +! x +! y +! z.
  Proof.
    intros.
    semigroup Acsg.
  Qed.

  Goal forall x y z w,
    (x +! y) +! (x +! z +! (w +! y) +! w) = w +! w +! z +! y +! y+! x +! x.
  Proof.
    intros.
    semigroup Acsg.
  Qed.
End Sample.


From mathcomp
     Require Import ssreflect eqtype ssrnat ssrbool seq.

Require Import arith.
Require Import tactics.
Require Import lists.
Require Import sem.

Definition id := nat.

Inductive expr : Type :=
  NE of Z
| BE of bool
| AddE of expr & expr
| SubE of expr & expr
| MulE of expr & expr
| DivE of expr & expr
| EqE of expr & expr
| LtE of expr & expr
| LeE of expr & expr
| NegE of expr
| AndE of expr & expr
| IfE of expr & expr & expr
| NilE
| PPendE of expr & expr
| LCaseE of expr & expr & expr
| VarE of id
| AppE of expr & expr
| AbsE of id & expr
| LetRecE of id & expr & expr
.

Definition is_icfm (e: expr) :=
  match e with NE _ => true | _ => false end.

Definition is_bcfm (e: expr) :=
  match e with BE _ => true | _ => false end.

Definition is_fcfm (e: expr) :=
  match e with AbsE _ _ => true | _ => false end.

Fixpoint is_cfm (e: expr) :=
  match e with
    NE _ => true
  | BE _ => true
  | AbsE _ _ => true
  | NilE => true
  | PPendE e1 e2 => is_cfm e1 && is_cfm e2
  | _ => false
  end.

Definition is_lcfm (e: expr) :=
  match e with
    NilE => true
  | PPendE e1 e2 => is_cfm e1 && is_cfm e2
  | _ => false
  end.

Fixpoint is_zlcfm (e: expr) : bool :=
  match e with
    NilE => true
  | PPendE (NE z) e2 => is_zlcfm e2
  | _ => false
  end.

Definition fun_config := expr.
Definition fun_rconfig := expr.

Fixpoint e_subst (e: expr) (x: id) (e': expr) :=
  match e with
    NE z => NE z
  | BE b => BE b
  | AddE e1 e2 => AddE (e_subst e1 x e') (e_subst e2 x e')
  | SubE e1 e2 => SubE (e_subst e1 x e') (e_subst e2 x e')
  | MulE e1 e2 => MulE (e_subst e1 x e') (e_subst e2 x e')
  | DivE e1 e2 => DivE (e_subst e1 x e') (e_subst e2 x e')
  | EqE e1 e2 => EqE (e_subst e1 x e') (e_subst e2 x e')
  | LtE e1 e2 => LtE (e_subst e1 x e') (e_subst e2 x e')
  | LeE e1 e2 => LeE (e_subst e1 x e') (e_subst e2 x e')
  | NegE e1 => NegE (e_subst e1 x e')
  | AndE e1 e2 => AndE (e_subst e1 x e') (e_subst e2 x e')
  | IfE e1 e2 e3 =>
    IfE (e_subst e1 x e') (e_subst e2 x e') (e_subst e3 x e')
  | NilE => NilE
  | PPendE e1 e2 => PPendE (e_subst e1 x e') (e_subst e2 x e')
  | LCaseE e1 e2 e3 =>
    LCaseE (e_subst e1 x e') (e_subst e2 x e') (e_subst e3 x e')
  | VarE x' => if (x == x') then e' else (VarE x')
  | AppE e1 e2 => AppE (e_subst e1 x e') (e_subst e2 x e')
  | AbsE x' e1 => if (x == x') then (AbsE x' e1) else (AbsE x' (e_subst e1 x e'))
  (* letrec x1 = \lam x2.e2 in e1 *)
  | LetRecE x1 e2 e1 =>
    let: e1' := (if x == x1 then e1 else (e_subst e1 x e')) in
    LetRecE x1 (e_subst e2 x e') e1'
  end.

Inductive fun_rule :
  seq (prod fun_config fun_rconfig) -> (prod fun_config fun_rconfig) -> Prop :=

| FUNR_NUM z: fun_rule [:: ] (NE z, NE z)
| FUNR_BOOL b: fun_rule [:: ] (BE b, BE b)
| FUNR_ADD e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (AddE e1 e2, NE (z1+z2)%Z)
| FUNR_SUB e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (SubE e1 e2, NE (z1-z2)%Z)
| FUNR_MUL e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (MulE e1 e2, NE (z1*z2)%Z)
| FUNR_DIV e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (DivE e1 e2, NE (z1/z2)%Z)
| FUNR_EQ e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (EqE e1 e2, BE (Z.eqb z1 z2))
| FUNR_LT e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (LtE e1 e2, BE (Z.ltb z1 z2))
| FUNR_LE e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (LeE e1 e2, BE (Z.leb z1 z2))
| FUNR_NEQ e1 b1:
    fun_rule [:: (e1, BE b1) ] (NegE e1, BE (~~b1))
| FUNR_AND e1 e2 b1 b2:
    fun_rule [:: (e1, BE b1); (e2, BE b2) ] (EqE e1 e2, BE (b1 && b2))
| FUNR_IFTT e1 e2 e3 cf:
    fun_rule [:: (e1, BE true); (e2, cf) ] (IfE e1 e2 e3, cf)
| FUNR_IFFF e1 e2 e3 cf:
    fun_rule [:: (e1, BE false); (e3, cf) ] (IfE e1 e2 e3, cf)
| FUNR_NIL: fun_rule [:: ] (NilE, NilE)
| FUNR_PPEND e e' cf cf':
    is_cfm cf -> is_cfm cf' ->
    fun_rule [:: (e, cf); (e', cf') ] (PPendE e e', PPendE cf cf')
| FUNR_LCASE1 e e' e'' cf:
    is_cfm cf -> fun_rule [:: (e, NilE); (e', cf) ] (LCaseE e e' e'', cf)
| FUNR_LCASE2 e e' e'' cf cf' cf'':
    is_cfm cf -> is_cfm cf' -> is_cfm cf'' ->
    fun_rule [:: (e, PPendE cf cf'); ((AppE (AppE e'' cf) cf'), cf'') ]
             (LCaseE e e' e'', cf'')
| FUNR_APP e e' e'' x cf cf':
    is_cfm cf -> is_cfm cf' ->
    fun_rule [:: (e, AbsE x e''); (e', cf'); (e_subst e'' x cf', cf) ]
             (AppE e e', cf)
| FUNR_ABS x e: fun_rule [:: ] (AbsE x e, AbsE x e)
| FUNR_LETREC e e' e'' x x' cf:
    e'' = (AbsE x' e') ->
    x <> x' ->
    fun_rule [:: (AppE (AbsE x e) (AbsE x' (LetRecE x (AbsE x' e') e')), cf) ]
             (LetRecE x e'' e, cf)
.

Instance fun_Sem : Sem fun_config fun_rconfig :=
  {
  rule := fun_rule
  }.

(* the list-merging program *)

Definition merge_id: id := 0.

Definition x_id: id := 1.
Definition x'_id: id := 2.

Definition i_id: id := 3.
Definition i'_id: id := 4.

Definition r_id: id := 5.
Definition r'_id: id := 6.

Definition e_if :=
  IfE (LeE (VarE i_id) (VarE i'_id))
      (PPendE (VarE i_id) (AppE (AppE (VarE merge_id) (VarE r_id)) (VarE x'_id)))
      (PPendE (VarE i'_id) (AppE (AppE (VarE merge_id) (VarE x_id)) (VarE r'_id))).

Definition e_lcase :=
  LCaseE (VarE x_id)
         (VarE x'_id)
         (AbsE i_id (AbsE r_id
                          (LCaseE (VarE x'_id)
                                  (VarE x_id)
                                  (AbsE i'_id (AbsE r'_id e_if))))).

Definition e_mg (lcf1 lcf2: expr) :=
  LetRecE merge_id
          (AbsE x_id (AbsE x'_id e_lcase))
          (AppE (AppE (VarE merge_id) lcf1) lcf2).

(* the specification *)

(* aux. function computing the sequence (list) for a list canonical form *)
(* assuming lcf is a list canonical form *)
Fixpoint lcf_seq (lcf: expr) : seq Z :=
  match lcf with
    PPendE (NE z) lcf' => (z :: lcf_seq lcf')
  | _ => [:: ]
  end.

(* the actual specification *)
Inductive mg_spec (u:unit): Spec unit fun_config fun_rconfig u :=

  FUN_SP_e_mg (lcf1 lcf2: expr) (zs1 zs2: seq Z):
    is_zlcfm lcf1 ->
    is_zlcfm lcf2 ->
    zs1 = lcf_seq lcf1 ->
    zs2 = lcf_seq lcf2 ->
    sorted zs1 ->
    sorted zs2 ->
    mg_spec _
            (e_mg lcf1 lcf2)
            (fun r => (is_zlcfm r /\
                       (forall z, occ (lcf_seq r) z = occ zs1 z + occ zs2 z) /\
                       sorted (lcf_seq r)))

| FUN_SP_e_unfold (lcf1 lcf2: expr) (zs1 zs2: seq Z):
    is_zlcfm lcf1 ->
    is_zlcfm lcf2 ->
    zs1 = lcf_seq lcf1 ->
    zs2 = lcf_seq lcf2 ->
    sorted zs1 ->
    sorted zs2 ->
    mg_spec _
            (AppE
               (AppE
                  (AbsE x_id
                        (LetRecE merge_id
                                 (AbsE x_id (AbsE x'_id e_lcase))
                                 (AbsE x'_id e_lcase)))
                  lcf1)
               lcf2)
            (fun r => (is_zlcfm r /\
                       (forall z, occ (lcf_seq r) z = occ zs1 z + occ zs2 z) /\
                       sorted (lcf_seq r))).

Ltac inv_zlcfm :=
  match goal with [ H : context [is_zlcfm _] |- _ ] => inv H end.

Lemma zlcfm_subst:
  forall e x e', is_zlcfm e -> e_subst e x e' = e.
Proof.
  elim; try (move=> *; inv_zlcfm; fail).
  - move=>//.
  - move=> e IH1 e0 IH2 x e' H_zlcfm.
    move=>/=.
    move: IH1=> /(_ x e')=> IH1.
    move: IH2=> /(_ x e')=> IH2.
    inversion H_zlcfm; subst.
    case En: e; rewrite En in H0; inv H0.
    move=>/=.
    apply IH2 in H0. rewrite H0=>//.
Qed.

Lemma zlcfm_not_in_spec:
  forall lcf prm, is_zlcfm lcf -> ~(exists P, mg_spec prm lcf P).
Proof.
  move=> lcf prm H_zlcfm H_ex_P.
  inversion H_ex_P as [P H_spec_P]; clear H_ex_P.
  inv H_spec_P; subst;
  simpl in H_zlcfm; inv H_zlcfm.
Qed.

Lemma zlcfm_infer_preserve:
  forall lcf cf param,
    is_zlcfm lcf ->
    infer param (mg_spec param) (lcf, cf) ->
    cf = lcf.
Proof.
  elim; try (move=> *; inv_zlcfm; fail).
  -
    move=> cf prm H_zlcfm H_inf. inv H_inf.
    inv H1; subst. auto.
  -
    move=> e IH1 e0 IH2 cf prm H_zlcfm H_inf.
    inversion H_zlcfm; subst.
    case En: e; rewrite En in H0; simpl in H0; inv H0.
    inversion H_inf; subst.
    rename H3 into H_rule; inversion H_rule; subst.
    ith_prem_exe_0 H4 h' mg_spec. clear h.
    ith_prem_1 H4 H'.
    have: ~(exists P, mg_spec prm e0 P) by apply zlcfm_not_in_spec; auto.
    inversion H' as [H_ne | H_e]; clear H'.
    +
      move=> H_ne'. inv H_ne.
      move: IH2=>/(_ cf' prm H0)=>IH2. apply IH2 in H2. rewrite H2=>//.
    +
      move=> H_ne'. inv H_e. inv H.
      have H_ex: exists P, mg_spec prm e0 P.
      { exists x; auto. }
      apply H_ne' in H_ex. inv H_ex.
Qed.

Lemma zlcfm_infer_nil:
  forall lcf param,
    is_zlcfm lcf ->
    infer param (mg_spec param) (lcf, NilE) ->
    lcf = NilE.
Proof.
  elim; try (move=> *; inv_zlcfm; fail).
  - try done.
  - move=> e IH1 e0 IH2 prm H_zlcfm H_inf.
    inv H_inf; subst.
    inv H1; subst.
Qed.

Ltac get_branch hyp_or hyp_nex :=
        let h1 := fresh "h" in (
          let h2 := fresh "h" in (
            let h3 := fresh "h" in (
              let h4 := fresh "h" in (
                inversion hyp_or as [h1 | h2];
                [ inv h1; auto |
                  inversion h2 as [P h4]; inv h4;
                  exfalso; apply hyp_nex; exists P; auto ]
              )
            )
          )
        ).

Lemma zlcfm_infer_pend0:
  forall lcf param cf cf',
    is_zlcfm lcf ->
    infer param (mg_spec param) (lcf, PPendE cf cf') ->
    exists z lcf'',
      lcf = PPendE (NE z) lcf'' /\
      cf = (NE z) /\
      cf' = lcf'' /\
      is_zlcfm lcf''.
Proof.
  elim; try (move=> *; inv_zlcfm; fail).
  -
    move=> param cf cf' H_zlcfm H_inf.
    inv H_inf. inv H1.
  -
    move=> e IH1 e0 IH2 prm cf cf' H_zlcfm H_inf.
    inversion H_zlcfm; subst.
    case En: e; rewrite En in H0; simpl in H0; inv H0.
    inversion H_inf; subst.
    inversion H3; subst.
    eexists. exists e0.
    apply: conj. eauto. apply: conj.
    ith_prem_exe_0 H4 h' mg_spec; auto.
    ith_prem_1 H4 h'.
    have H_nex: ~(exists P, mg_spec prm e0 P)
      by apply zlcfm_not_in_spec; auto.
    have H_inf0: infer prm (mg_spec prm) (e0, cf')
      by get_branch h' H_nex.
    apply: conj.
    apply zlcfm_infer_preserve with (param:=prm); auto.
    auto.
Qed.

Lemma zlcfm_infer_pend:
  forall lcf param cf cf',
    is_zlcfm lcf ->
    infer param (mg_spec param) (lcf, PPendE cf cf') ->
    exists z,
      lcf = PPendE (NE z) cf' /\
      cf = (NE z) /\
      is_zlcfm cf'.
Proof.
  move=> lcf prm cf cf' H_zlcfm H_inf.
  have H_ex0:
    exists z lcf'',
      lcf = PPendE (NE z) lcf'' /\
      cf = (NE z) /\
      cf' = lcf'' /\
      is_zlcfm lcf'' by apply zlcfm_infer_pend0 with (param:=prm); auto.
  inv H_ex0. inv H. inv H0. inv H2. inv H4.
  exists x. apply: conj. congruence. apply: conj=>//. congruence.
Qed.

Lemma inf_le_comp:
  forall z1 z2 prm b,
    infer prm (mg_spec prm) (LeE (NE z1) (NE z2), BE b) ->
    (z1 <=? z2)%Z = b.
Proof.
  move=> z1 z2 prm b H_inf.
  inv H_inf; subst.
  inv H1; subst.
  ith_prem_0 H2 H2'.
  have H_inf1': infer prm (mg_spec prm) (NE z1, NE z0).
  {
    have H_nex: ~(exists P, mg_spec prm (NE z1) P).
    { move=> contra. inv contra. inv H; subst. }
    get_branch H2' H_nex.
  }
  have H_z1_eq_z0: z1 = z0.
  { inv H_inf1'; subst. inv H3; subst; auto. }
  rewrite <- H_z1_eq_z0 in *.
  clear H2'. clear H_inf1'.
  ith_prem_1 H2 H2'.
  have H_inf2': infer prm (mg_spec prm) (NE z2, NE z3).
  {
    have H_nex: ~(exists P, mg_spec prm (NE z2) P).
    { move=> contra. inv contra. inv H; subst. }
    get_branch H2' H_nex.
  }
  have H_z3_eq_z2: z2 = z3.
  { inv H_inf2'; subst. inv H3; subst; auto. }
  rewrite <- H_z3_eq_z2 in *.
  done.
Qed.

Lemma zlcfm_shape:
  forall cf,
    is_zlcfm cf ->
    (cf = NilE \/ exists z cf', cf = PPendE (NE z) cf').
Proof.
  move=> cf H_zlcfm;
  try destruct cf; inv H_zlcfm.
  - left=>//.
  - right.
    destruct cf1; inv H0.
    exists z. exists cf2. auto.
Qed.

(* the correctness proof *)

Theorem mg_spec_valid: forall param, valid _ (mg_spec param).
Proof.
  init_verif.
  inversion H0; subst.

  - (* proof for overall expression *)
    rename H1 into H_lcfm_lcf1. rename H2 into H_lcfm_lcf2.
    rename H5 into H_sorted_lcf1. rename H6 into H_sorted_lcf2.
    inversion H as [c r' crs H_rule H_all]; subst.
    inversion H_rule; subst. clear H_rule.
    rename H4 into H_abs_eq.
    inversion H_abs_eq; subst.
    clear H_abs_eq.

    ith_prem_exe_0 H_all H' mg_spec.
    ith_prem_exe_0 h h' mg_spec. clear h0.
    ith_prem_exe_1 h h' mg_spec. clear h0.

    simpl in h. repeat rewrite zlcfm_subst in h; auto.
    ith_prem_2 h h'.
    inversion h' as [H_nex_P | H_exP]; clear h'.
    +  (* refute that there is no info about the expr *)
      exfalso. apply H_nex_P.
      eexists.
      apply FUN_SP_e_unfold
        with (lcf1:=lcf1) (lcf2:=lcf2) (zs1:=lcf_seq lcf1) (zs2:=lcf_seq lcf2);
        auto.
    +  (* there is some info about the expr in the spec *)
      inversion H_exP as [P [H_spec_P H_P_r]]; clear H_exP.
      inv H_spec_P; subst.
      auto.

  - (* proof for the unfolded expression *)
    rename H1 into H_lcfm_lcf1. rename H2 into H_lcfm_lcf2.
    rename H5 into H_sorted_lcf1. rename H6 into H_sorted_lcf2.
    inversion H as [c r' crs H_rule H_all]; subst.
    inversion H_rule; subst. clear H_rule.

    ith_prem_exe_0 H_all H' mg_spec.
    ith_prem_exe_0 h h' mg_spec. clear h0.
    ith_prem_1 h h'.
    inversion h' as [H_nexP | H_exP]; clear h'.
    2: {
      have H_nex: ~(exists P, mg_spec param lcf1 P) by apply zlcfm_not_in_spec; auto.
      inv H_exP. inv H1. exfalso. apply H_nex. exists x0; auto.
    }
    inversion H_nexP as [H_nexP0  H_infer]; clear H_nexP.
    have H_cf'0_eq_lcf1: cf'0 = lcf1 by eapply zlcfm_infer_preserve; eauto.
    symmetry in H_cf'0_eq_lcf1. rewrite <- H_cf'0_eq_lcf1 in *.
    ith_prem_exe_2 h h' mg_spec.
    rename H7 into H_abs_eq. inv H_abs_eq; subst.
    ith_prem_exe_0 h0 h' mg_spec.
    ith_prem_exe_0 h1 h' mg_spec. clear h2.
    ith_prem_exe_1 h1 h' mg_spec. clear h2.
    ith_prem_exe_2 h1 h' mg_spec. clear h2.
    rename H7 into H_is_cfm_abs. clear H_is_cfm_abs.
    rename H10 into H_is_cfm_abs. clear H_is_cfm_abs.
    clear h1. clear h0.
    rename H5 into H_is_cfm_abs. clear H_is_cfm_abs.
    clear H_infer. clear H_nexP0. clear H_abs_eq.

    ith_prem_1 H_all H'.
    inversion H' as [H_nexP | H_exP]; clear H'.
    2: {
      have H_nex: ~(exists P, mg_spec param lcf2 P) by apply zlcfm_not_in_spec; auto.
      inv H_exP. inv H1. exfalso. apply H_nex. exists x; auto.
    }
    inversion H_nexP as [H_nex H_infer]; clear H_nexP.
    have H_cf'_eq_lcf2: cf' = lcf2 by eapply zlcfm_infer_preserve; eauto.
    symmetry in H_cf'_eq_lcf2. rewrite <- H_cf'_eq_lcf2 in *.
    ith_prem_2 H_all H'.
    inversion H' as [H_nexP | H_exP]; clear H'.
    2: { inv H_exP. inv H1. inv H2. }
    repeat rewrite zlcfm_subst in H_nexP; auto.
    2: { rewrite zlcfm_subst; auto. }
    clear H_nex. clear H_infer.
    inversion H_nexP as [H_nex H_infer]; clear H_nexP.
    rename cf'0 into lcf1.

    inversion H_infer as [c0 r0 crs0 H_rule_lcase H_all'].
    rename H1 into H_c0_eq_. clear c0 H_c0_eq_.
    rename H2 into H_r0_eq_. clear r0 H_r0_eq_.
    clear H_nex.
    inv H_rule_lcase; subst.

    +  (* first list is NilE *)
      ith_prem_0 H_all' h'.
      have H_nex: ~(exists P, mg_spec param lcf1 P) by eapply zlcfm_not_in_spec; eauto.
      have H_inf:  infer param (mg_spec param) (lcf1, NilE).
      { inv h'. inv H1; auto. inv H1. inv H2. exfalso. apply H_nex. exists x; auto. }
      clear h'. clear H_nex.
      have H_lcf1_nil: lcf1 = NilE by eapply zlcfm_infer_nil; eauto.
      ith_prem_1 H_all' h'.
      have H_nex: ~(exists P, mg_spec param cf' P) by eapply zlcfm_not_in_spec; eauto.
      have H_inf': infer param (mg_spec param) (cf', r) by get_branch h' H_nex.
      have H_r_eq_cf': r = cf'. eapply zlcfm_infer_preserve; eauto.
      symmetry in H_r_eq_cf'. rewrite <- H_r_eq_cf' in *.
      rewrite H_lcf1_nil. simpl.
      apply: conj=>//.

    + (* first list is not NilE *)
      ith_prem_0 H_all' h'.
      have H_nex: ~ (exists P, mg_spec param lcf1 P) by eapply zlcfm_not_in_spec; eauto.
      have H_inf: infer param (mg_spec param) (lcf1, PPendE cf cf'0)
        by get_branch h' H_nex.
      apply zlcfm_infer_pend in H_inf; auto.
      inversion H_inf as [z1 [H_lcf1_eq_pend [H_cf_ne H_zlcfm_cf'0]]]; clear H_inf.
      symmetry in H_lcf1_eq_pend. rewrite <- H_lcf1_eq_pend in *.
      symmetry in H_cf_ne. rewrite <- H_cf_ne in *.
      clear h'. clear H_nex.
      ith_prem_exe_1 H_all' h' mg_spec.
      ith_prem_exe_0 h0 h' mg_spec.
      ith_prem_exe_0 h1 h' mg_spec. clear h2.
      ith_prem_exe_1 h1 h' mg_spec.
      ith_prem_exe_2 h1 h' mg_spec. clear h3. clear h2. clear h1.
      rename H9 into H_is_cfm_abs. clear H_is_cfm_abs.
      (* clear H1. clear H2. *) clear H15.
      ith_prem_1 h0 h'.
      have H_nex: ~(exists P, mg_spec param cf'0 P)
        by apply zlcfm_not_in_spec; auto.
      have H_inf: infer param (mg_spec param) (cf'0, cf'1) by get_branch h' H_nex.
      have H_cf'0_eq_cf'1: cf'1 = cf'0
        by apply zlcfm_infer_preserve with (param:=param); auto.
      rewrite <- H_cf'0_eq_cf'1 in *.
      (* cf'1 is the tail of the first list *)
      rewrite zlcfm_subst in h0; auto.
      rewrite zlcfm_subst in h0; auto.
      rename cf' into lcf2.
      clear H_nex h'.
      ith_prem_exe_2 h0 h' mg_spec.

      * (* second list is NilE *)
        ith_prem_0 h1 h'.
        have H_nex: ~(exists P, mg_spec param lcf2 P)
          by apply zlcfm_not_in_spec; auto.
        clear H_inf.
        rewrite zlcfm_subst in h'; auto.
        have H_inf: infer param (mg_spec param) (lcf2, NilE)
          by get_branch h' H_nex.
        have H_lcf2_nil: lcf2 = NilE
          by apply zlcfm_infer_nil with (param:=param); auto.
        rewrite H_lcf2_nil.

        clear H_nex. ith_prem_exe_1 h1 h1' mg_spec.
        ith_prem_exe_0 h2 h2' mg_spec. clear h3.
        ith_prem_1 h2 h2'.
        clear H_inf.
        rewrite zlcfm_subst in h2'; auto.
        have H_nex: (~exists P, mg_spec param cf'0 P)
          by apply zlcfm_not_in_spec; auto.
        have H_inf: infer param (mg_spec param) (cf'0, cf')
          by get_branch h2' H_nex.
        have H_cf'_eq_cf'0: cf' = cf'0
          by apply zlcfm_infer_preserve with (param:=param); auto.
        rewrite H_cf'_eq_cf'0.
        apply: conj.
        (* is_zlcfm (PPendE (NE z1) cf'0) *)
        simpl; auto.
        (* goal with occ *)
        apply: conj. move=> z.
        have: occ (lcf_seq NilE) z = 0 by simpl; auto.
        move->. rewrite add_zero. auto.
        (* sorted ... *)
        assumption.

      * (* second list is not NilE *)
        ith_prem_0 h1 h1'.
        rewrite zlcfm_subst in h1'; auto.
        have H_nex: ~(exists P, mg_spec param lcf2 P)
          by apply zlcfm_not_in_spec; auto.
        clear H_inf.
        have H_inf: infer param (mg_spec param) (lcf2, PPendE cf cf').
        get_branch h1' H_nex.
        apply zlcfm_infer_pend in H_inf; auto.
        inversion H_inf as [z2 [H_lcf2_eq_ [H_cf_eq_ H_zlcfm_cf']]];
          clear H_inf.
        subst. clear H_nex.
        ith_prem_exe_2 h0 h0' mg_spec.
        ith_prem_0 h2 h2'.
        inv h2'. inv H1. inv H9. inv H19.
        inv H1. inv H2. inv H9.
        rewrite zlcfm_subst in h2; auto.
        ith_prem_exe_0 h2 h2' mg_spec.
        ith_prem_0 h3 h3'.
        have H_nex: ~(exists P, mg_spec param (NE z2) P)
          by intro contra; inv contra; inv H1.
        have H_inf: infer param (mg_spec param) (NE z2, cf)
          by get_branch h3' H_nex.
        have H_ne_z2_eq_cf: NE z2 = cf.
        { inversion H_inf; subst. inv H3; subst; auto. }
        rewrite <- H_ne_z2_eq_cf in *.
        clear h3'. clear H_nex. clear H_inf.
        ith_prem_1 h3 h3'.
        have H_nex: ~(exists P, mg_spec param cf' P)
          by apply zlcfm_not_in_spec; auto.
        have H_inf: infer param (mg_spec param) (cf', cf'1)
          by get_branch h3' H_nex.
        have H_cf'_1_eq_cf': cf'1 = cf'.
        apply zlcfm_infer_preserve with (param:=param); auto.
        symmetry in H_cf'_1_eq_cf'. rewrite <- H_cf'_1_eq_cf' in *.
        clear H_nex H_inf.
        clear H_ne_z2_eq_cf H_cf'_1_eq_cf'. clear h3'.
        rename H9 into H_is_cfm_ne_z2. clear H_is_cfm_ne_z2.
        clear h3.
        ith_prem_exe_1 h2 h2' mg_spec.
        ith_prem_exe_0 h3 h3' mg_spec.
        ith_prem_exe_0 h4 h4' mg_spec. clear h5.
        ith_prem_1 h4 h4'.
        have H_nex: ~(exists P, mg_spec param (NE z2) P).
        { intro contra. inv contra. inv H1. }
        have H_inf: infer param (mg_spec param) (NE z2, cf'3)
          by get_branch h4' H_nex.
        have H_cf'3_eq_ne_z2: NE z2 = cf'3.
        { inv H_inf; subst. inv H3; subst; auto. }
        rewrite <- H_cf'3_eq_ne_z2 in *. clear H_cf'3_eq_ne_z2.
        clear h4' H_inf H_nex.
        ith_prem_exe_2 h4 h4' mg_spec. clear h5.
        rename H18 into H_is_cfm_abs. clear H_is_cfm_abs.
        clear h4.
        ith_prem_2 h3 h3'.
        inversion h3' as [H_nexP | H_exP].
        2: { inv H_exP. inv H1. inv H2. }
        inversion H_nexP as [H_nex H_inf]. clear H_nex.
        repeat (rewrite zlcfm_subst in H_inf; auto;
                [ | try (rewrite zlcfm_subst; auto)]).
        (* H_inf is about the inf result of the if expression *)
        inversion H_inf; subst.
        rename H3 into H_rule_if.
        inversion H_rule_if; subst.

        (* the true branch for the if expression *)
        rename H18 into H_forall_true.
        ith_prem_0 H_forall_true h'.
        have H_inf_tt: infer param (mg_spec param) (LeE (NE z1) (NE z2), BE true).
        {
          have H_nex: ~(exists P, mg_spec param (LeE (NE z1) (NE z2)) P).
          { intro contra. inv contra. inv H1. }
          get_branch h' H_nex.
        }
        apply inf_le_comp in H_inf_tt.
        clear h'.
        ith_prem_exe_1 H_forall_true h' mg_spec.
        ith_prem_exe_0 h4 h4' mg_spec.
        ith_prem_1 h4 h4'.
        fold e_lcase in h4'.
        rewrite zlcfm_subst in h4'; auto.
        rewrite zlcfm_subst in h4'; auto; [ | try (rewrite zlcfm_subst; auto)].
        rewrite zlcfm_subst in h4'; auto.
        clear H_nexP.
        inversion h4' as [H_nexP | H_exP]; clear h4'.
        (* refute that there is no info in the spec *)
        inv H_nexP.
        exfalso. apply H1.
        eexists.
        apply FUN_SP_e_unfold
          with (lcf1:=cf'0) (lcf2:=PPendE (NE z2) cf')
               (zs1:=lcf_seq cf'0) (zs2:=lcf_seq (PPendE (NE z2) cf'));
          eauto.
        (* goal on the sortedness of tail of first list *)
        simpl in H_sorted_lcf1.
        apply sorted_tail in H_sorted_lcf1; auto.

        (* there is some info in the spec *)
        inversion H_exP as [P H_mg_spec]; clear H_exP.
        inversion H_mg_spec as [H_spec_P H_P_cf'4]; clear H_mg_spec.
        inv H_spec_P; subst. clear H_spec_P.
        inversion H_P_cf'4 as [H_zlcfm_cf'4 [H_occ H_sorted]]; clear H_P_cf'4.
        apply: conj. simpl; auto. (* goal with is_zlcfm *)
        apply: conj.
        (* goal with occ *)
        move=> z. specialize (H_occ z).
        simpl in H_occ. simpl. rewrite H_occ.
        case En: (z1 =? z)%Z; case En': (z2 =? z)%Z;
          auto with zarith.
        (* goal on sortedness *)
        simpl.
        have H_cf'4_cases: cf'4 = NilE \/ exists z cf', cf'4 = PPendE (NE z) cf'
              by apply zlcfm_shape; auto.
        inversion H_cf'4_cases as [H_nil | H_n_nil]; clear H_cf'4_cases.
        rewrite H_nil. simpl. apply singleton_sorted.
        inversion H_n_nil as [z0 [cf'' H_cf'4_eq]]; clear H_n_nil.
        have H_corr:
          size (lcf_seq cf'0) > 0 /\ nth 0%Z (lcf_seq cf'4) 0 = nth 0%Z (lcf_seq cf'0) 0 \/
          size (lcf_seq (PPendE (NE z2) cf')) > 0 /\
          nth 0%Z (lcf_seq cf'4) 0 = nth 0%Z (lcf_seq (PPendE (NE z2) cf')) 0.
        {
          apply occ_sorted_hd_corr; auto with zarith.
          rewrite H_cf'4_eq. simpl. auto.
        }
        have H_simp: nth 0%Z (lcf_seq cf'4) 0 = z0 by rewrite H_cf'4_eq=>//=.
        rewrite H_simp in H_corr.
        inversion H_corr as [H_l_first | H_r_first]; clear H_corr.
        (* head ele of new list is head ele of first list *)
        inversion H_l_first as [H_sz_cf'0 H_z0_eq_]; clear H_l_first.
        have H_z1_le_: (z1 <= nth 0%Z (lcf_seq cf'0) 0)%Z.
        { apply sorted_hd_nxt; auto with zarith. }
        rewrite <- H_z0_eq_ in H_z1_le_. rewrite <- H_simp in H_z1_le_.
        have: z1 :: lcf_seq cf'4 = [:: z1] ++ lcf_seq cf'4 by auto.
        move->.
        apply sorted_concat; auto with zarith. apply singleton_sorted.
        have: size [:: z1] - 1 = 0 by auto with arith. move->.
        have: nth 0%Z [:: z1] 0 = z1 by auto. move->.
        auto with zarith.
        (* head ele of new list if head ele of second list *)
        inversion H_r_first as [H_sz_ H_z0_eq_]; clear H_r_first.
        have H_z1_le_: (z1 <= z2)%Z by apply Zle_bool_imp_le; auto.
        simpl in H_z0_eq_. rewrite <- H_z0_eq_ in *.
        have: z1 :: lcf_seq cf'4 = [:: z1] ++ lcf_seq cf'4 by auto.
        move->.
        apply sorted_concat; auto with zarith. apply singleton_sorted.
        have: size [:: z1] - 1 = 0 by auto with arith. move->.
        have: nth 0%Z [:: z1] 0 = z1 by auto. move->.
        auto with zarith.

        (* the false branch for the if expression *)
        have H_cf'2_eq_cf': cf'2 = cf'.
        {
          ith_prem_1 h3 h3''.
          have H_nex: ~(exists P, mg_spec param cf' P)
            by apply zlcfm_not_in_spec; auto.
          have H_inf': infer param (mg_spec param) (cf', cf'2)
            by get_branch h3'' H_nex.
          apply zlcfm_infer_preserve with (param:=param); auto.
        }
        symmetry in H_cf'2_eq_cf'. rewrite <- H_cf'2_eq_cf' in *.
        move: H_cf'2_eq_cf'.
        rename H18 into H_forall_false.
        ith_prem_0 H_forall_false h'.
        have H_inf_ff: infer param (mg_spec param) (LeE (NE z1) (NE z2), BE false).
        {
          have H_nex: ~(exists P, mg_spec param (LeE (NE z1) (NE z2)) P).
          { intro contra. inv contra. inv H1. }
          get_branch h' H_nex.
        }
        apply inf_le_comp in H_inf_ff.
        clear h'.
        ith_prem_exe_1 H_forall_false h' mg_spec.
        ith_prem_exe_0 h4 h4' mg_spec.
        ith_prem_1 h4 h4'.
        fold e_lcase in h4'.
        rewrite zlcfm_subst in h4'; auto. 2: { repeat rewrite zlcfm_subst; auto. }
        rewrite zlcfm_subst in h4'; auto. 2: { rewrite zlcfm_subst; auto. }
        rewrite zlcfm_subst in h4'; auto.
        clear H_nexP.
        inversion h4' as [H_nexP | H_exP]; clear h4'.
        (* refute that there is no info in the spec *)
        inv H_nexP.
        exfalso. apply H1.
        eexists.
        apply FUN_SP_e_unfold
          with (lcf1:=(PPendE (NE z1) cf'0)) (lcf2:=cf')
               (zs1:=lcf_seq (PPendE (NE z1) cf'0)) (zs2:=lcf_seq cf');
          eauto.
        (* goal on the sortedness of tail of first list *)
        simpl in H_sorted_lcf2.
        apply sorted_tail in H_sorted_lcf2; auto.

        (* there is some info in the spec *)
        move=> H'. move=> {H'}.
        inversion H_exP as [P H_mg_spec]; clear H_exP.
        inversion H_mg_spec as [H_spec_P H_P_cf'4]; clear H_mg_spec.
        inv H_spec_P; subst. clear H_spec_P.
        inversion H_P_cf'4 as [H_zlcfm_cf'4 [H_occ H_sorted]]; clear H_P_cf'4.
        apply: conj. simpl; auto. (* goal with is_zlcfm *)
        apply: conj.
        (* goal on occ *)
        move=> z. specialize (H_occ z).
        simpl in H_occ. simpl. rewrite H_occ.
        rewrite [(z2 =? z)%Z + ((z1 =? z)%Z + _ + _)]Nat.add_assoc.
        rewrite [((z2 =? z)%Z + ((z1 =? z)%Z + _))%coq_nat]Nat.add_assoc.
        rewrite [((z2 =? z)%Z + (z1 =? z)%Z)%coq_nat]Nat.add_comm.
        rewrite -[(((z1 =? z)%Z + (z2 =? z)%Z)%coq_nat + _)%coq_nat]Nat.add_assoc.
        rewrite [((z2 =? z)%Z + occ (lcf_seq cf'0) z)%coq_nat]Nat.add_comm.
        rewrite [((z1 =? z)%Z + (_ + (z2 =? z)%Z)%coq_nat)%coq_nat]Nat.add_assoc.
        auto with arith.
        (* goal on sortedness *)
        simpl.
        have H_cf'4_cases: cf'4 = NilE \/ exists z cf', cf'4 = PPendE (NE z) cf'
              by apply zlcfm_shape; auto.
        inversion H_cf'4_cases as [H_nil | H_n_nil]; clear H_cf'4_cases.
        rewrite H_nil. simpl. apply singleton_sorted.
        inversion H_n_nil as [z0 [cf'' H_cf'4_eq]]; clear H_n_nil.
        have H_corr:
          size (lcf_seq (PPendE (NE z1) cf'0)) > 0 /\
          nth 0%Z (lcf_seq cf'4) 0 = nth 0%Z (lcf_seq (PPendE (NE z1) cf'0)) 0 \/
          size (lcf_seq cf') > 0 /\
          nth 0%Z (lcf_seq cf'4) 0 = nth 0%Z (lcf_seq cf') 0.
        {
          apply occ_sorted_hd_corr; auto with zarith.
          rewrite H_cf'4_eq. simpl. auto.
        }
        have H_simp: nth 0%Z (lcf_seq cf'4) 0 = z0 by rewrite H_cf'4_eq=>//=.
        rewrite H_simp in H_corr.
        inversion H_corr as [H_l_first | H_r_first]; clear H_corr.
        (* head ele of new list is head ele of first list *)
        inversion H_l_first as [H_sz_ H_z0_eq_]; clear H_l_first.
        have H_z2_lt_: (z2 < z1)%Z by apply Z.leb_gt; auto.
        have H_z2_le_: (z2 <= z1)%Z by auto with zarith.
        simpl in H_z0_eq_. symmetry in H_z0_eq_. rewrite <- H_z0_eq_ in *.
        have: z2 :: lcf_seq cf'4 = [:: z2] ++ lcf_seq cf'4 by auto.
        move->.
        apply sorted_concat; auto with zarith. apply singleton_sorted.
        have: size [:: z2] - 1 = 0 by auto with arith. move->.
        have: nth 0%Z [:: z2] 0 = z2 by auto. move->.
        auto with zarith.
        (* head ele of new list is head ele of second list *)
        inversion H_r_first as [H_sz_cf'0 H_z0_eq_]; clear H_r_first.
        have H_z2_le_: (z2 <= nth 0%Z (lcf_seq cf') 0)%Z.
        { apply sorted_hd_nxt; auto with zarith. }
        rewrite <- H_z0_eq_ in H_z2_le_. rewrite <- H_simp in H_z2_le_.
        have: z2 :: lcf_seq cf'4 = [:: z2] ++ lcf_seq cf'4 by auto.
        move->.
        apply sorted_concat; auto with zarith. apply singleton_sorted.
        have: size [:: z2] - 1 = 0 by auto with arith. move->.
        have: nth 0%Z [:: z2] 0 = z2 by auto. move->.
        auto with zarith.

Qed.


Require Export XR_Rminus.
Require Export XR_IZR.
Require Export XR_Int_part.

Local Open Scope R_scope.

Definition frac_part r : R := r - IZR (Int_part r).


Require Import HoTT minus1Trunc.
Require Export basics nat_struct.
Require Import syntax.
Import Distributive.

(** This file: various results which apply to Q, for use in constructing R **)
(** Later, should split in order to require weaker hypotheses when possible **)

Module FullDecField.
Export Field_pr OrderedMagma_pr OrderedRing.

Section VarSec.

Context {T : Type}.
Variable L : PreringFull T.
Context {Hset : IsHSet T} {Hpr1 : RelationProp (#)}
{Hpr2 : RelationProp (<=)} {Hpr3 : RelationProp (<)}.
Context {Hl : IsFullDecField L}.
Context {Hdec : @Decidable T paths}.

Global Instance fullpseudo : FullPseudoOrder L.
Proof.
split;apply Hl.
Defined.

Global Instance fullposet : FullPoset L.
Proof.
apply fullpseudo_is_fullposet;apply _.
Defined.

Global Instance plus_lt_invariant : IsInvariant (+ <).
Proof.
apply linvariant_invariant. apply _.
red. apply _.
Defined.

Global Instance lt_trans : Transitive (<).
Proof.
apply fullposet.
Defined.

Global Instance plus_lt_compat : IsCompat (+ <).
Proof.
apply invariant_compat;apply _.
Defined.

Global Instance plus_lt_regular : forall z, IsRegular (+ <) z.
Proof.
intros. apply inverse_regular with (roppV z).
unfold gop;apply _. apply _. apply roppP.
Defined.

Global Instance strict_srorder : IsStrictSemiringOrder L.
Proof.
split;try apply Hl.
apply (@pseudo_is_strict T L _). apply _.
intros. apply Hl.
red. apply Hl. assumption.
Defined.

Global Instance plus_apart_invariant : IsInvariant (+ #).
Proof.
apply linvariant_invariant. apply _.
intros z x y. unfold rrel,gop. simpl. intros.
apply (@apart_iff_total_lt T L _).
apply (@apart_iff_total_lt T L _) in X. destruct X;[left|right];
apply plus_lt_invariant;assumption.
Defined.

Global Instance plus_leq_invariant : IsInvariant (+ <=).
Proof.
apply linvariant_invariant. apply _.
hnf. intros z x y.
unfold rrel,gop. simpl.
intros. apply (@le_iff_not_lt_flip T L _). intro H.
apply (@le_iff_not_lt_flip T L _) in X. apply X.
apply plus_lt_regular with z. assumption.
Defined.

Global Instance plus_leq_compat : IsCompat (+ <=).
Proof.
apply invariant_compat.
apply fullposet.
apply _.
Defined.

Lemma plus_lt_leq_lt : forall a b, a < b -> forall c d, c <= d ->
a + c < b+d.
Proof.
intros.
apply (@lt_le_trans T L _) with (b+c).
apply _.
apply plus_lt_invariant. assumption.
apply plus_leq_invariant. assumption.
Defined.

Lemma plus_leq_lt_lt : forall a b, a <= b -> forall c d, c < d ->
a+c < b+d.
Proof.
intros.
apply (@le_lt_trans T L _) with (b+c).
apply _.
(*NB:this simpl makes it go faster*)
simpl;apply plus_leq_invariant. assumption.
apply plus_lt_invariant. assumption.
Defined.

Lemma ropp_lt_flip : forall a b, a < b -> roppV b < roppV a.
Proof.
pose (H := @gopp_rrel_flip T (+ <) _).
simpl in H. unfold rrel in H.
change goppV with roppV in H. apply H. apply plus_lt_invariant.
Defined.

Lemma ropp_apart_flip : forall a b, a # b -> roppV b # roppV a.
Proof.
intros. apply (@apart_iff_total_lt T L _).
apply (@apart_iff_total_lt T L _) in X.
destruct X;[left|right];apply ropp_lt_flip;assumption.
Defined.

Lemma ropp_lt_flip_back : forall a b, roppV b < roppV a -> a < b.
Proof.
intros. pattern a;apply transport with (roppV (roppV a));[|
apply transport with (roppV (roppV b));[|apply ropp_lt_flip;assumption]];
apply gopp_gopp.
Defined.

Lemma ropp_leq_flip : forall a b, a <= b -> roppV b <= roppV a.
Proof.
intros. simpl;apply Hl.
intro H;simpl in X;apply Hl in X. apply X.
apply ropp_lt_flip_back;assumption.
Defined.

Lemma ropp_leq_flip_back : forall a b, roppV b <= roppV a -> a <= b.
Proof.
intros. simpl;apply Hl.
intro H;simpl in X;apply Hl in X. apply X.
apply ropp_lt_flip;assumption.
Defined.

Global Instance plus_leq_regular : forall z, IsRegular (+ <=) z.
Proof.
intros;apply inverse_regular with (roppV z).
unfold gop;apply _.
apply _.
apply roppP.
Defined.

Lemma lt_flip : forall {x y : T}, x < y -> y < x -> Empty.
Proof.
apply Hl.
Defined.

Lemma not_lt_apart_lt_flip : forall {x y : T}, ~ x < y -> x # y -> y < x.
Proof.
intros. apply (@apart_iff_total_lt T L _) in X0.
destruct X0;auto. destruct X;auto.
Defined.

Global Instance pospreserving : IsPosPreserving (+ ° <):= _.

Lemma mult_apart_embed : forall z, ZeroV # z ->
IsEmbedding (#) (#) (mult z).
Proof.
intros z Hz;split.
- hnf;unfold rrel. intros.
  assert (Hb : IsBinRegular (° #)). apply _.
  hnf in Hb. unfold rrel,gop in Hb. simpl in Hb.
  assert (dec_inv z ° (z°x) # dec_inv z ° (z°y)).
  pattern (dec_inv z ° (z°x)). apply transport with x.
  path_via ((dec_inv z ° z) ° x). apply inverse. apply dec_inv_ok.
  intros H;destruct H;apply (@irrefl T (#)) in Hz. assumption.
  apply Hl.
  apply inverse. apply associative. apply Hl.
  apply transport with y.
  path_via ((dec_inv z ° z) ° y). apply inverse. apply dec_inv_ok.
  intros H;destruct H;apply (@irrefl T (#)) in Hz. assumption.
  apply Hl.
  apply inverse. apply associative. apply Hl.
  assumption.
  apply Hb in X0. clear Hb. revert X0.
  apply minus1Trunc_rect_nondep;[|apply Hpr1].
  intros. destruct X0 as [H|H].
  apply (@irrefl T (#) Hl) in H. destruct H.
  assumption.
- hnf. unfold rrel.
  intros.
  assert (Hb : IsBinRegular (° #)). apply _.
  apply Hb in X.
  clear Hb;revert X.
  apply minus1Trunc_rect_nondep;[|apply Hpr1].
  unfold rrel. simpl. intros [H|H].
  apply (@irrefl T (#) Hl) in H. destruct H.
  assumption.
Defined.

Lemma mult_lt_embed_pos : forall z, ZeroV < z ->
IsEmbedding (<) (<) (mult z).
Proof.
assert (forall z : T, ZeroV < z -> IsMorphism lt lt (mult z)).
- intros z Hz;red;unfold gop,rrel;simpl;intros ? ? H.
  apply plus_lt_regular with (roppV (z ° x)).
  unfold gop,rrel. simpl.
  set (X := roppV (z°x) + z°x). pattern X;apply transport with ZeroV;
  unfold X;clear X.
  apply inverse.
  apply (@ropp_l T L _).
  set (X := roppV (z ° x) + z ° y). apply transport with (z ° ((roppV x) + y));
  unfold X;clear X.
  eapply concat. apply ldistributes. apply _.
  apply (@ap T T (fun k:T => k + _)).
  apply inverse. apply (@ropp_rmult_right T L _).
  apply pospreserving. assumption.
  apply plus_lt_regular with x.
  apply transport with y. unfold gop;simpl.
  path_via ((x+roppV x)+y).
  apply inverse. apply roppP.
  apply inverse;apply associative. apply Hl.
  unfold gop,rrel; simpl.
  set (X := x+ZeroV);pattern X;apply transport with x;unfold X;clear X.
  apply inverse;apply (@ZeroP T L _).
  assumption.

- intros z Hz;split. apply X;assumption.
  hnf;unfold rrel.
  intros ? ? H. apply not_lt_apart_lt_flip.
  intros H'. apply (lt_flip H).
  apply X. assumption.
  assumption.
  apply mult_apart_embed with z.
  apply (@apart_iff_total_lt T L _). left;assumption.
  unfold rrel. apply (@apart_iff_total_lt T L _). right;assumption.
Defined.

Lemma ropp_inv : forall x, roppV (dec_inv x) = dec_inv (roppV x).
Proof.
intros. destruct (Hdec ZeroV x) as [H|H];unfold rrel in H.
- destruct H.
  path_via ZeroV.
  eapply concat. apply ap. apply dec_inv0.
  apply ropp_zero.
  apply inverse. eapply concat. apply ap.
  apply ropp_zero. apply dec_inv0.
- apply (@inverse_unicity T (°) _ (roppV x)).
  apply linverse_inverse. red.
  unfold gop. apply transport with OneV.
  eapply concat;[|apply ropp_rmult_right].
  eapply concat;[|apply ap;apply ropp_rmult_left].
  apply inverse. eapply concat. apply gopp_gopp.
  apply (id_unique (°)).
  apply dec_inv_ok. assumption.
  apply One. apply One.

  apply dec_inv_ok. intro H'.
  pose (H0 := ap roppV H'). clearbody H0.
  apply H. eapply concat;[|eapply concat;[apply H0|]].
  symmetry. apply ropp_zero.
  apply gopp_gopp.
Defined.

Lemma mult_lt_embed_neg : forall z, z < ZeroV ->
IsEmbedding (<) (fun x y => y < x) (mult z).
Proof.
split;red; unfold rrel.
- intros.
  apply plus_lt_regular with (roppV (z ° y)).
  unfold gop,rrel;simpl.
  set (Y := roppV (z°y) + z°y). pattern Y;apply transport with ZeroV;unfold Y;
  clear Y.
  apply (id_unique (+)). apply Zero. apply inverse_right. exact (roppP (z°y)).
  apply transport with (roppV z ° (y + roppV x)).
  eapply concat. apply ldistributes. apply _.
  apply ap11;[apply ap|].
  apply inverse;exact (ropp_rmult_left z y).
  eapply concat;[symmetry;apply ropp_rmult_right|].
  eapply concat;[symmetry;apply ap;apply ropp_rmult_left|].
  apply gopp_gopp.

  apply pospreserving;change rrel with lt.
  pattern ZeroV. apply transport with (roppV ZeroV).
  apply ropp_zero.
  apply ropp_lt_flip. assumption.
  apply plus_lt_regular with x.
  unfold gop,rrel. simpl.
  set (Y := x+ZeroV). pattern Y;apply transport with x;unfold Y.
  apply inverse. apply (@Zero T L _).
  apply transport with y.
  path_via ((x + roppV x) + y).
  apply inverse. apply roppP.
  eapply concat. symmetry;apply associative. apply Hl.
  unfold gop;simpl.
  apply ap. apply commutative. apply Hl.
  assumption.

- intros.
  apply ropp_lt_flip in X0.
  rewrite ropp_rmult_left in X0. (* !! rewrite *)
  rewrite ropp_rmult_left in X0.
  apply mult_lt_embed_pos with (roppV z).
  apply ropp_lt_flip_back.
  rewrite ropp_zero;change roppV with goppV. rewrite gopp_gopp.
  assumption.
  assumption.
Qed.

Lemma mult_lt_pos_inverse_pos : forall x, ZeroV < x -> ZeroV < dec_inv x.
Proof.
intros.
apply mult_lt_embed_pos with (x°x).
apply pospreserving;assumption.
unfold rrel.
apply transport with x.
path_via (x °  (x ° dec_inv x)).
apply inverse. apply dec_inv_ok.
intros H;destruct H;apply Hl in X;assumption.
apply associative. apply Hl.
pattern (x ° x ° ZeroV). apply transport with ZeroV.
apply inverse. apply rmult_0_r.
assumption.
Defined.

Lemma mult_lt_neg_inverse_neg : forall x, x < ZeroV -> dec_inv x < ZeroV.
Proof.
intros. apply ropp_lt_flip_back.
pattern (roppV ZeroV). apply transport with ZeroV.
apply inverse. apply ropp_zero.
eapply transport.
symmetry;apply ropp_inv.
apply mult_lt_pos_inverse_pos.
apply ropp_lt_flip_back.
pattern (roppV (roppV x)). apply transport with x.
apply inverse. apply gopp_gopp.
eapply transport. symmetry. apply ropp_zero.
assumption.
Defined.

Lemma dec_inv_neq : forall x, ZeroV != x -> ZeroV != dec_inv x.
Proof.
intros x Hx H'.
generalize (ap (mult (x°x)) H').
intro Hx'.
apply Hx. eapply concat;[|eapply concat;[apply Hx'|]].
apply inverse. apply rmult_0_r.
path_via (x ° (x ° dec_inv x)).
apply inverse. apply associative;apply Hl.
apply dec_inv_ok. assumption.
Defined.

Lemma inv_inv : forall x, dec_inv (dec_inv x) = x.
Proof.
intros.
destruct (Hdec ZeroV x) as [Hx|Hx].
destruct Hx.
eapply concat;[apply ap|];apply dec_inv0.
unfold rrel in Hx.
apply (@inverse_unicity T (°) _ (dec_inv x)).
apply dec_inv_ok. apply dec_inv_neq. assumption.
apply inverse_symm. apply dec_inv_ok. assumption.
Defined.

Global Instance nat_embed_lt : IsEmbedding (<) (<) (nat_embed L).
Proof.
assert (IsMorphism (<) (<) (nat_embed L)).
red. unfold rrel.
assert (forall n, nat_embed L n < nat_embed L (S n)).
intros. pattern (nat_embed L n). apply transport with (ZeroV + nat_embed L n).
apply Zero.
simpl. apply plus_lt_leq_lt. apply fulldecfield_zero_lt_one.
apply fullposet.
intros n m H.
induction H. auto.

apply transitivity with (nat_embed L m).
assumption. apply X.

split;try assumption. red. unfold rrel.
intros. destruct (nat_trichotomic x y) as [?|H]. assumption.
destruct H as [H|H].
destruct H. apply (@irrefl T (<) _) in X0. destruct X0.
apply X in H. unfold rrel in H.
destruct (@pseudoorder_antisym T L _ _ _ X0 H).
Defined.

Global Instance nat_embed_inj : IsReflecting (paths) (paths) (nat_embed L).
Proof.
red;unfold rrel. intros.
destruct (nat_trichotomic x y) as [H|[H|H]];auto;
apply nat_embed_lt in H;unfold rrel in H;destruct X;
apply (@irrefl T (<) _) in H;destruct H.
Defined.

Global Instance nat_embed_apart : IsEmbedding (#) (#) (nat_embed L).
Proof.
split;red;unfold rrel.
intros. apply (@apart_iff_total_lt T L _).
destruct (nat_trichotomic x y) as [H|[H|H]];[left|destruct X;assumption|right];
apply nat_embed_lt;assumption.

intros. intro H. destruct H. apply (@irrefl T (#) Hl) in X. assumption.
Defined.

Global Instance nat_embed_leq : IsEmbedding (<=) (<=) (nat_embed L).
Proof.
split;red;unfold rrel.
intros. induction H.
apply fullposet.
simpl. eapply fullposet. apply IHnle.
change ((fun k => k <= OneV + nat_embed L m) (nat_embed L m)).
apply transport with (ZeroV + nat_embed L m).
apply Zero.
apply plus_leq_compat. apply (@lt_le T L _). apply fulldecfield_zero_lt_one.
apply fullposet.

intros. destruct x. apply nle_0.
change (x < y). apply nat_embed_lt.
unfold rrel.
eapply (@lt_le_trans T L _ _).
apply nat_embed_lt. apply nle_n.
assumption.
Defined.

Global Instance nat_embed_plus : Magma.IsMorphism (+) (+) (nat_embed L).
Proof.
apply _.
Defined.

Global Instance nat_embed_mult : Magma.IsMorphism (°) (°) (nat_embed L).
Proof.
apply _.
Defined.

Lemma mult_cancel : forall x : T, ZeroV != x -> Cancel (°) x.
Proof.
apply @intdom_partial_cancels.
red. intros.
apply min1. destruct (Hdec ZeroV a). left;assumption.
right.
apply (ap (fun k => dec_inv a ° k)) in X.
path_via (dec_inv a ° ZeroV).
apply inverse;apply rmult_0_r.
path_via (dec_inv a ° (a°b)).
path_via ((dec_inv a ° a) ° b).
apply associative. change (Associative (°)). apply _.
apply dec_inv_ok. assumption.
assumption.
Defined.

Section Average.

Definition avg_at (a b : T) (n m : nat) := a +
 nat_embed L m ° ((b + roppV a) ° (dec_inv (nat_embed L n))).

(*
avg_at a b n m := a + m (b-a) / n = (m b + (n-m) a) / n
 = b + ((n-m)a - (n-m)b)/n
 = avg_at b a n (n-m)
NB: only when n-m >= 0: n = m+k
*)

Lemma avg_comm : forall a b : T,
forall m k, 0 != k+m -> avg_at a b (k+m) m = avg_at b a (k+m) k.
Proof.
intros;unfold avg_at.
apply (@right_cancel T (°) (nat_embed L (k+m))).
apply mult_cancel.
apply nat_embed_apart in X. unfold rrel in X.
intro H;destruct H. apply @irrefl in X. assumption. apply fullposet.

unfold gop.
set (K := nat_embed L (k+m)).
path_via (a ° K + nat_embed L m ° (b + roppV a) ° (dec_inv K ° K)).
ssrapply (@ast2_full_semiring T L _); reflexivity.
path_via (a° K + nat_embed L m ° (b + roppV a)).
apply ap. apply dec_inv_ok.
change ZeroV with (nat_embed L 0);unfold K;clear K;intro H.
apply nat_embed_inj in H. auto.
path_via (b ° K + nat_embed L k ° (a + roppV b)).
pattern K. apply transport with (nat_embed L k + nat_embed L m).
unfold K. apply inverse. apply nat_embed_plus.
ssrapply (@ast2_full_semiring T L _). simpl. unfold gop.
apply ap.
path_via (ZeroV + nat_embed L m ° b).
path_via ((a + roppV a) ° nat_embed L m + nat_embed L m ° b).
ssrapply (@ast2_full_semiring T L _);reflexivity.
apply (@ap _ _ (fun k => k + _)).
path_via (ZeroV ° nat_embed L m).
apply (@ap _ _ (fun k : T => k ° _)).
apply ropp_r.
apply rmult_0_l.

apply inverse. path_via ((b + roppV b) ° nat_embed L k + nat_embed L m ° b).
ssrapply (@ast2_full_semiring T L _);reflexivity.
apply (@ap _ _ (fun k => k + _)).
path_via (ZeroV ° nat_embed L k).
apply (@ap _ _ (fun k => k ° _)). apply ropp_r.
apply rmult_0_l.

path_via (b ° K + (nat_embed L k ° (a + roppV b)) ° (dec_inv K ° K)).
apply inverse. apply ap. apply dec_inv_ok.
unfold K;change ZeroV with (nat_embed L 0);intro H.
apply nat_embed_inj in H. auto.
ssrapply (@ast2_full_semiring T L _);reflexivity.
Qed.

Lemma avg_gt : forall a b : T, a < b ->
forall n m, 0 < n -> 0 < m -> a < avg_at a b n m.
Proof.
unfold avg_at.
intros.
Defined.

End Average.

End VarSec.

End FullDecField.


Require Import Automatik.lib.operators.

(** * Operations over sets *)

Section Pset.

Variable A : Type.

Definition pset := (A -> Prop).

Definition inter (P Q : pset) : pset :=
  fun x => P x /\ Q x.

Definition union (P Q : pset) : pset :=
  fun x => P x \/ Q x.

Definition diff (P Q : pset) : pset :=
  fun x => P x /\ ~Q x.

Definition comp (P : pset) : pset :=
  fun x => ~P x.

Definition subseteq (P Q : pset) :=
  forall x, P x -> Q x.

Definition subset (P Q : pset) :=
  subseteq P Q /\ exists x, Q x /\ ~Q x.

End Pset.

Instance inter_cap (A : Type) : CapOp (pset A) := inter A.
Instance union_cup (A : Type) : CupOp (pset A) := union A.
Instance subseteq_subseteq (A : Type) : SubseteqOp (pset A) := subseteq A.
Instance subset_subset (A : Type) : SubsetOp (pset A) := subset A.


Require Import CT.Category.
Require Import CT.Functor.
Require Import CT.NaturalTransformation.
Require Export CT.Instance.NaturalTransformation.HCNaturalTransformation.
Require Export CT.Instance.NaturalTransformation.VCNaturalTransformation.
Require Import FunctionalExtensionality.

(** * Interchange of horizontal/vertical composition

Given functors \(F\), \(G\), \(H\) : \(C \to D\) and \(F'\), \(G'\), \(H'\) :
\(D \to E\), and natural transformations \(\alpha : F \Rightarrow G\),
\(\beta : G \Rightarrow H\), \(\alpha' : F' \Rightarrow G'\), and
\(\beta' : G' \Rightarrow H'\), then the following holds:

$$$$
(\beta' \circ \alpha') * (\beta \circ \alpha) = (\beta' * \beta) \circ (\alpha' * \alpha) : F' \circ F \to H' \circ H
$$$$
*)
Section NaturalTransformationInterchange.
  Context {A A' A'' : Category}.
  Context {F G H : Functor A A'}.
  Context {F' G' H' : Functor A' A''}.
  Context {alpha : NaturalTransformation F G}.
  Context {beta : NaturalTransformation G H}.
  Context {alpha' : NaturalTransformation F' G'}.
  Context {beta' : NaturalTransformation G' H'}.

  Let l := HCNaturalTransformation (VCNaturalTransformation alpha beta) (VCNaturalTransformation alpha' beta').
  Let r := VCNaturalTransformation (HCNaturalTransformation alpha alpha') (HCNaturalTransformation beta beta').

  Theorem NaturalTransformationInterchange : l = r.
  Proof.
    apply nt_eq.
    simpl.
    extensionality X.
    rewrite F_comp_law.
    repeat rewrite assoc.
    match goal with
      [|- (comp ?B ?A = comp ?C ?A)] =>
      let H := fresh in
      cut (B = C); [intro H; rewrite H; trivial|]
    end.
    repeat rewrite assoc_sym.
    match goal with
      [|- (comp ?B ?A = comp ?B ?C)] =>
      let H := fresh in
      cut (A = C); [intro H; rewrite H; trivial|]
    end.
    rewrite <- nt_commutes.
    reflexivity.
  Qed.
End NaturalTransformationInterchange.


(**************************************************************************)
(*  This is part of IMP-STATES-EXCEPTIONS, it is distributed under the    *)
(*       terms  of the GNU Lesser General Public License version 3        *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations Axioms Derived_co_Pairs Derived_co_Products.
Set Implicit Arguments.
Require Import ZArith.
Open Scope Z_scope.

Module Make(Import M: Memory.T).
  Module Export ProofsExp := Derived_co_Products.Make(M).

Goal forall A B C D (f: term B A) (g: term C B) (h: term D C),
  PURE epure f -> PURE epure g -> PURE epure h -> h o (g o f) === (h o g) o f.
Proof. intros. now rewrite assoc. Qed.

(**STATES**)

 (** annihilation lookup-update *)
 Theorem ALU: forall i: Loc,
         update i o lookup i === id.
         (* Prop: 2.1: All Cases *)
 Proof.
     intro i. apply local_global. intro k.
     destruct (Loc_dec i k) as [e|n]. rewrite <- e.
     (*Case k = i*)
     rewrite assoc.
     rewrite ax1, ids, idt. reflexivity.
     (*Case k <> i*)
     rewrite assoc. rewrite ax2; [| exact n].
       rewrite <- assoc. rewrite ss_unit; [| edecorate].
       cut (forget === id). intro H1. rewrite H1.
       reflexivity.
       (* forget == id *)
         symmetry. apply ss_unit. decorate.
 Qed.

 (** interaction lookup-lookup *)
 Theorem ILL: forall i,
         lookup i o forget o lookup i === lookup i.
         (* Prop: 2.2: All Cases: Simplified Version *)
 Proof.
     intro i. rewrite <- assoc.
       rewrite ss_unit; [| edecorate].
         cut (forget === id).
         intro H0. rewrite H0, ids. reflexivity.
           symmetry. apply ss_unit; decorate.
 Qed.

 (** interaction update-update *)
 Theorem IUU: forall (x: Loc) (p q: Z),
         (update x o constant q) o (update x o constant p) === update x o constant q.
         (* Prop: 2.3: IMP+Exc adapted version *)
 Proof. intros x p q. apply local_global.
          intro i. destruct(Loc_dec i x). rewrite e.
            (* i = x *)
            repeat rewrite assoc. rewrite ax1. setoid_rewrite idt.
            setoid_rewrite <- ids at 6. rewrite <- assoc. apply (@pwsrepl _ _ _ epure); [decorate |].
            apply ws_unit.
            (* i<>x *)
            repeat rewrite assoc. rewrite ax2; [| auto].
            setoid_rewrite <- assoc at 4.
            setoid_rewrite <- assoc at 3.
            cut(forget o constant q === (@id unit)).
              intro H. rewrite H. setoid_rewrite ids at 1.
              rewrite ax2; auto. repeat rewrite <- assoc. apply sstows.
              apply replsubs; [reflexivity |].
              setoid_rewrite ss_unit; [reflexivity| decorate| decorate].
            (*1st cut*)
             setoid_rewrite ss_unit; [reflexivity| decorate| decorate].
 Qed.

 (** interaction update-lookup *)
 Theorem IUL: forall i: Loc,
         lookup i o update i ~== id. (* Prop: 2.4: All Cases *)
 Proof. intro i. apply ax1. Qed.

 (** commutation update-update *)
 Lemma CUU: forall {x y: Loc}, forall (n m: Z), x<>y ->
	(update y o constant m) o (update x o constant n) ===
        (update x o constant n) o (update y o constant m).
         (*Prop 2.6: IMP+Exc adapted version.*)
 Proof.
    intros x y n m H0. apply local_global.
      intro i. destruct (Loc_dec i y). rewrite e.
        (* i = y *)
        repeat rewrite assoc. rewrite ax1.
        apply wssym. rewrite  ax2; [| decorate].
        setoid_rewrite <- assoc at 3.
        cut(forget o constant n === (@id unit)).
          intro H1. rewrite H1.
          setoid_rewrite ids. rewrite ax1.
          setoid_rewrite idt. rewrite <- assoc. setoid_rewrite <- ids at 1.
          apply (@pwsrepl _ _ _ epure); [decorate |].
          apply ws_unit; reflexivity.
        (*1st cut*)
        setoid_rewrite ss_unit; [reflexivity| decorate| decorate ].
        destruct (Loc_dec i x). rewrite e.
        (* i = x and i <> y*)
        repeat rewrite assoc. rewrite ax1.
        rewrite  ax2; [| auto].
        setoid_rewrite <- assoc at 3.
        cut(forget o constant m === (@id unit)).
          intro H1. rewrite H1.
          setoid_rewrite ids. rewrite ax1.
          setoid_rewrite idt. rewrite <- assoc. setoid_rewrite <- ids at 1.
          apply (@pwsrepl _ _ _ epure); [decorate |].
          apply ws_unit; reflexivity.
        (*2nd cut*)
        setoid_rewrite ss_unit; [reflexivity| decorate| decorate ].
        (* i <> x and i <> y *)
        repeat rewrite assoc. setoid_rewrite ax2; [| auto| auto].
        setoid_rewrite <- assoc at 3. setoid_rewrite <- assoc at 5.
        cut(forget o constant m === (@id unit)).
          intro H1. rewrite H1.
          setoid_rewrite ids. rewrite ax2; [| auto]. rewrite <- assoc.
          cut(forget o constant n === (@id unit)).
            intro H2. rewrite H2.
            setoid_rewrite ids. rewrite ax2; [| auto]. rewrite <- assoc. rewrite H1.
            rewrite ids. reflexivity.
          (*3rd cut*)
          setoid_rewrite ss_unit; [reflexivity| decorate| decorate ].
        (*4th cut*)
        setoid_rewrite ss_unit; [reflexivity| edecorate| decorate ].
 Qed.

 (** commutation lookup-constant *)
 Theorem CLC: forall (i: Loc) (c: Z),
         (lookup i o (update i o (constant c)))
         ===
         (constant c) o update i o (constant c).
         (*Prop 2.8: All Cases*)
 Proof.
     intros i c. apply effect.
     (* Case 1: <> o f == <> o g *)
     rewrite assoc.
     cut (forget o lookup i === (@id unit)).
       intro H. rewrite H, idt.
       do 2 rewrite assoc.
       cut (forget o constant c === (@id unit)).
         intro H1; rewrite H1, idt.
         reflexivity.
       (*1st cut*)
       setoid_rewrite ss_unit; [reflexivity| decorate| decorate].
     (*2nd cut*)
     setoid_rewrite ss_unit; [reflexivity| edecorate| decorate].
     (* Case 2: f ~ g *)
     rewrite assoc, ax1, idt. setoid_rewrite <- ids at 1. rewrite <- assoc.
     apply (@pwsrepl _ _ _ epure); [decorate |].
     apply ws_unit.
 Qed.

 (** interactcommutation lookup-update-update *)
 Lemma CLUC: forall (m: Loc) (p q: Z),
      (pair (lookup m) (constant q)) o (update m o constant p)
      ===
      (pair (constant p) (constant q)) o (update m o constant p).
 Proof.
      intros m p q.
        apply ss_lpair_u.
          (*pi1 o f === pi1 o g*)
          setoid_rewrite assoc. setoid_rewrite fst_lpair_eq; [| decorate| decorate| decorate| decorate].
          rewrite CLC, assoc. reflexivity.
          (*pi2 o f === pi2 o g*)
          setoid_rewrite assoc. setoid_rewrite snd_lpair_eq; [reflexivity| decorate| decorate| decorate| decorate].
 Qed.

 (** annihilation tag-untag *)
 Lemma ATU: forall e: EName, (tag e) o (untag e) === (@id Empty_set).
 Proof.
    intro e.
    apply elocal_global.
    intro r. destruct(Exc_dec r e) as [Ha|Hb]. rewrite Ha.
    (* case e = r *) (* (1) *)
    rewrite idt. setoid_rewrite <- ids at 6. rewrite <- assoc. (* (1.1) *)
    apply swrepl; [reflexivity| apply eax1]. (* (1.2) *)
    (* case e <> r *) (* (2) *)
    cut(tag e o (@empty unit) === (@id (Empty_set)));
      [ intro H0| setoid_rewrite ss_empty; [reflexivity| decorate| edecorate]].
    rewrite <- H0. setoid_rewrite <- assoc. (* (2.1) *)
    apply swrepl; [reflexivity| apply eax2; exact Hb]. (* (2.2) *)
Qed.

 (** commutation untag-untag *)
 Lemma CUUe: forall (t s: EName) , s <> t ->
    (rcoprod (untag t) id) o in2 o (untag s) === (lcoprod id (untag s)) o in1 o (untag t).
 Proof.
    intros. apply elocal_global. intro r.
    (* r = t /\ r <> s *)
    destruct(Exc_dec r s). rewrite e. setoid_rewrite <- assoc at 4. rewrite (@eax2 s t); [| exact H].
      setoid_rewrite <- assoc at 4. setoid_rewrite assoc at 2.
      cut (in1 o (@empty unit) === in2).
        intro H1. rewrite H1.
        rewrite assoc, (@ss_lcoprod_eq _ _ _ _ pure); [| edecorate| edecorate].
        setoid_rewrite <- assoc. rewrite eax1.
        setoid_rewrite ids. rewrite (@sw_rcoprod_eq _ _ _ _ pure); [| edecorate| edecorate].
        rewrite ids. reflexivity.
      (*1st cut*)
      setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].

     destruct(Exc_dec r t). rewrite e. setoid_rewrite <- assoc. rewrite (@eax2 t s); [| auto].
       setoid_rewrite <- assoc. setoid_rewrite assoc at 2.
        cut (in2 o (@empty unit) === in1).
          intro H1. rewrite H1.
          rewrite assoc, ss_rcoprod_eq; [| edecorate| edecorate].
          setoid_rewrite <- assoc. rewrite eax1.
          setoid_rewrite ids. rewrite sw_lcoprod_eq; [| edecorate| edecorate].
          rewrite ids. reflexivity.
      (*2nd cut*)
      setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].

     setoid_rewrite <- assoc. rewrite (@eax2 r s); [| auto].
       setoid_rewrite <- assoc. setoid_rewrite assoc at 2.
        cut (in2 o (@empty unit) === in1).
          intro H1. rewrite H1.
          rewrite assoc, ss_rcoprod_eq; [| edecorate| edecorate].
          setoid_rewrite <- assoc.
          rewrite (@eax2 r t); [| auto].
          setoid_rewrite assoc at 3.
          cut (in1 o (@empty unit) === in2).
            intro H2. rewrite H2.
            setoid_rewrite assoc at 2. rewrite ss_lcoprod_eq; [| edecorate| edecorate].
            setoid_rewrite <- assoc. rewrite eax2; [| auto].
            apply sstosw. setoid_rewrite assoc. apply replsubs; [| reflexivity].
            setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].
          (*4th cut*)
          setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].
        (*3rd cut*)
        setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].
Qed.

 (** annihilation catch-raise *)
 Lemma ACR: forall (l: EName), forall (X Y: Type) (f: term Y X), PPG rw f ->
 downcast ((copair id ((empty Y o tag l) o untag l) o in1) o f) === f.
 Proof.
    intros. apply (@swtoss _ _ rw); [decorate | edecorate |].
    rewrite <- sw_downcast.
    apply sstosw. setoid_rewrite <- assoc.
    transitivity(copair id ((@empty Y) o id) o in1 o f).
      rewrite assoc. apply replsubs; [| reflexivity]. apply replsubs; [| reflexivity].
        apply ss_lcopair_u.
          setoid_rewrite sw_lcopair_eq; [reflexivity| edecorate| edecorate].
          setoid_rewrite (@ss_lcopair_eq _ _ _ pure); [| edecorate| edecorate].
          rewrite <- assoc. rewrite ATU. reflexivity.
        setoid_rewrite <- idt at 10. apply replsubs; [| reflexivity].
        apply (@swtoss _ _ rw); [edecorate| edecorate |].
        apply (@sw_lcopair_eq _ _ _ pure); edecorate.
 Qed.

 Axiom mono: forall {X Y: Type} (f g: term Empty_set Y), PPG rw f /\ PPG rw g -> ((@empty X) o f === (@empty X) o g)-> f === g.

(*propagate*)
 Lemma PPT: forall X Y (e: EName) (a: term Y X), PPG rw a -> a o ((@empty X) o tag e) === (@empty Y) o tag e.
 Proof.
    intros X Y e a H.
    rewrite assoc. apply replsubs; [| reflexivity]. apply ss_empty; edecorate.
 Qed.

(*recover*)
 Lemma RCV: forall X Y (e: EName) (u1 u2: term unit Y), EPURE rw u1 -> EPURE rw u2 ->
            ((@empty X) o tag e) o u1 === ((@empty X) o tag e) o u2 -> u1 ===  u2.
 Proof.
    intros X Y e u1 u2 H0 H1 H2. setoid_rewrite <- assoc in H2.
      apply mono in H2; [| split; apply is_comp; [decorate| edecorate | decorate | edecorate ]].
      apply (@swtoss _ _ rw); [edecorate| edecorate| ].
        transitivity ((untag e o tag e) o u1). setoid_rewrite <- idt at 1.
          apply (@pswsubs _ _ _ rw). apply swsym, eax1. unfold pure_id.
            split; [exact H0| reflexivity].
        apply swsym.
        transitivity ((untag e o tag e) o u2). setoid_rewrite <- idt at 1.
      apply (@pswsubs _ _ _ rw). apply swsym, eax1. unfold pure_id.
            split; [exact H1| reflexivity].
        apply swsym. apply sstosw. setoid_rewrite <- assoc.
        apply replsubs; [reflexivity| exact H2].
 Qed.

(*try0*)
 Lemma TRY0: forall X Y (e: EName) (u: term Y X) (b: term Y unit), EPURE rw u -> PPG rw b ->
         downcast ((copair id (b o untag e) o in1) o u) === u.
 Proof.
    intros X Y e u b H0 H1.
      apply (@swtoss _ _ rw); [decorate |edecorate| ].
      rewrite <- sw_downcast.
        transitivity(id o u). apply (@pswsubs _ _ _ rw); [| split; [exact H0| reflexivity]].
        apply (@sw_lcopair_eq _ _ _ rw); edecorate.
      rewrite idt. reflexivity.
 Qed.

(*try1*)
 Lemma TRY1: forall X Y (e: EName) (u: term unit X) (b: term Y unit), EPURE rw u -> PPG rw b ->
            downcast ((copair id (b o untag e) o in1) o ((empty Y o tag e) o u)) === b o u.
 Proof.
    intros X Y e u b H0 H1.
      apply (@swtoss _ _ rw); [decorate |edecorate| ].
      rewrite <- sw_downcast.
      do 2 setoid_rewrite assoc. setoid_rewrite <- assoc at 3.
      cut (in2 === in1 o (@empty Y)).
        intro H2. rewrite <- H2.
        rewrite ss_lcopair_eq; [| edecorate].
        apply (@pswsubs _ _ _ rw); [| split; [exact H0| reflexivity]].
        rewrite <- assoc. rewrite eax1, ids. reflexivity.
      setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].
 Qed.

(* -------------------- End of Main Proofs -------------------- *)

End Make.


(* Chap 12.1 The Type Hierarchy *)

Require Import Cpdt.CpdtTactics Cpdt.MoreSpecif.
Require Import Classical_Prop.
Require Import ProofIrrelevance.
Require Import Eqdep.
Require Eqdep_dec.
Require RelationalChoice.

Check 0.
Check nat.
Check Set.
Check Type.

Set Printing Universes.

Check nat.
Check Type.
Check forall T:Type, T.

Set Implicit Arguments.
Set Asymmetric Patterns.

Definition id (T:Set) (x:T) :T := x.

Check id 0.
Reset id.

Definition id (T:Type) (x:T) :T := x.
Check id Set.
Check id Type.
(* Check id id. *)

(* Chap 12.1.1 *)

Inductive exp : Type -> Type :=
| Const : forall T : Type, T -> exp T
| Pair : forall T1 T2, exp T1 -> exp T2 -> exp (T1*T2)
| Eq : forall T, exp T -> exp T -> exp bool.

Check Const 0.
Check Pair (Const 0) (Const tt).
Check Eq (Const Set) (Const Type).

Print exp.
Print Universes.
Print prod.

Check (nat, (Type, Set)).
Inductive prod': Type->Type->Type:=
| pair' : forall A B:Type, A->B->prod' A B.

(* Check (pair' nat (pair' Type Set)). *)

Inductive foo (A:Type) : Type:=
| Foo : A-> foo A.

Check foo nat.
Check foo Set.
Check foo (foo Set).

Inductive bar   : Type := Bar: bar.
Check bar.

Theorem symmetry : forall A B:Type, A=B -> B=A.
  intros; rewrite H; reflexivity. Qed.

Theorem illustrative_but_silly_detour : unit=unit.
  Set Printing All.
Abort.

Theorem illustrative_but_silly_detour':(unit:Type)=unit.
  apply symmetry; reflexivity. Qed.

Unset Printing All.

Theorem ex_symmetry : (exists x, x=0)->(exists x, 0=x).
  eexists. destruct H. Restart.
  destruct 1 as [x].
  eapply ex_intro. symmetry. eassumption. Qed.

(* 12.2 *)
Print sig.
Print ex.
Print exist.

Definition projS A (P:A->Prop) (x : sig P):A :=
match x with
| exist v _ => v
end.

(*
Definition projE A (P:A->Prop) (x:ex P) : A :=
  match x with
    | ex_intro v _ => v
  end.
 *)

Definition sym_sig (x:sig (fun n=>n =0)) : sig (fun n => 0=n) :=
  match x with
  | exist n pf => exist _ n (sym_eq pf)
  end.
Extraction sym_sig.

Definition sym_ex (x: ex (fun n=> n=0)) : ex (fun n=> 0 =n) :=
  match x with
  | ex_intro n pf => ex_intro _ n (sym_eq pf)
  end.

Extraction sym_ex.

Check forall P Q:Prop, P \/ Q -> Q \/ P.
Inductive expP:Type->Prop :=
| ConstP : forall T, T->expP T
| PairP: forall T1 T2, expP T1-> expP T2->expP (T1*T2)
| EqP : forall T, expP T->expP T ->expP bool.

Check ConstP 0.
Check (PairP (ConstP 0) (ConstP tt)).
Check (EqP (ConstP Set) (ConstP Type)).

Inductive eqPlus: forall T, T->T->Prop:=
| Base : forall T (x:T), eqPlus x x
| Func : forall dom ran (f1 f2:dom->ran),
    (forall x:dom, eqPlus (f1 x) (f2 x)) -> eqPlus f1 f2.

Check (Base 0).
Check (Func (fun n => n) (fun n=> 0+n) (fun n=> Base n)).
Check (Base (Base 1)).

(* 12.3 *)

Require Import Classical_Prop.
Print classic.

Parameter num : nat.
Axiom positive : num>0.
Reset num.

Axiom not_classic : ~ forall P:Prop, P \/ ~P.
Theorem uhoh : False.
  generalize classic not_classic; tauto. Qed.

Theorem uhoh_again : 1+1=3.
  destruct uhoh. Qed.

Reset not_classic.

Theorem t1 : forall P:Prop, P -> ~ ~ P.
  tauto. Qed.

Print Assumptions t1.
Theorem t2 : forall P:Prop, ~ ~ P ->P.
  tauto. Qed.

Print Assumptions t2.

Theorem nat_eq_dec : forall n m:nat, n=m \/ n<>m.
  induction n. destruct m. intuition.
  - right. unfold not; intros. inversion H.
  - destruct m.
    + right; unfold not; intros; inversion H.
    + destruct (IHn m).
      * rewrite H. left; reflexivity.
      * right; unfold not in *; intros; apply H.
        inversion H0. reflexivity. Qed.

Require Import ProofIrrelevance.

Print proof_irrelevance.
Require Import ZArith.

(*
Definition pred_strong1 (n:nat) : n>0 -> nat:=
  match n with
  | O=> fun pf: 0 > 0 => match Z.zgtz pf with end
  | S n' => fun _ => n'
  end.
 *)

Require Import Eqdep.
Import Eq_rect_eq.
Print Eq_rect_eq.

Corollary UIP_refl : forall A (x:A) (pf: x=x), pf=eq_refl x.
  intros; replace pf with (eq_rect x (eq x) (eq_refl x) x pf);
    [symmetry; apply eq_rect_eq
    | exact (match pf as pf' return match pf' in _ = y return x=y with
                                    | eq_refl => eq_refl x
                                    end = pf' with
             | eq_refl => eq_refl _
             end)]. Qed.

Corollary UIP : forall A (x y:A) (pf1 pf2:x=y), pf1=pf2.
  intros; generalize pf1 pf2;subst;intros;
    match goal with
    | [ |- ?pf1 = ?pf2] => rewrite (UIP_refl pf1); rewrite (UIP_refl pf2); reflexivity
    end. Qed.

Require Import FunctionalExtensionality.
Print functional_extensionality_dep.
Corollary predicate_extensionality : forall (A:Type) (B:A->Prop) (f g:forall x:A, B x),
    (forall x:A, f x=g x) -> f=g.
  intros. apply functional_extensionality_dep; assumption. Qed.

(* 12.3.2 Axiom of Choice *)
Reset Printing.

Require Import ConstructiveEpsilon.
Check constructive_definite_description.
Print Assumptions constructive_definite_description.

(* 唯一 *)
Require Import ClassicalUniqueChoice.
Check dependent_unique_choice.

(* 选择公理 *)
Require Import ClassicalChoice.
Check choice.

Definition choice_Set (A B:Type) (R:A->B->Prop) (H: forall x:A, {y:B|R x y}):{f:A->B| forall x:A, R x (f x)}:=
  exist (fun f => forall x:A, R x (f x)) (fun x=> proj1_sig (H x)) (fun x=> proj2_sig (H x)).

Check exist.
Check proj1_sig.
Check proj2_sig.

Check forall (A:Type) (P:A->Prop) (x:A), {x:A|P x}.

(* 12.3.3 Axioms and Computation *)
Definition cast (x y:Set) (pf: x=y) (v:x):y :=
  match pf with
  | eq_refl => v
  end.

Eval compute in (cast (eq_refl( nat->nat)) (fun n => S n)) 12.
Eval compute in (fun n => S n) 12.

(*
Theorem t3 :(forall n:nat, fin (S n))=(forall n:nat, fin (n+1)).
  change ((forall n:nat, (fun n=> fin (S n)) n)=(forall n:nat, (fun n=>fin (n+1)) n));
    erewrite (functional_extensionality (fun n=> fin (n+1))); crush. Qed.

Eval compute in (cast t3 (fun _ => First)) 12.
 *)

(* 12.3.4 *)


Require Import RelationClasses.

Definition option_map2 (A B:Type) (f2: A -> A -> B) (f1: A -> B) (f0:B) o1 o2 :=
match o1 with
  | None =>
    match o2 with
      | None => f0
      | Some a2 => (f1 a2)
    end
  | Some a1 =>
    match o2 with
      | None => (f1 a1)
      | Some a2 => (f2 a1 a2)
    end
end.

Implicit Arguments option_map2 [A B].

Definition option_map_eq (A:Type) (eq: A -> A -> Prop) o1 o2 :=
  option_map2 eq (fun _ => False) True o1 o2.

Implicit Arguments option_map_eq [A].

Theorem option_map_eq_refl : forall A Aeq (EQUIV: Equivalence Aeq) (o: option A),
  option_map_eq Aeq o o.
  Proof.
    intros.
    unfold option_map_eq in *; unfold option_map2 in *.
    destruct o; auto.
    apply reflexivity; auto.
  Qed.

Theorem option_map_eq_symmetric: forall A Aeq (EQUIV: Equivalence Aeq) (o1 o2: option A),
  option_map_eq Aeq o1 o2 ->   option_map_eq Aeq o2 o1.
  Proof.
    intros.
    unfold option_map_eq in *; unfold option_map2 in *.
    destruct o1; destruct o2; auto.
    apply symmetry; auto.
  Qed.

Theorem option_map_eq_transitive:  forall A Aeq (EQUIV: Equivalence Aeq) (o1 o2 o3: option A),
  option_map_eq Aeq o1 o2 -> option_map_eq Aeq o2 o3 -> option_map_eq Aeq o1 o3.
  Proof.
    intros.
    unfold option_map_eq in *; unfold option_map2 in *.
    destruct o1; destruct o2; destruct o3; auto.
    apply transitivity with a0; auto.
    contradiction.
  Qed.

Theorem option_map_eq_Equiv: forall A (eqA:A->A->Prop) (EqA: Equivalence eqA),
  Equivalence (option_map_eq eqA).
Proof.
  intros.
  eapply Build_Equivalence.
  unfold Reflexive; apply option_map_eq_refl; auto.
  unfold Symmetric; apply option_map_eq_symmetric; auto.
  unfold Transitive; apply option_map_eq_transitive; auto.
Qed.

Implicit Arguments option_map_eq_Equiv [A].

Theorem option_map_eq_dec: forall A (eqA: A->A->Prop)
  (Hdec: forall a1 a2, {eqA a1 a2} + {~ eqA a1 a2}),
  forall o1 o2, {option_map_eq eqA o1 o2} + {~ option_map_eq eqA o1 o2}.
Proof.
  intros.
  destruct o1 as [a1|]; destruct o2 as [a2|]; simpl; intuition.
Qed.

Implicit Arguments option_map_eq_dec [A eqA].

Definition option_map1 (A B:Type) (f1:A -> B) (f0:B) o :=
  match o with
    | None => f0
    | Some a => f1 a
  end.

Implicit Arguments option_map1 [A B].

Theorem option_map_is_option_map1 :
  forall (A B:Type) (a:option A) (f:A->B),
    option_map f a = option_map1 (fun a => Some (f a)) None a.
Proof.
  auto.
Qed.

(* we need a version of this that has op and op' *)

(* Definition option_map1_compat_op A B eqA eqB  *)
(*   (EqA: Equivalence eqA) (EqB:Equivalence eqB) (op: A -> B) : Prop :=  *)
(*   forall a a', eqA a a' -> eqB (op a) (op a'). *)

(* Implicit Arguments option_map1_compat_op [A B]. *)

(* Theorem option_map1_Equiv A B eqA eqB EqA EqB op  *)
(*   (compat_op: @option_map1_compat_op A B eqA eqB EqA EqB op): *)
(*   forall base, @option_map1_compat_op (option A) B (option_map_eq eqA) eqB  *)
(*     (option_map_eq_Equiv eqA EqA) EqB (option_map1 op base). *)
(* Proof. *)
(*   intros. *)
(*   unfold option_map1_compat_op in *. *)
(*   intros. *)
(*   unfold option_map1. *)
(*   destruct EqB. *)
(*   destruct a; destruct a'; auto; contradiction. *)
(* Qed.   *)

Definition option_map1_compat_op A B eqA eqB
  (EqA: Equivalence eqA) (EqB:Equivalence eqB) (op op': A -> B) : Prop :=
  forall a a', eqA a a' -> eqB (op a) (op' a').

Implicit Arguments option_map1_compat_op [A B].

Theorem option_map1_Equiv A B eqA eqB EqA EqB op op'
  (compat_op: @option_map1_compat_op A B eqA eqB EqA EqB op op'):
  forall base base', eqB base base' ->
    @option_map1_compat_op (option A) B (option_map_eq eqA) eqB
    (option_map_eq_Equiv eqA EqA) EqB (option_map1 op base) (option_map1 op' base').
Proof.
  intros.
  unfold option_map1_compat_op in *.
  intros.
  unfold option_map1.
  destruct EqB.
  destruct a; destruct a'; auto; contradiction.
Qed.

Implicit Arguments option_map1_Equiv [A B].


Require Export ProjectiveGeometry.Dev.general_tactics.

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

Module Type fano_plane.

Parameter Point:Set.
Parameter A B C D E F G : Point.

Parameter Line: Set.
Parameter ABF BCD CAE ADG  BEG  CFG  DEF : Line.

Parameter Incid : Point -> Line -> Prop.

Axiom is_only_7_pts : forall P:Point, {P=A}+{P=B}+{P=C}+{P=D}+{P=E}+{P=F}+{P=G}.

Axiom is_only_7_lines : forall P:Line, {P=ABF}+{P=BCD}+{P=CAE}+{P=ADG}+{P=BEG}+{P=CFG}+{P=DEF}.

Definition is_fano_plane A B C D E F G ABF BCD CAE ADG BEG CFG DEF :=
(~A=B /\ ~A=C /\ ~A=D /\ ~A=E /\ ~A=F /\ ~A=G /\
~B=C /\ ~B=D /\ ~B=E /\ ~B=F /\ ~B=G /\
~C=D /\ ~C=E /\ ~C=F /\ ~C=G /\
~D=E /\ ~D=F /\ ~D=G /\
~E=F /\ ~E=G /\
~F=G) /\
(ABF<>BCD /\ ABF <>CAE /\ ABF <>ADG /\ ABF<>BEG /\ ABF<>CFG /\ ABF<>DEF /\
BCD<>CAE /\ BCD<>ADG /\ BCD<>BEG /\ BCD<>CFG /\ BCD<>DEF /\
CAE<>ADG /\ CAE<>BEG /\ CAE<>CFG /\ CAE<>DEF /\
ADG<>BEG /\ ADG<>CFG /\ADG<>DEF /\
BEG<>CFG /\ BEG<>DEF /\
CFG<>DEF )/\

( Incid A ABF /\ Incid B ABF /\ ~ Incid C ABF /\ ~ Incid D ABF /\ ~ Incid E ABF /\ Incid F ABF /\ ~ Incid G  ABF /\
 ~ Incid A BCD /\ Incid B BCD /\ Incid C BCD /\ Incid D BCD /\ ~ Incid E BCD /\ ~ Incid F BCD /\ ~ Incid G  BCD /\
 Incid A CAE /\ ~ Incid B CAE /\ Incid C CAE /\ ~ Incid D CAE /\ Incid E CAE /\ ~ Incid F CAE /\ ~ Incid G  CAE /\
 Incid A ADG /\ ~ Incid B ADG /\ ~ Incid C ADG /\ Incid D ADG /\ ~ Incid E ADG /\ ~ Incid F ADG /\ Incid G  ADG /\
 ~ Incid A BEG /\ Incid B BEG /\ ~ Incid C BEG /\ ~ Incid D BEG /\  Incid E BEG /\ ~ Incid F BEG /\ Incid G  BEG /\
 ~ Incid A CFG /\ ~ Incid B CFG /\ Incid C CFG /\ ~ Incid D CFG /\ ~ Incid E CFG /\ Incid F CFG /\ Incid G  CFG /\
 ~ Incid A DEF /\ ~ Incid B DEF /\ ~ Incid C DEF /\ Incid D DEF /\ Incid E DEF /\ Incid F DEF /\ ~ Incid G  DEF).

Axiom is_fano_plane_inst :  is_fano_plane A B C D E F G ABF BCD CAE ADG BEG CFG DEF.

End fano_plane.

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

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

with Definition A:= M.B
with Definition B:=M.E
with Definition C:=M.D
with Definition D:=M.F
with Definition E:=M.C
with Definition F:=M.G
with Definition G:=M.A

with Definition Line:=M.Line

with Definition ABF:=M.BEG
with Definition BCD:=M.DEF
with Definition CAE:=M.BCD
with Definition ADG:=M.ABF
with Definition BEG:=M.CAE
with Definition CFG:=M.ADG
with Definition DEF:=M.CFG

with Definition Incid :=M.Incid

with Definition is_fano_plane := M.is_fano_plane.

Definition Point:=M.Point.

Definition A:=M.B.
Definition B:=M.E.
Definition C:=M.D.
Definition D:=M.F.
Definition E:=M.C.
Definition F:=M.G.
Definition G:=M.A.

Definition Line:=M.Line.

Definition ABF:=M.BEG.
Definition BCD:=M.DEF.
Definition CAE:=M.BCD.
Definition ADG:=M.ABF.
Definition BEG:=M.CAE.
Definition CFG:=M.ADG.
Definition DEF:=M.CFG.

Definition Incid :=M.Incid.

Definition is_fano_plane := M.is_fano_plane.

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

Lemma is_only_7_lines : forall P:Line, {P=ABF}+{P=BCD}+{P=CAE}+{P=ADG}+{P=BEG}+{P=CFG}+{P=DEF}.
Proof.
generalize (M.is_only_7_lines).
unfold ABF, BCD, CAE, ADG, BEG, CFG, DEF .
intros H P;
generalize (H P); intuition.
Qed.

Lemma is_fano_plane_inst : is_fano_plane A B C D E F G ABF BCD CAE ADG BEG CFG DEF.
Proof.
generalize (M.is_fano_plane_inst).
unfold is_fano_plane, M.is_fano_plane.
intros H; decompose [and] H; clear H.
unfold A, B, C, D, E, F, G, ABF, BCD, CAE, ADG, BEG, CFG, DEF .
repeat split;try  assumption;try auto.
Qed.

End swapf3.

Module Desargues_from_A (M:fano_plane).

Import M.

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

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

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

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

Ltac solve_ex_l := first [solve_ex ABF
     |  solve_ex BCD
     |  solve_ex CAE
     |  solve_ex ADG
     |  solve_ex BEG
     |  solve_ex CFG
     |  solve_ex DEF
 ].

Ltac solve_ex_p := first [
        solve_ex A
     |  solve_ex B
     |  solve_ex C
     |  solve_ex D
     |  solve_ex E
     |  solve_ex F
     |  solve_ex G
 ].

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

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

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

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

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

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

Ltac case_eq_s  O := new_case O.

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

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

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

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

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

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

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

Ltac collinear_line_gen ABF BCD CAE ADG  BEG CFG DEF :=
match goal with
H : ~collinear ?P ?Q ?R |- _ =>
  solve [assert (collinear P Q R) by (solve_ex_l);
cut False; [intros Hf; elim Hf | auto]]
end.

Lemma Desargues_from_A_spec :  forall P Q R P' Q' R' alpha beta gamma lPQ lPR lQR lP'Q' lP'R' lQ'R',
((on_line P Q gamma lPQ) /\ (on_line P' Q' gamma lP'Q')) /\
((on_line P R beta lPR) /\ (on_line P' R' beta lP'R')) /\
((on_line Q R alpha lQR) /\ (on_line Q' R' alpha lQ'R')) /\
((on_line A P P' ADG) /\ (on_line A Q Q' CAE) /\(on_line A R R' ABF)) /\
~collinear A P Q /\  ~collinear A P R /\ ~collinear A Q R /\
~collinear P Q R /\ ~collinear P' Q' R' /\ ((~P=P')\/(~Q=Q')\/(~R=R')) ->
collinear alpha beta gamma.
Proof.

intros P Q R P' Q' R' alpha beta gamma lPQ lPR lQR lP'Q' lP'R' lQ'R'.
intros.
unfold on_line in  *;use H.
generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw.

case_clear P;
case_clear Q;
case_clear R;

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

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

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

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

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

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

Hint Resolve col_1 col_2 col_3 col_4 col_5 : Geom.

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

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

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

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

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

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

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

End Desargues_from_A.

Module Desargues (M:fano_plane).

Import M.

Module Import M2:= Desargues_from_A M.

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

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

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

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

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

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

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

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

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

End Desargues.