From Lambda Require Export Util.Lists Util.EqRect STLC.SimpleTypes.

(** Inspired by
    Programming Language Foundations in Agda. *)

(** De Bruijn syntax. *)

Reserved Notation "Γ '⊢' τ" (at level 80, no associativity).

Inductive term : list type -> type -> Set :=
| Id (Γ : list type) (τ : type) :
  Has τ Γ ->
  Γ ⊢ τ
| Abs (Γ : list type) (τ τ' : type) :
  τ :: Γ ⊢ τ' ->
  Γ ⊢ τ → τ'
| App (Γ : list type) (τ τ' : type) :
  Γ ⊢ τ → τ' ->
  Γ ⊢ τ ->
  Γ ⊢ τ'
where "Γ '⊢' τ" := (term Γ τ) : type_scope.

Equations Derive Signature NoConfusion NoConfusionHom Subterm for term.

Declare Scope term_scope.
Delimit Scope term_scope with term.

Notation "'`λ' t"
  := (Abs _ _ _ t)
       (at level 15, right associativity) : term_scope.
Notation "'λ' τ '⇒' t"
  := (Abs _ τ _ t)
       (at level 15, right associativity) : term_scope.
Notation "'λ' τ '↣' .. '↣' ρ '⇒' t"
  := (Abs _ τ _ .. (Abs _ ρ _ t) ..)
       (at level 15, right associativity) : term_scope.
Notation "x '⋅' y"
  := (App _ _ _ x y)
       (at level 14, left associativity) : term_scope.

Equations
  Rename
  {Γ Δ} :
  (forall τ, Has τ Γ -> Has τ Δ) -> forall {σ}, Γ ⊢ σ -> Δ ⊢ σ :=
  Rename f (Id _ _ h)   := Id _ _ (f _ h);
  Rename f (λ ρ ⇒ t')%term := (`λ Rename (ext_has f ρ) t')%term;
  Rename f (t₁ ⋅ t₂)%term  := (Rename f t₁ ⋅ Rename f t₂)%term.

Equations Exts : forall {Γ Δ},
    (forall τ, Has τ Γ -> Δ ⊢ τ) ->
    forall ρ σ, Has σ (ρ :: Γ) -> ρ :: Δ ⊢ σ :=
  Exts f _ _ HasO := Id _ _ HasO;
  Exts f _ _ (HasS hs) := Rename (fun τ => @HasS _ τ _ _) (f _ hs).

Equations Exts_app_l : forall {Γ Δ},
    (forall τ, Has τ Γ -> Δ ⊢ τ) ->
    forall τs τ, Has τ (τs ++ Γ) -> (τs ++ Δ) ⊢ τ :=
  Exts_app_l σ [] := σ;
  Exts_app_l σ (α :: τs) := Exts (Exts_app_l σ τs) α.

Equations
  subs : forall {Γ Δ},
    (forall {τ}, Has τ Γ -> Δ ⊢ τ) ->
    forall {σ}, Γ ⊢ σ -> Δ ⊢ σ :=
  subs f (Id _ _ h)   := f _ h;
  subs f (λ ρ ⇒ t')%term := (`λ subs (Exts f ρ) t')%term;
  subs f (t₁ ⋅ t₂)%term  := (subs f t₁ ⋅ subs f t₂)%term.

Equations sub_helper : forall {Γ τ}, Γ ⊢ τ -> forall τ', Has τ' (τ :: Γ) -> Γ ⊢ τ' :=
  sub_helper t _ HasO := t;
  sub_helper _ _ (HasS hs) := Id _ _ hs.

Definition sub {Γ τ τ'} (body : τ :: Γ ⊢ τ') (arg : Γ ⊢ τ) : Γ ⊢ τ' :=
    subs (sub_helper arg) body.

Notation "x '[[' y ']]'"
  := (sub x y) (at level 12, no associativity) : term_scope.

Reserved Notation "x '-->' y" (at level 80, no associativity).

Inductive bred {Γ} : forall {τ}, Γ ⊢ τ -> Γ ⊢ τ -> Prop :=
| bred_bred τ τ' (t₁ : τ :: Γ ⊢ τ') t₂ :
    ((`λ t₁) ⋅ t₂)%term --> (t₁ [[ t₂ ]])%term
| bred_abs τ τ' (t t' : τ :: Γ ⊢ τ') :
    t -->  t' ->
    (`λ t)%term --> (`λ t')%term
| bred_app_l τ τ' (t₁ t₁' : Γ ⊢ τ → τ') t₂ :
    t₁ -->  t₁' ->
    (t₁ ⋅ t₂)%term -->  (t₁' ⋅ t₂)%term
| bred_app_r τ τ' (t₁ : Γ ⊢ τ → τ') t₂ t₂' :
    t₂ -->  t₂' ->
    (t₁ ⋅ t₂)%term -->  (t₁ ⋅ t₂')%term
where "x '-->' y" := (bred x y) : type_scope.
Derive Signature for bred.

Print Assumptions bred.

Local Hint Constructors bred : core.

Variant value {Γ : list type} : forall {τ : type}, Γ ⊢ τ -> Prop :=
  Abs_value (τ τ' : type) (t : τ :: Γ ⊢ τ') : value (`λ t)%term.
Derive Signature for value.

Print Assumptions value.

Lemma canonical_forms_abs : forall {τ τ' : type} (t : [] ⊢ (τ → τ')%ty),
    value t -> exists body : [τ] ⊢ τ', t = (`λ body)%term.
Proof.
  intros τ τ' t v.
  depelim v; eauto.
Qed.

Print Assumptions canonical_forms_abs.

Local Hint Constructors bred : core.
Local Hint Constructors value : core.

Theorem Progress : forall {τ} (t : [] ⊢ τ), value t \/ exists t', t --> t'.
Proof.
  intros τ t; depind t; eauto.
  - inv h.
  - clear IHt2.
    destruct IHt1 as [v1 | (t1' & ih1)]; eauto.
    apply canonical_forms_abs in v1 as [t1' ?]; subst; eauto.
Qed.

Print Assumptions Progress.

Lemma bred_exm : forall {Γ τ} (t : Γ ⊢ τ),
    (exists t', t --> t') \/ forall t', ~ (t --> t').
Proof.
  intros Γ τ t; depind t; eauto.
  - right; intros t' H; inv H.
  - destruct IHt as [(t' & ih) | ih]; eauto.
    right; intros t' H; depelim H.
    apply ih in H; contradiction.
  - destruct IHt1 as [(t1' & ih1) | ih1]; eauto.
    destruct IHt2 as [(t2' & ih2) | ih2]; eauto.
    depelim t1; eauto.
    + right; intros t' H. depelim H.
      * depelim H.
      * apply ih2 in H; contradiction.
    + right; intros t' H. depelim H.
      * apply ih1 in H; contradiction.
      * apply ih2 in H; contradiction.
Qed.

Notation "e '-->*' e'"
  := (refl_trans_closure bred e e')
       (at level 40, no associativity).

(** Termination predicate. *)
Definition halts {Γ τ} (t : Γ ⊢ τ) : Prop :=
  exists t', t -->* t' /\ forall t'', ~ (t' -->  t'').

(** Strongly Normalizing. *)
Definition SN {Γ τ} : Γ ⊢ τ -> Prop := Acc (fun t' t => t -->  t').
Equations Derive Signature for Acc.

Section HaltsSN.
  Local Hint Constructors refl_trans_closure : core.

  Lemma SN_halts : forall {Γ τ} (t : Γ ⊢ τ), SN t -> halts t.
  Proof.
    intros Γ τ t Hsn; unfold halts; depind Hsn.
    destruct (bred_exm x) as [(t & Ht) | Ht]; eauto.
    apply H0 in Ht as Ht_. destruct Ht_ as (t' & Ht' & Ht''); eauto.
  Qed.
End HaltsSN.

Lemma Exts_app_l_idem :
  forall τs {Γ τ τ'} (x : Has τ (τs ++ Γ)) (t' : Γ ⊢ τ'),
    Exts_app_l
      (sub_helper t')
      τs _
      (ext_has_app_l
         (fun α : type => HasS (a:=α))
         τs _ x) = Id _ _ x.
Proof.
  intros τs Γ τ τ' x t'; depind τs; cbn.
  - rewrite ext_has_app_l_equation_1,
      Exts_app_l_equation_1,
      sub_helper_equation_2; reflexivity.
  - rewrite ext_has_app_l_equation_2,
      Exts_app_l_equation_2.
    depelim x.
    + rewrite ext_has_equation_1,
        Exts_equation_1; reflexivity.
    + rewrite ext_has_equation_2,
        Exts_equation_2, IHτs,
        Rename_equation_1; reflexivity.
Qed.

Lemma subs_Rename_app_l_idem :
  forall {Γ τ τ'} τs (t : τs ++ Γ ⊢ τ) (t' : Γ ⊢ τ'),
    subs
      (Exts_app_l (sub_helper t') τs)
      (Rename (ext_has_app_l (fun α => HasS (a:=α)) τs) t) = t.
Proof.
  intros Γ τ τ' τs t; depind t; intros t'.
  - rewrite Rename_equation_1,
      subs_equation_1, Exts_app_l_idem;
      reflexivity.
  - rewrite Rename_equation_2,subs_equation_2; f_equal.
    pose proof IHt _ _ _ (τ :: τs) t eq_refl t' as ih; clear IHt.
    rewrite ext_has_app_l_equation_2,
      Exts_app_l_equation_2 in ih. assumption.
  - rewrite Rename_equation_3,subs_equation_3; f_equal; auto.
Qed.

Lemma subs_Rename_idem : forall {Γ τ τ'} (t : Γ ⊢ τ) (t' : Γ ⊢ τ'),
    subs (sub_helper t') (Rename (fun τ' => HasS (a:=τ')) t) = t.
Proof.
  intros Γ τ τ' t t'.
  pose proof subs_Rename_app_l_idem [] t t' as h.
  rewrite Exts_app_l_equation_1,
    ext_has_app_l_equation_1 in h; assumption.
Qed.

Fail Lemma subs_Rename_comm :
  forall {Γ Δ} (σ : forall τ, Has τ Γ -> Δ ⊢ τ) τs ρs {τ} τ' (t : τs ++ Γ ⊢ τ),
    subs
      (Exts_app_l σ (τ' :: ρs))
      (Rename
         (ext_has_app_l (fun α => HasS (a:=α)) τs) t)
    = Rename
        (ext_has_app_l (fun α => HasS (a:=α)) ρs)
        (subs (Exts_app_l σ τs) t).

Lemma subs_Rename_comm :
  forall {Γ Δ} (σ : forall τ, Has τ Γ -> Δ ⊢ τ) τs {τ} τ' (t : τs ++ Γ ⊢ τ),
    subs
      (Exts_app_l σ (τ' :: τs))
      (Rename
         ((*ext_has_app_l*) (fun α => HasS (a:=α)) (*ρs*)) t)
    = Rename
        ((*ext_has_app_l*) (fun α => HasS (a:=α)) (*ρs*))
        (subs (Exts_app_l σ τs) t).
Proof.
  intros Γ Δ σ τs τ τ' t; depind t.
  - rewrite Rename_equation_1,
      Exts_app_l_equation_2.
    do 2 rewrite subs_equation_1.
    rewrite Exts_equation_2; reflexivity.
  - rewrite Rename_equation_2.
    do 2 rewrite subs_equation_2.
    rewrite Rename_equation_2; f_equal.
    rewrite Exts_app_l_equation_2.
    pose proof IHt _ _ σ (τ :: τs) _ τ' _ eq_refl as ih; clear IHt.
    do 2 rewrite Exts_app_l_equation_2 in ih.
Admitted.

Lemma subs_Exts_app_l :
  forall {Γ Δ} (σ : forall τ, Has τ Γ -> Δ ⊢ τ)
    τs {τ τ'} (x : Has τ' (τs ++ τ :: Γ)) (t' : Γ ⊢ τ),
    subs (Exts_app_l σ τs) (Exts_app_l (sub_helper t') τs _ x)
    = subs
        (Exts_app_l (sub_helper (subs σ t')) τs)
        (eq_rect_zwei
           (T:=fun u v => forall τ, Has τ u -> v ⊢ τ)
           (eq_sym (app_assoc _ _ _))
           (eq_sym (app_assoc _ _ _))
           (Exts_app_l σ (τs ++ [τ])) _ x).
Proof.
  intros Γ Δ σ τs τ τ' x t'.
  depind τs; cbn in *.
  - rewrite Exts_app_l_equation_2.
    do 3 rewrite Exts_app_l_equation_1.
    pose proof type_eqdec as ted; unfold dec_eq in ted.
    pose proof list_eq_dec ted as led.
    pose proof Eqdep_dec.UIP_dec led as h.
    pose proof h _ _ (app_assoc [] [τ] Γ) as h1; cbn in h1.
    specialize h1 with eq_refl.
    pose proof h _ _ (app_assoc [] [τ] Δ) as h2; cbn in h2.
    specialize h2 with eq_refl.
    rewrite h1, h2; clear h h1 h2 led ted.
    unfold eq_sym.
    rewrite eq_rect_zwei_equation_1.
    depelim x.
    + rewrite Exts_equation_1,subs_equation_1.
      do 2 rewrite sub_helper_equation_1; reflexivity.
    + rewrite Exts_equation_2,sub_helper_equation_2,
        subs_equation_1, subs_Rename_idem.
      reflexivity.
  - do 4 rewrite Exts_app_l_equation_2.
    pose proof type_eqdec as ted; unfold dec_eq in ted.
    pose proof list_eq_dec ted as led.
    pose proof Eqdep_dec.UIP_dec led as h.
    pose proof h _ _ (app_assoc (a :: τs) [τ] Γ) as h1; cbn in h1.
    specialize h1 with (f_equal (cons a) (app_assoc τs [τ] Γ)).
    pose proof h _ _ (app_assoc (a :: τs) [τ] Δ) as h2; cbn in h2.
    specialize h2 with (f_equal (cons a) (app_assoc τs [τ] Δ)).
    rewrite h1, h2; clear h h1 h2 led ted.
    do 2 rewrite eq_sym_map_distr. cbn.
    pose proof @map_subst_map_zwei_both as h.
    specialize h with (f:=cons a) (h:=cons a).
    specialize h with (P:=fun u v => forall τ, Has τ u -> v ⊢ τ).
    specialize h with (Q:=fun u v => forall τ, Has τ u -> v ⊢ τ). cbn in h.
    specialize h with (z:=Exts_app_l σ (τs ++ [τ])).
    specialize h with (g:=fun Γ Δ σ => @Exts Γ Δ σ a). cbn in h.
    rewrite h; clear h.
    depelim x.
    + do 2 rewrite Exts_equation_1.
      do 2 rewrite subs_equation_1.
      do 2 rewrite Exts_equation_1.
      reflexivity.
    + do 2 rewrite Exts_equation_2.
      pose proof IHτs _ _ x t' as ih; clear IHτs.
      assert (H:
               subs
                 (Exts (Exts_app_l σ τs) a)
                 (Rename
                    (fun α => HasS (a:=α))
                    (Exts_app_l (sub_helper t') τs _ x))
               = Rename
                   (fun α => HasS (a:=α))
                   (subs (Exts_app_l σ τs) (Exts_app_l (sub_helper t') τs τ' x))) by admit.
      rewrite H,ih. Check Exts_app_l (sub_helper t') τs _ x.

      admit (* TODO: helper lemma. *).
Admitted.

Lemma subs_subs_distr :
  forall {Γ Δ} (σ : forall τ, Has τ Γ -> Δ ⊢ τ)
    τs {τ τ'} (t : (τs ++ τ :: Γ) ⊢ τ') (t' : Γ ⊢ τ),
    subs
      (Exts_app_l σ τs)
      (subs (Exts_app_l (sub_helper t') τs) t)
    = subs
        (Exts_app_l (sub_helper (subs σ t')) τs)
        (subs
           (eq_rect_zwei
              (T:=fun u v => forall τ, Has τ u -> v ⊢ τ)
              (eq_sym (app_assoc _ _ _)) (eq_sym (app_assoc _ _ _))
              (Exts_app_l σ (τs ++ [τ])))
           t).
Proof.
  intros Γ Δ σ τs τ τ' t t'.
  depind t.
  - do 2 rewrite subs_equation_1.
    rewrite subs_Exts_app_l; reflexivity.
  - do 4 rewrite subs_equation_2; f_equal.
    pose proof IHt _ _ σ (τ :: τs) _ _ _ eq_refl t' as ih; clear IHt.
    do 2 rewrite Exts_app_l_equation_2 in ih.
    cbn in *; rewrite ih; clear ih.
    do 2 rewrite Exts_app_l_equation_2.
    pose proof type_eqdec as ted; unfold dec_eq in ted.
    pose proof list_eq_dec ted as led.
    pose proof Eqdep_dec.UIP_dec led as h.
    pose proof h _ _ (app_assoc (τ :: τs) [τ0] Γ0) as h1; cbn in h1.
    specialize h1 with (f_equal (cons τ) (app_assoc τs [τ0] Γ0)).
    pose proof h _ _ (app_assoc (τ :: τs) [τ0] Δ) as h2; cbn in h2.
    specialize h2 with (f_equal (cons τ) (app_assoc τs [τ0] Δ)).
    rewrite h1, h2; clear h h1 h2 led ted.
    do 2 rewrite eq_sym_map_distr. cbn.
    pose proof @map_subst_map_zwei_both as h.
    specialize h with (f:=cons τ) (h:=cons τ).
    specialize h with (P:=fun u v => forall τ, Has τ u -> v ⊢ τ).
    specialize h with (Q:=fun u v => forall τ, Has τ u -> v ⊢ τ). cbn in h.
    specialize h with (z:=Exts_app_l σ (τs ++ [τ0])).
    specialize h with (g:=fun Γ Δ ρ => @Exts Γ Δ ρ τ). cbn in h.
    rewrite h; clear h. reflexivity.
  - do 4 rewrite subs_equation_3; f_equal; eauto.
Qed.

Lemma subs_sub_distr :
  forall {Γ Δ} (σ : forall τ, Has τ Γ -> Δ ⊢ τ)
    {τ τ'} (t : τ :: Γ ⊢ τ') (t' : Γ ⊢ τ),
    subs σ (t [[t']])%term = (subs (Exts σ τ) t [[subs σ t']])%term.
Proof.
  intros Γ Δ σ τ τ' t t'.
  unfold "_ [[ _ ]]".
  pose proof subs_subs_distr σ [] t t' as h; cbn in h.
  rewrite Exts_app_l_equation_2 in h.
  do 3 rewrite Exts_app_l_equation_1 in h.
  rewrite h; clear h.
  pose proof type_eqdec as ted; unfold dec_eq in ted.
  pose proof list_eq_dec ted as led.
  pose proof Eqdep_dec.UIP_dec led as h.
  pose proof h _ _ (app_assoc [] [τ] Γ) as h1; cbn in h1.
  specialize h1 with eq_refl.
  pose proof h _ _ (app_assoc [] [τ] Δ) as h2; cbn in h2.
  specialize h2 with eq_refl.
  rewrite h1, h2; clear h h1 h2 led ted; cbn.
  rewrite eq_rect_zwei_equation_1; reflexivity.
Qed.

Lemma subs_bred : forall {Γ τ} (t t' : Γ ⊢ τ),
    t -->  t' -> forall {Δ} (σ : forall τ, Has τ Γ -> Δ ⊢ τ),
      subs σ t --> subs σ t'.
Proof.
  intros Γ τ t t' br; depind br; intros Δ σ.
  - rewrite subs_equation_3,subs_equation_2.
    assert (H:subs σ (t₁ [[t₂]])%term
              = (subs (Exts σ τ) t₁ [[subs σ t₂]])%term)
      by auto using subs_sub_distr.
    rewrite H; auto.
  - do 2 rewrite subs_equation_2; auto.
  - do 2 rewrite subs_equation_3; auto.
  - do 2 rewrite subs_equation_3; auto.
Qed.

Lemma sub_bred : forall {Γ τ τ'} (bdy bdy' : τ :: Γ ⊢ τ'),
    bdy --> bdy' -> forall (t : Γ ⊢ τ),
    (bdy [[ t ]])%term --> (bdy' [[ t ]])%term.
Proof.
  eauto using subs_bred.
Qed.

Print Assumptions sub_bred.


(***************************************************************************
* Safety for STLC with Datatypes - Infrastructure                          *
* Arthur Chargueraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import List LibLN STLC_Data_Definitions.

(* ********************************************************************** *)
(** ** Additional Definitions used in the Proofs *)

(** Computing free variables of a term. *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i j  => \{}
  | trm_fvar x    => \{x}
  | trm_abs t1    => (fv t1)
  | trm_fix t1    => (fv t1)
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  | trm_match t1 p1 e t2 => (fv t1) \u (fv e) \u (fv t2)
  | trm_unit      => \{}
  | trm_pair t1 t2 => (fv t1) \u (fv t2)
  | trm_inj1 t1   => (fv t1)
  | trm_inj2 t1   => (fv t1)
  end.

(** Computing free variables of a list of terms. *)

Definition fv_list :=
  List.fold_right (fun t acc => fv t \u acc) \{}.

(** Free variables of the default term. *)

Lemma trm_def_fresh : fv trm_def = \{}.
Proof.
  auto.
Qed.

(** Substitution for names *)

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i j  => trm_bvar i j
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs t1    => trm_abs (subst z u t1)
  | trm_fix t1    => trm_fix (subst z u t1)
  | trm_match t1 p1 e t2 => trm_match (subst z u t1) p1
                               (subst z u e)
                               (subst z u t2)
  | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2)
  | trm_unit      => trm_unit
  | trm_pair t1 t2 => trm_pair (subst z u t1) (subst z u t2)
  | trm_inj1 t1  => trm_inj1 (subst z u t1)
  | trm_inj2 t1  => trm_inj2 (subst z u t1)
  end.

Notation "[ z ~> u ] t" := (subst z u t) (at level 68).

(** Iterated substitution *)

Fixpoint substs (zs : list var) (us : list trm) (t : trm)
   {struct zs} : trm :=
  match zs, us with
  | z::zs', u::us' => substs zs' us' ([z ~> u]t)
  | _, _ => t
  end.

(** Predicate caraterizing lists of a given number of terms *)

Definition terms := list_for_n term.

(** Iterated typing *)

Inductive typings (E : env) : list trm -> list typ -> Prop :=
  | typings_nil : typings E nil nil
  | typings_cons : forall ts Us t U,
      typings E ts Us ->
      typing E t U ->
      typings E (t::ts) (U::Us).

(* ********************************************************************** *)
(** ** Instanciation of Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : env => dom x) in
  let D := gather_vars_with (fun x : trm => fv x) in
  let E := gather_vars_with (fun x : list trm => fv_list x) in
  constr:(A \u B \u C \u D \u E).

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

Ltac pick_freshes n Y :=
  let L := gather_vars in (pick_freshes_gen L n Y).

Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base_simple T gather_vars.

Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; autos*.

Hint Constructors term value red typing typings.

Hint Extern 1 (_ \notin fv trm_def) =>
  rewrite trm_def_fresh.

Hint Extern 1 (terms _ _) => split; auto.

(* todo *)

Hint Rewrite
  map_concat
  dom_empty dom_single dom_push dom_push dom_concat dom_map : rew_env.
  (*Hint Rewrite concat_assoc : rew_env.*)

Tactic Notation "simpl_env" :=
  autorewrite with rew_env in *.

Hint Extern 1 (fresh (dom (_ & _)) _ _) => simpl_env.

(* ********************************************************************** *)
(** ** Properties of iterated operators *)

Lemma fv_list_map : forall ts1 ts2,
  fv_list (ts1 ++ ts2) = fv_list ts1 \u fv_list ts2.
Proof.
  induction ts1; simpl; intros.
  rewrite* union_empty_l.
  rewrite IHts1. rewrite* union_assoc.
Qed.

Lemma typings_concat : forall E ts1 Us1 ts2 Us2,
  typings E ts1 Us1 ->
  typings E ts2 Us2 ->
  typings E (ts1++ts2) (Us1++Us2).
Proof.
  induction ts1; introv Typ1 Typ2; inversions Typ1; simpls*.
Qed.

(* ********************************************************************** *)
(** ** Properties of substitution *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ;
  simpl in *; inversion* Equ; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; f_equal*.
  pick_fresh x. forwards~ K: (H0 x).
   apply* (@open_rec_term_core t1 0 (trm_fvars (x::nil))).
  pick_fresh x. pick_fresh f. forwards~ K: (H0 x f).
   apply* (@open_rec_term_core t1 0 (trm_fvars (x::f::nil))).
  pick_freshes (pat_arity p) xs. forwards~ K: (H1 xs).
   apply* (@open_rec_term_core e 0 (trm_fvars xs)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : forall x t u,
  x \notin fv t ->
  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; f_equal*. case_var*.
Qed.

Lemma subst_fresh_list : forall z u ts,
  z \notin fv_list ts ->
  ts = List.map (subst z u) ts.
Proof.
  induction ts; simpl; intros Fr.
  auto. f_equal. rewrite~ subst_fresh. auto.
Qed.

Lemma subst_fresh_trm_fvars : forall z u xs,
  fresh (\{z}) (length xs) xs ->
  trm_fvars xs = List.map (subst z u) (trm_fvars xs).
Proof.
  intros. apply subst_fresh_list.
  induction xs; simpls. auto. destruct H. auto.
Qed.

Lemma substs_fresh : forall xs us t,
  fresh (fv t) (length xs) xs ->
  substs xs us t = t.
Proof.
  induction xs; simpl; intros us t Fr.
  auto. destruct us. auto.
  inversions Fr. rewrite* subst_fresh.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ (List.map (subst x u) t2).
Proof.
  intros. unfold open, opens. simpl. generalize 0.
  induction t1; intros; simpl; f_equal*.
  case_nat*. unfold trm_nth.
   apply list_map_nth. apply* subst_fresh.
  case_var*. apply* open_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_vars : forall x ys u t,
  fresh \{x} (length ys) ys ->
  term u ->
  ([x ~> u]t) ^ ys = [x ~> u] (t ^ ys).
Proof.
  introv Fr Tu. rewrite* subst_open.
  unfold trm_fvars. f_equal.
  induction ys; simpls. auto.
  destruct Fr. case_var. f_equal*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma substs_intro_ind : forall t xs us vs,
  fresh (fv t \u fv_list vs \u fv_list us) (length xs) xs ->
  terms (length xs) us ->
  terms (length vs) vs ->
  t ^^ (vs ++ us) = substs xs us (t ^^ (vs ++ (trm_fvars xs))).
Proof.
  induction xs; simpl; introv Fr Tu Tv;
   destruct Tu; destruct us; tryfalse.
  auto.
  inversions H0. lets [Fr1 _]: Fr. simpls.
  rewrite app_last.
  forwards K: (IHxs us (vs++t0::nil)); clear IHxs.
    rewrite* fv_list_map.
    auto.
    split~. inversions Tv. apply* Forall_app.
  rewrite K. clear K.
  f_equal. rewrite~ subst_open. rewrite~ subst_fresh.
  f_equal. rewrite map_app.
  simpl. case_var; tryfalse*.
  rewrite <- app_last.
  f_equal. apply~ subst_fresh_list.
  f_equal. apply* subst_fresh_trm_fvars.
Qed.

Lemma substs_intro : forall xs t us,
  fresh (fv t \u fv_list us) (length xs) xs ->
  terms (length xs) us ->
  t ^^ us = substs xs us (t ^ xs).
Proof.
  intros. apply* (@substs_intro_ind t xs us nil).
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpls*.
  case_var*.
  apply_fresh term_abs. intros y Fr.
   rewrite* subst_open_vars. apply~ H1.
  apply_fresh term_fix. intros y f Fr.
   rewrite* subst_open_vars. apply~ H1.
  apply_fresh* term_match. intros ys Fr.
   rewrite* subst_open_vars.
Qed.

Hint Resolve subst_term.

(** Terms are stable by iterated substitution *)

Lemma substs_terms : forall xs us t,
  terms (length xs) us ->
  term t ->
  term (substs xs us t).
Proof.
  induction xs; destruct us; introv TU TT; simpl; auto.
  inversions TU. simpls. inversions H. inversions* H0.
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> bodys 1 t1.
Proof.
  intros. unfold bodys. inversions* H.
  exists L. intros.
  destruct xs; simpl in H0; destruct H0.
  destruct xs; simpl in H2; destruct H2. auto.
Qed.

Lemma body_to_term_abs : forall t1,
  bodys 1 t1 -> term (trm_abs t1).
Proof.
  destruct 1. apply_fresh* term_abs.
Qed.

Lemma term_fix_to_body : forall t1,
  term (trm_fix t1) -> bodys 2 t1.
Proof.
  intros. unfold bodys. inversions* H.
  exists L. intros.
  destruct xs; simpl in H0; destruct H0.
  destruct xs; simpl in H2; destruct H2.
  destruct xs; simpl in H3; destruct H3.
  auto.
Qed.

Lemma body_to_term_fix : forall t1,
  bodys 2 t1 -> term (trm_fix t1).
Proof.
   destruct 1. apply_fresh* term_fix.
Qed.

Lemma term_match_to_body : forall t1 t2 e p,
  term (trm_match t1 p e t2) -> bodys (pat_arity p) e.
Proof.
  intros. unfold bodys. inversions* H.
Qed.

Lemma body_to_term_match : forall t1 t2 e p,
  term t1 -> term t2 -> bodys (pat_arity p) e ->
  term (trm_match t1 p e t2).
Proof.
  destruct 3. apply_fresh* term_match.
Qed.

Hint Resolve body_to_term_abs term_abs_to_body
             body_to_term_fix term_fix_to_body
             body_to_term_match.

Hint Extern 1 (bodys (pat_arity ?p) ?e) =>
  match goal with H: context [trm_match ?t1 p e ?t2] |- _ =>
    apply (@term_match_to_body t1 t2) end.

(** ** Opening a body with a term gives a term *)

Lemma open_terms : forall t us,
  bodys (length us) t ->
  terms (length us) us ->
  term (t ^^ us).
Proof.
  introv [L K] WT. pick_freshes (length us) xs. poses Fr' Fr.
  rewrite (fresh_length _ _ _  Fr) in WT, Fr'.
  rewrite* (@substs_intro xs). apply* substs_terms.
Qed.

Hint Resolve open_terms.

(** The matching function returns a list of terms of the expected length. *)

Lemma pat_match_terms : forall p t ts,
  (pat_match p t) = Some ts -> term t ->
  terms (pat_arity p) ts.
Proof.
  induction p; simpl; introv EQ TT;
   try solve [ inversions EQ; auto ];
   destruct t; inversions EQ; inversions TT; autos*.
  remember (pat_match p1 t1) as K1. symmetry in HeqK1.
   remember (pat_match p2 t2) as K2. symmetry in HeqK2.
   destruct K1 as [ts1|]; destruct K2 as [ts2|]; try discriminate.
   inversions EQ. unfolds terms. apply* list_for_n_concat.
Qed.

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** A typing relation holds only if the environment has no
   duplicated keys and the pre-term is locally-closed. *)

Lemma typing_regular : forall E e T,
  typing E e T -> ok E /\ term e.
Proof.
  split; induction* H.
  pick_fresh x. forward~ (H0 x) as K. inversions* K.
  pick_fresh x. pick_fresh f. forward~ (H0 x f) as K.
   inversions K. inversions* H3.
Qed.

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular : forall e,
  value e -> term e.
Proof.
  induction 1; autos*.
Qed.

(** A reduction relation only holds on pairs of locally-closed terms. *)

Lemma red_regular : forall e e',
  red e e' -> term e /\ term e'.
Proof.
  induction 1; use value_regular.
  splits*. forward~ (@pat_match_terms p t1 ts) as K.
  rewrite (proj1 K) in H0, K. autos*.
Qed.

(** Automation for reasoning on well-formedness. *)

Hint Extern 1 (ok ?E) =>
  match goal with
  | H: typing E _ _ |- _ => apply (proj1 (typing_regular H))
  end.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: typing _ t _ |- _ => apply (proj2 (typing_regular H))
  | H: red t _ |- _ => apply (proj1 (red_regular H))
  | H: red _ t |- _ => apply (proj2 (red_regular H))
  | H: value t |- _ => apply (value_regular H)
  end.


Require Import Coq.Lists.List.
Require Import MirrorCore.Reify.Reify.
Require Import MirrorCore.CTypes.CoreTypes.
Require Import MirrorCore.Lambda.ExprCore.
Require Import McExamples.PolyRewrite.MSimple.

(** Declare patterns **)
Reify Declare Patterns patterns_simple_typ : typ.
Reify Declare Patterns patterns_simple : (expr typ func).

Definition reify_simple_typ' :=
  CPatterns patterns_simple_typ.
Reify Declare Syntax reify_simple_typ := reify_simple_typ'.

Axiom otherFunc : BinNums.positive -> expr typ func.

Reify Declare Typed Table table_terms : BinNums.positive => typ.

(** Declare syntax **)
Definition reify_simple' :=
  CFix
    (CFirst (CPatterns patterns_simple ::
             CApp (CRec 0) (CRec 0) (@ExprCore.App typ func) ::
             CAbs (CCall reify_simple_typ) (CRec 0) (@ExprCore.Abs typ func) ::
             CVar (@ExprCore.Var typ func) ::
             CMap otherFunc (CTypedTable (CCall reify_simple_typ) table_terms)
             :: nil)).
Reify Declare Syntax reify_simple := reify_simple'.

Local Notation "x @ y" := (@RApp x y) (only parsing, at level 30).
Local Notation "'!!' x" := (@RExact _ x) (only parsing, at level 25).
Local Notation "'?' n" := (@RGet n RIgnore) (only parsing, at level 25).
Local Notation "'?!' n" := (@RGet n RConst) (only parsing, at level 25).
Local Notation "'#'" := RIgnore (only parsing, at level 0).

Reify Pattern patterns_simple_typ += (!! nat)  => (tyBase0 tyNat).
Reify Pattern patterns_simple_typ += (!! bool) => (tyBase0 tyBool).
Reify Pattern patterns_simple_typ += (!! Prop) => (@tyProp typ').
Reify Pattern patterns_simple_typ += (@RImpl (@RGet 0 RIgnore) (@RGet 1 RIgnore)) => (fun (a b : function (CCall reify_simple_typ)) => tyArr a b).

Reify Pattern patterns_simple += (@RGet 0 RConst) => (fun (n : @id nat) => @Inj typ func (N n)).
Reify Pattern patterns_simple += (!! plus) => (Inj (typ:=typ) Plus).
Reify Pattern patterns_simple += (!! NPeano.Nat.ltb) => (Inj (typ:=typ) Lt).
Reify Pattern patterns_simple += (!! @eq @ ?0) =>
(fun (t : function (CCall reify_simple_typ)) => Inj (typ:=typ) (Eq t)).
Reify Pattern patterns_simple += (RPi (?0) (?1)) =>
  (fun (t : function (CCall reify_simple_typ))
       (b : function (CCall reify_simple)) =>
     (App (Inj (All t)) (Abs t b))).
Reify Pattern patterns_simple += (!! @ex @ ?0) =>
  (fun (t : function (CCall reify_simple_typ)) => Inj (typ:=typ) (Ex t)).
Reify Pattern patterns_simple += (!! and) => (Inj (typ:=typ) And).
Reify Pattern patterns_simple += (!! or) => (Inj (typ:=typ) Or).
Reify Pattern patterns_simple += (!! Basics.impl) => (Inj (typ:=typ) Impl).

Instance Reify_expr_simple : Reify (expr typ func) :=
{ reify_scheme := CCall reify_simple }.

Instance Reify_simple_type : Reify typ :=
{ reify_scheme := CCall reify_simple_typ }.

Ltac reify_typ trm :=
  let k e :=
      refine e
  in
  reify_expr reify_simple_typ k [[ True ]] [[ trm ]].

Ltac reify trm :=
  let k e :=
      refine e
  in
  reify_expr reify_simple k [[ True ]] [[ trm ]].

Ltac reify_simple trm k :=
  reify_expr reify_simple k [[ True ]] [[ trm ]].

Definition test_typ : typ.
  reify_typ (nat -> nat).
Defined.
Print test_typ.

Definition test_typ_2 : typ.
  reify_typ ((nat -> nat) -> nat -> (nat -> nat -> nat -> nat)).
Defined.
Print test_typ_2.

Definition test_1 : expr typ func.
  reify (0 = 0).
Defined.
Print test_1.

Definition test_2 : expr typ func.
  reify ((NPeano.Nat.ltb 0 1) = (NPeano.Nat.ltb 0 0)).
Defined.
Print test_2.

Definition test_3 : expr typ func.
  reify ((fun x => x) 1).
Defined.
Print test_3.

Definition test_4 : expr typ func.
  reify ((fun x => x) 1).
Defined.
Print test_4.

Definition test_5 : expr typ func.
  reify ((fun x y => x) 1 3).
Defined.
Print test_5.

Definition test_6 : expr typ func.
  reify ((fun x : nat => x) = (fun y : nat => y)).
Defined.
Print test_6.

Definition test_7 : expr typ func.
  reify (forall x : nat, 1 = 1 -> (x + 1) = 1).
Defined.
Print test_7.

(** Something that doesn't fit **)
Definition id T (x : T) : T := x.

Definition test_fail : expr typ func.
  reify (id nat 0).
Defined.
Print test_fail.

Definition foo : nat := 6.
Reify Seed Typed Table table_terms += 1 => [[ MSimple.tyNat , foo ]].

Definition test_table : expr typ func.
  reify (foo).
Defined.
Print test_table.


(** * The Subject Reduction Property. *)
Require Import PTS_base.
Require Import PTS_term.
Require Import PTS_red.
Require Import PTS_env.
Require Import PTS_type.
Require Import List.

Module Type ut_sr_mod  (X:term_sig) (Y:pts_sig X) (TM:ut_term_mod X) (EM:ut_env_mod X TM) (RM: ut_red_mod X TM).
 Include (ut_typ_mod X Y TM EM RM).
  Import TM EM RM.
Open Scope UT_scope.

(** In order to prove SR, we need to be able to talk
about reduction inside a context. *)

Reserved Notation " a →e b " (at level 20).
Reserved Notation " a →→e b "(at level 20).
Reserved Notation " a ≡e b " (at level 20).

(* How to deal with Beta reduction in the context *)
Inductive Beta_env : Env -> Env -> Prop :=
 | Beta_env_hd   : forall A B Γ , A →  B  -> (A::Γ) →e (B::Γ)
 | Beta_env_cons : forall A Γ Γ', Γ →e Γ' -> (A::Γ) →e (A::Γ')
where " E →e F " := (Beta_env E F) : UT_scope.

Inductive Betas_env : Env -> Env -> Prop :=
 | Betas_env_refl  : forall Γ       , Γ →→e Γ
 | Betas_env_Beta  : forall Γ Γ'    , Γ →e Γ'  -> Γ →→e Γ'
 | Betas_env_trans : forall Γ Γ' Γ'', Γ →→e Γ' -> Γ' →→e Γ'' -> Γ →→e Γ''
where " E →→e F" := (Betas_env E F) : UT_scope.

Inductive Betac_env : Env -> Env -> Prop :=
 | Betac_env_Betas : forall Γ Γ'    , Γ →→e Γ' -> Γ ≡e Γ'
 | Betac_env_sym   : forall Γ Γ'    , Γ ≡e  Γ' -> Γ' ≡e Γ
 | Betac_env_trans : forall Γ Γ' Γ'', Γ ≡e  Γ' -> Γ' ≡e Γ'' -> Γ ≡e Γ''
where "E ≡e F" := (Betac_env E F) : UT_scope.

Hint Constructors Beta_env Betas_env Betac_env.

(** Some basic properties of Beta inside context.*)
Lemma Betas_env_nil : forall Γ, nil →→e Γ -> Γ = nil.
intros. remember (@nil Term) as N. revert HeqN.
induction H; intros; subst; try discriminate.
trivial. inversion H. rewrite IHBetas_env1 in *; trivial.
intuition.
Qed.

Lemma Betas_env_nil2 : forall Γ, Γ →→e nil -> Γ = nil.
intros. remember (@nil Term) as N. revert HeqN.
induction H; intros; subst; try discriminate.
trivial. inversion H. rewrite IHBetas_env2 in *; trivial.
intuition.
Qed.

Lemma Betas_env_inv :forall A B Γ Γ', (A::Γ)  →→e ( B::Γ') -> A →→ B /\ Γ →→e Γ'.
intros. remember (A::Γ) as Γ1; remember (B::Γ') as Γ2.
revert A B Γ Γ' HeqΓ1 HeqΓ2. induction H; intros; subst; try discriminate.
injection HeqΓ2; intros; subst; clear HeqΓ2. intuition.
inversion H; subst; clear H.  intuition. intuition.
destruct Γ'. apply Betas_env_nil in H0. discriminate.
destruct (IHBetas_env1 A t Γ0 Γ') as ( ? & ?); trivial. clear IHBetas_env1.
destruct (IHBetas_env2 t B Γ' Γ'0) as ( ? & ?); trivial. clear IHBetas_env2.
eauto.
Qed.

Lemma Betas_env_hd : forall A B Γ , A→→B -> (A::Γ) →→e (B::Γ).
intros.
induction H.
constructor.
constructor; apply Beta_env_hd; trivial.
apply Betas_env_trans with (N::Γ); intuition.
Qed.

Lemma Betas_env_cons : forall A Γ Γ', Γ →→e Γ' -> (A::Γ) →→e (A::Γ').
intros.
induction H.
constructor.
constructor; apply Beta_env_cons; trivial.
apply Betas_env_trans with (A::Γ'); trivial.
Qed.

Lemma Betas_env_comp : forall A B Γ Γ', A→→B -> Γ →→e Γ' -> (A::Γ) →→e (B::Γ').
intros.
apply Betas_env_trans with (A::Γ').
apply Betas_env_cons; trivial.
apply Betas_env_hd; trivial.
Qed.

(** There is two ways to prove SR: either we prove that reduction inside the
context and inside the term "at the same time" is valid, or we first do this
for the context only at first, but we need to weaken a little the hypothesis.
  Here we choose the second solution.*)
(** First step toward full SR: if we do reductions inside the context
  of a valid judgment, and if the resulting context is well-formed,
  then the judgement is still valid with the resulting context. *)
Lemma Beta_env_sound :   forall Γ M T, Γ ⊢ M : T -> forall Γ', Γ' ⊣ -> Γ →e Γ' -> Γ' ⊢ M : T .
induction 1; intros.
(**)
constructor; trivial.
(**)
revert A v H0 H H1.
induction H2; intros. destruct H0 as (AA&  ? & ?). inversion H3; subst; clear H3.
inversion H1; subst; clear H1. inversion H2; subst; clear H2.
apply Cnv with ( B  ↑ 1 ) s. intuition.
constructor. econstructor;apply H1. exists B; intuition.
change !s with !s ↑ 1. apply thinning with s0 ;trivial.
constructor. trivial. exists AA; intuition.
destruct H0 as (AA&  ? & ?).  inversion H3; subst; clear H3.
constructor. trivial. exists A; intuition.
change (S(S n)) with (1+S n). change #(S n) with (#n  ↑ 1).
rewrite <- lift_lift.
inversion H1; subst; clear H1.
apply thinning with s; trivial. apply IHBeta_env. eauto. inversion H; subst; clear H. eauto.
eauto.
(**)
econstructor. apply H. apply IHtyp1; eauto. apply IHtyp2; eauto.
(**)
econstructor. apply H. apply IHtyp1; eauto. apply IHtyp2; eauto. apply IHtyp3; eauto.
(**)
econstructor.  apply IHtyp1; eauto. apply IHtyp2; eauto.
(**)
econstructor. apply H. eapply IHtyp1; eauto. apply IHtyp2; eauto.
Qed.

(** Same with expansion in the context.*)
Lemma Beta_env_sound_up :   forall Γ M T, Γ ⊢ M : T -> forall Γ', Γ' ⊣ -> Γ' →e Γ -> Γ' ⊢ M : T  .
induction 1; intros.
(**)
constructor; trivial.
(**)
revert A v H0 H H1. induction H2; intros. destruct H0 as (AA&  ? & ?). inversion H3; subst; clear H3.
inversion H1; subst; clear H1. inversion H2; subst; clear H2.
apply Cnv with ( A  ↑ 1 ) s. intuition.
constructor. econstructor; apply H1.  exists A; intuition.
change !s with !s ↑ 1. apply thinning with s0 ;trivial.
constructor. trivial. exists AA; intuition.
destruct H0 as (AA&  ? & ?).  inversion H3; subst; clear H3.
constructor. trivial. exists A; intuition.
change (S(S n)) with (1+S n). change #(S n) with (#n  ↑ 1).
rewrite <- lift_lift.
inversion H1; subst; clear H1.
apply thinning with s; trivial. apply IHBeta_env. exists AA; intuition. inversion H; subst; clear H. eauto.
eauto.
(**)
econstructor. apply H. apply IHtyp1; eauto. apply IHtyp2; eauto.
(**)
econstructor. apply H. apply IHtyp1; eauto. apply IHtyp2; eauto. apply IHtyp3; eauto.
(**)
econstructor.  apply IHtyp1; eauto. apply IHtyp2; eauto.
(**)
econstructor. apply H. eapply IHtyp1; eauto. apply IHtyp2; eauto.
Qed.

(** Second Step: reduction in the term.*)
Lemma Beta_sound : forall Γ M T, Γ ⊢ M : T -> forall N, M → N ->  Γ ⊢ N : T.
induction 1; intros.
(*1*)
inversion H1.
(*2*)
inversion H1.
(*3*)
inversion H2; subst; clear H2. econstructor; eauto. econstructor. apply H. intuition.
eapply Beta_env_sound. apply H1. eauto. intuition.
(*4*)
inversion H3; subst; clear H3. eauto.
apply Cnv with ( Π (A'), B) s3. eauto.
econstructor. apply H. eauto.
eapply Beta_env_sound. apply H1. econstructor. eauto. intuition.
eapply Beta_env_sound. apply H2. econstructor. eauto. intuition.
econstructor; eauto.
(*5*)
inversion H1; subst; clear H1.
assert (exists u, Γ ⊢ Π(A),B : !u). apply TypeCorrect in H.
destruct H. destruct H; discriminate. trivial.
destruct H1. apply gen_pi in H1 as (s & t & u & h); decompose [and] h; clear h.
apply gen_la in H  as (u1 & u2 & u3 & D & ? & ? & ? & ? & ?).
apply PiInj in H as (? & ?).
eapply Cnv with (s := t). eapply Betac_subst2. apply Betac_sym. apply H9.
eapply substitution. apply H7. eapply Cnv. apply H. apply H0. apply H6. constructor.
eauto. change !t with (!t  [ ← N] ). eapply substitution. apply H5. apply H0. constructor.
eauto.

econstructor.  eauto. trivial.
assert (exists u, Γ ⊢ Π(A),B : !u). apply TypeCorrect in H.
destruct H. destruct H; discriminate. trivial.
destruct H1. apply gen_pi in H1 as (s & t & u & h); decompose [and] h; clear h.
apply Cnv with (B [← N']) t. apply Betac_subst. auto.
econstructor. apply H. eauto.
change !t with (!t  [ ← N] ). eapply substitution. apply H6. apply H0. constructor.
eauto.
(**)
eauto.
Qed.

(** With both lemmas, we can now prove the full SR.*)
Lemma SubjectRed : forall Γ M T, Γ ⊢ M : T->
  forall N , M →→ N -> Γ ⊢ N : T.
intros. induction H0.
trivial. eapply Beta_sound.
apply H. trivial. intuition.
Qed.

(** Reduction in the type is valid.*)
Lemma Betas_typ_sound : forall Γ M T, Γ ⊢ M : T ->
 forall T', T →→ T' -> Γ ⊢ M : T'.
intros.
assert ((exists s, T = !s )\/ exists s,  Γ ⊢ T : !s ) by ( apply TypeCorrect in H; intuition).
destruct H1 as [[s Hs]|[s Hs]].
rewrite Hs in *. apply Betas_S in H0. rewrite H0; trivial.
apply Cnv with T s; intuition.
apply SubjectRed with T; intuition.
Qed.

(** Wellformation of a context after reduction.*)
Lemma Beta_env_sound2 : forall Γ Γ', Γ ⊣ -> Γ →e Γ' -> Γ' ⊣.
intros. induction H0; intuition.
inversion H; subst; clear H.
econstructor. eapply Beta_sound. apply H2. trivial.
inversion H; subst; clear H.
econstructor. eapply Beta_env_sound. apply H2.  apply IHBeta_env.
eauto. trivial.
Qed.

Lemma Betas_env_sound2 : forall Γ Γ', Γ ⊣ -> Γ →→e Γ' -> Γ' ⊣.
intros.
induction H0; intuition.
eapply Beta_env_sound2. apply H. trivial.
Qed.

Lemma Betas_env_sound :   forall Γ M T, Γ ⊢ M : T-> forall Γ', Γ →→e Γ' -> Γ' ⊢ M : T.
intros.
induction H0; intuition.
eapply Beta_env_sound. apply H. apply Beta_env_sound2 with Γ. apply wf_typ in H. trivial.
trivial. trivial.
Qed.

Lemma Betas_env_sound_up :   forall Γ M T, Γ ⊢ M : T -> forall Γ', Γ' ⊣ -> Γ' →→e Γ -> Γ' ⊢ M : T.
intros. revert M T H H0 .
induction H1; intros.
trivial.
eapply Beta_env_sound_up. apply H0. trivial. trivial.
apply IHBetas_env1. apply IHBetas_env2. trivial. apply Betas_env_sound2 with Γ; trivial.
trivial.
Qed.

(** In its complete form: SubjectReduction. *)
Lemma Subject_Reduction :  forall Γ M T, Γ ⊢ M : T ->
  forall Γ' N T', M →→ N -> Γ →→e Γ' ->  T →→ T' -> Γ' ⊢ N : T'.
intros.
apply Betas_typ_sound with T; intuition.
apply Betas_env_sound with Γ; intuition.
apply SubjectRed with M; intuition.
Qed.

End ut_sr_mod.


Require Import Coq.Lists.List.
Require C.
Require Run.

Import ListNotations.
Import C.Notations.

Fixpoint map_seq {E : Effect.t} {A B : Type} (f : A -> C.t E B) (l : list A)
  : C.t E (list B) :=
  match l with
  | [] => ret []
  | x :: l =>
    let! y := f x in
    let! l := map_seq f l in
    ret (y :: l)
  end.

Fixpoint map_par {E : Effect.t} {A B : Type} (f : A -> C.t E B) (l : list A)
  : C.t E (list B) :=
  match l with
  | [] => ret []
  | x :: l =>
    let! y_l := join (f x) (map_par f l) in
    let (y, l) := y_l in
    ret (y :: l)
  end.

Fixpoint iter_seq {E : Effect.t} {A : Type} (f : A -> C.t E unit) (l : list A)
  : C.t E unit :=
  match l with
  | [] => ret tt
  | x :: l =>
    do! f x in
    iter_seq f l
  end.

Fixpoint iter_par {E : Effect.t} {A : Type} (f : A -> C.t E unit) (l : list A)
  : C.t E unit :=
  match l with
  | [] => ret tt
  | x :: l =>
    let! _ : unit * unit := join (f x) (iter_par f l) in
    ret tt
  end.

Module Run.
  Import Io.Run.

  Fixpoint map_seq {E : Effect.t} {A B C : Type} {f : A -> C.t E B}
    (l : list C) (x : C -> A) (y : C -> B)
    (run_f : forall (v : C), Run.t (f (x v)) (y v)) {struct l}
    : Run.t (map_seq f (List.map x l)) (List.map y l).
    destruct l as [|v l].
    - apply Ret.
    - apply (Let (run_f v)).
      apply (Let (map_seq _ _ _ _ _ l x y run_f)).
      apply Ret.
  Defined.

  Definition map_seq_id {E : Effect.t} {A B : Type} {f : A -> C.t E B}
    (l : list B) (x : B -> A) (run_f : forall (v : B), Run.t (f (x v)) v)
    : Run.t (List.map_seq f (List.map x l)) l.
    rewrite <- List.map_id.
    now apply map_seq.
  Defined.

  Fixpoint map_par {E : Effect.t} {A B C : Type} {f : A -> C.t E B}
    (l : list C) (x : C -> A) (y : C -> B)
    (run_f : forall (v : C), Run.t (f (x v)) (y v)) {struct l}
    : Run.t (map_par f (List.map x l)) (List.map y l).
    destruct l as [|v l].
    - apply Ret.
    - eapply Let. apply (Join (run_f v) (map_par _ _ _ _ _ l x y run_f)).
      apply Ret.
  Defined.

  Definition map_par_id {E : Effect.t} {A B : Type} {f : A -> C.t E B}
    (l : list B) (x : B -> A) (run_f : forall (v : B), Run.t (f (x v)) v)
    : Run.t (List.map_par f (List.map x l)) l.
    rewrite <- List.map_id.
    now apply map_par.
  Defined.
End Run.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C P : Universe, ((wd_ O E /\ (wd_ O Eprime /\ (wd_ O A /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A C /\ (wd_ B O /\ (wd_ C P /\ (wd_ O Eprime /\ (wd_ O E /\ (wd_ A C /\ (col_ O E A /\ (col_ O E B /\ (col_ O Eprime C /\ (col_ C P C /\ col_ O E C))))))))))))))) -> col_ E A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A C Aprime Bprime Cprime : Universe, ((wd_ P Q /\ (wd_ P Aprime /\ (wd_ P Bprime /\ (wd_ P Cprime /\ (wd_ A Aprime /\ (wd_ C Bprime /\ (wd_ C Cprime /\ (wd_ A C /\ (wd_ C P /\ (wd_ A P /\ (col_ P Q Aprime /\ (col_ P Q Bprime /\ (col_ P Q Cprime /\ col_ A C C))))))))))))) -> col_ P Cprime Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C O Oprime Cprime Bprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ O Cprime /\ (wd_ Oprime Cprime /\ (wd_ O Bprime /\ (wd_ Oprime Bprime /\ (wd_ O Oprime /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Oprime B /\ (wd_ Oprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (col_ Bprime Oprime A /\ (col_ Oprime Bprime Cprime /\ (col_ Oprime B C /\ (col_ Bprime A C /\ col_ Cprime A B)))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Rewriter.Util.Notations.
Local Set Universe Polymorphism.

(** [x <- f ; C] encodes a call to function [f] with [C] as the
  continuation. In [C], [x] refers to the output of [f]. *)

Delimit Scope cps_scope with cps.

(* [cpscall] is a marker to get Coq to print code using this notation only when it was actually used *)
Definition cpscall {R} (f:forall{T}(continuation:R->T),T) {T} (continuation:R->T)
:= @f T continuation.
Notation "x' <- v ; C" := (cpscall v%cps (fun x' => C%cps)) : cps_scope.

(** A value of type [~>R] accepts a continuation that takes an
     argument of type [R].  It is meant to be used in [Definition] and
     such; for example:
<<
     Definition add_cps (a b:nat) : ~> nat.
>>
     The return type of the continuation is not yet specified; every
     [~> R] is universally quantified over the possible return types
     of the continuations that it can be applied to.
 *)
Notation "~> R" := (forall T (_:R->T), T) : type_scope.

(** The type [A ~> R] contains functions that takes an argument of
  type [A] and pass a value of type [R] to the continuation. Functions
  that take multiple arguments can be encoded as [A -> B ~> C] or [A
  ~> B ~>C] -- the first form requires both arguments to be specified
  before its output can be CPS-bound, the latter must be bound once it
  is partially applied to one argument. *)
Notation "A ~> R" := (A -> ~>R) : type_scope.

(* [cpsreturn] is a marker to get Coq to print loop notations before a [return] *)
Definition cpsreturn {T} (x:T) := x.
(** [return x] passes [x] to the continuation implicit in the previous notations. *)
Notation "'return' x" := (cpsreturn (fun T (continuation:_->T) => continuation x)) : cps_scope.

Definition cpsbind {A B} (v:~> A) (f:A ~> B) : ~> B
  := fun T k => (a <- v; fa <- f a; k fa)%cps.
Notation "x' <--- v ; C" := (cpsbind v%cps (fun x' => C%cps)) : cps_scope.

Definition cps_option_bind {A B} (v:~> option A) (f:A ~> option B) : ~> option B
  := cpsbind v (fun x' T k => match x' with Some x' => f x' T k | None => k None end).
Notation "x' <-- v ; C" := (cps_option_bind v%cps (fun x' => C%cps)) : cps_scope.

Module CPSBindNotations.
  Notation "x' <- v ; C" := (cpsbind v%cps (fun x' => C%cps)) : cps_scope.
End CPSBindNotations.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal16.

Derive Show for bool.

              Derive Arbitrary for bool.

              Instance Dec_Eq_bool : Dec_Eq bool.

              Proof. dec_eq. Qed.
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq bool (even (plus (Zero) (Zero))) (true)).
Admitted.
QuickChick lfind_hyp_test.


(*|
###################################################################
Coq: How to refer to the types generated by a specific constructor?
###################################################################

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

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

For example, if I define a function from ``nat`` to ``nat``, it would
be
|*)

Definition plusfive (a : nat) : nat := a + 5.

(*|
However, I would like to define a function whose arguments are
``nat``\ s constructed using the ``S`` constructor (i.e. nonzero) is
that possible to directly specify as a type? something like

.. code-block:: coq

    Definition plusfive (a : nat.S) : nat := a + 5.

(I know that for this case I could also add an argument with a proof
that ``a`` is nonzero, but I am wondering if it is possible to
directly name the type based on the ``S`` constructor).
|*)

(*|
Answer
******

Functions have to be complete, so you will have to use some subtype
instead of ``nat``, or add an argument that reduces input space, for
instance ``(H: a <> 0)``
|*)

Reset Initial. (* .none *)
Definition plusfive (a : nat) (H : a <> 0) :=
  match a as e return a = e -> _ with
  | S _ => fun _  => a + 5
  | _   => fun H0 => match (H H0) with end
  end eq_refl.

(*|
However, these kinds of tricks have been discovered to be very
cumbersome to work with in large developments, and often one instead
uses complete functions on the base type that return dummy values for
bad input values, and prove that the function is called with correct
arguments separately from the function definition. See for example how
division is defined in the standard library.
|*)

Require Import Nat.
Print div. (* .unfold *)

(*|
So ``Compute (div 1 0).`` gives you ``0``.

The nice thing is that you can use ``div`` in expressions directly,
without having to interleave proofs that the denominator is non-zero.
Proving that an expression is correct is then done *after* it has been
defined, not at the same time.
|*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*i 	$Id$	 i*)

Require Import Bool.
Require Import Sumbool.
Require Import NArith.
Require Import Ndigits.
Require Import Ndec.
Require Import Map.
Require Import Fset.

Section MapAxioms.

  Variables A B C : Type.

  Lemma eqm_sym : forall f f':ad -> option A, eqm A f f' -> eqm A f' f.
  Proof.
    unfold eqm in |- *. intros. rewrite H. reflexivity.
  Qed.

  Lemma eqm_refl : forall f:ad -> option A, eqm A f f.
  Proof.
    unfold eqm in |- *. trivial.
  Qed.

  Lemma eqm_trans :
   forall f f' f'':ad -> option A, eqm A f f' -> eqm A f' f'' -> eqm A f f''.
  Proof.
    unfold eqm in |- *. intros. rewrite H. exact (H0 a).
  Qed.

  Definition eqmap (m m':Map A) := eqm A (MapGet A m) (MapGet A m').

  Lemma eqmap_sym : forall m m':Map A, eqmap m m' -> eqmap m' m.
  Proof.
    intros. unfold eqmap in |- *. apply eqm_sym. assumption.
  Qed.

  Lemma eqmap_refl : forall m:Map A, eqmap m m.
  Proof.
    intros. unfold eqmap in |- *. apply eqm_refl.
  Qed.

  Lemma eqmap_trans :
   forall m m' m'':Map A, eqmap m m' -> eqmap m' m'' -> eqmap m m''.
  Proof.
    intros. exact (eqm_trans (MapGet A m) (MapGet A m') (MapGet A m'') H H0).
  Qed.

  Lemma MapPut_as_Merge :
   forall (m:Map A) (a:ad) (y:A),
     eqmap (MapPut A m a y) (MapMerge A m (M1 A a y)).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapPut_semantics A m a y a0).
    rewrite (MapMerge_semantics A m (M1 A a y) a0). unfold MapGet at 2.
    elim (sumbool_of_bool (Neqb a a0)); intro H; rewrite H; reflexivity.
  Qed.

  Lemma MapPut_ext :
   forall m m':Map A,
     eqmap m m' ->
     forall (a:ad) (y:A), eqmap (MapPut A m a y) (MapPut A m' a y).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapPut_semantics A m' a y a0).
    rewrite (MapPut_semantics A m a y a0).
    case (Neqb a a0); [ reflexivity | apply H ].
  Qed.

  Lemma MapPut_behind_as_Merge :
   forall (m:Map A) (a:ad) (y:A),
     eqmap (MapPut_behind A m a y) (MapMerge A (M1 A a y) m).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapPut_behind_semantics A m a y a0).
    rewrite (MapMerge_semantics A (M1 A a y) m a0). reflexivity.
  Qed.

  Lemma MapPut_behind_ext :
   forall m m':Map A,
     eqmap m m' ->
     forall (a:ad) (y:A),
       eqmap (MapPut_behind A m a y) (MapPut_behind A m' a y).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapPut_behind_semantics A m' a y a0).
    rewrite (MapPut_behind_semantics A m a y a0). rewrite (H a0). reflexivity.
  Qed.

  Lemma MapMerge_empty_m_1 : forall m:Map A, MapMerge A (M0 A) m = m.
  Proof.
    trivial.
  Qed.

  Lemma MapMerge_empty_m : forall m:Map A, eqmap (MapMerge A (M0 A) m) m.
  Proof.
    unfold eqmap, eqm in |- *. trivial.
  Qed.

  Lemma MapMerge_m_empty_1 : forall m:Map A, MapMerge A m (M0 A) = m.
  Proof.
    simple induction m; trivial.
  Qed.

  Lemma MapMerge_m_empty : forall m:Map A, eqmap (MapMerge A m (M0 A)) m.
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite MapMerge_m_empty_1. reflexivity.
  Qed.

  Lemma MapMerge_empty_l :
   forall m m':Map A, eqmap (MapMerge A m m') (M0 A) -> eqmap m (M0 A).
  Proof.
    unfold eqmap, eqm in |- *. intros. cut (MapGet A (MapMerge A m m') a = MapGet A (M0 A) a).
    rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a); trivial.
    intros. discriminate H0.
    exact (H a).
  Qed.

  Lemma MapMerge_empty_r :
   forall m m':Map A, eqmap (MapMerge A m m') (M0 A) -> eqmap m' (M0 A).
  Proof.
    unfold eqmap, eqm in |- *. intros. cut (MapGet A (MapMerge A m m') a = MapGet A (M0 A) a).
    rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a); trivial.
    exact (H a).
  Qed.

  Lemma MapMerge_assoc :
   forall m m' m'':Map A,
     eqmap (MapMerge A (MapMerge A m m') m'')
       (MapMerge A m (MapMerge A m' m'')).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A (MapMerge A m m') m'' a).
    rewrite (MapMerge_semantics A m (MapMerge A m' m'') a). rewrite (MapMerge_semantics A m m' a).
    rewrite (MapMerge_semantics A m' m'' a).
    case (MapGet A m'' a); case (MapGet A m' a); trivial.
  Qed.

  Lemma MapMerge_idempotent : forall m:Map A, eqmap (MapMerge A m m) m.
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A m m a).
    case (MapGet A m a); trivial.
  Qed.

  Lemma MapMerge_ext :
   forall m1 m2 m'1 m'2:Map A,
     eqmap m1 m'1 ->
     eqmap m2 m'2 -> eqmap (MapMerge A m1 m2) (MapMerge A m'1 m'2).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A m1 m2 a).
    rewrite (MapMerge_semantics A m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity.
  Qed.

  Lemma MapMerge_ext_l :
   forall m1 m'1 m2:Map A,
     eqmap m1 m'1 -> eqmap (MapMerge A m1 m2) (MapMerge A m'1 m2).
  Proof.
    intros. apply MapMerge_ext. assumption.
    apply eqmap_refl.
  Qed.

  Lemma MapMerge_ext_r :
   forall m1 m2 m'2:Map A,
     eqmap m2 m'2 -> eqmap (MapMerge A m1 m2) (MapMerge A m1 m'2).
  Proof.
    intros. apply MapMerge_ext. apply eqmap_refl.
    assumption.
  Qed.

  Lemma MapMerge_RestrTo_l :
   forall m m' m'':Map A,
     eqmap (MapMerge A (MapDomRestrTo A A m m') m'')
       (MapDomRestrTo A A (MapMerge A m m'') (MapMerge A m' m'')).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A (MapDomRestrTo A A m m') m'' a).
    rewrite (MapDomRestrTo_semantics A A m m' a).
    rewrite
     (MapDomRestrTo_semantics A A (MapMerge A m m'') (MapMerge A m' m'') a)
     .
    rewrite (MapMerge_semantics A m' m'' a). rewrite (MapMerge_semantics A m m'' a).
    case (MapGet A m'' a); case (MapGet A m' a); reflexivity.
  Qed.

  Lemma MapRemove_as_RestrBy :
   forall (m:Map A) (a:ad) (y:B),
     eqmap (MapRemove A m a) (MapDomRestrBy A B m (M1 B a y)).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapRemove_semantics A m a a0).
    rewrite (MapDomRestrBy_semantics A B m (M1 B a y) a0). elim (sumbool_of_bool (Neqb a a0)).
    intro H. rewrite H. rewrite (Neqb_complete a a0 H). rewrite (M1_semantics_1 B a0 y).
    reflexivity.
    intro H. rewrite H. rewrite (M1_semantics_2 B a a0 y H). reflexivity.
  Qed.

  Lemma MapRemove_ext :
   forall m m':Map A,
     eqmap m m' -> forall a:ad, eqmap (MapRemove A m a) (MapRemove A m' a).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapRemove_semantics A m' a a0).
    rewrite (MapRemove_semantics A m a a0).
    case (Neqb a a0); [ reflexivity | apply H ].
  Qed.

  Lemma MapDomRestrTo_empty_m_1 :
   forall m:Map B, MapDomRestrTo A B (M0 A) m = M0 A.
  Proof.
    trivial.
  Qed.

  Lemma MapDomRestrTo_empty_m :
   forall m:Map B, eqmap (MapDomRestrTo A B (M0 A) m) (M0 A).
  Proof.
    unfold eqmap, eqm in |- *. trivial.
  Qed.

  Lemma MapDomRestrTo_m_empty_1 :
   forall m:Map A, MapDomRestrTo A B m (M0 B) = M0 A.
  Proof.
    simple induction m; trivial.
  Qed.

  Lemma MapDomRestrTo_m_empty :
   forall m:Map A, eqmap (MapDomRestrTo A B m (M0 B)) (M0 A).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_m_empty_1 m). reflexivity.
  Qed.

  Lemma MapDomRestrTo_assoc :
   forall (m:Map A) (m':Map B) (m'':Map C),
     eqmap (MapDomRestrTo A C (MapDomRestrTo A B m m') m'')
       (MapDomRestrTo A B m (MapDomRestrTo B C m' m'')).
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDomRestrTo_semantics A C (MapDomRestrTo A B m m') m'' a).
    rewrite (MapDomRestrTo_semantics A B m m' a).
    rewrite (MapDomRestrTo_semantics A B m (MapDomRestrTo B C m' m'') a).
    rewrite (MapDomRestrTo_semantics B C m' m'' a).
    case (MapGet C m'' a); case (MapGet B m' a); trivial.
  Qed.

  Lemma MapDomRestrTo_idempotent :
   forall m:Map A, eqmap (MapDomRestrTo A A m m) m.
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A A m m a).
    case (MapGet A m a); trivial.
  Qed.

  Lemma MapDomRestrTo_Dom :
   forall (m:Map A) (m':Map B),
     eqmap (MapDomRestrTo A B m m') (MapDomRestrTo A unit m (MapDom B m')).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A B m m' a).
    rewrite (MapDomRestrTo_semantics A unit m (MapDom B m') a).
    elim (sumbool_of_bool (in_FSet a (MapDom B m'))). intro H.
    elim (MapDom_semantics_2 B m' a H). intros y H0. rewrite H0. unfold in_FSet, in_dom in H.
    generalize H. case (MapGet unit (MapDom B m') a); trivial. intro H1. discriminate H1.
    intro H. rewrite (MapDom_semantics_4 B m' a H). unfold in_FSet, in_dom in H.
    generalize H. case (MapGet unit (MapDom B m') a); trivial.
    intros H0 H1. discriminate H1.
  Qed.

  Lemma MapDomRestrBy_empty_m_1 :
   forall m:Map B, MapDomRestrBy A B (M0 A) m = M0 A.
  Proof.
    trivial.
  Qed.

  Lemma MapDomRestrBy_empty_m :
   forall m:Map B, eqmap (MapDomRestrBy A B (M0 A) m) (M0 A).
  Proof.
    unfold eqmap, eqm in |- *. trivial.
  Qed.

  Lemma MapDomRestrBy_m_empty_1 :
   forall m:Map A, MapDomRestrBy A B m (M0 B) = m.
  Proof.
    simple induction m; trivial.
  Qed.

  Lemma MapDomRestrBy_m_empty :
   forall m:Map A, eqmap (MapDomRestrBy A B m (M0 B)) m.
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_m_empty_1 m). reflexivity.
  Qed.

  Lemma MapDomRestrBy_Dom :
   forall (m:Map A) (m':Map B),
     eqmap (MapDomRestrBy A B m m') (MapDomRestrBy A unit m (MapDom B m')).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A B m m' a).
    rewrite (MapDomRestrBy_semantics A unit m (MapDom B m') a).
    elim (sumbool_of_bool (in_FSet a (MapDom B m'))). intro H.
    elim (MapDom_semantics_2 B m' a H). intros y H0. rewrite H0.
    unfold in_FSet, in_dom in H. generalize H. case (MapGet unit (MapDom B m') a); trivial.
    intro H1. discriminate H1.
    intro H. rewrite (MapDom_semantics_4 B m' a H). unfold in_FSet, in_dom in H.
    generalize H. case (MapGet unit (MapDom B m') a); trivial.
    intros H0 H1. discriminate H1.
  Qed.

  Lemma MapDomRestrBy_m_m_1 :
   forall m:Map A, eqmap (MapDomRestrBy A A m m) (M0 A).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A A m m a).
    case (MapGet A m a); trivial.
  Qed.

  Lemma MapDomRestrBy_By :
   forall (m:Map A) (m' m'':Map B),
     eqmap (MapDomRestrBy A B (MapDomRestrBy A B m m') m'')
       (MapDomRestrBy A B m (MapMerge B m' m'')).
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDomRestrBy_semantics A B (MapDomRestrBy A B m m') m'' a).
    rewrite (MapDomRestrBy_semantics A B m m' a).
    rewrite (MapDomRestrBy_semantics A B m (MapMerge B m' m'') a).
    rewrite (MapMerge_semantics B m' m'' a).
    case (MapGet B m'' a); case (MapGet B m' a); trivial.
  Qed.

  Lemma MapDomRestrBy_By_comm :
   forall (m:Map A) (m':Map B) (m'':Map C),
     eqmap (MapDomRestrBy A C (MapDomRestrBy A B m m') m'')
       (MapDomRestrBy A B (MapDomRestrBy A C m m'') m').
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDomRestrBy_semantics A C (MapDomRestrBy A B m m') m'' a).
    rewrite (MapDomRestrBy_semantics A B m m' a).
    rewrite (MapDomRestrBy_semantics A B (MapDomRestrBy A C m m'') m' a).
    rewrite (MapDomRestrBy_semantics A C m m'' a).
    case (MapGet C m'' a); case (MapGet B m' a); trivial.
  Qed.

  Lemma MapDomRestrBy_To :
   forall (m:Map A) (m':Map B) (m'':Map C),
     eqmap (MapDomRestrBy A C (MapDomRestrTo A B m m') m'')
       (MapDomRestrTo A B m (MapDomRestrBy B C m' m'')).
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDomRestrBy_semantics A C (MapDomRestrTo A B m m') m'' a).
    rewrite (MapDomRestrTo_semantics A B m m' a).
    rewrite (MapDomRestrTo_semantics A B m (MapDomRestrBy B C m' m'') a).
    rewrite (MapDomRestrBy_semantics B C m' m'' a).
    case (MapGet C m'' a); case (MapGet B m' a); trivial.
  Qed.

  Lemma MapDomRestrBy_To_comm :
   forall (m:Map A) (m':Map B) (m'':Map C),
     eqmap (MapDomRestrBy A C (MapDomRestrTo A B m m') m'')
       (MapDomRestrTo A B (MapDomRestrBy A C m m'') m').
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDomRestrBy_semantics A C (MapDomRestrTo A B m m') m'' a).
    rewrite (MapDomRestrTo_semantics A B m m' a).
    rewrite (MapDomRestrTo_semantics A B (MapDomRestrBy A C m m'') m' a).
    rewrite (MapDomRestrBy_semantics A C m m'' a).
    case (MapGet C m'' a); case (MapGet B m' a); trivial.
  Qed.

  Lemma MapDomRestrTo_By :
   forall (m:Map A) (m':Map B) (m'':Map C),
     eqmap (MapDomRestrTo A C (MapDomRestrBy A B m m') m'')
       (MapDomRestrTo A C m (MapDomRestrBy C B m'' m')).
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDomRestrTo_semantics A C (MapDomRestrBy A B m m') m'' a).
    rewrite (MapDomRestrBy_semantics A B m m' a).
    rewrite (MapDomRestrTo_semantics A C m (MapDomRestrBy C B m'' m') a).
    rewrite (MapDomRestrBy_semantics C B m'' m' a).
    case (MapGet C m'' a); case (MapGet B m' a); trivial.
  Qed.

  Lemma MapDomRestrTo_By_comm :
   forall (m:Map A) (m':Map B) (m'':Map C),
     eqmap (MapDomRestrTo A C (MapDomRestrBy A B m m') m'')
       (MapDomRestrBy A B (MapDomRestrTo A C m m'') m').
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDomRestrTo_semantics A C (MapDomRestrBy A B m m') m'' a).
    rewrite (MapDomRestrBy_semantics A B m m' a).
    rewrite (MapDomRestrBy_semantics A B (MapDomRestrTo A C m m'') m' a).
    rewrite (MapDomRestrTo_semantics A C m m'' a).
    case (MapGet C m'' a); case (MapGet B m' a); trivial.
  Qed.

  Lemma MapDomRestrTo_To_comm :
   forall (m:Map A) (m':Map B) (m'':Map C),
     eqmap (MapDomRestrTo A C (MapDomRestrTo A B m m') m'')
       (MapDomRestrTo A B (MapDomRestrTo A C m m'') m').
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDomRestrTo_semantics A C (MapDomRestrTo A B m m') m'' a).
    rewrite (MapDomRestrTo_semantics A B m m' a).
    rewrite (MapDomRestrTo_semantics A B (MapDomRestrTo A C m m'') m' a).
    rewrite (MapDomRestrTo_semantics A C m m'' a).
    case (MapGet C m'' a); case (MapGet B m' a); trivial.
  Qed.

  Lemma MapMerge_DomRestrTo :
   forall (m m':Map A) (m'':Map B),
     eqmap (MapDomRestrTo A B (MapMerge A m m') m'')
       (MapMerge A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m'')).
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDomRestrTo_semantics A B (MapMerge A m m') m'' a).
    rewrite (MapMerge_semantics A m m' a).
    rewrite
     (MapMerge_semantics A (MapDomRestrTo A B m m'')
        (MapDomRestrTo A B m' m'') a).
    rewrite (MapDomRestrTo_semantics A B m' m'' a).
    rewrite (MapDomRestrTo_semantics A B m m'' a).
    case (MapGet B m'' a); case (MapGet A m' a); trivial.
  Qed.

  Lemma MapMerge_DomRestrBy :
   forall (m m':Map A) (m'':Map B),
     eqmap (MapDomRestrBy A B (MapMerge A m m') m'')
       (MapMerge A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m'')).
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDomRestrBy_semantics A B (MapMerge A m m') m'' a).
    rewrite (MapMerge_semantics A m m' a).
    rewrite
     (MapMerge_semantics A (MapDomRestrBy A B m m'')
        (MapDomRestrBy A B m' m'') a).
    rewrite (MapDomRestrBy_semantics A B m' m'' a).
    rewrite (MapDomRestrBy_semantics A B m m'' a).
    case (MapGet B m'' a); case (MapGet A m' a); trivial.
  Qed.

  Lemma MapDelta_empty_m_1 : forall m:Map A, MapDelta A (M0 A) m = m.
  Proof.
    trivial.
  Qed.

  Lemma MapDelta_empty_m : forall m:Map A, eqmap (MapDelta A (M0 A) m) m.
  Proof.
    unfold eqmap, eqm in |- *. trivial.
  Qed.

  Lemma MapDelta_m_empty_1 : forall m:Map A, MapDelta A m (M0 A) = m.
  Proof.
    simple induction m; trivial.
  Qed.

  Lemma MapDelta_m_empty : forall m:Map A, eqmap (MapDelta A m (M0 A)) m.
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite MapDelta_m_empty_1. reflexivity.
  Qed.

  Lemma MapDelta_nilpotent : forall m:Map A, eqmap (MapDelta A m m) (M0 A).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m a).
    case (MapGet A m a); trivial.
  Qed.

  Lemma MapDelta_as_Merge :
   forall m m':Map A,
     eqmap (MapDelta A m m')
       (MapMerge A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m)).
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite (MapDelta_semantics A m m' a).
    rewrite
     (MapMerge_semantics A (MapDomRestrBy A A m m') (
        MapDomRestrBy A A m' m) a).
    rewrite (MapDomRestrBy_semantics A A m' m a).
    rewrite (MapDomRestrBy_semantics A A m m' a).
    case (MapGet A m a); case (MapGet A m' a); trivial.
  Qed.

  Lemma MapDelta_as_DomRestrBy :
   forall m m':Map A,
     eqmap (MapDelta A m m')
       (MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m')).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a).
    rewrite
     (MapDomRestrBy_semantics A A (MapMerge A m m') (
        MapDomRestrTo A A m m') a).
    rewrite (MapDomRestrTo_semantics A A m m' a). rewrite (MapMerge_semantics A m m' a).
    case (MapGet A m a); case (MapGet A m' a); trivial.
  Qed.

  Lemma MapDelta_as_DomRestrBy_2 :
   forall m m':Map A,
     eqmap (MapDelta A m m')
       (MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m' m)).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a).
    rewrite
     (MapDomRestrBy_semantics A A (MapMerge A m m') (
        MapDomRestrTo A A m' m) a).
    rewrite (MapDomRestrTo_semantics A A m' m a). rewrite (MapMerge_semantics A m m' a).
    case (MapGet A m a); case (MapGet A m' a); trivial.
  Qed.

  Lemma MapDelta_sym :
   forall m m':Map A, eqmap (MapDelta A m m') (MapDelta A m' m).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a).
    rewrite (MapDelta_semantics A m' m a).
    case (MapGet A m a); case (MapGet A m' a); trivial.
  Qed.

  Lemma MapDelta_ext :
   forall m1 m2 m'1 m'2:Map A,
     eqmap m1 m'1 ->
     eqmap m2 m'2 -> eqmap (MapDelta A m1 m2) (MapDelta A m'1 m'2).
  Proof.
    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m1 m2 a).
    rewrite (MapDelta_semantics A m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity.
  Qed.

  Lemma MapDelta_ext_l :
   forall m1 m'1 m2:Map A,
     eqmap m1 m'1 -> eqmap (MapDelta A m1 m2) (MapDelta A m'1 m2).
  Proof.
    intros. apply MapDelta_ext. assumption.
    apply eqmap_refl.
  Qed.

  Lemma MapDelta_ext_r :
   forall m1 m2 m'2:Map A,
     eqmap m2 m'2 -> eqmap (MapDelta A m1 m2) (MapDelta A m1 m'2).
  Proof.
    intros. apply MapDelta_ext. apply eqmap_refl.
    assumption.
  Qed.

  Lemma MapDom_Split_1 :
   forall (m:Map A) (m':Map B),
     eqmap m (MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m')).
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite
     (MapMerge_semantics A (MapDomRestrTo A B m m') (
        MapDomRestrBy A B m m') a).
    rewrite (MapDomRestrBy_semantics A B m m' a).
    rewrite (MapDomRestrTo_semantics A B m m' a).
    case (MapGet B m' a); case (MapGet A m a); trivial.
  Qed.

  Lemma MapDom_Split_2 :
   forall (m:Map A) (m':Map B),
     eqmap m (MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m')).
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite
     (MapMerge_semantics A (MapDomRestrBy A B m m') (
        MapDomRestrTo A B m m') a).
    rewrite (MapDomRestrBy_semantics A B m m' a).
    rewrite (MapDomRestrTo_semantics A B m m' a).
    case (MapGet B m' a); case (MapGet A m a); trivial.
  Qed.

  Lemma MapDom_Split_3 :
   forall (m:Map A) (m':Map B),
     eqmap
       (MapDomRestrTo A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m'))
       (M0 A).
  Proof.
    unfold eqmap, eqm in |- *. intros.
    rewrite
     (MapDomRestrTo_semantics A A (MapDomRestrTo A B m m')
        (MapDomRestrBy A B m m') a).
    rewrite (MapDomRestrBy_semantics A B m m' a).
    rewrite (MapDomRestrTo_semantics A B m m' a).
    case (MapGet B m' a); case (MapGet A m a); trivial.
  Qed.

End MapAxioms.

Lemma MapDomRestrTo_ext :
 forall (A B:Type) (m1:Map A) (m2:Map B) (m'1:Map A)
   (m'2:Map B),
   eqmap A m1 m'1 ->
   eqmap B m2 m'2 ->
   eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m'1 m'2).
Proof.
  unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A B m1 m2 a).
  rewrite (MapDomRestrTo_semantics A B m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity.
Qed.

Lemma MapDomRestrTo_ext_l :
 forall (A B:Type) (m1:Map A) (m2:Map B) (m'1:Map A),
   eqmap A m1 m'1 ->
   eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m'1 m2).
Proof.
  intros. apply MapDomRestrTo_ext; [ assumption | apply eqmap_refl ].
Qed.

Lemma MapDomRestrTo_ext_r :
 forall (A B:Type) (m1:Map A) (m2 m'2:Map B),
   eqmap B m2 m'2 ->
   eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m1 m'2).
Proof.
  intros. apply MapDomRestrTo_ext; [ apply eqmap_refl | assumption ].
Qed.

Lemma MapDomRestrBy_ext :
 forall (A B:Type) (m1:Map A) (m2:Map B) (m'1:Map A)
   (m'2:Map B),
   eqmap A m1 m'1 ->
   eqmap B m2 m'2 ->
   eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m'1 m'2).
Proof.
  unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A B m1 m2 a).
  rewrite (MapDomRestrBy_semantics A B m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity.
Qed.

Lemma MapDomRestrBy_ext_l :
 forall (A B:Type) (m1:Map A) (m2:Map B) (m'1:Map A),
   eqmap A m1 m'1 ->
   eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m'1 m2).
Proof.
  intros. apply MapDomRestrBy_ext; [ assumption | apply eqmap_refl ].
Qed.

Lemma MapDomRestrBy_ext_r :
 forall (A B:Type) (m1:Map A) (m2 m'2:Map B),
   eqmap B m2 m'2 ->
   eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m1 m'2).
Proof.
  intros. apply MapDomRestrBy_ext; [ apply eqmap_refl | assumption ].
Qed.

Lemma MapDomRestrBy_m_m :
 forall (A:Type) (m:Map A),
   eqmap A (MapDomRestrBy A unit m (MapDom A m)) (M0 A).
Proof.
  intros. apply eqmap_trans with (m' := MapDomRestrBy A A m m). apply eqmap_sym.
  apply MapDomRestrBy_Dom.
  apply MapDomRestrBy_m_m_1.
Qed.

Lemma FSetDelta_assoc :
 forall s s' s'':FSet,
   eqmap unit (MapDelta _ (MapDelta _ s s') s'')
     (MapDelta _ s (MapDelta _ s' s'')).
Proof.
  unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics unit (MapDelta unit s s') s'' a).
  rewrite (MapDelta_semantics unit s s' a).
  rewrite (MapDelta_semantics unit s (MapDelta unit s' s'') a).
  rewrite (MapDelta_semantics unit s' s'' a).
  case (MapGet _ s a); case (MapGet _ s' a); case (MapGet _ s'' a); trivial.
  intros. elim u. elim u1. reflexivity.
Qed.

Lemma FSet_ext :
 forall s s':FSet,
   (forall a:ad, in_FSet a s = in_FSet a s') -> eqmap unit s s'.
Proof.
  unfold in_FSet, eqmap, eqm in |- *. intros. elim (sumbool_of_bool (in_dom _ a s)). intro H0.
  elim (in_dom_some _ s a H0). intros y H1. rewrite (H a) in H0. elim (in_dom_some _ s' a H0).
  intros y' H2. rewrite H1. rewrite H2. elim y. elim y'. reflexivity.
  intro H0. rewrite (in_dom_none _ s a H0). rewrite (H a) in H0. rewrite (in_dom_none _ s' a H0).
  reflexivity.
Qed.

Lemma FSetUnion_comm :
 forall s s':FSet, eqmap unit (FSetUnion s s') (FSetUnion s' s).
Proof.
  intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_union. apply orb_comm.
Qed.

Lemma FSetUnion_assoc :
 forall s s' s'':FSet,
   eqmap unit (FSetUnion (FSetUnion s s') s'')
     (FSetUnion s (FSetUnion s' s'')).
Proof.
  exact (MapMerge_assoc unit).
Qed.

Lemma FSetUnion_M0_s : forall s:FSet, eqmap unit (FSetUnion (M0 unit) s) s.
Proof.
  exact (MapMerge_empty_m unit).
Qed.

Lemma FSetUnion_s_M0 : forall s:FSet, eqmap unit (FSetUnion s (M0 unit)) s.
Proof.
  exact (MapMerge_m_empty unit).
Qed.

Lemma FSetUnion_idempotent : forall s:FSet, eqmap unit (FSetUnion s s) s.
Proof.
  exact (MapMerge_idempotent unit).
Qed.

Lemma FSetInter_comm :
 forall s s':FSet, eqmap unit (FSetInter s s') (FSetInter s' s).
Proof.
  intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_inter. apply andb_comm.
Qed.

Lemma FSetInter_assoc :
 forall s s' s'':FSet,
   eqmap unit (FSetInter (FSetInter s s') s'')
     (FSetInter s (FSetInter s' s'')).
Proof.
  exact (MapDomRestrTo_assoc unit unit unit).
Qed.

Lemma FSetInter_M0_s :
 forall s:FSet, eqmap unit (FSetInter (M0 unit) s) (M0 unit).
Proof.
  exact (MapDomRestrTo_empty_m unit unit).
Qed.

Lemma FSetInter_s_M0 :
 forall s:FSet, eqmap unit (FSetInter s (M0 unit)) (M0 unit).
Proof.
  exact (MapDomRestrTo_m_empty unit unit).
Qed.

Lemma FSetInter_idempotent : forall s:FSet, eqmap unit (FSetInter s s) s.
Proof.
  exact (MapDomRestrTo_idempotent unit).
Qed.

Lemma FSetUnion_Inter_l :
 forall s s' s'':FSet,
   eqmap unit (FSetUnion (FSetInter s s') s'')
     (FSetInter (FSetUnion s s'') (FSetUnion s' s'')).
Proof.
  intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_inter.
  rewrite in_FSet_inter. rewrite in_FSet_union. rewrite in_FSet_union.
  case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity.
Qed.

Lemma FSetUnion_Inter_r :
 forall s s' s'':FSet,
   eqmap unit (FSetUnion s (FSetInter s' s''))
     (FSetInter (FSetUnion s s') (FSetUnion s s'')).
Proof.
  intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_inter.
  rewrite in_FSet_inter. rewrite in_FSet_union. rewrite in_FSet_union.
  case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity.
Qed.

Lemma FSetInter_Union_l :
 forall s s' s'':FSet,
   eqmap unit (FSetInter (FSetUnion s s') s'')
     (FSetUnion (FSetInter s s'') (FSetInter s' s'')).
Proof.
  intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_union.
  rewrite in_FSet_union. rewrite in_FSet_inter. rewrite in_FSet_inter.
  case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity.
Qed.

Lemma FSetInter_Union_r :
 forall s s' s'':FSet,
   eqmap unit (FSetInter s (FSetUnion s' s''))
     (FSetUnion (FSetInter s s') (FSetInter s s'')).
Proof.
  intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_union.
  rewrite in_FSet_union. rewrite in_FSet_inter. rewrite in_FSet_inter.
  case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity.
Qed.


Require Export Coq.ZArith.ZArith.
Require Import PerformanceExperiments.Harness.
Require Export PerformanceExperiments.rewrite_repeated_app_common.

Definition args_of_size (s : size) : list nat
  := match s with
     | Sanity => seq 1 3
     | SuperFast => seq 1 15
     | Fast => seq 1 22
     | Medium => []
     | Slow => []
     | VerySlow => []
     end.

Require Import Coq.ssr.ssreflect.
Ltac do_ssr_rewrite_bang := try rewrite !f'g'.
Ltac do_ssr_rewrite_once := try rewrite f'g'.
Ltac do_ssr_rewrite_ques := try rewrite ?f'g'.
Ltac do_ssr_rewrite_bang_evar := try rewrite !(f'g' _).
Ltac do_ssr_rewrite_once_evar := try rewrite (f'g' _).
Ltac do_ssr_rewrite_ques_evar := try rewrite ?(f'g' _).

Ltac time_solve_goal0 n :=
  time "try-ssr-rewrite!-cold-noop-regression-linear" do_ssr_rewrite_bang;
  time "try-ssr-rewrite!-noop-regression-linear" do_ssr_rewrite_bang;
  time "try-ssr-rewrite-noop-regression-linear" do_ssr_rewrite_once;
  time "try-ssr-rewrite?-noop-regression-linear" do_ssr_rewrite_ques;
  time "try-ssr-rewrite!-evar-noop-regression-linear" do_ssr_rewrite_bang_evar;
  time "try-ssr-rewrite-evar-noop-regression-linear" do_ssr_rewrite_once_evar;
  time "try-ssr-rewrite?-evar-noop-regression-linear" do_ssr_rewrite_ques_evar;
  reflexivity.

Ltac run0 sz := Harness.runtests args_of_size describe_goal_noop_exp mkgoal_noop_exp redgoal time_solve_goal0 sz.
Global Open Scope Z_scope.

(*
Goal True.
  Time run0 Fast.
 *)


Require Import Coq.Lists.List.

Require Import Category.Lib.
Require Import Category.Theory.Coq.Functor.
Require Import Category.Theory.Coq.Functor.Proofs.
Require Import Category.Theory.Coq.Tuple.
Require Import Category.Theory.Functor.

Generalizable All Variables.

Theorem uncurry_works : forall {X Y Z} (x : X) (y : Y) (f : X -> Y -> Z),
  uncurry f (x, y) = f x y.
Proof. reflexivity. Qed.

Lemma fst_snd : forall a b (z : a * b),
  (let '(x, y) := z in (x, y)) = (fst z, snd z).
Proof. intros ? ? [?]; auto. Qed.

Lemma unsplit : forall a b (xs : list (a * b)),
  map (fun x => (fst x, snd x)) xs = xs.
Proof.
  intros.
  induction xs as [|x xs IHxs]; auto; simpl.
  rewrite IHxs.
  destruct x; auto.
Qed.

Program Definition Tuple_Functor {x} : IsFunctor (Tuple_Functor x) := {|
  a_fmap := Tuple_Functor x;
|}.
Next Obligation.
  proper.
  simpl.
  now rewrite H.
Qed.


Require Import Cosa.Lib.Header.
Require Import Cosa.Abstract.NumericalDomain.
Require Import Cosa.Abstract.Lang.
Require Import Cosa.Shape.Summary.
Require Import Cosa.Shape.Graph.
(* spiwack: [Graph] and [NumericalDomain] are imported because of typeclasses. *)

(** Pairing of a [Graph.t] and a value domain element. *)
Module NumGraph.

Section NumGraph.

Variable num_dom : NumericalDomain.t Graph.node.
Variable ind_env : Summary.env.

Definition t := (Graph.t ind_env * num_dom)%type.

Let γ_graph (g:Graph.t ind_env) : ℘ (Graph.conc) :=
  Graph.γ (Summary.γ ind_env) g
.

(** [γ_num a] is the set of all concrete states whose valuation is in
    in the concretisation of [a]. *)
Let γ_num (a:num_dom) : ℘ (Graph.conc) :=
  fun s => fst s ∈ NumericalDomain.γ _ _ a
.

Definition γ (a:t) : ℘ (Graph.conc) :=
  γ_graph (fst a) ∩ γ_num (snd a)
.

End NumGraph.

Arguments γ {num_dom} {ind_env} a _.

End NumGraph.

(** The abstract domain is the set of pairs of a [NumGraph.t] and an
    abstract environment relating variables to nodes in the graph. *)

(** Concrete environments. *)
Notation cenv := (PTree.t Values.val).

(** Abstract environments. *)
Notation aenv := (PTree.t Graph.node).

Definition compatible_env (ν:valuation) (e:cenv) (e':aenv) :=
  forall x, e!x = option_map ν (e'!x)
.

Section ShapeDomain.

Variable num_dom : NumericalDomain.t Graph.node.
Variable ind_env : Summary.env.

Definition t := (aenv*NumGraph.t num_dom ind_env)%type.

Definition γ (a:t) : ℘ ( cenv * ConcreteFragment.fragment ) :=
  fun eh => exists ν, (ν,snd eh) ∈ NumGraph.γ (snd a) /\
                      forall x, (fst eh) ! x = match (fst a) ! x with
                                              | Some α => Some (ν α)
                                              | None => None
                                              end
.

End ShapeDomain.

Arguments γ {num_dom} {ind_env} a _.


From stdpp Require Export vector.
From iris.algebra Require Export ofe.
From iris.algebra Require Import list.
Set Default Proof Using "Type".

Section ofe.
  Context {A : ofeT}.

  Instance vec_equiv m : Equiv (vec A m) := equiv (A:=list A).
  Instance vec_dist m : Dist (vec A m) := dist (A:=list A).

  Definition vec_ofe_mixin m : OfeMixin (vec A m).
  Proof. by apply (iso_ofe_mixin vec_to_list). Qed.
  Canonical Structure vecC m : ofeT := OfeT (vec A m) (vec_ofe_mixin m).

  Global Instance list_cofe `{Cofe A} m : Cofe (vecC m).
  Proof.
    apply: (iso_cofe_subtype (λ l : list A, length l = m)
      (λ l, eq_rect _ (vec A) (list_to_vec l) m) vec_to_list)=> //.
    - intros v []. by rewrite /= vec_to_list_of_list.
    - intros c. by rewrite (conv_compl 0 (chain_map _ c)) /= vec_to_list_length.
  Qed.

  Global Instance vnil_discrete : Discrete (@vnil A).
  Proof. intros v _. by inv_vec v. Qed.
  Global Instance vcons_discrete n x (v : vec A n) :
    Discrete x → Discrete v → Discrete (x ::: v).
  Proof.
    intros ?? v' ?. inv_vec v'=>x' v'. inversion_clear 1.
    constructor. by apply discrete. change (v ≡ v'). by apply discrete.
  Qed.
  Global Instance vec_ofe_discrete m : OfeDiscrete A → OfeDiscrete (vecC m).
  Proof. intros ? v. induction v; apply _. Qed.
End ofe.

Arguments vecC : clear implicits.
Typeclasses Opaque vec_dist.

Section proper.
  Context {A : ofeT}.

  Global Instance vcons_ne n :
    Proper (dist n ==> forall_relation (λ x, dist n ==> dist n)) (@vcons A).
  Proof. by constructor. Qed.
  Global Instance vcons_proper :
    Proper (equiv ==> forall_relation (λ x, equiv ==> equiv)) (@vcons A).
  Proof. by constructor. Qed.

  Global Instance vlookup_ne n m :
    Proper (dist n ==> eq ==> dist n) (@Vector.nth A m).
  Proof.
    intros v. induction v as [|x m v IH]; intros v'; inv_vec v'.
    - intros _ x. inv_fin x.
    - intros x' v' EQ i ? <-. inversion_clear EQ. inv_fin i=> // i. by apply IH.
  Qed.
  Global Instance vlookup_proper m :
    Proper (equiv ==> eq ==> equiv) (@Vector.nth A m).
  Proof.
    intros v v' ? x x' ->. apply equiv_dist=> n. f_equiv. by apply equiv_dist.
  Qed.

  Global Instance vec_to_list_ne m : NonExpansive (@vec_to_list A m).
  Proof. by intros v v'. Qed.
  Global Instance vec_to_list_proper m : Proper ((≡) ==> (≡)) (@vec_to_list A m).
  Proof. by intros v v'. Qed.
End proper.

(** Functor *)
Definition vec_map {A B : ofeT} m (f : A → B) : vecC A m → vecC B m :=
  @vmap A B f m.
Lemma vec_map_ext_ne {A B : ofeT} m (f g : A → B) (v : vec A m) n :
  (∀ x, f x ≡{n}≡ g x) → vec_map m f v ≡{n}≡ vec_map m g v.
Proof.
  intros Hf. eapply (list_fmap_ext_ne f g v) in Hf.
  by rewrite -!vec_to_list_map in Hf.
Qed.
Instance vec_map_ne {A B : ofeT} m f n :
  Proper (dist n ==> dist n) f →
  Proper (dist n ==> dist n) (@vec_map A B m f).
Proof.
  intros ? v v' H. eapply list_fmap_ne in H; last done.
  by rewrite -!vec_to_list_map in H.
Qed.
Definition vecC_map {A B : ofeT} m (f : A -n> B) : vecC A m -n> vecC B m :=
  CofeMor (vec_map m f).
Instance vecC_map_ne {A A'} m :
  NonExpansive (@vecC_map A A' m).
Proof. intros n f g ? v. by apply vec_map_ext_ne. Qed.

Program Definition vecCF (F : cFunctor) m : cFunctor := {|
  cFunctor_car A B := vecC (cFunctor_car F A B) m;
  cFunctor_map A1 A2 B1 B2 fg := vecC_map m (cFunctor_map F fg)
|}.
Next Obligation.
  intros F A1 A2 B1 B2 n m f g Hfg. by apply vecC_map_ne, cFunctor_ne.
Qed.
Next Obligation.
  intros F m A B l.
  change (vec_to_list (vec_map m (cFunctor_map F (cid, cid)) l) ≡ l).
  rewrite vec_to_list_map. apply listCF.
Qed.
Next Obligation.
  intros F m A1 A2 A3 B1 B2 B3 f g f' g' l.
  change (vec_to_list (vec_map m (cFunctor_map F (f ◎ g, g' ◎ f')) l)
    ≡ vec_map m (cFunctor_map F (g, g')) (vec_map m (cFunctor_map F (f, f')) l)).
  rewrite !vec_to_list_map. by apply (cFunctor_compose (listCF F)  f g f' g').
Qed.

Instance vecCF_contractive F m :
  cFunctorContractive F → cFunctorContractive (vecCF F m).
Proof.
  by intros ?? A1 A2 B1 B2 n ???; apply vecC_map_ne; first apply cFunctor_contractive.
Qed.