From iris.base_logic Require Export upred.
From stdpp Require Import finite.
From iris.algebra Require Export updates.
Set Default Proof Using "Type".
Local Hint Extern 1 (_ ≼ _) => etrans; [eassumption|].
Local Hint Extern 1 (_ ≼ _) => etrans; [|eassumption].
Local Hint Extern 10 (_ ≤ _) => omega.

(** logical connectives *)
Program Definition uPred_pure_def {M} (φ : Prop) : uPred M :=
  {| uPred_holds n x := φ |}.
Solve Obligations with done.
Definition uPred_pure_aux : seal (@uPred_pure_def). by eexists. Qed.
Definition uPred_pure {M} := unseal uPred_pure_aux M.
Definition uPred_pure_eq :
  @uPred_pure = @uPred_pure_def := seal_eq uPred_pure_aux.

Instance uPred_inhabited M : Inhabited (uPred M) := populate (uPred_pure True).

Program Definition uPred_and_def {M} (P Q : uPred M) : uPred M :=
  {| uPred_holds n x := P n x ∧ Q n x |}.
Solve Obligations with naive_solver eauto 2 with uPred_def.
Definition uPred_and_aux : seal (@uPred_and_def). by eexists. Qed.
Definition uPred_and {M} := unseal uPred_and_aux M.
Definition uPred_and_eq: @uPred_and = @uPred_and_def := seal_eq uPred_and_aux.

Program Definition uPred_or_def {M} (P Q : uPred M) : uPred M :=
  {| uPred_holds n x := P n x ∨ Q n x |}.
Solve Obligations with naive_solver eauto 2 with uPred_def.
Definition uPred_or_aux : seal (@uPred_or_def). by eexists. Qed.
Definition uPred_or {M} := unseal uPred_or_aux M.
Definition uPred_or_eq: @uPred_or = @uPred_or_def := seal_eq uPred_or_aux.

Program Definition uPred_impl_def {M} (P Q : uPred M) : uPred M :=
  {| uPred_holds n x := ∀ n' x',
       x ≼ x' → n' ≤ n → ✓{n'} x' → P n' x' → Q n' x' |}.
Next Obligation.
  intros M P Q n1 n1' x1 x1' HPQ [x2 Hx1'] Hn1 n2 x3 [x4 Hx3] ?; simpl in *.
  rewrite Hx3 (dist_le _ _ _ _ Hx1'); auto. intros ??.
  eapply HPQ; auto. exists (x2 ⋅ x4); by rewrite assoc.
Qed.
Definition uPred_impl_aux : seal (@uPred_impl_def). by eexists. Qed.
Definition uPred_impl {M} := unseal uPred_impl_aux M.
Definition uPred_impl_eq :
  @uPred_impl = @uPred_impl_def := seal_eq uPred_impl_aux.

Program Definition uPred_forall_def {M A} (Ψ : A → uPred M) : uPred M :=
  {| uPred_holds n x := ∀ a, Ψ a n x |}.
Solve Obligations with naive_solver eauto 2 with uPred_def.
Definition uPred_forall_aux : seal (@uPred_forall_def). by eexists. Qed.
Definition uPred_forall {M A} := unseal uPred_forall_aux M A.
Definition uPred_forall_eq :
  @uPred_forall = @uPred_forall_def := seal_eq uPred_forall_aux.

Program Definition uPred_exist_def {M A} (Ψ : A → uPred M) : uPred M :=
  {| uPred_holds n x := ∃ a, Ψ a n x |}.
Solve Obligations with naive_solver eauto 2 with uPred_def.
Definition uPred_exist_aux : seal (@uPred_exist_def). by eexists. Qed.
Definition uPred_exist {M A} := unseal uPred_exist_aux M A.
Definition uPred_exist_eq: @uPred_exist = @uPred_exist_def := seal_eq uPred_exist_aux.

Program Definition uPred_internal_eq_def {M} {A : ofeT} (a1 a2 : A) : uPred M :=
  {| uPred_holds n x := a1 ≡{n}≡ a2 |}.
Solve Obligations with naive_solver eauto 2 using (dist_le (A:=A)).
Definition uPred_internal_eq_aux : seal (@uPred_internal_eq_def). by eexists. Qed.
Definition uPred_internal_eq {M A} := unseal uPred_internal_eq_aux M A.
Definition uPred_internal_eq_eq:
  @uPred_internal_eq = @uPred_internal_eq_def := seal_eq uPred_internal_eq_aux.

Program Definition uPred_sep_def {M} (P Q : uPred M) : uPred M :=
  {| uPred_holds n x := ∃ x1 x2, x ≡{n}≡ x1 ⋅ x2 ∧ P n x1 ∧ Q n x2 |}.
Next Obligation.
  intros M P Q n1 n2 x y (x1&x2&Hx&?&?) [z Hy] Hn.
  exists x1, (x2 ⋅ z); split_and?; eauto using uPred_mono, cmra_includedN_l.
  eapply dist_le, Hn. by rewrite Hy Hx assoc.
Qed.
Definition uPred_sep_aux : seal (@uPred_sep_def). by eexists. Qed.
Definition uPred_sep {M} := unseal uPred_sep_aux M.
Definition uPred_sep_eq: @uPred_sep = @uPred_sep_def := seal_eq uPred_sep_aux.

Program Definition uPred_wand_def {M} (P Q : uPred M) : uPred M :=
  {| uPred_holds n x := ∀ n' x',
       n' ≤ n → ✓{n'} (x ⋅ x') → P n' x' → Q n' (x ⋅ x') |}.
Next Obligation.
  intros M P Q n1 n1' x1 x1' HPQ ? Hn n3 x3 ???; simpl in *.
  eapply uPred_mono with n3 (x1 ⋅ x3);
    eauto using cmra_validN_includedN, cmra_monoN_r, cmra_includedN_le.
Qed.
Definition uPred_wand_aux : seal (@uPred_wand_def). by eexists. Qed.
Definition uPred_wand {M} := unseal uPred_wand_aux M.
Definition uPred_wand_eq :
  @uPred_wand = @uPred_wand_def := seal_eq uPred_wand_aux.

(* Equivalently, this could be `∀ y, P n y`.  That's closer to the intuition
   of "embedding the step-indexed logic in Iris", but the two are equivalent
   because Iris is afine.  The following is easier to work with. *)
Program Definition uPred_plainly_def {M} (P : uPred M) : uPred M :=
  {| uPred_holds n x := P n ε |}.
Solve Obligations with naive_solver eauto using uPred_mono, ucmra_unit_validN.
Definition uPred_plainly_aux : seal (@uPred_plainly_def). by eexists. Qed.
Definition uPred_plainly {M} := unseal uPred_plainly_aux M.
Definition uPred_plainly_eq :
  @uPred_plainly = @uPred_plainly_def := seal_eq uPred_plainly_aux.

Program Definition uPred_persistently_def {M} (P : uPred M) : uPred M :=
  {| uPred_holds n x := P n (core x) |}.
Next Obligation.
  intros M; naive_solver eauto using uPred_mono, @cmra_core_monoN.
Qed.
Definition uPred_persistently_aux : seal (@uPred_persistently_def). by eexists. Qed.
Definition uPred_persistently {M} := unseal uPred_persistently_aux M.
Definition uPred_persistently_eq :
  @uPred_persistently = @uPred_persistently_def := seal_eq uPred_persistently_aux.

Program Definition uPred_later_def {M} (P : uPred M) : uPred M :=
  {| uPred_holds n x := match n return _ with 0 => True | S n' => P n' x end |}.
Next Obligation.
  intros M P [|n1] [|n2] x1 x2; eauto using uPred_mono, cmra_includedN_S with lia.
Qed.
Definition uPred_later_aux : seal (@uPred_later_def). by eexists. Qed.
Definition uPred_later {M} := unseal uPred_later_aux M.
Definition uPred_later_eq :
  @uPred_later = @uPred_later_def := seal_eq uPred_later_aux.

Program Definition uPred_ownM_def {M : ucmraT} (a : M) : uPred M :=
  {| uPred_holds n x := a ≼{n} x |}.
Next Obligation.
  intros M a n1 n2 x1 x [a' Hx1] [x2 Hx] Hn. eapply cmra_includedN_le=>//.
  exists (a' ⋅ x2). by rewrite Hx(assoc op) Hx1.
Qed.
Definition uPred_ownM_aux : seal (@uPred_ownM_def). by eexists. Qed.
Definition uPred_ownM {M} := unseal uPred_ownM_aux M.
Definition uPred_ownM_eq :
  @uPred_ownM = @uPred_ownM_def := seal_eq uPred_ownM_aux.

Program Definition uPred_cmra_valid_def {M} {A : cmraT} (a : A) : uPred M :=
  {| uPred_holds n x := ✓{n} a |}.
Solve Obligations with naive_solver eauto 2 using cmra_validN_le.
Definition uPred_cmra_valid_aux : seal (@uPred_cmra_valid_def). by eexists. Qed.
Definition uPred_cmra_valid {M A} := unseal uPred_cmra_valid_aux M A.
Definition uPred_cmra_valid_eq :
  @uPred_cmra_valid = @uPred_cmra_valid_def := seal_eq uPred_cmra_valid_aux.

Program Definition uPred_bupd_def {M} (Q : uPred M) : uPred M :=
  {| uPred_holds n x := ∀ k yf,
      k ≤ n → ✓{k} (x ⋅ yf) → ∃ x', ✓{k} (x' ⋅ yf) ∧ Q k x' |}.
Next Obligation.
  intros M Q n1 n2 x1 x2 HQ [x3 Hx] Hn k yf Hk.
  rewrite (dist_le _ _ _ _ Hx); last lia. intros Hxy.
  destruct (HQ k (x3 ⋅ yf)) as (x'&?&?); [auto|by rewrite assoc|].
  exists (x' ⋅ x3); split; first by rewrite -assoc.
  eauto using uPred_mono, cmra_includedN_l.
Qed.
Definition uPred_bupd_aux : seal (@uPred_bupd_def). by eexists. Qed.
Definition uPred_bupd {M} := unseal uPred_bupd_aux M.
Definition uPred_bupd_eq : @uPred_bupd = @uPred_bupd_def := seal_eq uPred_bupd_aux.

(* Latest notation *)
Notation "'⌜' φ '⌝'" := (uPred_pure φ%stdpp%type)
  (at level 1, φ at level 200, format "⌜ φ ⌝") : uPred_scope.
Notation "'False'" := (uPred_pure False) : uPred_scope.
Notation "'True'" := (uPred_pure True) : uPred_scope.
Infix "∧" := uPred_and : uPred_scope.
Notation "(∧)" := uPred_and (only parsing) : uPred_scope.
Infix "∨" := uPred_or : uPred_scope.
Notation "(∨)" := uPred_or (only parsing) : uPred_scope.
Infix "→" := uPred_impl : uPred_scope.
Infix "∗" := uPred_sep (at level 80, right associativity) : uPred_scope.
Notation "(∗)" := uPred_sep (only parsing) : uPred_scope.
Notation "P -∗ Q" := (uPred_wand P Q)
  (at level 99, Q at level 200, right associativity) : uPred_scope.
Notation "∀ x .. y , P" :=
  (uPred_forall (λ x, .. (uPred_forall (λ y, P)) ..)%I)
  (at level 200, x binder, y binder, right associativity) : uPred_scope.
Notation "∃ x .. y , P" :=
  (uPred_exist (λ x, .. (uPred_exist (λ y, P)) ..)%I)
  (at level 200, x binder, y binder, right associativity) : uPred_scope.
Notation "■ P" := (uPred_plainly P)
  (at level 20, right associativity) : uPred_scope.
Notation "□ P" := (uPred_persistently P)
  (at level 20, right associativity) : uPred_scope.
Notation "▷ P" := (uPred_later P)
  (at level 20, right associativity) : uPred_scope.
Infix "≡" := uPred_internal_eq : uPred_scope.
Notation "✓ x" := (uPred_cmra_valid x) (at level 20) : uPred_scope.
Notation "|==> Q" := (uPred_bupd Q)
  (at level 99, Q at level 200, format "|==>  Q") : uPred_scope.
Notation "P ==∗ Q" := (P ⊢ |==> Q)
  (at level 99, Q at level 200, only parsing) : stdpp_scope.
Notation "P ==∗ Q" := (P -∗ |==> Q)%I
  (at level 99, Q at level 200, format "P  ==∗  Q") : uPred_scope.

Coercion uPred_valid {M} (P : uPred M) : Prop := True%I ⊢ P.
Typeclasses Opaque uPred_valid.

Notation "P -∗ Q" := (P ⊢ Q)
  (at level 99, Q at level 200, right associativity) : stdpp_scope.

Module uPred.
Definition unseal_eqs :=
  (uPred_pure_eq, uPred_and_eq, uPred_or_eq, uPred_impl_eq, uPred_forall_eq,
  uPred_exist_eq, uPred_internal_eq_eq, uPred_sep_eq, uPred_wand_eq,
  uPred_persistently_eq, uPred_plainly_eq, uPred_persistently_eq,
  uPred_later_eq, uPred_ownM_eq, uPred_cmra_valid_eq, uPred_bupd_eq).
Ltac unseal := rewrite !unseal_eqs /=.

Section primitive.
Context {M : ucmraT}.
Implicit Types φ : Prop.
Implicit Types P Q : uPred M.
Implicit Types A : Type.
Notation "P ⊢ Q" := (@uPred_entails M P%I Q%I). (* Force implicit argument M *)
Notation "P ⊣⊢ Q" := (equiv (A:=uPred M) P%I Q%I). (* Force implicit argument M *)
Arguments uPred_holds {_} !_ _ _ /.
Hint Immediate uPred_in_entails.

(** Non-expansiveness and setoid morphisms *)
Global Instance pure_proper : Proper (iff ==> (⊣⊢)) (@uPred_pure M) | 0.
Proof. intros φ1 φ2 Hφ. by unseal; split=> -[|n] ?; try apply Hφ. Qed.
Global Instance pure_ne n : Proper (iff ==> dist n) (@uPred_pure M) | 1.
Proof. by intros φ1 φ2 ->. Qed.

Global Instance and_ne : NonExpansive2 (@uPred_and M).
Proof.
  intros n P P' HP Q Q' HQ; unseal; split=> x n' ??.
  split; (intros [??]; split; [by apply HP|by apply HQ]).
Qed.
Global Instance and_proper :
  Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@uPred_and M) := ne_proper_2 _.
Global Instance or_ne : NonExpansive2 (@uPred_or M).
Proof.
  intros n P P' HP Q Q' HQ; split=> x n' ??.
  unseal; split; (intros [?|?]; [left; by apply HP|right; by apply HQ]).
Qed.
Global Instance or_proper :
  Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@uPred_or M) := ne_proper_2 _.
Global Instance impl_ne :
  NonExpansive2 (@uPred_impl M).
Proof.
  intros n P P' HP Q Q' HQ; split=> x n' ??.
  unseal; split; intros HPQ x' n'' ????; apply HQ, HPQ, HP; auto.
Qed.
Global Instance impl_proper :
  Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@uPred_impl M) := ne_proper_2 _.
Global Instance sep_ne : NonExpansive2 (@uPred_sep M).
Proof.
  intros n P P' HP Q Q' HQ; split=> n' x ??.
  unseal; split; intros (x1&x2&?&?&?); ofe_subst x;
    exists x1, x2; split_and!; try (apply HP || apply HQ);
    eauto using cmra_validN_op_l, cmra_validN_op_r.
Qed.
Global Instance sep_proper :
  Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@uPred_sep M) := ne_proper_2 _.
Global Instance wand_ne :
  NonExpansive2 (@uPred_wand M).
Proof.
  intros n P P' HP Q Q' HQ; split=> n' x ??; unseal; split; intros HPQ x' n'' ???;
    apply HQ, HPQ, HP; eauto using cmra_validN_op_r.
Qed.
Global Instance wand_proper :
  Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@uPred_wand M) := ne_proper_2 _.
Global Instance internal_eq_ne (A : ofeT) :
  NonExpansive2 (@uPred_internal_eq M A).
Proof.
  intros n x x' Hx y y' Hy; split=> n' z; unseal; split; intros; simpl in *.
  - by rewrite -(dist_le _ _ _ _ Hx) -?(dist_le _ _ _ _ Hy); auto.
  - by rewrite (dist_le _ _ _ _ Hx) ?(dist_le _ _ _ _ Hy); auto.
Qed.
Global Instance internal_eq_proper (A : ofeT) :
  Proper ((≡) ==> (≡) ==> (⊣⊢)) (@uPred_internal_eq M A) := ne_proper_2 _.
Global Instance forall_ne A n :
  Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_forall M A).
Proof.
  by intros Ψ1 Ψ2 HΨ; unseal; split=> n' x; split; intros HP a; apply HΨ.
Qed.
Global Instance forall_proper A :
  Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@uPred_forall M A).
Proof.
  by intros Ψ1 Ψ2 HΨ; unseal; split=> n' x; split; intros HP a; apply HΨ.
Qed.
Global Instance exist_ne A n :
  Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_exist M A).
Proof.
  intros Ψ1 Ψ2 HΨ.
  unseal; split=> n' x ??; split; intros [a ?]; exists a; by apply HΨ.
Qed.
Global Instance exist_proper A :
  Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@uPred_exist M A).
Proof.
  intros Ψ1 Ψ2 HΨ.
  unseal; split=> n' x ?; split; intros [a ?]; exists a; by apply HΨ.
Qed.
Global Instance later_contractive : Contractive (@uPred_later M).
Proof.
  unseal; intros [|n] P Q HPQ; split=> -[|n'] x ?? //=; try omega.
  apply HPQ; eauto using cmra_validN_S.
Qed.
Definition later_ne : NonExpansive (@uPred_later M) := _.
Global Instance later_proper :
  Proper ((⊣⊢) ==> (⊣⊢)) (@uPred_later M) := ne_proper _.
Global Instance plainly_ne : NonExpansive (@uPred_plainly M).
Proof.
  intros n P1 P2 HP.
  unseal; split=> n' x; split; apply HP; eauto using @ucmra_unit_validN.
Qed.
Global Instance plainly_proper :
  Proper ((⊣⊢) ==> (⊣⊢)) (@uPred_plainly M) := ne_proper _.
Global Instance persistently_ne : NonExpansive (@uPred_persistently M).
Proof.
  intros n P1 P2 HP.
  unseal; split=> n' x; split; apply HP; eauto using @cmra_core_validN.
Qed.
Global Instance persistently_proper :
  Proper ((⊣⊢) ==> (⊣⊢)) (@uPred_persistently M) := ne_proper _.
Global Instance ownM_ne : NonExpansive (@uPred_ownM M).
Proof.
  intros n a b Ha.
  unseal; split=> n' x ? /=. by rewrite (dist_le _ _ _ _ Ha); last lia.
Qed.
Global Instance ownM_proper: Proper ((≡) ==> (⊣⊢)) (@uPred_ownM M) := ne_proper _.
Global Instance cmra_valid_ne {A : cmraT} :
  NonExpansive (@uPred_cmra_valid M A).
Proof.
  intros n a b Ha; unseal; split=> n' x ? /=.
  by rewrite (dist_le _ _ _ _ Ha); last lia.
Qed.
Global Instance cmra_valid_proper {A : cmraT} :
  Proper ((≡) ==> (⊣⊢)) (@uPred_cmra_valid M A) := ne_proper _.
Global Instance bupd_ne : NonExpansive (@uPred_bupd M).
Proof.
  intros n P Q HPQ.
  unseal; split=> n' x; split; intros HP k yf ??;
    destruct (HP k yf) as (x'&?&?); auto;
    exists x'; split; auto; apply HPQ; eauto using cmra_validN_op_l.
Qed.
Global Instance bupd_proper : Proper ((≡) ==> (≡)) (@uPred_bupd M) := ne_proper _.
Global Instance uPred_valid_proper : Proper ((⊣⊢) ==> iff) (@uPred_valid M).
Proof. solve_proper. Qed.
Global Instance uPred_valid_mono : Proper ((⊢) ==> impl) (@uPred_valid M).
Proof. solve_proper. Qed.
Global Instance uPred_valid_flip_mono :
  Proper (flip (⊢) ==> flip impl) (@uPred_valid M).
Proof. solve_proper. Qed.

(** Introduction and elimination rules *)
Lemma pure_intro φ P : φ → P ⊢ ⌜φ⌝.
Proof. by intros ?; unseal; split. Qed.
Lemma pure_elim' φ P : (φ → True ⊢ P) → ⌜φ⌝ ⊢ P.
Proof. unseal; intros HP; split=> n x ??. by apply HP. Qed.
Lemma pure_forall_2 {A} (φ : A → Prop) : (∀ x : A, ⌜φ x⌝) ⊢ ⌜∀ x : A, φ x⌝.
Proof. by unseal. Qed.

Lemma and_elim_l P Q : P ∧ Q ⊢ P.
Proof. by unseal; split=> n x ? [??]. Qed.
Lemma and_elim_r P Q : P ∧ Q ⊢ Q.
Proof. by unseal; split=> n x ? [??]. Qed.
Lemma and_intro P Q R : (P ⊢ Q) → (P ⊢ R) → P ⊢ Q ∧ R.
Proof. intros HQ HR; unseal; split=> n x ??; by split; [apply HQ|apply HR]. Qed.

Lemma or_intro_l P Q : P ⊢ P ∨ Q.
Proof. unseal; split=> n x ??; left; auto. Qed.
Lemma or_intro_r P Q : Q ⊢ P ∨ Q.
Proof. unseal; split=> n x ??; right; auto. Qed.
Lemma or_elim P Q R : (P ⊢ R) → (Q ⊢ R) → P ∨ Q ⊢ R.
Proof. intros HP HQ; unseal; split=> n x ? [?|?]. by apply HP. by apply HQ. Qed.

Lemma impl_intro_r P Q R : (P ∧ Q ⊢ R) → P ⊢ Q → R.
Proof.
  unseal; intros HQ; split=> n x ?? n' x' ????. apply HQ;
    naive_solver eauto using uPred_mono, cmra_included_includedN.
Qed.
Lemma impl_elim P Q R : (P ⊢ Q → R) → (P ⊢ Q) → P ⊢ R.
Proof. by unseal; intros HP HP'; split=> n x ??; apply HP with n x, HP'. Qed.

Lemma forall_intro {A} P (Ψ : A → uPred M): (∀ a, P ⊢ Ψ a) → P ⊢ ∀ a, Ψ a.
Proof. unseal; intros HPΨ; split=> n x ?? a; by apply HPΨ. Qed.
Lemma forall_elim {A} {Ψ : A → uPred M} a : (∀ a, Ψ a) ⊢ Ψ a.
Proof. unseal; split=> n x ? HP; apply HP. Qed.

Lemma exist_intro {A} {Ψ : A → uPred M} a : Ψ a ⊢ ∃ a, Ψ a.
Proof. unseal; split=> n x ??; by exists a. Qed.
Lemma exist_elim {A} (Φ : A → uPred M) Q : (∀ a, Φ a ⊢ Q) → (∃ a, Φ a) ⊢ Q.
Proof. unseal; intros HΦΨ; split=> n x ? [a ?]; by apply HΦΨ with a. Qed.

Lemma internal_eq_refl {A : ofeT} (a : A) : uPred_valid (M:=M) (a ≡ a).
Proof. unseal; by split=> n x ??; simpl. Qed.
Lemma internal_eq_rewrite {A : ofeT} a b (Ψ : A → uPred M) :
  NonExpansive Ψ → a ≡ b ⊢ Ψ a → Ψ b.
Proof. intros HΨ. unseal; split=> n x ?? n' x' ??? Ha. by apply HΨ with n a. Qed.

(* BI connectives *)
Lemma sep_mono P P' Q Q' : (P ⊢ Q) → (P' ⊢ Q') → P ∗ P' ⊢ Q ∗ Q'.
Proof.
  intros HQ HQ'; unseal.
  split; intros n' x ? (x1&x2&?&?&?); exists x1,x2; ofe_subst x;
    eauto 7 using cmra_validN_op_l, cmra_validN_op_r, uPred_in_entails.
Qed.
Lemma True_sep_1 P : P ⊢ True ∗ P.
Proof.
  unseal; split; intros n x ??. exists (core x), x. by rewrite cmra_core_l.
Qed.
Lemma True_sep_2 P : True ∗ P ⊢ P.
Proof.
  unseal; split; intros n x ? (x1&x2&?&_&?); ofe_subst;
    eauto using uPred_mono, cmra_includedN_r.
Qed.
Lemma sep_comm' P Q : P ∗ Q ⊢ Q ∗ P.
Proof.
  unseal; split; intros n x ? (x1&x2&?&?&?); exists x2, x1; by rewrite (comm op).
Qed.
Lemma sep_assoc' P Q R : (P ∗ Q) ∗ R ⊢ P ∗ (Q ∗ R).
Proof.
  unseal; split; intros n x ? (x1&x2&Hx&(y1&y2&Hy&?&?)&?).
  exists y1, (y2 ⋅ x2); split_and?; auto.
  + by rewrite (assoc op) -Hy -Hx.
  + by exists y2, x2.
Qed.
Lemma wand_intro_r P Q R : (P ∗ Q ⊢ R) → P ⊢ Q -∗ R.
Proof.
  unseal=> HPQR; split=> n x ?? n' x' ???; apply HPQR; auto.
  exists x, x'; split_and?; auto.
  eapply uPred_mono with n x; eauto using cmra_validN_op_l.
Qed.
Lemma wand_elim_l' P Q R : (P ⊢ Q -∗ R) → P ∗ Q ⊢ R.
Proof.
  unseal =>HPQR. split; intros n x ? (?&?&?&?&?). ofe_subst.
  eapply HPQR; eauto using cmra_validN_op_l.
Qed.

(* The plainness modality *)
Lemma plainly_mono P Q : (P ⊢ Q) → ■ P ⊢ ■ Q.
Proof. intros HP; unseal; split=> n x ? /=. apply HP, ucmra_unit_validN. Qed.
Lemma plainly_elim' P : ■ P ⊢ □ P.
Proof. unseal; split; simpl; eauto using uPred_mono, @ucmra_unit_leastN. Qed.
Lemma plainly_idemp P : ■ P ⊢ ■ ■ P.
Proof. unseal; split=> n x ?? //. Qed.

Lemma plainly_forall_2 {A} (Ψ : A → uPred M) : (∀ a, ■ Ψ a) ⊢ (■ ∀ a, Ψ a).
Proof. by unseal. Qed.
Lemma plainly_exist_1 {A} (Ψ : A → uPred M) : (■ ∃ a, Ψ a) ⊢ (∃ a, ■ Ψ a).
Proof. by unseal. Qed.

Lemma prop_ext P Q : ■ ((P → Q) ∧ (Q → P)) ⊢ P ≡ Q.
Proof.
  unseal; split=> n x ? /= HPQ; split=> n' x' ? HP;
    split; eapply HPQ; eauto using @ucmra_unit_least.
Qed.

(* Always *)
Lemma persistently_mono P Q : (P ⊢ Q) → □ P ⊢ □ Q.
Proof. intros HP; unseal; split=> n x ? /=. by apply HP, cmra_core_validN. Qed.
Lemma persistently_elim P : □ P ⊢ P.
Proof.
  unseal; split=> n x ? /=.
  eauto using uPred_mono, @cmra_included_core, cmra_included_includedN.
Qed.
Lemma persistently_idemp_2 P : □ P ⊢ □ □ P.
Proof. unseal; split=> n x ?? /=. by rewrite cmra_core_idemp. Qed.

Lemma persistently_forall_2 {A} (Ψ : A → uPred M) : (∀ a, □ Ψ a) ⊢ (□ ∀ a, Ψ a).
Proof. by unseal. Qed.
Lemma persistently_exist_1 {A} (Ψ : A → uPred M) : (□ ∃ a, Ψ a) ⊢ (∃ a, □ Ψ a).
Proof. by unseal. Qed.

Lemma persistently_and_sep_l_1 P Q : □ P ∧ Q ⊢ □ P ∗ Q.
Proof.
  unseal; split=> n x ? [??]; exists (core x), x; simpl in *.
  by rewrite cmra_core_l cmra_core_idemp.
Qed.

(* The following two laws are very similar, and indeed they hold not just for □
   and ■, but for any modality defined as `M P n x := ∀ y, R x y → P n y`. *)
Lemma persistently_impl_plainly P Q : (■ P → □ Q) ⊢ □ (■ P → Q).
Proof.
  unseal; split=> /= n x ? HPQ n' x' ????.
  eapply uPred_mono with n' (core x)=>//; [|by apply cmra_included_includedN].
  apply (HPQ n' x); eauto using cmra_validN_le.
Qed.

Lemma plainly_impl_plainly P Q : (■ P → ■ Q) ⊢ ■ (■ P → Q).
Proof.
  unseal; split=> /= n x ? HPQ n' x' ????.
  eapply uPred_mono with n' ε=>//; [|by apply cmra_included_includedN].
  apply (HPQ n' x); eauto using cmra_validN_le.
Qed.

(* Later *)
Lemma later_mono P Q : (P ⊢ Q) → ▷ P ⊢ ▷ Q.
Proof.
  unseal=> HP; split=>-[|n] x ??; [done|apply HP; eauto using cmra_validN_S].
Qed.
Lemma löb P : (▷ P → P) ⊢ P.
Proof.
  unseal; split=> n x ? HP; induction n as [|n IH]; [by apply HP|].
  apply HP, IH, uPred_mono with (S n) x; eauto using cmra_validN_S.
Qed.
Lemma later_forall_2 {A} (Φ : A → uPred M) : (∀ a, ▷ Φ a) ⊢ ▷ ∀ a, Φ a.
Proof. unseal; by split=> -[|n] x. Qed.
Lemma later_exist_false {A} (Φ : A → uPred M) :
  (▷ ∃ a, Φ a) ⊢ ▷ False ∨ (∃ a, ▷ Φ a).
Proof. unseal; split=> -[|[|n]] x /=; eauto. Qed.
Lemma later_sep P Q : ▷ (P ∗ Q) ⊣⊢ ▷ P ∗ ▷ Q.
Proof.
  unseal; split=> n x ?; split.
  - destruct n as [|n]; simpl.
    { by exists x, (core x); rewrite cmra_core_r. }
    intros (x1&x2&Hx&?&?); destruct (cmra_extend n x x1 x2)
      as (y1&y2&Hx'&Hy1&Hy2); eauto using cmra_validN_S; simpl in *.
    exists y1, y2; split; [by rewrite Hx'|by rewrite Hy1 Hy2].
  - destruct n as [|n]; simpl; [done|intros (x1&x2&Hx&?&?)].
    exists x1, x2; eauto using dist_S.
Qed.
Lemma later_false_excluded_middle P : ▷ P ⊢ ▷ False ∨ (▷ False → P).
Proof.
  unseal; split=> -[|n] x ? /= HP; [by left|right].
  intros [|n'] x' ????; eauto using uPred_mono, cmra_included_includedN.
Qed.
Lemma persistently_later P : □ ▷ P ⊣⊢ ▷ □ P.
Proof. by unseal. Qed.
Lemma plainly_later P : ■ ▷ P ⊣⊢ ▷ ■ P.
Proof. by unseal. Qed.

(* Own *)
Lemma ownM_op (a1 a2 : M) :
  uPred_ownM (a1 ⋅ a2) ⊣⊢ uPred_ownM a1 ∗ uPred_ownM a2.
Proof.
  unseal; split=> n x ?; split.
  - intros [z ?]; exists a1, (a2 ⋅ z); split; [by rewrite (assoc op)|].
    split. by exists (core a1); rewrite cmra_core_r. by exists z.
  - intros (y1&y2&Hx&[z1 Hy1]&[z2 Hy2]); exists (z1 ⋅ z2).
    by rewrite (assoc op _ z1) -(comm op z1) (assoc op z1)
      -(assoc op _ a2) (comm op z1) -Hy1 -Hy2.
Qed.
Lemma persistently_ownM_core (a : M) : uPred_ownM a ⊢ □ uPred_ownM (core a).
Proof.
  split=> n x /=; unseal; intros Hx. simpl. by apply cmra_core_monoN.
Qed.
Lemma ownM_unit : uPred_valid (M:=M) (uPred_ownM ε).
Proof. unseal; split=> n x ??; by  exists x; rewrite left_id. Qed.
Lemma later_ownM a : ▷ uPred_ownM a ⊢ ∃ b, uPred_ownM b ∧ ▷ (a ≡ b).
Proof.
  unseal; split=> -[|n] x /= ? Hax; first by eauto using ucmra_unit_leastN.
  destruct Hax as [y ?].
  destruct (cmra_extend n x a y) as (a'&y'&Hx&?&?); auto using cmra_validN_S.
  exists a'. rewrite Hx. eauto using cmra_includedN_l.
Qed.

(* Valid *)
Lemma ownM_valid (a : M) : uPred_ownM a ⊢ ✓ a.
Proof.
  unseal; split=> n x Hv [a' ?]; ofe_subst; eauto using cmra_validN_op_l.
Qed.
Lemma cmra_valid_intro {A : cmraT} (a : A) : ✓ a → uPred_valid (M:=M) (✓ a).
Proof. unseal=> ?; split=> n x ? _ /=; by apply cmra_valid_validN. Qed.
Lemma cmra_valid_elim {A : cmraT} (a : A) : ¬ ✓{0} a → ✓ a ⊢ False.
Proof. unseal=> Ha; split=> n x ??; apply Ha, cmra_validN_le with n; auto. Qed.
Lemma plainly_cmra_valid_1 {A : cmraT} (a : A) : ✓ a ⊢ ■ ✓ a.
Proof. by unseal. Qed.
Lemma cmra_valid_weaken {A : cmraT} (a b : A) : ✓ (a ⋅ b) ⊢ ✓ a.
Proof. unseal; split=> n x _; apply cmra_validN_op_l. Qed.

(* Basic update modality *)
Lemma bupd_intro P : P ==∗ P.
Proof.
  unseal. split=> n x ? HP k yf ?; exists x; split; first done.
  apply uPred_mono with n x; eauto using cmra_validN_op_l.
Qed.
Lemma bupd_mono P Q : (P ⊢ Q) → (|==> P) ==∗ Q.
Proof.
  unseal. intros HPQ; split=> n x ? HP k yf ??.
  destruct (HP k yf) as (x'&?&?); eauto.
  exists x'; split; eauto using uPred_in_entails, cmra_validN_op_l.
Qed.
Lemma bupd_trans P : (|==> |==> P) ==∗ P.
Proof. unseal; split; naive_solver. Qed.
Lemma bupd_frame_r P R : (|==> P) ∗ R ==∗ P ∗ R.
Proof.
  unseal; split; intros n x ? (x1&x2&Hx&HP&?) k yf ??.
  destruct (HP k (x2 ⋅ yf)) as (x'&?&?); eauto.
  { by rewrite assoc -(dist_le _ _ _ _ Hx); last lia. }
  exists (x' ⋅ x2); split; first by rewrite -assoc.
  exists x', x2. eauto using uPred_mono, cmra_validN_op_l, cmra_validN_op_r.
Qed.
Lemma bupd_ownM_updateP x (Φ : M → Prop) :
  x ~~>: Φ → uPred_ownM x ==∗ ∃ y, ⌜Φ y⌝ ∧ uPred_ownM y.
Proof.
  unseal=> Hup; split=> n x2 ? [x3 Hx] k yf ??.
  destruct (Hup k (Some (x3 ⋅ yf))) as (y&?&?); simpl in *.
  { rewrite /= assoc -(dist_le _ _ _ _ Hx); auto. }
  exists (y ⋅ x3); split; first by rewrite -assoc.
  exists y; eauto using cmra_includedN_l.
Qed.
Lemma bupd_plainly P : (|==> ■ P) ⊢ P.
Proof.
  unseal; split => n x Hnx /= Hng.
  destruct (Hng n ε) as [? [_ Hng']]; try rewrite right_id; auto.
  eapply uPred_mono; eauto using ucmra_unit_leastN.
Qed.

(* Products *)
Lemma prod_equivI {A B : ofeT} (x y : A * B) : x ≡ y ⊣⊢ x.1 ≡ y.1 ∧ x.2 ≡ y.2.
Proof. by unseal. Qed.
Lemma prod_validI {A B : cmraT} (x : A * B) : ✓ x ⊣⊢ ✓ x.1 ∧ ✓ x.2.
Proof. by unseal. Qed.

(* Type-level Later *)
Lemma later_equivI {A : ofeT} (x y : A) : Next x ≡ Next y ⊣⊢ ▷ (x ≡ y).
Proof. by unseal. Qed.

(* Discrete *)
Lemma discrete_valid {A : cmraT} `{!CmraDiscrete A} (a : A) : ✓ a ⊣⊢ ⌜✓ a⌝.
Proof. unseal; split=> n x _. by rewrite /= -cmra_discrete_valid_iff. Qed.
Lemma discrete_eq {A : ofeT} (a b : A) : Discrete a → a ≡ b ⊣⊢ ⌜a ≡ b⌝.
Proof.
  unseal=> ?. apply (anti_symm (⊢)); split=> n x ?; by apply (discrete_iff n).
Qed.

(* Option *)
Lemma option_equivI {A : ofeT} (mx my : option A) :
  mx ≡ my ⊣⊢ match mx, my with
             | Some x, Some y => x ≡ y | None, None => True | _, _ => False
             end.
Proof.
  unseal. do 2 split. by destruct 1. by destruct mx, my; try constructor.
Qed.
Lemma option_validI {A : cmraT} (mx : option A) :
  ✓ mx ⊣⊢ match mx with Some x => ✓ x | None => True end.
Proof. unseal. by destruct mx. Qed.

(* Contractive functions *)
Lemma contractiveI {A B : ofeT} (f : A → B) :
  Contractive f ↔ (∀ a b, ▷ (a ≡ b) ⊢ f a ≡ f b).
Proof.
  split; unseal; intros Hf.
  - intros a b; split=> n x _; apply Hf.
  - intros i a b; eapply Hf, ucmra_unit_validN.
Qed.

(* Function extensionality *)
Lemma ofe_morC_equivI {A B : ofeT} (f g : A -n> B) : f ≡ g ⊣⊢ ∀ x, f x ≡ g x.
Proof. by unseal. Qed.
Lemma ofe_fun_equivI `{B : A → ofeT} (g1 g2 : ofe_fun B) :
  g1 ≡ g2 ⊣⊢ ∀ i, g1 i ≡ g2 i.
Proof. by uPred.unseal. Qed.

Lemma ofe_fun_validI `{B : A → ucmraT} (g : ofe_fun B) : ✓ g ⊣⊢ ∀ i, ✓ g i.
Proof. by uPred.unseal. Qed.

(* Sigma OFE *)
Lemma sig_equivI {A : ofeT} (P : A → Prop) (x y : sigC P) :
  x ≡ y ⊣⊢ proj1_sig x ≡ proj1_sig y.
Proof. by unseal. Qed.
End primitive.
End uPred.


Require Import Setoid.

Definition segv : forall x, (x = 0%nat) -> (forall (y : nat), (y < x)%nat -> nat) = forall (y : nat), (y < 0)%nat -> nat.
intros x eq.
assert (H : forall y, (y < x)%nat = (y < 0)%nat).
rewrite -> eq. auto.
Set Typeclasses Debug.
Fail setoid_rewrite <- H. (* The command has indeed failed with message:
=> Stack overflow. *)


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj25synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (mult lv0 lv1) (plus Zero (plus lv2 lv1))) (plus lv3 lv2)).
Admitted.
QuickChick conj25synthconj2.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj34synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus (mult lv0 lv1) lv1) (plus (Succ Zero) lv0)) (plus (mult lv0 lv2) lv2)).
Admitted.
QuickChick conj34synthconj4.


Require Import stdpp.list.
Require Import ssreflect.
From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
Local Open Scope Z.

(* upd_Znth 0
                 (upd_Znth 31 (map (fun x : ℤ => Vint (Int.repr x)) (firstn 31 contents_n) ++ [Vundef])
                    (Vint
                       (Int.zero_ext 8
                          (Int.or (Int.and (Int.repr (Znth 31 contents_n 0)) (Int.repr 127)) (Int.repr 64)))))
                 (Vint
                    (cast_int_int I8 Unsigned
                       (Int.and (Int.repr (Znth 0 (firstn 31 contents_n) 0)) (Int.repr 248))))
 *)
(*
z = n
z[31]=(n[31]&127)|64;
z[0]&=248;
*)

(* Eval compute in (ZofList 8 [Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;
Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;
Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;
Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;127]). *)
(* Eval compute in Z.ones 255.
(* 57896044618658097711785492504343953926634992332820282019728792003956564819967 *) *)
(* Eval compute in (ZofList 8 [248;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;
Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;
Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;
Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;127]). *)
(* 57896044618658097711785492504343953926634992332820282019728792003956564819960 *)

(* Eval compute in Z.land (Z.ones 255) (-8). *)
(* Definition Zclamp' (n : Z) : Z :=
  (Z.lor (Z.land n 57896044618658097711785492504343953926634992332820282019728792003956564819960) (Z.shiftl 64 (31 * 8))).
*)
Definition Zclamp (n : Z) : Z :=
  (Z.lor (Z.land n (Z.land (Z.ones 255) (-8))) (Z.shiftl 64 (31 * 8))).

Lemma Zclamp_min n : 0 <= Zclamp n.
Proof.
rewrite /Zclamp.
apply Z.lor_nonneg; split => //.
apply Z.land_nonneg ; right => //.
Qed.

Lemma Zclamp_max n : Zclamp n < 2^255.
Proof.
rewrite /Zclamp.
apply Z_lor_bound => //.
have ->: Z.land n 57896044618658097711785492504343953926634992332820282019728792003956564819960 = Z.land (Z.land n 57896044618658097711785492504343953926634992332820282019728792003956564819960) (Z.ones 255).
rewrite -Z.land_assoc => //=.
rewrite Z.land_ones => //.
apply Z_mod_lt => //.
Qed.

Close Scope Z.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus lv3 (Succ (plus Zero lv1)))).
Admitted.
QuickChick conj18synthconj1.


Set Warnings "-notation-overridden,-parsing".
Require Import Tweetnacl_verif.init_tweetnacl.
Require Import Tweetnacl.Low.Car25519.
Require Import Tweetnacl.Low.Carry_n.
Require Import Tweetnacl.Low.BackCarry.

Open Scope Z.

Definition car25519_spec :=
 DECLARE _car25519
  WITH v_o: val, sh : share, o : list Z
  PRE [ _o OF (tptr tlg)]
        PROP  (writable_share sh;
                Forall (fun x => -Z.pow 2 62 < x < Z.pow 2 62) o;
                Zlength o = 16)
        LOCAL (temp _o v_o)
        SEP   (sh [{ v_o }] <<(lg16)-- mVI64 o)
  POST [ tvoid ]
        PROP (
              Forall (fun x => 38 * - 2 ^ 47 <= x < 2 ^ 16 + 38 * 2 ^ 47) (car25519 o)
             )
        LOCAL()
        SEP (sh [{ v_o }] <<(lg16)-- mVI64 (car25519 o)).

Definition car25519_Inv sh v_o o :=
  EX i : Z,
   PROP  (writable_share sh;
          Forall (fun x => -Z.pow 2 62 < x < Z.pow 2 62) o;
          Zlength o = 16;
          i >= 0)
   LOCAL (temp _o v_o)
   SEP   (sh [{ v_o }] <<(lg16)-- mVI64 (if Z.ltb i 16 then (Carrying_n 16 (nat_of_Z i) 0 o) else car25519 o)).

Close Scope Z.


From defaultt Require Import lprop set.
From Coq Require Import List.

Record default : Type := {
  d_pre : Form;
  d_just : list Form;
  d_conc : Form;
  d_just_wf : length d_just >= 1;
}.

(** Default Theories *)
Record DT := {
  W : set Form;
  D : set default;
}.

(** Fixpoint Characterization of DT Extensions *)
Module Fix.

(** Properties of the Γ operator *)
Record GammaRules (dt : DT) (S S' : set Form) : Prop := {
  gamma_W         : W dt ⊆ S';
  gamma_closed_1  : S' ≡ theory S';
  gamma_closed_2  :
    forall d, D dt d -> S' (d_pre d) ->
    (forall j, In j (d_just d) -> ~(S (Fneg j))) ->
    S' (d_conc d)
}.

(** Γ(S) is defined as the smalles set satisfying [GammaRules] *)
Definition GammaOp (dt : DT) (S : set Form) : set Form :=
  smallest (GammaRules dt S).

(** An extensions is a fixpoint of the Γ operator *)
Definition Extension (dt : DT) (E : set Form) : Prop :=
  E ≡ GammaOp dt E.

End Fix.

(** 'Sequential' Characterization of DT Extensions *)
Module Seq.

Definition Extension (dt : DT) (E : set Form) : Prop :=
  False (* TODO *).

End Seq.

(** The fixpoint and the sequential characterization are equivalent *)
Theorem Extension_Fix_Seq:
  forall dt, Fix.Extension dt ≡ Seq.Extension dt.
Proof.
  (* TODO *)
Admitted.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Language Subtyping Notations.

Lemma typing_regular :
  forall (T : ctx) (e : trm) (A : typ),
    typing T nil infer_mode e A -> uniq T.
Proof.
Admitted.

Lemma typing_weaken :
  forall (T1 T2 T3: ctx) (e : trm) (A : typ),
    typing (T1 ++ T2) nil infer_mode e A ->
    uniq (T1 ++ T3 ++ T2) ->
    typing (T1 ++ T3 ++ T2) nil infer_mode e A.
Proof.
  intros.
  remember (T1 ++ T2) as T12.
  generalize dependent T1.
  induction H; intros; subst; eauto.
  - apply typing_abs1 with (L := dom (T1 ++ T3 ++ T2) \u L).
    intros x Frx.
    rewrite_env (([(x, A)] ++ T1) ++ T3 ++ T2).
    apply H0. auto. simpl_env. reflexivity.
    simpl_env. apply uniq_push. assumption. auto.
  - apply typing_abs2 with (L := dom (T1 ++ T3 ++ T2) \u L).
    intros x Frx.
    rewrite_env (([(x, A)] ++ T1) ++ T3 ++ T2).
    apply H0. auto. simpl_env. reflexivity.
    simpl_env. apply uniq_push. assumption. auto.
Qed.

Lemma typing_check_to_infer :
  forall (T : ctx) (e : trm) (A : typ),
    typing T nil check_mode e A ->
    exists (B : typ), typing T nil infer_mode e B /\ sub B A.
Proof.
  intros T e A Htyp.
  induction Htyp; eauto.
  - exists A. split.
    + constructor. assumption. assumption.
    + apply sub_reflexivity.
  - exists (typ_arrow A B). split.
Admitted.
(* this isn't working beacuse
to infer t_abs, we may require arguments *arg* to assist *)


(** * Push-Button Synthesis of Barrett Reduction *)
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.derive.Derive.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ErrorT.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Crypto.Stringification.Language.
Require Import Crypto.Arithmetic.BarrettReduction.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.ModOps.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Arithmetic.UniformWeight.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.Fancy.Compiler.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Require Import Crypto.PushButtonSynthesis.Primitives.
Require Import Crypto.PushButtonSynthesis.BarrettReductionReificationCache.
Require Import Crypto.PushButtonSynthesis.InvertHighLow.
Import ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope. Local Open Scope bool_scope.

Import
  Language.Compilers
  Language.Wf.Compilers
  Stringification.Language.Compilers.
Import Compilers.API.

Import COperationSpecifications.Primitives.
Import COperationSpecifications.BarrettReduction.

Import Associational Positional.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Local Opaque reified_barrett_red_gen. (* needed for making [autorewrite] not take a very long time *)

Section rbarrett_red.
  Context {output_language_api : ToString.OutputLanguageAPI}
          {static : static_opt}
          {internal_static : internal_static_opt}
          {inline : inline_opt}
          {inline_internal : inline_internal_opt}
          (M : Z)
          (machine_wordsize : machine_wordsize_opt).

  Let value_range := r[0 ~> (2^machine_wordsize - 1)%Z]%zrange.
  Let flag_range := r[0 ~> 1]%zrange.
  Let bound := Some value_range.
  Let mu := (2 ^ (2 * machine_wordsize)) / M.
  Let muLow := mu mod (2 ^ machine_wordsize).
  Let consts_list := [M; muLow].

  Definition possible_values_of_machine_wordsize
    := [1; machine_wordsize / 2; machine_wordsize; 2 * machine_wordsize]%Z.
  Let possible_values := possible_values_of_machine_wordsize.

  Local Existing Instance default_language_naming_conventions.
  Local Existing Instance default_documentation_options.
  Local Existing Instance default_output_options.
  Local Existing Instance AbstractInterpretation.default_Options.
  Local Instance widen_carry : widen_carry_opt := false.
  Local Instance widen_bytes : widen_bytes_opt := true.
  Local Instance only_signed : only_signed_opt := false.
  Local Instance no_select_size : no_select_size_opt := None.
  Local Instance split_mul_to : split_mul_to_opt := None.
  Local Instance split_multiret_to : split_multiret_to_opt := None.
  Local Instance unfold_value_barrier : unfold_value_barrier_opt := true.
  Local Instance assembly_hints_lines : assembly_hints_lines_opt := [].
  Local Instance ignore_unique_asm_names : ignore_unique_asm_names_opt := false.
  Local Instance low_level_rewriter_method : low_level_rewriter_method_opt := default_low_level_rewriter_method.

  Let fancy_args
    := (Some {| Pipeline.invert_low log2wordsize := invert_low log2wordsize consts_list;
                Pipeline.invert_high log2wordsize := invert_high log2wordsize consts_list;
                Pipeline.value_range := value_range;
                Pipeline.flag_range := flag_range |}).

  Lemma fancy_args_good
    : match fancy_args with
      | Some {| Pipeline.invert_low := il ; Pipeline.invert_high := ih |}
        => (forall s v v' : Z, il s v = Some v' -> v = Z.land v' (2^(s/2)-1))
           /\ (forall s v v' : Z, ih s v = Some v' -> v = Z.shiftr v' (s/2))
      | None => True
      end.
  Proof.
    cbv [fancy_args invert_low invert_high constant_to_scalar constant_to_scalar_single consts_list fold_right];
      split; intros; break_innermost_match_hyps; Z.ltb_to_lt; subst; congruence.
  Qed.
  Local Hint Extern 1 => apply fancy_args_good: typeclass_instances. (* This is a kludge *)

  Lemma mut_correct :
    0 < machine_wordsize ->
    Partition.partition (uweight machine_wordsize) (1 + 1) (muLow + 2 ^ machine_wordsize) = [muLow; 1].
  Proof.
    intros; cbn. subst muLow.
    assert (0 < 2^machine_wordsize) by ZeroBounds.Z.zero_bounds.
    pose proof (Z.mod_pos_bound mu (2^machine_wordsize) ltac:(lia)).
    rewrite !uweight_S, weight_0; auto using uwprops with lia.
    autorewrite with zsimplify.
    Modulo.push_Zmod. autorewrite with zsimplify. Modulo.pull_Zmod.
    rewrite <-Modulo.Z.mod_pull_div by lia.
    autorewrite with zsimplify. RewriteModSmall.Z.rewrite_mod_small.
    reflexivity.
  Qed.
  Lemma Mt_correct :
    0 < machine_wordsize ->
    2^(machine_wordsize - 1) < M < 2^machine_wordsize ->
    Partition.partition (uweight machine_wordsize) 1 M = [M].
  Proof.
    intros; cbn. assert (0 < 2^(machine_wordsize-1)) by ZeroBounds.Z.zero_bounds.
    rewrite !uweight_S, weight_0; auto using uwprops with lia.
    autorewrite with zsimplify. RewriteModSmall.Z.rewrite_mod_small.
    reflexivity.
  Qed.

  (** Note: If you change the name or type signature of this
        function, you will need to update the code in CLI.v *)
  Definition check_args {T} (requests : list string) (res : Pipeline.ErrorT T)
    : Pipeline.ErrorT T
    := fold_right
         (fun '(b, e) k => if b:bool then Error e else k)
         res
         [
            ((negb (1 <? machine_wordsize))%Z, Pipeline.Value_not_ltZ "machine_wordsize ≤ 1" 1 machine_wordsize);
            ((negb (2 ^ (machine_wordsize-1) <? M))%Z, Pipeline.Value_not_ltZ "M ≤ 2^(machine_wordsize-1)" (2^(machine_wordsize-1)) M);
            ((negb (M <? 2 ^ machine_wordsize))%Z, Pipeline.Value_not_ltZ "2 ^ machine_wordsize ≤ M" M (2^machine_wordsize));
            ((negb (muLow + 2 ^ machine_wordsize =? ((2 ^ 2) ^ machine_wordsize) / M))%Z, Pipeline.Values_not_provably_equalZ "muLow + 2^machine_wordsize ≠ (2 ^ 2) ^ machine_wordsize) / M" (muLow + 2^machine_wordsize) (((2 ^ 2) ^ machine_wordsize) / M));
            (negb ((2 * (((2 ^ 2) ^ machine_wordsize) mod M) <=? 2 ^ (machine_wordsize + 1) - (muLow + 2 ^ machine_wordsize)))%Z, Pipeline.Value_not_leZ ("(2 * ((2 ^ 2) ^ machine_wordsize) mod M)  2 ^ (machine_wordsize + 1) - (muLow + 2 ^ machine_wordsize)") (2 * (((2 ^ 2) ^ machine_wordsize) mod M)) (2 ^ (machine_wordsize + 1) - (muLow + 2 ^ machine_wordsize))) ].

  Local Arguments Z.mul !_ !_.

  Local Ltac use_curve_good_t :=
    repeat first [ assumption
                 | progress cbv [EquivModulo.Z.equiv_modulo]
                 | progress rewrite ?Z.mul_0_r, ?Pos.mul_1_r, ?Z.mul_1_r in *
                 | reflexivity
                 | lia
                 | progress cbn in *
                 | progress intros
                 | solve [ auto with zarith ]
                 | rewrite Z.log2_pow2 by use_curve_good_t ].

  Context (requests : list string)
          (curve_good : check_args requests (Success tt) = Success tt).

  Lemma use_curve_good
    : 1 < machine_wordsize
      /\ 2 ^ (machine_wordsize - 1) <= M < 2 ^ machine_wordsize
      /\ muLow + 2 ^ machine_wordsize = (2 ^ 2) ^ machine_wordsize / M
      /\ 2 ^ (machine_wordsize - 1) < M < 2 ^ machine_wordsize
      /\ 2 * ((2 ^ 2) ^ machine_wordsize mod M) <= 2 ^ (machine_wordsize + 1) - (muLow + 2 ^ machine_wordsize).
  Proof using curve_good.
    prepare_use_curve_good ().
    { use_curve_good_t. }
  Qed.

  Definition barrett_red
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         fancy_args (* fancy *)
         possible_values
         (reified_barrett_red_gen
            @ GallinaReify.Reify M
            @ GallinaReify.Reify (machine_wordsize:Z)
            @ GallinaReify.Reify (machine_wordsize:Z)
            @ GallinaReify.Reify 1%nat
            @ GallinaReify.Reify [muLow;1]
            @ GallinaReify.Reify [M])
         (bound, (bound, tt))
         bound.

  Definition sbarrett_red (prefix : string)
    : string * (Pipeline.ErrorT (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "barrett_red" barrett_red
          (fun _ _ _ => @nil string).

  Local Ltac solve_barrett_red_preconditions :=
    repeat first [ lia
                 | assumption
                 | match goal with |- ?x = ?x => reflexivity end
                 | apply use_curve_good
                 | progress autorewrite with zsimplify
                 | progress intros
                 | progress cbv [weight]
                 | rewrite mut_correct
                 | rewrite Mt_correct
                 | rewrite uweight_eq_alt'
                 | rewrite Z.pow_mul_r by lia ].

  Local Strategy -100 [barrett_red]. (* needed for making Qed not take forever *)
  Local Opaque expr.Interp. (* to prevent [autorewrite with interp_gen_cache] from taking forever *)
  Lemma barrett_red_correct res (Hres : barrett_red = Success res)
    : barrett_red_correct machine_wordsize M (API.Interp res).
  Proof using M curve_good.
    cbv [barrett_red_correct]; intros.
    assert (1 < machine_wordsize) by apply use_curve_good.
    pose proof (Z.mod_pos_bound mu (2^machine_wordsize) ltac:(lia)).
    rewrite <-Fancy.fancy_reduce_correct with (mu := muLow + 2^machine_wordsize) (width:=machine_wordsize) (sz:=1%nat) (mut:=[muLow;1]) (Mt:=[M]) by solve_barrett_red_preconditions.
    remember Fancy.fancy_reduce eqn:?. (* to prevent [reflexivity] from taking forever *)
    prove_correctness' ltac:(fun _ => idtac) use_curve_good.
    { subst; reflexivity. }
    { cbv [ZRange.type.base.option.is_bounded_by ZRange.type.base.is_bounded_by bound is_bounded_by_bool value_range upper lower]. rewrite Bool.andb_true_iff, !Z.leb_le. lia. }
    { cbv [ZRange.type.base.option.is_bounded_by ZRange.type.base.is_bounded_by bound is_bounded_by_bool value_range upper lower]. rewrite Bool.andb_true_iff, !Z.leb_le. lia. }
  Qed.

  Lemma Wf_barrett_red res (Hres : barrett_red = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). apply fancy_args_good. Qed.
End rbarrett_red.

Module Export Hints.
  Hint Opaque
       barrett_red
  : wf_op_cache.
  Hint Immediate
       Wf_barrett_red
  : wf_op_cache.
End Hints.


Require Import
  HoTT.Basics.Equivalences
  HoTT.Types.Bool
  HoTT.Types.Forall
  HoTT.Types.Sigma
  HoTT.Types.Prod
  HoTT.Algebra.UniversalAlgebra.Finitary.ua_homomorphism.

Import algebra_notations ne_list.notations.

(** The following section defines product algebra [ProdAlgebra].
    Section [bin_prod_algebra] specialises the definition to
    binary product algebra. *)

Section prod_algebra.
  Context `{Funext} {σ : Signature} (I : Type) (A : I → Algebra σ).

  Definition carriers_prod_algebra : Carriers σ
    := λ (s : Sort σ), ∀ (i:I), A i s.

  Fixpoint op_prod_algebra (w : SymbolType σ)
      : (∀ i, Operation (A i) w) →
        Operation carriers_prod_algebra w :=
    match w return (∀ i, Operation (A i) w) →
                    Operation carriers_prod_algebra w
    with
    | [:_:] => idmap
    | _ ::: g => λ f p, op_prod_algebra g (λ i, f i (p i))
    end.

  Definition ops_prod_algebra (u : Symbol σ)
    : Operation carriers_prod_algebra (σ u)
    := op_prod_algebra (σ u) (λ (i:I), u ^^ A i).

  Definition ProdAlgebra : Algebra σ
    := BuildAlgebra carriers_prod_algebra ops_prod_algebra.

  Global Instance trunc_prod_algebra {n : trunc_index}
    `{!∀ i, IsTruncAlgebra n (A i)}
    : IsTruncAlgebra n ProdAlgebra.
  Proof.
    intro s. exact _.
  Qed.
End prod_algebra.

(** The next section defines the product projection homomorphisms. *)

Section hom_proj_prod_algebra.
  Context `{Funext} {σ : Signature} (I : Type) (A : I → Algebra σ).

  Definition def_proj_prod_algebra (i:I) (s : Sort σ) (c : ProdAlgebra I A s)
    : A i s
    := c i.

  Lemma oppreserving_proj_prod_algebra {w : SymbolType σ}
    (i : I) (v : ∀ i : I, Operation (A i) w) (α : Operation (A i) w)
    (P : v i = α)
    : OpPreserving (def_proj_prod_algebra i)
        (op_prod_algebra I A w v) α.
  Proof.
    induction w.
    - exact P.
    - intro p. apply (IHw (λ i, v i (p i)) (α (p i))). f_ap.
  Defined.

  Global Instance is_homomorphism_proj_prod_algebra (i:I)
    : IsHomomorphism (def_proj_prod_algebra i).
  Proof.
    intro u.
    by apply oppreserving_proj_prod_algebra.
  Defined.

  Definition hom_proj_prod_algebra (i : I)
    : Homomorphism (ProdAlgebra I A) (A i)
    := BuildHomomorphism (def_proj_prod_algebra i).

End hom_proj_prod_algebra.

(** The product algebra univarsal mapping property [ump_prod_algebra]. *)

Section ump_prod_algebra.
  Context
    `{Funext}
    {σ : Signature}
    (I : Type)
    (A : I → Algebra σ)
    (C : Algebra σ).

  Definition hom_prod_algebra_mapout
    (f : Homomorphism C (ProdAlgebra I A)) (i:I)
    : Homomorphism C (A i)
    := hom_compose (hom_proj_prod_algebra I A i) f.

  Definition def_prod_algebra_mapin (f : ∀ (i:I) s, C s → A i s)
    : ∀ (s : Sort σ) , C s → ProdAlgebra I A s
    := λ (s : Sort σ) (x : C s) (i : I), f i s x.

  Lemma oppreserving_prod_algebra_mapin {w : SymbolType σ}
    (f : ∀ (i:I) s, C s → A i s)
    (α : ∀ (i:I), Operation (A i) w) (β : Operation C w)
    (P : ∀ (i:I), OpPreserving (f i) β (α i))
    : OpPreserving (def_prod_algebra_mapin f) β
        (op_prod_algebra I A w (λ i, α i)).
  Proof.
    induction w.
    - funext i. apply P.
    - intro x. apply IHw. intro i. apply P.
  Defined.

  Global Instance is_homomorphism_prod_algebra_mapin
    (f : ∀ (i:I), Homomorphism C (A i))
    : IsHomomorphism (def_prod_algebra_mapin f).
  Proof.
    intro u.
    apply oppreserving_prod_algebra_mapin.
    intro i.
    apply f.
  Defined.

  Definition hom_prod_algebra_mapin (f : ∀ i, Homomorphism C (A i))
    : Homomorphism C (ProdAlgebra I A)
    := BuildHomomorphism (def_prod_algebra_mapin f).

  (** Given a family of homomorphisms [h : ∀ (i:I), Homomorphism C (A i)]
      there is a unique homomorphism [f : Homomorphism C (ProdAlgebra I A)]
      such that [h i = hom_compose (pr i) f], where

      <<
        pr i = hom_proj_prod_algebra I A i
      >>

      is the ith projection homomorphism. *)

 Lemma ump_prod_algebra `{!∀ i, IsHSetAlgebra (A i)}
   : (∀ (i:I), Homomorphism C (A i)) <~> Homomorphism C (ProdAlgebra I A).
  Proof.
    apply (equiv_adjointify hom_prod_algebra_mapin hom_prod_algebra_mapout).
    - intro f. by apply path_hset_homomorphism.
    - intro f. funext i. by apply path_hset_homomorphism.
  Defined.
End ump_prod_algebra.

(** Binary product algebra. *)

Section bin_prod_algebra.
  Context `{Funext} {σ : Signature} (A B : Algebra σ).

  Definition bin_prod_algebras (b:Bool) : Algebra σ
    := if b then B else A.

  Global Instance trunc_bin_prod_algebras {n : trunc_index}
    `{!IsTruncAlgebra n A} `{!IsTruncAlgebra n B}
    : ∀ (b:Bool), IsTruncAlgebra n (bin_prod_algebras b).
  Proof.
    intros []; exact _.
  Qed.

  Definition BinProdAlgebra : Algebra σ :=
    ProdAlgebra Bool bin_prod_algebras.

  Definition fst_prod_algebra : Homomorphism BinProdAlgebra A
    := hom_proj_prod_algebra Bool bin_prod_algebras false.

  Definition snd_prod_algebra : Homomorphism BinProdAlgebra B
    := hom_proj_prod_algebra Bool bin_prod_algebras true.
End bin_prod_algebra.

Module prod_algebra_notations.

  Global Notation "A × B" := (BinProdAlgebra A B)
                             (at level 40, left associativity)
                             : Algebra_scope.

End prod_algebra_notations.

Import prod_algebra_notations.

(** Specialisation of the product algebra univarsal mapping property
    to binary product. *)

Section ump_bin_prod_algebra.
  Context
    `{Funext}
    {σ : Signature}
    (A B C : Algebra σ)
    `{!IsHSetAlgebra A} `{!IsHSetAlgebra B}.

 Lemma ump_bin_prod_algebra
   : Homomorphism C A * Homomorphism C B <~> Homomorphism C (A × B).
  Proof.
    set (k := λ (b:Bool), Homomorphism C (bin_prod_algebras A B b)).
    exact (equiv_compose
            (ump_prod_algebra Bool (bin_prod_algebras A B) C)
            (equiv_bool_forall_prod k)^-1).
  Defined.
End ump_bin_prod_algebra.


Welcome to Coq 8.4pl6 (January 2017)

Coq < Notation "x ++ y" := (app x y) (right associativity, at level 60).

Coq < Notation "[ ]" := nil.
Setting notation at level 0.

Coq < Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Setting notation at level 0.

Coq < Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
1 subgoal

  ============================
   [1; 2; 3] ++ [4; 5] = [1; 2; 3; 4; 5]

test_app1 < Proof,

test_app1 < reflexivity.
No more subgoals.

test_app1 < Qed.
reflexivity.

test_app1 is defined

Coq < Example test_app2: nil ++ [4;5] = [4;5].
1 subgoal

  ============================
   [] ++ [4; 5] = [4; 5]

test_app2 < Proof.
1 subgoal

  ============================
   [] ++ [4; 5] = [4; 5]

test_app2 < reflexivity.
No more subgoals.

test_app2 < Qed.
reflexivity.

test_app2 is defined

Coq < Example test_app3: [1;2;3] ++ nil = [1;2;3].
1 subgoal

  ============================
   [1; 2; 3] ++ [] = [1; 2; 3]

test_app3 < Proof.
1 subgoal

  ============================
   [1; 2; 3] ++ [] = [1; 2; 3]

test_app3 < reflexivity.
No more subgoals.

test_app3 < Qed.
reflexivity.

test_app3 is defined


  (***************************************************************)
  (*   This file is part of the static analyses developement -   *)
  (*   specification of kildall's algorithm, and proof it is a   *)
  (*   bytecode verifier -                                       *)
  (*							         *)
  (*   File : inst_types.v				         *)
  (*   Authors : S. Coupet-Grimal, W. Delobel 		         *)
  (*   Content : instanciation of kildall's algorithm for        *)
  (*             type analysis                                   *)
  (***************************************************************)

Unset Standard Proposition Elimination Names.

Section inst_types.

  Require Export machine.
  Require Export kildall_bv.

  Variable fcn : function. (* the function on which verification is performed *)
  Notation n := (fcn_size fcn).
  Notation bc := (fcn_bytecode fcn).
  Notation Rt := (fcn_ret fcn).
  Notation Instruction := (instruction n).
  Notation Get_function := (get_function_by_name functions).
  Notation Get_constr := (get_constr_by_name constructors).

  (* set of the instructions' states *)
  Inductive Sigma : Set :=
    | Top_T : Sigma (* top element *)
    | Bot_T : Sigma (* bottom element *)
    | Types : list name->Sigma. (* list of type names, one for each element on the actual stack *)

  (* order on Sigma *)
  Definition r (a : Sigma) (b : Sigma) : Prop :=
    match a,b with
      _, Top_T => True
      |
        Top_T, _ => False
      |
        Bot_T, _ => True
      |
        _, Bot_T => False
      |
        a, b => a=b
    end.

  Lemma eq_list_name_dec : forall (a b : list name), {a=b}+{a<>b}.
  Proof.
    apply list_eq_dec.
    apply eq_name_dec.
  Qed.

  (* sup on Sigma *)
  Definition f (a : Sigma) (b : Sigma) : Sigma :=
    match a,b with
      _, Top_T => Top_T
      |
        Top_T, _ => Top_T
      |
        Bot_T, x => x
      |
        x, Bot_T => x
      |
        Types a, Types b => match (eq_list_name_dec a b) with
      	       	              left _ => Types a
		              |
		                right _ => Top_T
		            end
    end.

  (************************************************************************)
  (*                     Results on (Sigma, r, f)                         *)
  (************************************************************************)

  Lemma eq_Sigma_dec : forall (t t' : Sigma), {t=t'} + {t<>t'}.
  Proof.
    induction t.
    intro t'; destruct t'; [left | right | right]; try (intro h; inversion h).
    trivial.
    intro t'; destruct t'; [right | left | right]; try (intro h; inversion h).
    trivial.
    intro t'; destruct t'; [right | right | idtac]; try (intro h; inversion h).
    elim (eq_list_name_dec l l0); intro case; [left | right].
    subst l; trivial.
    intro h; inversion h; apply case; trivial.
  Qed.

  Lemma Top_T_top : forall (a : Sigma), r a Top_T.
  Proof.
    intro a; destruct a; constructor.
  Qed.

  Lemma Bot_T_bot : forall (a : Sigma), r Bot_T a.
  Proof.
    intro a; destruct a; constructor.
  Qed.

  Lemma r_is_order : order Sigma r.
  Proof.
    split.
  (*refl*)
    intro x.
    elim x; constructor.
  (*trans*)
    intros x y z.
    elim x.
    elim y.
    intro H; clear H; elim z; trivial.
    intro H; inversion H.
    intros l H; inversion H.
    elim z; constructor.
    intro l; elim y.
    elim z.
    trivial.
    intros h H; inversion H.
    intros l' h H; inversion H.
    intro H; inversion H.
    intros l0 H.
    inversion H.
    subst l0.
    trivial.
  (*antisym*)
    intros x y.
    elim x; elim y; try trivial; intros H1 H2.
    inversion H1.
    inversion H2.
    inversion H2.
    intro H; inversion H.
    intro H; inversion H.
    inversion H2.
  Qed.

  Lemma f_is_lub : lub Sigma r f.
  Proof.
    split.
  (* lub1 *)
    intros a b.
    elim a.
    elim b; constructor.
    apply Bot_T_bot.
    elim b; try constructor.
    unfold f; intros l l0; elim (eq_list_name_dec l0 l); constructor.
    split; intros a b.
  (* lub2 *)
    elim b.
    elim a; constructor.
    apply Bot_T_bot.
    elim a; try constructor.
    unfold f; intros l l0; elim (eq_list_name_dec l l0); intro case.
    subst l; constructor.
    constructor.
  (* lub3 *)
    intros c H; elim H; clear H; intros rac rbc.
    destruct c.
    apply Top_T_top.
    destruct a; destruct b; try inversion rac; try inversion rbc.
    constructor.
    unfold f; destruct a; destruct b; try inversion rac; try inversion rbc; try constructor.
    elim (eq_list_name_dec l l); intro case; [constructor | elim case]; trivial.
  Qed.

  Lemma r_is_semilattice : semilattice Sigma r f.
  Proof.
    split.
    apply r_is_order.
    apply f_is_lub.
  Qed.

  Lemma AccTop_T : Acc (strict (inv r)) Top_T.
  Proof.
    constructor.
    intros y H; elim H; clear H; intros H1 H2.
    destruct y; try inversion H1.
    elim H2; trivial.
  Qed.

  Lemma AccSl : forall (l : list name), Acc (strict (inv r)) (Types l).
  Proof.
    intro l; constructor.
    intros y H; elim H; clear H; intros H1 H2.
    destruct y; try inversion H1.
    apply AccTop_T.
    subst l0; elim H2; trivial.
  Qed.

  Lemma wfr : ascending_chain r.
  Proof.
    unfold ascending_chain.
    unfold well_founded.
    induction a.
    apply AccTop_T.
    constructor; intros y H; elim H; clear H; intros H1 H2.
    destruct y.
    apply AccTop_T.
    elim H2; trivial.
    apply AccSl.
    apply AccSl.
  Qed.

  (************************************************************************)
  (*                       Definition of Step                             *)
  (************************************************************************)

  Definition Step (p:nat) (C: p <n) (s:Sigma) :  list Sigma :=
    match bc[p|C] with
    (* Return *)
      | i_return =>
        match s with
          | Bot_T => Bot_T :: nil
          | Top_T => Top_T :: nil
          | Types l =>
      	    match l with
      	      | nil => Top_T :: nil
      	      | e::t =>
      	        match (eq_name_dec e Rt) with
      	          | left _ => (Types (e::t)) :: nil
      	          | right _ => Top_T :: nil
      	        end
      	    end
        end
    (* Stop *)
      | i_stop => nil
    (* Load *)
      | i_load i =>
        match s with
          | Bot_T => Bot_T :: nil
          | Top_T => Top_T :: nil
          | Types l =>
      	    match (rev l)[i] with
	      | Some h => (Types (h::l)) :: nil
	      |  _ => Top_T :: nil
	    end
        end
    (* Call *)
      | i_call g ar =>
        match s with
          | Bot_T => Bot_T :: nil
          | Top_T => Top_T :: nil
          | Types l =>
      	    match (split_k_elements ar l) with
      	      | Some (lk, lr) =>
      	        match (Get_function g) with
      	          | Some gcn =>
      	       	    match (eq_list_name_dec (rev lk) (fcn_args gcn)) with
      	       	      | left _ => (Types ((fcn_ret gcn)::lr)) :: nil
      	       	      | right _ => Top_T :: nil
      	       	    end
      	          | _ => Top_T :: nil
      	        end
      	      | _ => Top_T :: nil
      	    end
        end
    (* Build *)
      | i_build c ar =>
        match s with
          | Bot_T => Bot_T :: nil
          | Top_T => Top_T :: nil
          | Types l =>
      	    match (split_k_elements ar l) with
      	      | Some (lk,lr) =>
      	        match (Get_constr c) with
      	          | Some const =>
      	       	    match eq_list_name_dec (rev lk) (cons_args const) with
                      | left _ => (Types ((cons_ret const)::lr)) :: nil
      	       	      | right _ => Top_T :: nil
      	       	    end
                  | _ => Top_T :: nil
      	        end
              | _ => Top_T :: nil
      	    end
        end
    (* Branch *)
      | i_branch c _ _ =>
        match s with
        | Bot_T => Bot_T :: (Bot_T :: nil)
        | Top_T => Top_T :: (Top_T :: nil)
        |  Types l =>
      	  match (Get_constr c) with
      	    | Some const =>
      	      match l with
      	       | h::t =>
      	         match eq_name_dec h (cons_ret const) with
      	       	  | left _ => (Types ((rev (cons_args const))++t)) :: ((Types l) :: nil)
      	       	  | right _ => Top_T :: (Top_T :: nil)
      	         end
      	       | nil => Top_T :: (Top_T :: nil)
      	      end
            | _ => Top_T :: (Top_T :: nil)
      	   end
        end
    end.

  (* Step does not vary upon its second argument *)
  Lemma Step_equiv : forall (p:nat) (C C': p <n) (s:Sigma),
    (Step p C s) = (Step p C' s).
  Proof.
    intros; unfold Step.
    rewrite (element_at_irrel Instruction n bc p C' C).
    trivial.
  Qed.

  Lemma Step_Succs_aux_same_length : forall (p:nat) (C: p <n) (s:Sigma),
    nb_length (Succs_aux n bc p C) = length (Step p C s).
  Proof.
    intros p C s.
    unfold Succs_aux ; unfold Step.
    destruct (bc[p|C]) as [ | | j | fnm ar | cnm ar | cnm j Cj]; try elim s; simpl; trivial.
    (* return *)
    intro l; destruct l as [ | e l']; simpl.
    trivial.
    elim (eq_name_dec e Rt); simpl; trivial.
    (* load *)
    intro l.
    CaseEq ((rev l)[j]); simpl; trivial.
    (* call *)
    intros l.
    elim (split_k_elements ar l); elim (Get_function fnm); simpl; try trivial.
    intros a a0; elim a0; simpl; try trivial.
    intros a1 b; elim (eq_list_name_dec (rev a1) (fcn_args a)); simpl; trivial.
    intro a; destruct a; simpl; trivial.
    (* build *)
    intro l.
    elim (split_k_elements ar l); elim (Get_constr cnm); simpl; try trivial.
    intros a a0; elim a0; simpl; try trivial.
    intros a1 b; elim (eq_list_name_dec (rev a1) (cons_args a)); simpl; trivial.
    intro a; destruct a; simpl; trivial.
    (* branch *)
    intros l.
    elim (Get_constr cnm); simpl; try trivial.
    destruct l; simpl; try trivial.
    intros a; elim (eq_name_dec n (cons_ret a)); simpl; trivial.
  Defined.

    (* Step and Succs produce same length lists *)
  Lemma Step_Succs_same_length : forall (lr : last_return_or_stop n bc) (p:nat) (C: p <n) (s:Sigma),
    nb_length (Succs n bc lr p C) = length (Step p C s).
  Proof.
    intros lr p C s.
    replace (nb_length (Succs n bc lr p C)) with (nb_length (Succs_aux n bc p C)).
    apply Step_Succs_aux_same_length; assumption.
    unfold Succs.
    apply nb_list_convert_length with (l:=Succs_aux n bc p C) (H:=Succs_better_bound n bc p C lr).
  Defined.

  Lemma refl_dep_r : forall (l : list Sigma),
    list_pointwise Sigma r l l.
  Proof.
    induction l; try constructor.
    elim a; constructor.
    apply IHl.
  Qed.

  Lemma dep_r_Bot_T_1 : forall (l : list Sigma),
    1 = length l -> list_pointwise Sigma r (Bot_T :: nil) l.
  Proof.
    induction l; simpl; intro H.
    inversion H.
    constructor.
    apply Bot_T_bot.
    destruct l; try constructor; simpl in H.
    inversion H.
  Qed.

  Lemma dep_r_Top_T_1 : forall (l : list Sigma),
    1 = length l -> list_pointwise Sigma r l (Top_T :: nil).
  Proof.
    induction l; simpl; intro H.
    inversion H.
    constructor.
    apply Top_T_top.
    destruct l; try constructor; simpl in H.
    inversion H.
  Qed.

  Lemma dep_r_Bot_T_2 : forall (l : list Sigma),
    2 = length l -> list_pointwise Sigma r (Bot_T :: (Bot_T :: nil)) l.
  Proof.
    induction l; simpl; intro H.
    inversion H.
    destruct l; simpl.
    inversion H.
    constructor.
    apply Bot_T_bot.
    constructor.
    apply Bot_T_bot.
    destruct l; try constructor; simpl in H.
    inversion H.
  Qed.

  Lemma dep_r_Top_T_2 : forall (l : list Sigma),
    2 = length l -> list_pointwise Sigma r l (Top_T :: (Top_T :: nil)).
  Proof.
    induction l; simpl; intro H.
    inversion H.
    destruct l; simpl.
    inversion H.
    constructor.
    apply Top_T_top.
    constructor.
    apply Top_T_top.
    destruct l; try constructor; simpl in H.
    inversion H.
  Qed.

    (* monotonicity of Step : *)
  Lemma monotone_Step : monotonestep Sigma n Step r.
  Proof.
    intros p C s t rst.
    destruct s; destruct t; try inversion rst.
    apply refl_dep_r.
    unfold Step; CaseEq (bc[p|C]); simpl; auto; try constructor; auto; try constructor.
    assumption.
    constructor.
    apply refl_dep_r.
    (* list_pointwise Sigma r (Step p C Bot_T) (Step p C (Types l)) : *)
    unfold Step; CaseEq (bc[p|C]); simpl; auto; try constructor; auto; try constructor.
    (* return *)
    intro; apply dep_r_Bot_T_1.
    destruct l as [ | e t]; simpl.
    trivial.
    elim (eq_name_dec e Rt); simpl; trivial.
    (* load *)
    intros j case; apply dep_r_Bot_T_1.
    CaseEq ((rev l)[j]); simpl; trivial.
    (* call *)
    intros g ar case; apply dep_r_Bot_T_1.
    elim (split_k_elements ar l); elim (Get_function g); simpl; try trivial.
    intros gcn p0; destruct p0 as [lk lr].
    elim (eq_list_name_dec (rev lk) (fcn_args gcn)); simpl; trivial.
    intro p0; destruct p0; simpl; trivial.
    (* build *)
    intros c ar case; apply dep_r_Bot_T_1.
    elim (split_k_elements ar l); elim (Get_constr c); simpl; trivial.
    intros cnst p0; destruct p0 as [lk lr].
    elim (eq_list_name_dec (rev lk) (cons_args cnst)); simpl; trivial.
    intro a; destruct a; simpl; trivial.
    (* branch *)
    intros c i Ci case; apply dep_r_Bot_T_2.
    elim (Get_constr c); simpl; try trivial.
    intro cnst; destruct l as [|h t]; simpl; trivial.
    elim (eq_name_dec h (cons_ret cnst)); simpl; try trivial.
    (* list_pointwise Sigma r (Step p C (Types l)) (Step p C Top_T)  : *)
    unfold Step; CaseEq (bc[p|C]); simpl; auto; try constructor; auto; try constructor.
    (* return *)
    intro; apply dep_r_Top_T_1.
    destruct l as [| h t]; simpl.
    trivial.
    elim (eq_name_dec h Rt); simpl; trivial.
    (* load *)
    intros j case; apply dep_r_Top_T_1.
    destruct ((rev l)[j]); simpl; trivial.
    (* call *)
    intros g ar case; apply dep_r_Top_T_1.
    elim (split_k_elements ar l); elim (Get_function g); simpl; trivial.
    intros gcn p0; destruct p0 as [lk lr].
    elim (eq_list_name_dec (rev lk) (fcn_args gcn)); simpl; trivial.
    intro a; destruct a; simpl; trivial.
    (* build *)
    intros c ar case; apply dep_r_Top_T_1.
    elim (split_k_elements ar l); elim (Get_constr c); simpl; trivial.
    intros cnst p0; destruct p0 as [lk lr].
    elim (eq_list_name_dec (rev lk) (cons_args cnst)); simpl; trivial.
    intro a; destruct a; simpl; trivial.
    (* branch *)
    intros c i Ci case; apply dep_r_Top_T_2.
    elim (Get_constr c); destruct l as [|h t]; simpl; trivial.
    intro cnst; elim (eq_name_dec h (cons_ret cnst)); simpl; trivial.
    (* list_pointwise Sigma r (Step p C (Types l0)) (Step p C (Types l0)) : *)
    apply refl_dep_r.
  Qed.

    (************************************************************************)
    (*                          Definition of Wti                           *)
    (************************************************************************)

  Definition Wti (ss : vector Sigma n) (p : nat) (C : p < n): Prop :=
    match (ss[p|C]) with
      Top_T => False
      |
        Bot_T => True
      |
        Types l =>
        match (bc[p|C]) with
         (* Return *)
          i_return =>
          match l with
            Ret::t =>
            match (eq_name_dec Ret Rt) with
      	      left _ => True
      	      |
      	        right _ => False
      	    end
      	    |
      	      _ => False
          end
          |
         (* Stop *)
            i_stop => True
          |
         (* Load *)
            i_load i =>
            match (ss[S p|_]) with
	      Some (Types l') =>
      	      match ((rev l)[i]) with
      	        Some li =>
      	        match (eq_list_name_dec (li::l) l') with
      	       	  left _ => True
      	       	  |
      	       	    right _ => False
	        end
	        |
	          None => False
	      end
      	      |
      	        _ => False
            end
          |
         (* Call *)
            i_call g ar =>
            match (split_k_elements ar l) with
      	      Some (lk, lr) =>
      	      match (Get_function g) with
      	        Some gcn =>
      	        match (eq_list_name_dec (rev lk) (fcn_args gcn)) with
      	       	  left _ =>
      	       	    match (ss[S p|_]) with
      	       	      Some (Types l') =>
      	       	      match (eq_list_name_dec ((fcn_ret gcn)::lr) l') with
      	       	       	left _ => True
      	       	       	|
      	       	       	  right _ => False
      	       	      end
      	       	      |
      	       	        _ => False
      	       	    end
      	       	  |
      	       	    right _ => False
      	        end
      	        |
      	          _ => False
      	      end
      	      |
      	        _ => False
            end
          |
         (* Build *)
            i_build c ar =>
            match (split_k_elements ar l) with
      	      Some (lk, lr) =>
      	      match (Get_constr c) with
      	        Some const =>
      	        match (eq_list_name_dec (rev lk) (cons_args const)) with
      	       	  left _ =>
      	       	    match (ss[S p|_]) with
      	       	      Some (Types l') =>
      	       	      match (eq_list_name_dec ((cons_ret const)::lr) l') with
      	       	       	left _ => True
      	       	       	|
      	       	       	  right _ => False
      	       	      end
      	       	      |
      	       	        _ => False
      	       	    end
      	       	  |
      	       	    right _ => False
      	        end
      	        |
      	          _ => False
      	      end
      	      |
      	        _ => False
            end
          |
         (* Branch *)
            i_branch c i Ci =>
            (match eq_Sigma_dec (ss[p|C]) (ss[i|Ci]) with
	       left _ => True
      	       |
      	         right _ => False
             end)
            /\
            (match (Get_constr c) with
      	       Some const =>
      	       match l with
      	         h::t =>
      	         match (eq_name_dec (cons_ret const) h) with
      	       	   left _ =>
      	       	     match (ss[S p|_]) with
      	       	       Some (Types l') =>
      	       	       match (eq_list_name_dec ((rev (cons_args const))++t) l') with
      	       	       	 left _ => True
      	       	       	 |
      	       	       	   right _ => False
      	       	       end
      	       	       |
      	       	         _ => False
      	       	     end
      	       	   |
      	       	     right _ => False
      	         end
      	         |
      	           _ => False
      	       end
      	       |
      	         _ => False
             end)
        end
    end.

    (* Program states for which Wti holds at rank p are stable at rank p *)
  Lemma Wti_imp_stable : forall (lrs_bc : last_return_or_stop n bc) (ss : vector Sigma n)
    (p : nat) (C : p < n) (Tfree : ~ Top_T INv ss),
    Wti ss p C -> stable Sigma n (Succs n bc lrs_bc) Step r (Step_Succs_same_length lrs_bc) ss p C.
  Proof.

    unfold stable.
    intros lrs_bc ss p C Tfree Wt q t H .
    cut (q <n); [intro Cq | apply (m_list_get_witness (step' Sigma n (Succs n bc lrs_bc) Step
      (Step_Succs_same_length lrs_bc) p C (ss[p|C])) (q, t) H)].
    rewrite (element_at_irrel Sigma n ss q (m_list_get_witness (step' Sigma n (Succs n bc lrs_bc) Step
      (Step_Succs_same_length lrs_bc) p C (ss[p|C])) (q, t) H)Cq).
    cut (m_list_belong (combine (Succs_aux n bc p C) (Step p C (ss[p|C]))
      (Step_Succs_aux_same_length p C (ss[p|C]))) (q, t));
    [clear H | generalize H; unfold step'; unfold Succs; apply m_list_convert_belong].
    clear lrs_bc.
    generalize Wt; clear Wt.
    CaseEq (ss[p|C]).
    (* Top_T *)
    unfold Wti; intros case H; rewrite case in H; inversion H.
    (* Bot_T *)
    intros case dd Hbelong; clear dd;
      cut (m_list_belong_snd (combine (Succs_aux n bc p C) (Step p C Bot_T) (Step_Succs_aux_same_length p C Bot_T)) t).
    clear Hbelong; intro Hbelong; generalize (in_snd_combine_in_snd _ _ _ _ _ _ Hbelong).
    intro Hin; replace t with Bot_T.
    apply Bot_T_bot.
    unfold Step in Hin; destruct (bc[p|C]); inversion Hin; trivial; try inversion H; trivial.
    inversion H0.
    generalize Hbelong; apply belong_and_snd.
    (* Some l *)
    intros l case.
    unfold Wti; unfold Step; unfold Succs_aux; unfold Step_Succs_aux_same_length;
      rewrite case; destruct (bc[p|C]); simpl.
    (* return *)
    CaseEq l; [intros case' H; inversion H | intros n0 l0 case'].
    elim (eq_name_dec n0 Rt); intros case'' H' H.
    subst n0.
    inversion H; inversion H0.
    subst q; rewrite (element_at_irrel Sigma n ss p Cq C); rewrite case; rewrite case'; constructor.
    inversion H'.
    (* stop *)
    intros dd H; inversion H.
    (* load *)
    CaseEq (ss[S p|_]).

    intros l0 case'.
    destruct l0.
    intro F; inversion F.
    intro F; inversion F.
    destruct ((rev l)[n]).
    elim (eq_list_name_dec (n0 :: l) l0); intros case'' H; [clear H | inversion H].
    intro H; inversion H; inversion H0.
    subst q; subst l0; subst t.
    rewrite (element_at_unsafe_to_safe Sigma _ ss (S p) Cq (Types (n0 :: l)) case').
    constructor.
    intro F; inversion F.

    intros case' H; inversion H.

    (* call *)
    generalize (split_k_elements_ok name n0 l); intro Hsplit_ok.
    destruct (split_k_elements n0 l); [idtac | intro F; inversion F].
    destruct p0.
    CaseEq (Get_function n); [idtac | intros dd F; inversion F].
    intros f0 case_fun.
    cut (l = l0 ++ l1); [intro; subst l | apply (Hsplit_ok l0 l1); trivial].
    clear Hsplit_ok.
    CaseEq (ss[S p|_]).
    intros s case_ss_S_p; destruct s.
    intro H; cut False; [intro F; inversion F | idtac].
    generalize H; elim (eq_list_name_dec (rev l0) (fcn_args f0)); trivial.
    intro H; cut False; [intro F; inversion F | idtac].
    generalize H; elim (eq_list_name_dec (rev l0) (fcn_args f0)); trivial.
    elim (eq_list_name_dec ((fcn_ret f0) :: l1) l).
    intro; subst l.
    destruct f0.
    simpl in *.
    elim (eq_list_name_dec (rev l0) fcn_args).
    intros case_sign d H; inversion H; inversion H0.
    subst q t.
    rewrite (element_at_unsafe_to_safe Sigma _ ss (S p) Cq (Types (fcn_ret :: l1)) case_ss_S_p).
    constructor.
    intros dd F; inversion F.
    intros dd H; cut False; [intro F; inversion F | idtac].
    generalize H; elim (eq_list_name_dec (rev l0) (fcn_args f0)); trivial.
    intros dd H; cut False; [intro F; inversion F | idtac].
    generalize H; elim (eq_list_name_dec (rev l0) (fcn_args f0)); trivial.

    (* build *)
    generalize (split_k_elements_ok name n0 l); intro Hsplit_ok.
    destruct (split_k_elements n0 l).
    destruct p0.
    CaseEq (Get_constr n).
    intros c case_constr.
    destruct c; simpl in *.
    elim (eq_list_name_dec (rev l0) cons_args).
    CaseEq (ss[S p|_]).
    intros s case_ss_S_p case_cons.
    destruct s.
    intro F; inversion F.
    intro F; inversion F.
    elim (eq_list_name_dec (cons_ret :: l1) l2); intro case_eq.
    intros dd H; clear dd; inversion H; inversion H0; subst l2 cons_args q t.
    rewrite (element_at_unsafe_to_safe Sigma _ ss (S p) Cq (Types (cons_ret :: l1)) case_ss_S_p).
    constructor.
    intro F; inversion F.
    intros H H' F; inversion F.
    intros H F; inversion F.
    intros H F; inversion F.
    intro F; inversion F.

    (* branch *)
    elim (eq_Sigma_dec (Types l) (ss[i|l0])); intro case2.
    intro H; elim H; clear H; intro H; clear H.
    destruct (Get_constr c).
    destruct c0; simpl in *.
    destruct l.
    intro H; inversion H.
    simpl.
    elim (eq_name_dec cons_ret n); intro comp3.
    CaseEq (ss[S p|_]).
    intros s case_ss_S_p; destruct s.
    intro H; inversion H.
    intro H; inversion H.
    elim (eq_list_name_dec (rev cons_args ++ l) l1); intro comp.
    intro dd; clear dd.
    simpl.
    elim (eq_name_dec n cons_ret); intro comp2.
    intro H; inversion H; clear H.
    inversion H0.
    subst q t n l1.
    rewrite (element_at_unsafe_to_safe Sigma _ ss (S p) Cq (Types (rev cons_args ++ l)) case_ss_S_p).
    constructor.
    subst n.
    inversion H0.
    inversion H.
    subst q t.
    rewrite (element_at_irrel Sigma n ss i Cq l0).
    rewrite <- case2.
    constructor.
    inversion H.
    elim comp2; symmetry; assumption.
    intro H; inversion H.
    intros dd H; inversion H.
    intro H; inversion H.
    intro H; inversion H.
    intro H; elim H; clear H; intro H; inversion H.
  Qed.

  Lemma stable_imp_Wti : forall (lrs_bc : last_return_or_stop n bc) (ss : vector Sigma n)
    (p : nat) (C : p < n) (Tfree : ~ Top_T INv ss),
    stable Sigma n (Succs n bc lrs_bc) Step r (Step_Succs_same_length lrs_bc) ss p C -> Wti ss p C.
  Proof.
    unfold stable.
    intros lrs_bc ss p C Tfree H.
    cut (forall (q : nat) (Cq : q < n) (t : Sigma)
      (H : m_list_belong (combine (Succs_aux n bc p C) (Step p C (ss[p|C]))
      	(Step_Succs_aux_same_length p C (ss[p|C]))) (q,t)),
      r t (ss[q|Cq])).
    clear H.
    unfold Wti; unfold Step; unfold Succs_aux.
    CaseEq (ss[p|C]).
    (* Top_T *)
    intro case; elim Tfree; rewrite <- case; apply element_at_belong.
    (* Bot_T *)
    intro case; unfold Step_Succs_aux_same_length; destruct (bc[p|C]); simpl; trivial.
    (* Some l *)
    intros l case.
    cut ((p = pred n) -> (bc[p|C] = i_return n \/ bc[p|C] = i_stop n)).
    intro alt_lrsbc.
    unfold Step_Succs_aux_same_length; destruct (bc[p|C]) as [| |j|g ar|c ar|c j Cj]; simpl.
    (* return *)
    CaseEq l.
    intros case' H.
    generalize (H p C Top_T); clear H; intro H.
    simpl in H.
    cut ((p, Top_T) = (p, Top_T) \/ False).
    intro H1.
    generalize (H H1); clear H.
    CaseEq (ss[p|C]).
    rewrite case.
    intro H2; inversion H2.
    intros; assumption.
    intros; assumption.
    left; trivial.
    intros n0 l0 casel.
    elim (eq_name_dec n0 Rt); intro comp; simpl.
    trivial.
    intro H; generalize (H p C Top_T); clear H; intro H.
    cut ((p, Top_T) = (p, Top_T) \/ False).
    intro H1; generalize (H H1); clear H.
    rewrite case; intro H.
    inversion H.
    left; trivial.
    (* stop *)
    trivial.
    (* load *)
    destruct ((rev l)[j]) as [lj| ].
    cut (S p < n).
    intro Csp.
    cut ((S p, Top_T) = (S p, Top_T) \/ False).
    intro casebelong.

    CaseEq (ss[S p|_]).
    intros s case_ss_S_p.
    simpl; cut ((S p, Types (lj :: l)) = (S p, Types (lj :: l)) \/ False); [intro casebelong' | left; trivial].
    intro H; generalize (H (S p) Csp (Types (lj :: l)) casebelong'); clear H; intro H.
    destruct s.
    apply Tfree.
    replace Top_T with ((ss[S p|Csp])).
    apply element_at_belong.
    apply (element_at_unsafe_to_safe Sigma n ss (S p) Csp Top_T case_ss_S_p).
    replace (ss[S p|Csp]) with Bot_T in H.
    inversion H.
    symmetry; apply (element_at_unsafe_to_safe Sigma n ss (S p) Csp Bot_T case_ss_S_p).
    elim (eq_list_name_dec (lj :: l) l0); intro comp.
    trivial.
    elim comp.
    replace (ss[S p|Csp]) with (Types l0) in H.
    inversion H; trivial.
    symmetry; apply (element_at_unsafe_to_safe Sigma n ss (S p) Csp (Types l0) case_ss_S_p).

    intros case_ss_S_p H.

    generalize (element_at_unsafe_none Sigma n ss (S p) case_ss_S_p).
    apply lt_not_ge; assumption.
    left; trivial.

    compare p (pred n); intro comp.
    elim (alt_lrsbc comp); intro cc; inversion cc.
    clear alt_lrsbc lj case l Tfree ss lrs_bc.
    destruct n.
    inversion C.
    cut (p < n).
    auto with arith.
    simpl in comp.
    apply lt_S_neq_lt; assumption.

    simpl.
    cut (S p < n).
    intro Csp.
    intro H; CaseEq (ss[S p|_]).
    destruct s; intro case_ss_S_p.
    apply Tfree.
    replace Top_T with ((ss[S p|Csp])).
    apply element_at_belong.
    apply (element_at_unsafe_to_safe Sigma n ss (S p) Csp Top_T case_ss_S_p).
    cut ((S p, Top_T) = (S p, Top_T) \/ False); [intro case_belong | left; trivial].
    generalize (H (S p) Csp Top_T case_belong); clear H; intro H.
    replace (ss[S p|Csp]) with Bot_T in H.
    inversion H.
    symmetry; apply (element_at_unsafe_to_safe Sigma n ss (S p) Csp Bot_T case_ss_S_p).
    cut ((S p, Top_T) = (S p, Top_T) \/ False); [intro case_belong | left; trivial].
    generalize (H (S p) Csp Top_T case_belong); clear H; intro H.
    replace (ss[S p|Csp]) with (Types l0) in H.
    inversion H.
    symmetry; apply (element_at_unsafe_to_safe Sigma n ss (S p) Csp (Types l0) case_ss_S_p).
    intro case_ss_S_p; generalize (element_at_unsafe_none Sigma n ss (S p) case_ss_S_p).
    apply lt_not_ge; assumption.

    compare p (pred n); intro comp.
    elim (alt_lrsbc comp); intro cc; inversion cc.
    clear alt_lrsbc j case l Tfree ss lrs_bc.
    destruct n.
    inversion C.
    cut (p < n).
    auto with arith.
    simpl in comp.
    apply lt_S_neq_lt; assumption.

    (* call *)
    cut (S p < n).
    intro Csp.
    cut ((S p, Top_T) = (S p, Top_T) \/ False); [intro casebelong | left; trivial].
    destruct (split_k_elements ar l); simpl.
    destruct p0.
    destruct (Get_function g).
    destruct f0; simpl.
    elim (eq_list_name_dec (rev l0) fcn_args); intro case_fcn.
    CaseEq (ss[S p|_]).
    cut ((S p, Types (fcn_ret :: l1)) = (S p, Types (fcn_ret :: l1)) \/ False); [intro case_belong | left; trivial].
    intros s case_ss_S_p H; generalize (H (S p) Csp (Types (fcn_ret :: l1)) case_belong);
      clear H; intro H; destruct s.
    apply Tfree.
    replace Top_T with (ss[S p|Csp]).
    apply element_at_belong.
    apply element_at_unsafe_to_safe; assumption.
    replace (ss[S p|Csp]) with Bot_T in H.
    inversion H.
    symmetry; apply element_at_unsafe_to_safe; assumption.
    elim (eq_list_name_dec (fcn_ret :: l1) l2); intro comp.
    trivial.
    apply comp.
    replace (ss[S p|Csp]) with (Types l2) in H.
    inversion H; trivial.
    symmetry; apply element_at_unsafe_to_safe; assumption.

    intros case_ss_S_p H; generalize (element_at_unsafe_none Sigma n ss (S p) case_ss_S_p).
    apply lt_not_ge; assumption.
    simpl; intro H; generalize (H (S p) Csp Top_T casebelong); clear H.
    CaseEq (ss[S p|Csp]).
    intros case_ss_S_p dd; clear dd; apply Tfree.
    replace Top_T with (ss[S p|Csp]).
    apply element_at_belong.
    intros H' H; inversion H.
    intros l' H' H; inversion H.

    simpl; intro H; generalize (H (S p) Csp Top_T casebelong); clear H.
    CaseEq (ss[S p|Csp]).
    intros case_ss_S_p dd; clear dd; apply Tfree.
    replace Top_T with (ss[S p|Csp]).
    apply element_at_belong.
    intros H' H; inversion H.
    intros l' H' H; inversion H.

    simpl; intro H; generalize (H (S p) Csp Top_T casebelong); clear H.
    CaseEq (ss[S p|Csp]).
    intros case_ss_S_p dd; clear dd; apply Tfree.
    replace Top_T with (ss[S p|Csp]).
    apply element_at_belong.
    intros H' H; inversion H.
    intros l' H' H; inversion H.

    compare p (pred n); intro comp.
    elim (alt_lrsbc comp); intro cc; inversion cc.
    clear alt_lrsbc ar case l Tfree ss lrs_bc.
    destruct n.
    inversion C.
    cut (p < n).
    auto with arith.
    simpl in comp.
    apply lt_S_neq_lt; assumption.

    (* build *)
    cut (S p < n).
    intro Csp.
    cut ((S p, Top_T) = (S p, Top_T) \/ False); [intro casebelong | left; trivial].
    destruct (split_k_elements ar l); simpl.
    destruct p0.
    destruct (Get_constr c).
    destruct c0; simpl.
    elim (eq_list_name_dec (rev l0) cons_args); intro case_cons.
    CaseEq (ss[S p|_]).
    cut ((S p, Types (cons_ret :: l1)) = (S p, Types (cons_ret :: l1)) \/ False); [intro case_belong | left; trivial].
    intros s case_ss_S_p H; generalize (H (S p) Csp (Types (cons_ret :: l1)) case_belong);
      clear H; intro H; destruct s.
    apply Tfree.
    replace Top_T with (ss[S p|Csp]).
    apply element_at_belong.
    apply element_at_unsafe_to_safe; assumption.
    replace (ss[S p|Csp]) with Bot_T in H.
    inversion H.
    symmetry; apply element_at_unsafe_to_safe; assumption.
    elim (eq_list_name_dec (cons_ret :: l1) l2); intro comp.
    trivial.
    apply comp.
    replace (ss[S p|Csp]) with (Types l2) in H.
    inversion H; trivial.
    symmetry; apply element_at_unsafe_to_safe; assumption.

    intros case_ss_S_p H; generalize (element_at_unsafe_none Sigma n ss (S p) case_ss_S_p).
    apply lt_not_ge; assumption.
    simpl; intro H; generalize (H (S p) Csp Top_T casebelong); clear H.
    CaseEq (ss[S p|Csp]).
    intros case_ss_S_p dd; clear dd; apply Tfree.
    replace Top_T with (ss[S p|Csp]).
    apply element_at_belong.
    intros H' H; inversion H.
    intros l' H' H; inversion H.

    simpl; intro H; generalize (H (S p) Csp Top_T casebelong); clear H.
    CaseEq (ss[S p|Csp]).
    intros case_ss_S_p dd; clear dd; apply Tfree.
    replace Top_T with (ss[S p|Csp]).
    apply element_at_belong.
    intros H' H; inversion H.
    intros l' H' H; inversion H.

    simpl; intro H; generalize (H (S p) Csp Top_T casebelong); clear H.
    CaseEq (ss[S p|Csp]).
    intros case_ss_S_p dd; clear dd; apply Tfree.
    replace Top_T with (ss[S p|Csp]).
    apply element_at_belong.
    intros H' H; inversion H.
    intros l' H' H; inversion H.

    compare p (pred n); intro comp.
    elim (alt_lrsbc comp); intro cc; inversion cc.
    clear alt_lrsbc ar case l Tfree ss lrs_bc.
    destruct n.
    inversion C.
    cut (p < n).
    auto with arith.
    simpl in comp.
    apply lt_S_neq_lt; assumption.

    (* branch *)
    cut (S p < n).
    intro Csp.
    destruct (Get_constr c); simpl.
    destruct c0; simpl.
    cut ((j, Top_T) = (S p, Top_T) \/ (j, Top_T) = (j, Top_T) \/ False).
    intro Hbelong2.

    destruct l; simpl.
    intro H; generalize (H j Cj Top_T Hbelong2); intro H1.
    elim Tfree.
    replace Top_T with (ss[j|Cj]); [apply element_at_belong | symmetry].
    destruct (ss[j|Cj]); try inversion H1; trivial.
    elim (eq_name_dec n cons_ret); intro case_ret; simpl.
    subst n.
    elim (eq_name_dec cons_ret cons_ret); intro d_case; [clear d_case | elim d_case; trivial].
    elim (eq_Sigma_dec (Types (cons_ret :: l)) (ss[j|Cj])); intros case_ss_j H.
    split; trivial.

    CaseEq (ss[S p|_]).
    intros s case_ss_S_p; destruct s.
    apply Tfree; replace Top_T with (ss[S p|Csp]).
    apply element_at_belong.
    apply element_at_unsafe_to_safe; assumption.
    cut ((S p, Types (rev cons_args ++ l)) = (S p, Types (rev cons_args ++ l)) \/ (S p, Types (rev cons_args ++ l)) = (j, Types (cons_ret :: l)) \/ False); [intro Hbelong | left; trivial].
    generalize (H (S p) Csp (Types (rev cons_args ++ l)) Hbelong).
    replace (ss[S p|Csp]) with Bot_T; [clear H; intro H; inversion H | symmetry].
    apply element_at_unsafe_to_safe; assumption.
    elim (eq_list_name_dec (rev cons_args ++ l) l0); trivial.
    intro dd; apply dd; clear dd.
    cut ((S p, Types (rev cons_args ++ l)) = (S p, Types (rev cons_args ++ l)) \/ (S p, Types (rev cons_args ++ l)) = (j, Types (cons_ret :: l)) \/ False); [intro Hbelong | left; trivial].
    generalize (H (S p) Csp (Types (rev cons_args ++ l)) Hbelong).
    replace (ss[S p|Csp]) with (Types l0); [clear H; intro H; inversion H | symmetry].
    trivial.
    apply element_at_unsafe_to_safe; assumption.
    intro Hnone; generalize (element_at_unsafe_none Sigma n ss (S p) Hnone).
    apply lt_not_ge; trivial.

    cut ((j,Types (cons_ret :: l)) = (S p, Types (rev cons_args ++ l)) \/ (j,Types (cons_ret :: l)) = (j,Types (cons_ret :: l)) \/ False); [intro Hbelong | right; left; trivial].
    elim (case_ss_j); symmetry.
    generalize (H j Cj (Types (cons_ret :: l)) Hbelong); CaseEq (ss[j|Cj]).
    intro Htop; elim Tfree; rewrite <- Htop; apply element_at_belong.
    intros Hbot H'; inversion H'.
    intros l1 dd H'; inversion H'; trivial.

    intro H; generalize (H j Cj Top_T Hbelong2); intro H1.
    elim Tfree.
    replace Top_T with (ss[j|Cj]); [apply element_at_belong | destruct (ss[j|Cj]); inversion H1; trivial].
    right; left; trivial.
    cut ((S p, Top_T) = (S p, Top_T) \/ (S p, Top_T) = (j, Top_T) \/ False); [intros Hbelong H | left; trivial].
    generalize (H (S p) Csp Top_T Hbelong); clear H; intro H.
    elim Tfree.
    replace Top_T with (ss[S p|Csp]); [apply element_at_belong | destruct (ss[S p|Csp]); trivial; inversion H].

    compare p (pred n); intro comp.
    elim (alt_lrsbc comp); intro cc; inversion cc.
    clear alt_lrsbc case l Tfree ss lrs_bc.
    destruct n.
    inversion C.
    cut (p < n).
    auto with arith.
    simpl in comp.
    apply lt_S_neq_lt; assumption.

    cut (0<n).
    intros Cn peq; subst p.
    rewrite (element_at_irrel Instruction n bc (pred n) C (lt_pred_n_n n Cn)).
    apply lrs_bc.
    clear case l Tfree ss lrs_bc.
    destruct n.
    inversion C.
    auto with arith.

    intros q Cq t Hbelong.
    cut (m_list_belong (step' Sigma n (Succs n bc lrs_bc) Step (Step_Succs_same_length lrs_bc) p C (ss[p|C])) (q, t)).
    intro Hb.
    generalize (H q t Hb).
    clear H; intro H.
    rewrite (element_at_irrel Sigma n ss q Cq (m_list_get_witness (step' Sigma n (Succs n bc lrs_bc) Step (Step_Succs_same_length lrs_bc) p C (ss[p|C])) (q, t) Hb)); assumption.
    generalize Hbelong; unfold step'; unfold Succs.
    apply m_list_belong_convert.

  Qed.

  Lemma Wti_and_stable_agree : forall (lrs_bc : last_return_or_stop n bc),
    wi_and_stable_agree Sigma n (Succs n bc lrs_bc) Step Wti r Top_T (Step_Succs_same_length lrs_bc).

    intro lrs_bc.
    unfold wi_and_stable_agree.
    intros ss p Cp Tfree; split.
    apply Wti_imp_stable; assumption.
    apply stable_imp_Wti; assumption.
  Qed.

    (************************************************************************)
    (*                              Kildall                                 *)
    (************************************************************************)

  Definition Kildall_types (lrs_bc : last_return_or_stop n bc) :=
    (Kildall Sigma n (Succs n bc lrs_bc) Step r f (Step_Succs_same_length lrs_bc) eq_Sigma_dec r_is_semilattice wfr).

  Theorem Kildall_Is_Bytecode_Verifier : forall (lrs_bc : last_return_or_stop n bc),
    Is_bytecode_verifier Sigma n Wti r Top_T (Kildall_types lrs_bc).
  Proof.
    intro lrs_bc.
    unfold Kildall_types.
    apply Kildall_is_bytecode_verifier.
    apply Succs_equiv.
    apply Step_equiv.
    apply monotone_Step.
    unfold is_top_element; apply Top_T_top.
    apply Wti_and_stable_agree; assumption.
  Qed.

End inst_types.

    (*
    Kildall_types
         : forall fcn : function,
           last_return_or_stop (fcn_size fcn) (fcn_body fcn) ->
           vector Sigma (fcn_size fcn) -> vector Sigma (fcn_size fcn)
    *)