From Coq.Unicode Require Import Utf8.
From Coq.Lists Require Import List.
From Autosubst Require Import Autosubst.
From Coq.Relations Require Import Relations.
From ShortLogrels Require Import prelude language.

Inductive expr :=
| Var (v : var)
| TT
| Pair (e1 e2 : expr)
| Fst (e : expr)
| Snd (e : expr)
| Lam (e : {bind expr})
| App (e1 e2 : expr).

Global Instance Ids_expr : Ids expr. derive. Defined.
Global Instance Rename_expr : Rename expr. derive. Defined.
Global Instance Subst_expr : Subst expr. derive. Defined.
Global Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

Inductive is_val : expr → Prop :=
| IVTT : is_val TT
| IVPair e1 e2 : is_val e1 → is_val e2 → is_val (Pair e1 e2)
| IVLam e : is_val (Lam e).

Inductive type :=
| TUnit
| TProd (τ1 τ2 : type)
| TFun (τ1 τ2 : type).

Definition context := environment type.

Inductive typed : context → expr → type → Prop :=
| TPVar Γ v tp : lookup Γ v = Some tp → typed Γ (Var v) tp
| TPTT Γ : typed Γ TT TUnit
| TPPAIR Γ e1 τ1 e2 τ2 : typed Γ e1 τ1 → typed Γ e2 τ2 → typed Γ (Pair e1 e2) (TProd τ1 τ2)
| TPFst Γ e τ1 τ2 : typed Γ e (TProd τ1 τ2) → typed Γ (Fst e) τ1
| TPSnd Γ e τ1 τ2 : typed Γ e (TProd τ1 τ2) → typed Γ (Snd e) τ2
| TPLam Γ e τ1 τ2 : typed (τ1 :: Γ) e τ2 → typed Γ (Lam e) (TFun τ1 τ2)
| TPApp Γ e1 e2 τ1 τ2 : typed Γ e1 (TFun τ1 τ2) → typed Γ e2 τ1 → typed Γ (App e1 e2) τ2.

Inductive head_step : expr → expr → Prop :=
| SFst e1 e2 : is_val e1 → is_val e2 → head_step (Fst (Pair e1 e2)) e1
| SSnd e1 e2 : is_val e1 → is_val e2 → head_step (Snd (Pair e1 e2)) e2
| SApp e1 e2 : is_val e2 → head_step (App (Lam e1) e2) e1.[e2/].

Inductive is_ectx : (expr → expr) → Prop :=
| ECTX_id : is_ectx (λ e, e)
| ECTX_Fst K : is_ectx K → is_ectx (λ e, Fst (K e))
| ECTX_Snd K : is_ectx K → is_ectx (λ e, Snd (K e))
| ECTX_Pair1 K e2 : is_ectx K → is_ectx (λ e, Pair (K e) e2)
| ECTX_Pair2 e1 K : is_val e1 → is_ectx K → is_ectx (λ e, Pair e1 (K e))
| ECTX_App1 K e2 : is_ectx K → is_ectx (λ e, App (K e) e2)
| ECTX_App2 e1 K : is_val e1 → is_ectx K → is_ectx (λ e, App e1 (K e)).

Local Hint Constructors is_ectx : is_ectx.

Lemma is_ectx_val : ∀ (e : expr) (K : expr → expr), is_ectx K → is_val (K e) → is_val e.
Proof.
  intros e K HK; revert e.
  induction HK; [trivial; fail|inversion 1; subst; auto .. ].
Qed.

Lemma is_val_dec e : is_val e ∨ ¬ is_val e.
Proof.
  induction e; try (right; inversion 1; fail).
  - left; constructor.
  - destruct IHe1; destruct IHe2; [left; constructor; auto; fail|right; inversion 1; tauto .. ].
  - left; constructor.
Qed.

Lemma ectx_head_step K e e' : is_ectx K → head_step (K e) e' → (∀ f : expr, K f = f) ∨ is_val e.
Proof.
  intros HK; revert e e'.
  induction HK.
  - left; trivial.
  - inversion HK; inversion 1; subst; right; [econstructor; eauto|eapply is_ectx_val; eauto .. ].
  - inversion HK; inversion 1; subst; right; [econstructor; eauto|eapply is_ectx_val; eauto .. ].
  - inversion HK; inversion 1.
  - inversion HK; inversion 1.
  - inversion HK; inversion 1; subst; right; constructor.
  - inversion 1; subst; right; eapply is_ectx_val; eauto.
Qed.

Lemma ectx_inj K e e' : is_ectx K → K e = K e' → e = e'.
Proof.
  intros HK; revert e e'.
  induction HK; intros e e' Hee.
  - trivial.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
Qed.

Lemma ectx_compose K K' : is_ectx K → is_ectx K' → is_ectx (λ e : expr, K (K' e)).
Proof.
  intros HK; revert K'.
  induction HK; [trivial| intros; econstructor; eauto .. ].
Qed.

Lemma ectxs_nesting K e K' e' :
  is_ectx K → is_ectx K' → K e = K' e' → ¬ is_val e → ¬ is_val e' →
  (∃ K'' : expr → expr, is_ectx K'' ∧ (∀ f : expr, K f = K' (K'' f)))
  ∨ (∃ K'' : expr → expr, is_ectx K'' ∧ (∀ f : expr, K' f = K (K'' f))).
Proof.
  intros HK; revert e e' K'.
  induction HK as [|?? IHK|?? IHK | K e2 ? IHK|e1 K Hval ? IHK|K e2 ? IHK|e1 K Hval ? IHK];
    intros e e' K' HK' Hee Hnve Hnve'.
  - right; exists K'; auto.
  - destruct HK'; [left; exists (λ e, Fst (K e)); auto with is_ectx; fail| |congruence ..].
    destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
      (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK'; [left; exists (λ e, Snd (K e)); auto with is_ectx; fail|
                    congruence| |congruence ..].
    destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption| assumption|left|right];
      (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK' as [| | | |? ? Hval | |];
      [left; eexists (λ e, Pair (K e) e2); eauto with is_ectx; fail|
        congruence|congruence | | |congruence .. ].
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
        [congruence|assumption|assumption|left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
  - destruct HK'; [left; eexists (λ e, Pair e1 (K e)); eauto with is_ectx; fail|
        congruence|congruence | | |congruence .. ].
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
        [congruence|assumption|assumption|left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK' as [| | | | | |? ? Hval];
      [left; exists (λ e, App (K e) e2); auto with is_ectx; fail|
        congruence|congruence| congruence|congruence| ..].
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
  - destruct HK';
      [left; exists (λ e, App e1 (K e)); auto with is_ectx; fail|
        congruence|congruence| congruence|congruence| ..].
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
Qed.

Global Instance stlc_valid_language : valid_language is_val is_ectx head_step.
Proof.
  split.
  - inversion 1; inversion 1.
  - apply is_ectx_val.
  - constructor.
  - apply is_val_dec.
  - apply ectx_head_step.
  - apply ectx_inj.
  - apply ectx_compose.
  - apply ectxs_nesting.
Qed.

Lemma det_head_step_fst v1 v2 : is_val v1 → is_val v2 → det_head_step (Fst (Pair v1 v2)) v1.
Proof.
  intros; split; [constructor; assumption| inversion 1; subst; reflexivity].
Qed.

Lemma det_head_step_snd v1 v2 : is_val v1 → is_val v2 → det_head_step (Snd (Pair v1 v2)) v2.
Proof.
  intros; split; [constructor; assumption| inversion 1; subst; reflexivity].
Qed.

Lemma det_head_step_app e v : is_val v → det_head_step (App (Lam e) v) e.[v/].
Proof.
  intros; split; [econstructor; assumption| inversion 1; subst; reflexivity].
Qed.

Ltac solve_det_head_step :=
  solve [eapply det_head_step_fst; assumption|
          eapply det_head_step_snd; assumption|
          eapply det_head_step_app; eassumption].


(*** Membership predicates ***)

Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Ring.
Require Import ott_list_base.
Require Import ott_list_core.
Require Import ott_list_nth.
Set Implicit Arguments.

(*** Membership predicate ***)

Section In.
Variable A : Set.
Implicit Types x : A.
Implicit Types xs l : list A.

(* Speed up proofs by providing trivial consequences of [List.in_or_app] that
   do not require eauto. *)
Lemma In_left_app :
  forall l l' a, In a l -> In a (l ++ l').
Proof. auto with datatypes. Qed.
Lemma In_right_app :
  forall l l' a, In a l -> In a (l ++ l').
Proof. auto with datatypes. Qed.

Lemma not_in_app_or :
  forall l l' a, ~In a (l ++ l') -> ~In a l /\ ~In a l'.
Proof. unfold not; auto with datatypes. Qed.
Lemma not_in_or_app :
  forall l l' a, ~In a l /\ ~In a l' -> ~In a (l ++ l').
Proof. unfold not; destruct 1; intros. pose (in_app_or _ _ _ H1). tauto. Qed.

Lemma nth_error_In :
  forall l n x, nth_error l n = Some x -> In x l.
Proof.
  intros; generalize dependent l; induction n; destruct l; intros;
    simpl in *; simplify_eq H; auto.
Qed.

Lemma nth_safe_In :
  forall l n H, In (nth_safe l n H) l.
Proof.
  intros. eapply nth_error_In. rewrite nth_safe_eq_nth_error. eauto.
Qed.

End In.

Hint Resolve In_left_app In_right_app : datatypes.
Hint Resolve not_in_app_or not_in_or_app : datatypes.
Hint Resolve nth_error_In nth_safe_In : datatypes.

(*** Membership predicate and map ***)

Lemma image_In_map :
  forall (A B:Set) x l (f:A->B),
    In x l -> In (f x) (map f l).
Proof.
  intros. induction l; simpl in * . tauto. destruct H; subst; tauto.
Qed.

Lemma In_map_exists :
  forall (A B:Set) l y (f:A->B),
    In y (map f l) -> exists x, y = f x /\ In x l.
Proof.
  intros. induction l; simpl in * . tauto. destruct H. eauto. firstorder.
Qed.

Ltac elim_In_map H x Eq Mem :=
  let tmp := fresh "tmp" in (
    try rename H into tmp;
    elim (In_map_exists _ _ _ tmp); intro x; destruct 1 as [Eq Mem];
    try clear tmp
  ).

Ltac elim_all_In_map :=
  repeat match goal with
           | H : In ?y (map ?f ?l) |- _ =>
             let Eq := fresh "Eq" with tmp := fresh "tmp" in (
               rename H into tmp;
               elim (In_map_exists _ _ _ tmp); intro; destruct 1 as [Eq Mem];
               clear tmp
             )
         end.

(*** Membership function ***)

Section list_mem.
Variable A : Set.
Variable (eq_dec : forall (a b:A), {a=b} + {a<>b}).
Implicit Types x : A.
Implicit Types xs l : list A.

Ltac case_eq foo :=
  generalize (refl_equal foo);
  pattern foo at -1;
  case foo.

Notation list_mem := (list_mem eq_dec).

Lemma list_mem_implies_In :
  forall x l, Is_true (list_mem x l) -> In x l.
Proof.
  intros. induction l. assumption. simpl in *; destruct (eq_dec a x); tauto.
Qed.
Lemma list_mem_false_implies_not_In :
  forall x l, list_mem x l = false -> ~In x l.
Proof.
  intros. induction l; simpl in * . tauto.
  destruct (eq_dec a x). discriminate. tauto.
Qed.
Lemma case_list_mem_In :
  forall x l, if list_mem x l then In x l else ~In x l.
Proof.
  intros; induction l; simpl in * . tauto.
  destruct (eq_dec a x). tauto. destruct (list_mem x l); tauto.
Qed.
Lemma list_mem_eq_In_dec :
  forall x l, list_mem x l = if In_dec eq_dec x l then true else false.
Proof.
  intros. assert (If := case_list_mem_In x l).
  destruct (list_mem x l); destruct (In_dec eq_dec x l); tauto.
Qed.

Lemma In_implies_list_mem :
  forall x l, In x l -> Is_true (list_mem x l).
Proof.
  intros. induction l. assumption.
  simpl in *; destruct (eq_dec a x); simpl; tauto.
Qed.
Lemma not_In_implies_list_mem_false :
  forall x l, ~In x l -> list_mem x l = false.
Proof.
  intros. induction l; simpl in * . tauto. destruct (eq_dec a x); tauto.
Qed.

Lemma list_mem_app :
  forall x l l', list_mem x (l++l') = list_mem x l || list_mem x l'.
Proof.
  intros; repeat rewrite list_mem_eq_In_dec;
    repeat match goal with |- context C [In_dec ?eq_dec_ ?x_ ?l_] =>
             destruct (In_dec eq_dec_ x_ l_)
           end;
    intros; try ring; elimtype False;
    (let a := type of i in (generalize dependent i; fold (~a)));
    auto with datatypes.
Qed.

Lemma nth_error_mem :
  forall l n x, nth_error l n = Some x -> Is_true (list_mem x l).
Proof. intros; apply In_implies_list_mem. eapply nth_error_In; eauto. Qed.
Lemma nth_safe_mem :
  forall l n H, Is_true (list_mem (nth_safe l n H) l).
Proof. intros; apply In_implies_list_mem. apply nth_safe_In; auto. Qed.

End list_mem.

Hint Rewrite list_mem_app : lists.

(*** Removing an element ***)

Section list_minus.
Variable A : Set.
Variable (eq_dec : forall (a b:A), {a=b} + {a<>b}).
Implicit Types x : A.
Implicit Types xs l : list A.

Notation list_minus := (list_minus eq_dec).

Lemma not_In_list_minus_self :
  forall l x, ~In x (list_minus l (x::nil)).
Proof.
  induction l; intros; simpl in * . tauto.
  destruct (eq_dec x a); simpl in *; firstorder.
Qed.

Lemma In_list_plus :
  forall x l l', In x (list_minus l l') -> In x l.
Proof.
  induction l; intros; simpl in * . assumption.
  destruct (list_mem eq_dec a l'); simpl in *; firstorder.
Qed.

Lemma In_list_minus_other :
  forall l x x', x' <> x -> In x l -> In x (list_minus l (x'::nil)).
Proof.
  induction l; intros; simpl in * . assumption.
  destruct (eq_dec x' a); subst; simpl in * .
  apply IHl; tauto.
  destruct H0. tauto. auto.
Qed.

End list_minus.

Hint Resolve In_list_plus : In_list_plus.
Hint Resolve In_list_minus_other : datatypes.


Require Import Utf8.
Require Import IxFree.Base IxFree.UnaryFixpoint.

Require Import Arith.
Require Import Omega.

Definition IRel_2 {A : Type} (P : A → Type) := ∀ x, IRel_1 (P x).
Definition True_2 {A : Type} {P : A → Type} : IRel_2 P := λ _, True_1.

Program Definition contractive_2 {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) :=
  ∀ (n : nat) (R₁ R₂ : IRel_2 P),
  (∀ k, k < n → ∀ x y, (k ⊨ R₁ x y) <-> (k ⊨ R₂ x y)) →
  ∀ x y, (n ⊨ f R₁ x y) <-> (n ⊨ f R₂ x y).

Fixpoint pow_IRel_2 {A : Type} {P : A → Type}
    (f : IRel_2 P → IRel_2 P) (n : nat) (R₀ : IRel_2 P) :=
  match n with
  | 0   => R₀
  | S n => f (pow_IRel_2 f n R₀)
  end.

Lemma pow_IRel_2_limit {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) :
  contractive_2 f → ∀ k n m : nat, k ≤ n → k ≤ m → ∀ x y,
  ((k ⊨ f (pow_IRel_2 f n True_2) x y) <->
   (k ⊨ f (pow_IRel_2 f m True_2) x y)).
Proof.
  intro Hcon.
  apply (well_founded_ind lt_wf (λ k, ∀ n m, k ≤ n → k ≤ m → ∀ x y, (_ : Prop))).
  intros k HI n m H₁ H₂ x y ; destruct k.
  + apply Hcon ; intros ; omega.
  + apply Hcon ; intros l Hl.
    destruct n ; [ exfalso ; omega | ].
    destruct m ; [ exfalso ; omega | ].
    apply HI ; omega.
Qed.

Definition I_fix_2_func {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) :
    ∀ x, P x → nat → Prop :=
  λ x y n, n ⊨ f (pow_IRel_2 f n True_2) x y.

Lemma I_fix_2_func_monotone {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) :
  contractive_2 f → ∀ x y, monotone (I_fix_2_func f x y).
Proof.
  intros Hcon x y n ; induction n.
  + unfold I_fix_2_func ; simpl.
    intro H₁; apply (Hcon 0 True_2 (f True_2)).
    - intros k H; inversion H.
    - apply I_valid_monotone_S; assumption.
  + unfold I_fix_2_func.
    intro H₁; apply (Hcon (S n)
        (pow_IRel_2 f (S n) True_2) (pow_IRel_2 f (S (S n)) True_2)).
    - intros; apply pow_IRel_2_limit; trivial; omega.
    - apply I_valid_monotone_S; assumption.
Qed.

Definition I_fix_2 {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) (p : contractive_2 f) :
  IRel_2 P :=
  λ x y, mk_IProp (I_fix_2_func f x y) (I_fix_2_func_monotone f p x y).

Lemma I_fix_2_is_fixpoint {A : Type} {P : A → Type}
  (f : IRel_2 P → IRel_2 P) (p : contractive_2 f) :
  ∀ x y n, (n ⊨ I_fix_2 f p x y) <-> (n ⊨ f (I_fix_2 f p) x y).
Proof.
  intros x y n; apply iff_trans with (B := (n ⊨ f (pow_IRel_2 f n True_2) x y)).
  { split; intro H; [ apply I_valid_elim in H | apply I_valid_intro ]; auto. }
  apply p; intros k Hle x' y'.
  destruct n; [ omega | ]; simpl.
  apply iff_trans with (B := (k ⊨ f (pow_IRel_2 f k True_2) x' y')).
  { apply pow_IRel_2_limit; trivial; omega. }
  split; intro H; [ apply I_valid_intro | apply I_valid_elim in H ]; auto.
Qed.

Lemma I_fix_2_unroll {A : Type} {P : A → Type}
  (f : IRel_2 P → IRel_2 P) (p : contractive_2 f) :
  ∀ x y n, (n ⊨ I_fix_2 f p x y) → (n ⊨ f (I_fix_2 f p) x y).
Proof.
apply I_fix_2_is_fixpoint.
Qed.

Lemma I_fix_2_roll {A : Type} {P : A → Type}
  (f : IRel_2 P → IRel_2 P) (p : contractive_2 f) :
  ∀ x y n, (n ⊨ f (I_fix_2 f p) x y) → (n ⊨ I_fix_2 f p x y).
Proof.
apply I_fix_2_is_fixpoint.
Qed.


Set Warnings "-notation-overridden,-parsing".
From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Lia.
From PLF Require Export Imp.

Definition Assertion := state -> Prop.

(* assertion is a proposition/property of a state *)

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Declare Scope hore_spec_scope.
Notation "P ->> Q" := (assert_implies P Q)
                        (at level 80) : hoare_spec_scope.

Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

Definition Aexp : Type := state -> nat.

Definition assert_of_Prop (P : Prop) : Assertion := fun _ => P.
Definition Aexp_of_nat (n : nat) : Aexp := fun _ => n.

Definition Aexp_of_aexp (a : aexp) : Aexp := fun st => aeval st a.

Coercion assert_of_Prop : Sortclass >-> Assertion.
Coercion Aexp_of_nat : nat >-> Aexp.
Coercion Aexp_of_aexp : aexp >-> Aexp.

Arguments assert_of_Prop /.
Arguments Aexp_of_nat /.
Arguments Aexp_of_aexp /.

Declare Scope assertion_scope.
Bind Scope assertion_scope with Assertion.
Bind Scope assertion_scope with Aexp.
Delimit Scope assertion_scope with assertion.

Notation assert P := (P%assertion : Assertion).
Notation mkAexp a := (a%assertion : Aexp).

Notation "~ P" := (fun st => ~ assert P st) : assertion_scope.
Notation "P /\ Q" := (fun st => assert P st /\ assert Q st) : assertion_scope.
Notation "P \/ Q" := (fun st => assert P st \/ assert Q st) : assertion_scope.
Notation "P -> Q" := (fun st => assert P st ->  assert Q st) : assertion_scope.
Notation "P <-> Q" := (fun st => assert P st <->  assert Q st) : assertion_scope.
Notation "a = b" := (fun st => mkAexp a st = mkAexp b st) : assertion_scope.
Notation "a <> b" := (fun st => mkAexp a st <> mkAexp b st) : assertion_scope.
Notation "a <= b" := (fun st => mkAexp a st <= mkAexp b st) : assertion_scope.
Notation "a < b" := (fun st => mkAexp a st < mkAexp b st) : assertion_scope.
Notation "a >= b" := (fun st => mkAexp a st >= mkAexp b st) : assertion_scope.
Notation "a > b" := (fun st => mkAexp a st > mkAexp b st) : assertion_scope.
Notation "a + b" := (fun st => mkAexp a st + mkAexp b st) : assertion_scope.
Notation "a - b" := (fun st => mkAexp a st - mkAexp b st) : assertion_scope.
Notation "a * b" := (fun st => mkAexp a st * mkAexp b st) : assertion_scope.

Definition ap {X} (f : nat -> X) (x : Aexp) :=
  fun st => f (x st).

Definition ap2 {X} (f : nat -> nat -> X) (x : Aexp) (y : Aexp) (st : state) :=
  f (x st) (y st).

Definition hoare_triple (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st',
     st =[ c ]=> st'  ->
     P st  -> Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c custom com at level 99)
  : hoare_spec_scope.

Theorem hoare_post_true :
  forall (P Q : Assertion) c,
  (forall st, Q st) -> {{P}} c {{Q}}.
Proof.
  intros.
  unfold hoare_triple.
  intros. apply H.
Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~ (P st)) ->
  {{P}} c {{Q}}.
Proof.
  intros. unfold hoare_triple. intros.
  apply H in H1. inversion H1.
Qed.

(* The goal of Hoare logic is
to provide a compositional method
for proving the validity of specific Hoare triples.*)

Definition assn_sub X a (P:Assertion) : Assertion :=
  fun (st : state) =>
    P (X !-> aeval st a ; st).

Notation "P [ X |-> a ]" := (assn_sub X a P)
  (at level 10, X at next level, a custom com).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} X := a {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.
Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple, "->>".
  intros P P' Q c Hhoare Himp st st' Heval Hpre.
  apply Hhoare with (st := st).
  - assumption.
  - apply Himp. assumption.
Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple, "->>".
  intros P Q Q' c Hhoare Himp st st' Heval Hpre.
  apply Himp.
  apply Hhoare with (st := st).
  - assumption.
  - assumption.
Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Htriple Hpre Hpost.
  apply hoare_consequence_pre with (P' := P').
  - apply hoare_consequence_post with (Q' := Q').
    + assumption.
    + assumption.
  - assumption.
Qed.

Hint Unfold assert_implies hoare_triple assn_sub t_update : core.
Hint Unfold assert_of_Prop Aexp_of_nat Aexp_of_aexp : core.

Theorem hoare_skip : forall P,
     {{P}} skip {{P}}.
Proof.
  intros P st st' H HP. inversion H; subst. assumption.
Qed.

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1; c2 {{R}}.
Proof.
  unfold hoare_triple.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  eapply H1; try (repeat eassumption).
  eapply H2; try (repeat eassumption).
Qed.


Require Import Coq.Strings.String.
Require Import Arith.EqNat.
Require Import ZArith.

From QuickChick Require Import QuickChick.

Require Import TestingCommon.
Require Import Printing.
Require Import Shrinking.
Require Import Generation.

Open Scope string_scope.

Require Import Reachability.

Definition is_low_state st lab := isLow (pc_lab (st_pc st)) lab.

Definition propSSNI_helper (t : table) (v : Variation) : Checker  :=
    let '(Var lab st1 st2) := v in
    (*  Checker.trace (Show.show lab ++ Show.nl ++
     showStatePair lab frameMap1 frameMap2 st1 st2) *)
    collect (option_bind opcode_of_instr
                         (instr_lookup (st_imem st1) (st_pc st1)))

    (* collect (show lab) *)
            (if indist lab st1 st2 then
               (* XXX Our generator should always give us this by design.
                  If that's not the case the generator is broken. *)
               match fstep t st1  with
                 | Some st1' =>
                   if is_low_state st1 lab then
                     match fstep t st2 with
                       | Some st2' =>
                         collect "LOW -> *" (
(*
                                   whenFail
                                     ("LOW -> *" ++ nl ++
                                                 (show_execution lab [st1; st1'] [st2; st2']))
*)
                                     (indist lab st1' st2')(*:Gen QProp*))
                       | _ => (* 1 took a low step and 2 failed *)
                         collect "Second failed" (checker true)
                     (*
                ((Checker.trace (show_pair lab st1 st1'))
                (checker false))
                      *)
                     (* XXX This used to fail the checker in ICFP paper.
                  But here it does happen for Alloc, Store and BRet *)
                     end
                   else (* is_high st1 *)
                     if is_low_state st1' lab then
                       match fstep t st2 with
                         | Some st2' =>
                           if is_low_state st2' lab then
                             collect "HIGH -> LOW" (
(*
                                       whenFail ("HIGH -> LOW" ++ Show.nl ++
                                                                (show_execution lab [st1; st1'] [st2; st2']))
*)
                                                 (indist lab st1' st2') (* : Gen QProp *)
                                     )
                           else collect "Second not low" (checker true)
                         (* This can happen; it's just a discard *)
                         (* TODO: could check that st2' `indist` st1 *)
                         | _ => collect "Second failed H" (checker true)
                       (* This can happen; it's just a discard *)
                       end
                     else
                       collect "HIGH -> HIGH" (
(*
                                 whenFail ("HIGH -> HIGH" ++ Show.nl ++
                                                          (show_pair lab st1 st1'))
*)
                                       (indist lab st1 st1')
                               (*: Gen QProp*))
                 | _ => collect "Failed" (checker true)
               (* This can happen; it's just a discard *)
               (* TODO: could check if st2 does a H -> H step *)
               end
             else collect "Not indist!" (checker true)).
           (* XXX this should never happen with a correct generator;
              and prop_generate_indist already tests this;
              so this should either go away or become (propery false) *)

  Definition propSSNI t : Checker :=
    forAllShrinkShow gen_variation_state (fun _ => nil) (fun _ => ""%string)
      (* shrinkVState *)
      (propSSNI_helper t).


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)

(*| .. coq:: none |*)
Require Import Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Classes.Morphisms.
Require Import Coq.Classes.DecidableClass.
Require Import Coq.Lists.List.
Import ListNotations. (* from List *)

Require Import Coq.Bool.Bool.
Require Import Coq.Classes.SetoidClass.
Open Scope equiv_scope.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Logic.Decidable.
Set Implicit Arguments.
Set Strict Implicit.

Require Import Oqarina.formalisms.Expressions.Propositions.
Require Import Oqarina.CoqExt.all.
(*| .. coq:: |*)

(*| .. coq:: none |*)
Section Specifications.
(*| .. coq:: |*)

(*|
Specification
=============

In the following, we provide a definition of a specification theory adapted from :cite:`10.1007/978-3-642-28872-2_3`,

Informally, given a class S of specifications, a specification theory includes a composition operator :coq:`×` to combine specifications to larger ones. Additionally, a specification theory has a refinement relation :coq:`≤` to relate “concrete” and “abstract” specifications. This relation defines a preorder, i.e., it is transitive and reflexive.
To obtain a specification theory, refinement must be compositional in the sense that it must be preserved by the composition operator.

|*)

(*| For a given type :coq:`T`, we define the concept of a model. A
model is equipped with a :coq:`valid` function that asserts model
validity, it is a decidable proposition. |*)

Class Model (T : Type) := {
    valid : T -> Prop;
    valid_decidable : forall (t : T), Decision (valid t);
}.

(*| For a given type :coq:`T`, we define the concept of a refinement. A
refinement is a relation that is also a preorder, that is reflexive and transitive. |*)

Class Refinement (T : Type) := {
    refinement : relation T ;
    refinement_preorder : PreOrder refinement
}.
Notation "s1 ≼ s2" := (refinement s1 s2)
    (at level 70, no associativity).

(*| For a given type :coq:`T`, we define the notion of composition.
The :coq:`compose` operator is commutative and associative.
Composition is connected to the notion of refinment through a
compatibility relation. |*)

Class Composition (T : Type) `{Refinement T} `{Setoid T} := {
    compose: T -> T -> T;

    compose_comm :> Setoid_Commutative compose;
    compose_assoc :> Setoid_SemiGroup compose;
    compose_compatible : forall S1 S2 T1 T2,
        S1 ≼ S2 -> T1 ≼ T2 -> (compose S1 T1) ≼ (compose S2 T2);
}.

(*| From these considerations, we can now define the :coq`Specification`
typeclass, equipped with a refinement and a composition operation. |*)

Class Specification (T : Type) `{s : Setoid T} := {
    m :> Model T;
    refinement_op :> Refinement T;
    compose_op :> Composition;
}.

(*| In :cite:`10.1007/978-3-642-28872-2_3`, the authors only consider composition operator as total function. We acknowledge that this is a strong hypothesis: semantic or syntactic rules may forbid some compositions to happem, or they might be incomplete. A typical example being two AADL components being composed: composition can be done in multiple ways, e.g. variations in connections, as subcomponents of different components, etc. Instead, we define a composition operation as a partial function. Partial composition is commutative and compatible with the notion of refinement. |*)

Class Partial_Composition (T : Type)  `{Refinement T} := {
    partial_compose: list T -> T -> Prop ;

    partial_compose_comm : forall (l l': list T) S,
        partial_compose l S
            -> Permutation l l'
            -> partial_compose l' S;

    partial_compose_compatible: forall S1 S2 T1 T2 R,
        S1 ≼ S2 -> T1 ≼ T2
            -> partial_compose [S2 ;T2] R
            -> partial_compose [S1 ;T1] R;
}.

(*| From these considerations, we can now define the :coq:`Rich_Specification` typeclass, equipped with a refinement and a partial composition operation. We call this "rich" as a partial composition is a natural consequence of rich modeling languages. |*)

Class Rich_Specification (T : Type) `{s : Setoid T} := {
    r :> Model T;
    r_refinement_op :> Refinement T;
    r_compose_op :> Partial_Composition;
}.

(*| .. coq:: none |*)
End Specifications.
(*| .. coq:: |*)

(*| We encapsulate the following notations to ease model
manipulation. |*)

Module Specifications_Notations.

Notation "s1 '×' s2" := (compose s1 s2)
    (at level 70, right associativity).

Notation "s3 |=c s1 '×' s2" := (partial_compose [s1 ;s2 ] s3)
    (at level 70, right associativity).

Notation "s1 ≼ s2" := (refinement s1 s2)
    (at level 70, no associativity).

End Specifications_Notations.

(*| .. coq:: none |*)
Section Specifications_PropF.

Import Specifications_Notations.
(*| .. coq:: |*)

(*|
Specification -- PropF
======================

In this section, we provide an instantiation of the previous
classes for propositions (see :coq:`PropF`). We build incrementally the notion of model (i.e. a PropF), of a refinement, and of a composition. |*)

Variable PropVars : Set.

(* A PropF is always valid, per construction of the Coq syntax. *)
Definition Valid_PropF (P : PropF PropVars) := True.

Lemma Valid_PropF_decidable: forall t : PropF PropVars,
    Decision (Valid_PropF t).
Proof.
    intros. compute. intuition.
Qed.

Instance Models_PropF : Model (PropF PropVars) := {
    valid := Valid_PropF;
    valid_decidable := Valid_PropF_decidable;
}.

Definition PropF_equiv (p1 p2: PropF PropVars) :=
    forall v, Eval_PropF v p1 = Eval_PropF v p2.

Lemma PropF_equiv_Reflexive : Reflexive PropF_equiv.
Proof.
    unfold Reflexive, PropF_equiv.
    intuition.
Qed.

Lemma PropF_equiv_Symetric: Symmetric PropF_equiv.
Proof.
    unfold Symmetric, PropF_equiv.
    intuition.
Qed.

Lemma PropF_equiv_Transitive: Transitive PropF_equiv.
Proof.
    unfold Transitive, PropF_equiv.
    intros.
    specialize (H v).
    specialize (H0 v).
    rewrite H.
    intuition.
Qed.

Instance Setoid_PropF : Setoid (PropF PropVars) := {
    equiv := PropF_equiv;
    setoid_equiv :=
        Build_Equivalence _ PropF_equiv_Reflexive
            PropF_equiv_Symetric PropF_equiv_Transitive ;
}.

(* P1 refines P2 iff P2 => P1. *)

Definition Refinement_PropF' (P1 P2: PropF PropVars) :=
    forall v, sat_PropF v P2 -> sat_PropF v P1.

Lemma Refinement_PropF_Reflexive : forall P1,
    Refinement_PropF' P1 P1.
Proof.
    unfold Refinement_PropF'. intuition.
Qed.

Lemma Refinement_PropF_Transitive : forall P1 P2 P3,
    Refinement_PropF' P1 P2
        -> Refinement_PropF' P2 P3
        -> Refinement_PropF' P1 P3.
Proof.
    unfold Refinement_PropF'. intuition.
Qed.

Instance Refinement_PropF : Refinement (PropF PropVars) := {
    refinement := Refinement_PropF';
    refinement_preorder :=
        Build_PreOrder _ Refinement_PropF_Reflexive Refinement_PropF_Transitive;
}.

(* The composition of two PropF is their conjunction. *)

Definition compose_PropF (p1 p2: PropF PropVars) :=
    (Conj p1 p2).

Lemma compose_PropF_comm: forall (p1 p2: PropF PropVars),
    (compose_PropF p1 p2) == (compose_PropF p2 p1).
Proof.
    unfold compose_PropF. simpl.
    unfold PropF_equiv. simpl.
    intros.
    rewrite andb_comm. intuition.
Qed.

Instance compose_PropF_Setoid_Commutative :
    Setoid_Commutative compose_PropF  := {
    commute_proof := compose_PropF_comm;
}.

Lemma compose_PropF_assoc: forall (p1 p2 p3: PropF PropVars),
    compose_PropF p1 (compose_PropF p2 p3) ==
        compose_PropF (compose_PropF p1 p2) p3.
Proof.
    unfold compose_PropF. simpl.
    unfold PropF_equiv. simpl.
    intros.
    rewrite andb_assoc. intuition.
Qed.

Instance compose_PropF_Setoid_SemiGroup :
    Setoid_SemiGroup compose_PropF := {
    assoc_f := compose_PropF_assoc;
}.

Lemma compose_PropF_compatible : forall (S1 S2 T1 T2 : PropF PropVars),
    S1 ≼ S2 -> T1 ≼ T2 ->
        (compose_PropF S1 T1) ≼ (compose_PropF S2 T2).
Proof.
    unfold compose_PropF. unfold refinement. simpl.
    unfold Refinement_PropF'.
    intros.
    rewrite sat_PropF_and_rewrite in *.
    split.
    - apply H. intuition.
    - apply H0. intuition.
Qed.

Instance Composition_PropF : Composition := {
    compose := compose_PropF ;
    compose_compatible := compose_PropF_compatible ;
    compose_assoc := compose_PropF_Setoid_SemiGroup ;
    compose_comm := compose_PropF_Setoid_Commutative ;
}.

(*| Finally, we can combine all results and build a valid instance of
a specification from PropF.|*)

Instance Specification_PropF : Specification := {
    m := Models_PropF;
    refinement_op := Refinement_PropF ;
    compose_op := Composition_PropF;
}.

(*| .. coq:: none |*)
End Specifications_PropF.


From Undecidability.L Require Export L.

(** * Step-indexed interpreter and modesty *)

(** ** Step-indexed interpreter *)

Fixpoint eval (n : nat) (u : term) :=
  match u with
  | var n => None
  | lambda s => Some (lambda s)
  | app s t => match n with
           | 0   => None
           | S n => match eval n s, eval n t with
                    | Some (lambda s), Some t => eval n (subst s 0 t)
                    |   _ , _ => None
                    end
            end
  end.

Lemma eval_S n s t : eval n s = Some t -> eval (S n) s = Some t.
Proof.
  revert s t; induction n; intros; cbn in H;
    repeat (destruct _ eqn:_; subst; try congruence; eauto).
    remember (S n) as n'; cbn; subst.
    now rewrite (IHn _ _ E), (IHn _ _ E0), (IHn _ _ H).
Qed.

Lemma eval_step s s' t n : s ≻ s' -> eval n s' = Some t -> eval (S n) s = Some t.
Proof.
  revert s s' t; induction n; intros.
  - cbn in H0. destruct _; inv H0.
    cbn. destruct _; inv H. now rewrite H3.
  - cbn in H0. inv H; repeat (destruct _ eqn:_; subst; try congruence).
    + cbn; now rewrite E, E0, E1.
    + cbn; now rewrite E.
    + remember (S n); cbn; subst.
      erewrite eval_S, IHn; eauto. now eapply eval_S.
    + remember (S n). cbn. subst.
      erewrite IHn, eval_S; eauto. now eapply eval_S.
Qed.

Lemma evaluates_eval s t : evaluates s t -> exists n, eval n s = Some t.
Proof.
  intros [A B] % evaluates_equiv. eapply equiv_star_lam in A; eauto. induction A.
  - destruct B. subst; now exists 0.
  - destruct (IHA B) as [k C]. eauto using eval_step.
Qed.

Lemma eval_evaluates n s t : eval n s = Some t -> evaluates s t.
Proof.
  revert s t; induction n; intros.
  - inv H. destruct _; try congruence. inv H1. firstorder.
  - inv H. repeat (destruct _ eqn:_; subst; try congruence).
    eapply IHn in E. eapply IHn in E0. eapply IHn in H1. eauto. inv H1. eauto.
Qed.

Lemma equiv_eval s t : lam t -> s ≡ t -> exists n, eval n s = Some t.
Proof.
  intros. eapply evaluates_eval. firstorder using evaluates_equiv.
Qed.

Lemma eval_equiv s s' n : eval n s = Some s' -> s ≡ s'.
Proof.
  intros ? % eval_evaluates. firstorder using evaluates_equiv.
Qed.

Lemma eval_lambda n s t : eval n s = Some t -> lam t.
Proof.
  intros ? % eval_evaluates. firstorder using evaluates_equiv.
Qed.

(** ** Modesty *)

Require Import DecidableRecognisable Encodings Coq.Logic.ConstructiveEpsilon.

Definition cChoice := constructive_indefinite_ground_description_nat_Acc.
Lemma computable_eva s : eva s -> { v | s ▷ v }.
Proof.
  intros.
  assert (exists n v, eval n s = Some v) by (destruct H as (? & ? % evaluates_eval); firstorder).
  eapply cChoice in H0 as []. destruct (eval x s) eqn:E.
  - exists t. eauto using eval_evaluates.
  - exfalso. firstorder congruence.
  - intros. destruct (eval n s). eauto.
    right. intros []. congruence.
Defined.

Lemma dec_pdec p : decidable p -> forall x, p x \/ ~ p x.
Proof.
  firstorder.
Qed.

Lemma decidable_dec p : decidable p -> exists f, forall s, f s = true <-> p s.
Proof with try tauto; try (eexists; reflexivity).
  intros (u & proc_u & Hu).
  assert (forall s, {v | u (tenc s) ▷ v}). {
    intros. eapply computable_eva. destruct (Hu s). exists T. tauto.
    exists F; tauto.
  }

  exists (fun s =>  let (v, _) := H s in if decision (v = T) then true else false).

  intros. destruct _. decide (x = T).
  - subst. firstorder. eapply decidable_spec; eauto.
  - firstorder. congruence. exfalso. eapply decidable_spec; eauto.
    destruct (Hu s) as [ [? [H4 ?] %evaluates_equiv] | []].
    destruct T_equiv_F.
    assert (x ≡ T) by now rewrite <- e, <- H4. eapply unique_normal_forms in H6. subst. congruence.
    eapply evaluates_abst; eauto. value. firstorder using evaluates_equiv.
Qed.

Fixpoint unenc s :=
match s with
| lambda (lambda 1) => Some 0
| lambda (lambda (app 0 s)) => match unenc s with Some n => Some (S n) | x=>x end
| _ => None
end.

Lemma unenc_correct m : (unenc (enc m)) = Some m.
Proof.
  induction m; simpl; now try rewrite IHm.
Qed.

Lemma unenc_correct2 t n : unenc t = Some n -> enc n = t.
Proof.
  revert n. eapply (size_induction (f := size) (p := (fun t => forall n, unenc t = Some n -> enc n = t))). clear t. intros t IHt n H.
  destruct t; try now inv H.
  destruct t; try now inv H.
  destruct t; try now inv H.
  destruct n0; try now inv H. destruct n0; try now inv H.
  destruct t1; try now inv H. destruct n0; try now inv H.
  simpl in H. destruct (unenc t2) eqn:A.
  specialize (IHt t2).
  assert (B : size t2 < size (lambda (lambda 0 t2))). simpl. omega.
  eapply IHt in B.
  destruct n. inv H. inversion H. subst n0.
    simpl. repeat f_equal. eassumption. eassumption. inv H.
Qed.

Fixpoint decode (s : term) :=
  match s with
  | lambda (lambda (lambda (app (var 2) t))) => match unenc t with Some n => Some (var n) | None => None end
  | lambda (lambda (lambda (app (app (var 1) s) t))) => match decode s, decode t with
                        | Some s, Some t => Some (s t)
                        | _, _ => None
                        end
  | lambda (lambda (lambda (app (var 0) s))) => match decode s with
                      | Some s => Some (lambda s)
                      | None => None
                                end
  | _ => None
  end.

Lemma decode_correct t : (decode (tenc t)) = Some t.
Proof.
  induction t; simpl.
  - now rewrite unenc_correct.
  - now rewrite IHt1, IHt2.
  - now rewrite IHt.
Qed.

Lemma decode_correct2 s t :
  decode s = Some t -> tenc t = s.
Proof.
  revert t. eapply (size_induction (f := size) (p := (fun s => forall t, decode s = Some t -> tenc t = s))).
  clear s. intros s IHs t H.
  destruct s; try now inv H.
  destruct s; try now inv H.
  destruct s; try now inv H.
  destruct s; try now inv H.
  destruct s1; try now inv H.
  destruct n as [ | [ | [] ] ]; try now inv H.
  - cbn in *. destruct (decode s2) eqn:E; inv H.
    eapply IHs in E; try omega. cbn. now rewrite E.
  - cbn in *. destruct (unenc s2) eqn:E; inv H.
    eapply unenc_correct2 in E. now rewrite <- E.
  - destruct s1_1; try now inv H. destruct n as [ | [] ]; try now inv H.
    cbn in *. destruct _ eqn:E1; inv H. destruct _ eqn:E2; inv H1. eapply IHs in E1; try omega.
    eapply IHs in E2; try omega. cbn. now rewrite <- E1, <- E2.
Qed.

Lemma L_computable_computable u :
  (forall s, exists t, u (tenc s) ▷ tenc t) -> { f | forall s, u (tenc s) ▷ tenc (f s)}.
Proof.
  intros H.
  assert (forall s, eva (u (tenc s))). intros. destruct (H s) as [t H1]. eauto.
  exists (fun s => match decode (proj1_sig (computable_eva (H0 s))) with Some t => t | None => 0 end).

  intros s.
  destruct (H s) as [t Ht].
  destruct computable_eva. cbn.
  enough (x = tenc t).
  - subst. now erewrite decode_correct.
  - eapply unique_normal_forms. now eapply evaluates_abst in e. value.
    now rewrite <- Ht, <- e.
Defined.


Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibProd LibContainer LibSet
     LibRelation LibPer .
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import TLCBuffer
     UnionFind01Data UnionFind04Compress.

(* We now define an inductive predicate that encodes the process of performing
   path compression iteratively along a path, up to the root. [ipc] stands for
   ``iterative path compression''. The predicate [ipc F x l F'] means that in
   the initial state [F], performing path compression along the path that
   begins at [x] leads in [l] steps to the final state [F']. *)

(* We define backward and forward variants of this predicate, [bw_ipc] and
   [fw_ipc].

   The forward variant corresponds intuitively to a two-pass algorithm, where
   the first pass finds the representative [z], and the second pass performs
   iterated path compression. This formulation is clearly the sequential
   composition of several path compression steps. For this reason, this
   formulation is more amenable to a simple proof of several lemmas (e.g.
   [amortized_cost_fw_ipc_preliminary] and [is_rdsf_fw_ipc]).

   The backward variant corresponds intuitively to the one-pass, recursive
   formulation of path compression, where path compression is performed as the
   stack is unwound. This formulation is *not* clearly the sequential
   composition of several path compression steps, because it is not obvious
   a priori that the representative of [x] before compression is the
   representative of [x] after compression.

   Naturally, the two predicates are in fact equivalent. *)

Inductive bw_ipc V (F : binary V) : V -> nat -> binary V -> Prop :=
| BWIPCBase:
    forall x,
    is_root F x ->
    bw_ipc F x 0 F
| BWIPCStep:
    forall F' F'' x y z l,
    F x y ->
    is_repr F y z ->
    bw_ipc F y l F' ->
    F'' = compress F' x z ->
    bw_ipc F x (S l) F''.

Inductive fw_ipc V : binary V -> V -> nat -> binary V -> Prop :=
| FWIPCBase:
    forall F x,
    is_root F x ->
    fw_ipc F x 0 F
| FWIPCStep:
    forall (F : binary V) F' x y z l,
    F x y ->
    is_repr F y z ->
    fw_ipc (compress F x z) y l F' ->
    fw_ipc F x (S l) F'.

Hint Constructors bw_ipc : bw_ipc.
Hint Constructors fw_ipc : fw_ipc.

(* ------------------------------------------ ------------------------------- *)

(* Provided there is no path from [y] to [x], forward iterative compression at
   [y] commutes with one step of compression at [x]. *)

(* This statement should really be presented as a commutative diagram. *)

Lemma fw_ipc_compress_preliminary:
  forall V F x y z l F',
  @fw_ipc V F y l F' ->
  ~ path F y x ->
  fw_ipc (compress F x z) y l (compress F' x z).
Proof using.
  induction 1; intros.
  (* Base. *)
  { econstructor;
    eauto using compress_preserves_roots_other_than_x, not_rtclosure_inv_neq. }
  (* Step. *)
  { forwards: IHfw_ipc.
    (* The assumption that there is no path from [y] to [x] remains true as we move
       from [y] to its successor and perform one step of compression at [y]. *)
    { eauto 6 using compress_preserves_paths_converse, is_repr_path with rtclosure. }
    (* The assumption that there is no path from [y] to [x] gives us the fact that
       [y] and [x] are distinct. It is used twice below. *)
    forwards: not_rtclosure_inv_neq; eauto.
    econstructor.
    { eauto using compress_preserves_other_edges. }
    { eauto using compress_preserves_is_repr_weak with rtclosure. }
    { rewrite compress_compress by eauto. assumption. }}
Qed.

(* A corollary of the previous lemma. *)

Lemma fw_ipc_compress:
  forall V D F x y z l F',
  @is_dsf V D F ->
  F x y ->
  is_repr F y z ->
  fw_ipc F y l F' ->
  fw_ipc (compress F x z) y l (compress F' x z).
Proof using.
  eauto using fw_ipc_compress_preliminary, acyclicity with tclosure.
Qed.

(* -------------------------------------------------------------------------- *)

(* Provided there is no path from [y] to [x], backward iterative compression at
   [y] commutes with one step of un-compression at [x]. *)

(* This statement should really be presented as a commutative diagram. *)

Lemma bw_ipc_compress_preliminary:
  forall V Fxz y l Fxz',
  @bw_ipc V Fxz y l Fxz' ->
  forall F x z,
  Fxz = compress F x z ->
  ~ path F y x ->
  exists F',
  Fxz' = compress F' x z /\
  bw_ipc F y l F'.
Proof using.
  induction 1; intros; subst.
  (* Base. *)
  { eexists. split. eauto.
    econstructor; eauto using compress_preserves_roots_converse. }
  (* Step. *)
  { (* The assumption that there is no path from [y] to [x] gives us the fact that
       [y] and [x] are distinct. *)
    forwards: not_rtclosure_inv_neq; eauto.
    (* This implies that the edge of [x] to [y], which exists after compression,
       already existed before compression. *)
    forwards: compress_preserves_other_edges_converse; eauto.
    forwards: IHbw_ipc.
      { eauto. }
      { eauto 6 using compress_preserves_paths_converse, is_repr_path with rtclosure. }
    unpack. subst. eexists. split.
    eapply compress_compress. { eauto. }
    econstructor;
      eauto 6 using compress_preserves_is_repr_weak_converse,
        compress_preserves_paths_converse, is_repr_path with rtclosure. }
Qed.

(* A corollary of the previous lemma. *)

Lemma bw_ipc_compress:
  forall V D F x y z l F'',
  @is_dsf V D F ->
  F x y ->
  is_repr F y z ->
  bw_ipc (compress F x z) y l F'' ->
  exists F',
  F'' = compress F' x z /\
  bw_ipc F y l F'.
Proof using.
  eauto using bw_ipc_compress_preliminary, acyclicity with tclosure.
Qed.

(* -------------------------------------------------------------------------- *)

(* Equivalence between [fw_ipc] and [bw_ipc]. *)

Lemma bw_ipc_fw_ipc:
  forall V F x l F',
  @bw_ipc V F x l F' ->
  forall D,
  is_dsf D F ->
  @fw_ipc V F x l F'.
Proof using.
  induction 1; intros; subst; econstructor; eauto using fw_ipc_compress.
Qed.

Lemma fw_ipc_bw_ipc:
  forall V F x l F',
  @fw_ipc V F x l F' ->
  forall D,
  is_dsf D F ->
  @bw_ipc V F x l F'.
Proof using.
  induction 1; intros; subst.
  { econstructor; eauto. }
  { forwards: IHfw_ipc.
      eauto using is_dsf_compress, is_repr_path.
    forwards: bw_ipc_compress; eauto. unpack.
    econstructor; eauto. }
Qed.

(* -------------------------------------------------------------------------- *)

(* Iterative path compression, starting at an arbitrary vertex [x], is always
   possible. *)

(* I believe that this lemma may be useful in avoiding a chicken-and-egg
   problem. In the CFML proof of the OCaml code for iterative path
   compression, we must prove that we have enough credits for the code to
   operate. This requires arguing that the initial potential is high enough,
   using the lemma [amortized_cost_fw_ipc]. But this lemma has a hypothesis of
   the form [fw_ipc V F x l F'] -- that is, it requires proving, ahead of
   time, that iterative path compression terminates. *)

Lemma ipc_defined_preliminary:
  forall V D F,
  @is_dsf V D F ->
  forall x r,
  path F x r ->
  is_root F r ->
  exists l F',
  bw_ipc F x l F'.
Proof using.
  induction 2 using rtclosure_ind_l; intros.
  { repeat econstructor. eauto. }
  { forwards: IHrtclosure. eauto. unpack.
    do 2 eexists. eapply BWIPCStep; eauto with is_repr. }
Qed.

Lemma ipc_defined:
  forall V D F,
  @is_dsf V D F ->
  forall x,
  exists l F',
  bw_ipc F x l F'.
Proof using.
  intros.
  forwards [ r [ ? ? ]]: is_dsf_defined_is_repr x. eauto.
  eauto using ipc_defined_preliminary.
Qed.

(* -------------------------------------------------------------------------- *)

(* Iterative path compression is a composition of several path compression
   steps, so it preserves the agreement between [R] and [F]. This property
   is easy to establish for [fw_ipc], and is then transported to [bw_ipc]. *)

Lemma fw_ipc_preserves_RF_agreement:
  forall V F x l F',
  @fw_ipc V F x l F' ->
  forall R D,
  is_dsf D F ->
  fun_in_rel R (is_repr F) ->
  fun_in_rel R (is_repr F').
Proof using.
  induction 1; eauto 6 using is_repr_path, is_dsf_compress, compress_R_compress_agree.
Qed.

Lemma bw_ipc_preserves_RF_agreement:
  forall V F x l F',
  @bw_ipc V F x l F' ->
  forall R D,
  is_dsf D F ->
  fun_in_rel R (is_repr F) ->
  fun_in_rel R (is_repr F').
Proof using.
  eauto using fw_ipc_preserves_RF_agreement, bw_ipc_fw_ipc.
Qed.


Require Import ssreflect ssrfun.
Set Automatic Coercions Import.
Require Import FunctionalExtensionality.
Require Import relations.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Functional.
Variables A B : Type.

Definition FuncType : Type
  := forall (T : monadType), A -> T B.
End Functional.

Module AcceptableFO.
Section axiom.
Variable T T' : monadType.

Definition TRtypeFO
  := forall X X', Rel X X' -> Rel (T X) (T' X').

Definition acceptableTRFO (TR : TRtypeFO) : Prop :=
  forall X X' (R : Rel X X') (x : X) (x' : X'),
    R x x' -> TR X X' R (tval T x) (tval T' x').
End axiom.

Record TRaccFO (T T' : monadType) := mkTRacc {
  TR :> TRtypeFO T T';
  axiomAcc :> acceptableTRFO TR
}.

End AcceptableFO.

Notation TRtypeFO := AcceptableFO.TRtypeFO.
Notation TRaccTypeFO := AcceptableFO.TRaccFO.
Notation TRFO := AcceptableFO.TR.
Notation AccFO :=  AcceptableFO.axiomAcc.

Section Purity.
Variables A B : Type.

Definition isPure (f : FuncType A B) : Prop
  := forall (T T' : monadType) (TRacc : TRaccTypeFO T T'),
    (@IdR A =R=> (TRFO TRacc) _ _ (@IdR B)) (f T) (f T').
End Purity.

Section RepresentationTheorems.
Variables A B : Type.

Lemma lem_pure (g : A -> B) : isPure (fun T => (@tval T _) \o g).
Proof.
rewrite /isPure.
move => T T' TR a a'; elim => {a'}.
now apply: AccFO.
Qed.

Section TopTopMonadicRelation.
Variable T : monadType.

Definition RelTop X X' (R : Rel X X') : Rel (X -> T B) (X' -> B)
  := fun h h' =>
       forall x x', R x x' -> h x = tval _ (h' x').

Definition RelTopTop X X' (R : Rel X X') : Rel (T X) X'
  := fun t t' =>
       forall h h', RelTop R h h' -> tbind t h = tval _ (h' t').

Definition TRacc1 : TRaccTypeFO T Id.
exists RelTopTop.
rewrite /RelTopTop /RelTop /=.
move => X X' R /=.
by intuition; rewrite taxiom0; auto.
Defined.

End TopTopMonadicRelation.

Theorem pure_is_pure (f : FuncType A B) (Hpure : isPure f) T :
  exists g : A -> B, @f T = (@tval _ _) \o g.
Proof.
exists (@f Id).
extensionality a => /=.
have H := Hpure _ _ (@TRacc1 T).
rewrite -[X in X = _]taxiom1.
apply : (H _ _ eq_refl (@tval _ _) id).
rewrite /RelTop /=.
by move => ? ?; elim.
Qed.

End RepresentationTheorems.


From LF Require Import Maps.
From LF Require Import Imp.
From Coq Require Import Classical.

Reserved Notation
         "st '=[' c ']=>inf'"
         (at level 40, c custom com at level 99).

CoInductive evalinf : com -> state -> Prop :=
  | I_Seq1 : forall c1 c2 st,
      st  =[ c1 ]=>inf  ->
      st  =[ c1 ; c2 ]=>inf
  | I_Seq2 : forall c1 c2 st st',
      st  =[ c1 ]=> st'  ->
      st' =[ c2 ]=>inf ->
      st  =[ c1 ; c2 ]=>inf
  | I_IfTrue : forall st b c1 c2,
      beval st b = true ->
      st =[ c1 ]=>inf ->
      st =[ if b then c1 else c2 end]=>inf
  | I_IfFalse : forall st b c1 c2,
      beval st b = false ->
      st =[ c2 ]=>inf ->
      st =[ if b then c1 else c2 end]=>inf
  | I_WhileBody : forall st b c,
      beval st b = true ->
      st  =[ c ]=>inf ->
      st  =[ while b do c end ]=>inf
  | I_WhileLoop : forall st st' b c,
      beval st b = true ->
      st =[ c ]=> st' ->
      st' =[ while b do c end ]=>inf ->
      st  =[ while b do c end ]=>inf
  where "st =[ c ]=>inf" := (evalinf c st ).

Lemma loop_diverges: forall st,
  st =[ loop ]=>inf.
Proof.
  cofix COINDHYP; intros.
  unfold loop.
  eapply I_WhileLoop.
  - reflexivity.
  - constructor.
  - fold loop. apply COINDHYP.
Qed.

Lemma state_unchaning_loop_converges: forall b c st,
  beval st b = true ->
  st =[ c ]=> st ->
  st =[ while b do c end ]=>inf.
Proof.
  cofix COINDHYP. intros.
  eapply I_WhileLoop.
  - auto.
  - eauto.
  - eapply COINDHYP; auto.
Qed.

Lemma loop_diverges': forall st,
  st =[ loop ]=>inf.
Proof.
  intros.
  apply state_unchaning_loop_converges; auto; constructor.
Qed.

Definition loop' : com :=
  <{ while 1 <= X do
       X := X + 1
     end }>.

Lemma loop'_converges: forall st,
  st X = 0 -> st =[ loop' ]=> st /\ ~st =[ loop']=>inf.
Proof.
  intros st Hx; inversion Hx; split.
  - econstructor; simpl; rewrite H0; reflexivity.
  - intros H; inversion H; subst;
    simpl in H3; rewrite H0 in H3; discriminate.
Qed.

Theorem eval_evalinf_exclusive: forall c st st',
    st =[ c ]=> st' -> ~(st =[ c ]=>inf).
Proof.
    intros c st st' H.
    induction H; intros contra; inversion contra;
    subst; try congruence; auto.
    - apply IHeval2. remember (eval_deterministic _ _ _ _ H H3); subst; auto.
    - generalize (eval_deterministic _ _ _ _ H0 H5); intros. subst st'0; auto.
Qed.

Reserved Notation
         "st '=[' c ']=>>' st'"
         (at level 40, c custom com at level 99).

CoInductive coeval : com -> state -> state -> Prop :=
| C_Skip : forall (st : state),
    st =[ skip ]=>> st
| C_Ass  : forall st a n x,
    aeval st a = n ->
    st =[ x := a ]=>> (x !-> n; st)
| C_Seq : forall c1 c2 st st' st'',
    st  =[ c1 ]=>> st'  ->
    st' =[ c2 ]=>> st'' ->
    st  =[ c1 ; c2 ]=>> st''
| C_IfTrue : forall st st' b c1 c2,
    beval st b = true ->
    st =[ c1 ]=>> st' ->
    st =[ if b then c1 else c2 end]=>> st'
| C_IfFalse : forall st st' b c1 c2,
    beval st b = false ->
    st =[ c2 ]=>> st' ->
    st =[ if b then c1 else c2 end]=>> st'
| C_WhileFalse : forall b st c,
    beval st b = false ->
    st =[ while b do c end ]=>> st
| C_WhileTrue : forall st st' st'' b c,
    beval st b = true ->
    st  =[ c ]=>> st' ->
    st' =[ while b do c end ]=>> st'' ->
    st  =[ while b do c end ]=>> st''
where "st =[ c ]=>> st'" := (coeval c st st').

Theorem eval_coeval: forall c st st',
    st =[ c ]=> st' ->
    st =[ c ]=>> st'.
Proof.
  induction 1; econstructor; eauto; assumption.
Qed.

Lemma coeval_loop: forall st,
  st =[ loop ]=>> st.
Proof.
    cofix COINDHYP.
    intros; unfold loop.
    eapply C_WhileTrue.
    - auto.
    - constructor.
    - apply COINDHYP.
Qed.

Lemma coeval_loop': forall st,
  st X = 0 -> st =[ loop ]=>> st.
Proof.
    cofix COINDHYP.
    intros; unfold loop.
    eapply C_WhileTrue.
    - auto.
    - constructor.
    - apply COINDHYP; auto.
Qed.

Lemma coeval_noteval_evalinf: forall c st st',
  st =[ c ]=>> st' -> ~(st =[ c ]=> st') -> st =[ c ]=>inf.
Proof.
    cofix COINDHYP. intros.
    inversion H; subst.
    - (* skip *) elim H0; constructor.
    - (* x := a *) elim H0; constructor; auto.
    - (* c1; c2 *) elim (classic (st =[ c1 ]=> st'0)); intro.
      + (* st =[ c1 ]=> st'0 *)
        elim (classic (st'0 =[ c2 ]=> st')); intro.
        * (* st'0 =[ c2 ]=> st' *)
          elim H0. econstructor; try apply H3;  apply H4.
        * (* ~ st'0 =[ c2 ]=> st' *)
          eapply I_Seq2; try apply H3. eapply COINDHYP; eauto; auto.
      + (* ~ st =[ c1 ]=> st'0 *)
        eapply I_Seq1; eapply COINDHYP; eauto.
    - (* if true then c1 else c2 end *)
      elim (classic (st =[ c1 ]=> st')); intro.
      + (* st =[ c1 ]=> st' *)
        elim H0; econstructor; try apply H1; apply H3.
      + (* ~st =[ c1 ]=> st' *)
        eapply I_IfTrue; try apply H1; eauto.
    - (* if false then c1 else c2 end *)
      elim (classic (st =[ c2 ]=> st')); intro.
        + (* st =[ c2 ]=> st' *)
          elim H0. eapply E_IfFalse; try apply H1; apply H3.
        + (* ~st =[ c2 ]=> st' *)
          eapply I_IfFalse; try apply H1; eauto.
    - (* while false do c end *)
      elim H0. eapply E_WhileFalse; auto.
    - (* while true do c end *)
      elim (classic ( st =[ c0 ]=> st'0 )); intro.
      (* st =[ c0 ]=> st'0 *)
      + elim (classic ( st'0 =[ while b do c0 end ]=> st')); intro.
        (* ~ st'0 =[ while b do c0 end ]=> st' *)
        * elim H0; eauto using E_WhileTrue.
        (* ~ st'0 =[ while b do c0 end ]=> st' *)
        * eapply I_WhileLoop; eauto.
      (* ~ st =[ c0 ]=> st'0 *)
      + eapply I_WhileBody; eauto.
Qed.

Theorem coeval_eval_or_evalinf: forall c st st',
    st =[ c ]=>> st' ->
    st =[ c ]=> st' \/ st =[ c ]=>inf.
Proof.
  intros. elim (classic (st =[ c ]=> st')); intros.
  left; auto.
  right. eapply coeval_noteval_evalinf; eauto.
Qed.

Theorem eval_coeval_deterministic: forall c st st',
    st =[ c ]=> st' ->
    forall st'', st =[ c ]=>> st''-> st' = st''.
Proof.
  intros c st st' H. induction H; intros st''' H';
   inversion H'; subst; try congruence; auto.
   - (* st =[c1; c2]=>>st''' *)
      remember (IHeval1 _ H3); subst; auto.
   - (* st =[ while true do c end ]=>> st''' *)
      remember (IHeval1 _ H5); subst; auto.
Qed.


Require Import
  Coq.Bool.Sumbool Ssreflect.ssreflect Ssreflect.seq
  FormalPS.stdlib_ext FormalPS.Core.

Set Implicit Arguments.

(*
instfalse_spec, insttrue_spec, instbool_spec:
  ブール値の仕様。
  false は何もしない命令である。
  true は swap と同様の振舞いをする命令である。
*)
Definition instbool_spec (b : bool) (i1 : inst) : Prop :=
  forall i2 i3 vs cs,
    (i3 :: i2 :: vs, i1 :: cs) |=>*
    ((if b then [:: i2; i3] else [:: i3; i2]) ++ vs, cs).

(*
exists_false, exists_true:
  ブール値の仕様を満たす命令。
*)
Lemma exists_bool b : {instbool : inst | instbool_spec b instbool }.
Proof.
  case: b; eexists => i1 i2 vs cs /=.
  - evalpartial evalswap; evalauto.
  - evalpartial evalnop; evalauto.
Defined.

Notation instbool b := (proj1_sig (exists_bool b)).
Notation evalbool b := (proj2_sig (exists_bool b)).

Hint Resolve ((fun b => evalbool b) :
  forall b, instbool_spec b (instbool b)).

(*
instbool_eqmap:
*)
Lemma instbool_eqmap :
  forall b1 b2 i, instbool_spec b1 i -> instbool_spec b2 i -> b1 = b2.
Proof.
  move => b1 b2 i H H0.
  have: let f b := if b then [:: instpop; instcopy]
                        else [:: instcopy; instpop] in
        let s1 := (f b1, [::]) in
        let s2 := (f b2, [::]) in s1 |=>* s2 \/ s2 |=>* s1
    by apply (@eval_semi_uniqueness ([:: instcopy; instpop], [:: i]));
      [evalpartial H | evalpartial H0]; rewrite cats0; evalauto.
  by move: b1 b2 {H H0} => [] [] [] //= H; inversion H; inversion H0.
Qed.

(*
exists_not:
  not 命令。
*)
Lemma exists_not :
  { instnot : inst |
    forall (b : bool) i1 vs cs, instbool_spec b i1 ->
    exists i2 : inst, instbool_spec (negb b) i2 /\
    (i1 :: vs, instnot :: cs) |=>* (i2 :: vs, cs) }.
Proof.
  eexists => b i1 vs cs H.
  evalpartial' (evalpush instswap).
  evalpartial evalcons.
  evalauto.
  case: b H => H i2 i3 vs' cs'; evalauto; evalpartial H; evalauto.
Defined.

Notation instnot := (proj1_sig exists_not).
Notation evalnot := (proj2_sig exists_not).

(*
exists_if, exists_execif:
  ブール値による条件分岐の命令。
  exists_if は、ブール値によってスタックの先頭にある2つの値のうちどちらを残すか
  を切り替える。後者(exists_execif)は、exists_if によって選択される命令を実行す
  る。
*)
Lemma exists_if :
  { instif : inst |
    forall (b : bool) i1 i2 i3 vs cs, instbool_spec b i1 ->
    (i3 :: i2 :: i1 :: vs, instif :: cs) |=>*
    ((if b then i2 else i3) :: vs, cs) }.
Proof.
  eexists => b i1 i2 i3 vs cs H.
  evalpartial' evalquote.
  evalpartial' evalswap.
  evalpartial' evalquote.
  evalpartial' evalcons.
  evalpartial' evalsnoc.
  evalpartial' evalexec.
  evalauto.
  case: b H => H; evalpartial H => /=; evalpartial evalpop; evalauto.
Defined.

Notation instif := (proj1_sig exists_if).
Notation evalif := (proj2_sig exists_if).

Lemma exists_execif :
  { instexecif : inst |
    forall (b : bool) i1 i2 i3 vs cs, instbool_spec b i1 ->
    (i3 :: i2 :: i1 :: vs, instexecif :: cs) |=>*
    (vs, (if b then i2 else i3) :: cs) }.
Proof.
  eexists => b i1 i2 i3 vs cs H.
  evalpartial' (evalif b).
  evalpartial evalexec.
  evalauto.
Defined.

Notation instexecif := (proj1_sig exists_execif).
Notation evalexecif := (proj2_sig exists_execif).

(*
instxor:
  xor 命令。
*)
Definition instxor : inst := instcons.

Lemma evalxor :
  forall (b1 b2 : bool) i1 i2 vs cs,
  instbool_spec b1 i1 -> instbool_spec b2 i2 ->
  exists i3 : inst, instbool_spec (xorb b1 b2) i3 /\
  (i2 :: i1 :: vs, instxor :: cs) |=>* (i3 :: vs, cs).
Proof.
  (do 2 case) => i1 i2 vs cs H H0; evalauto => i3 i4 vs' cs';
    evalauto; evalpartial H; evalpartial H0; evalauto.
Qed.

(*
exists_and:
  and 命令。
*)
Lemma exists_and :
  { instand : inst |
    forall (b1 b2 : bool) i1 i2 vs cs,
    instbool_spec b1 i1 -> instbool_spec b2 i2 ->
    exists i3 : inst, instbool_spec (andb b1 b2) i3 /\
    (i2 :: i1 :: vs, instand :: cs) |=>* (i3 :: vs, cs) }.
Proof.
  eexists => b1 b2 i1 i2 vs cs H H0.
  evalpartial' evalswap.
  do 2 evalpartial' evalpush.
  evalpartial (evalexecif b1).
  case b1 => /=.
  - evalpartial evalnop.
    by evalauto.
  - evalpartial' evalpop.
    evalpartial evalpush.
    by evalauto.
Defined.

Notation instand := (proj1_sig exists_and).
Notation evaland := (proj2_sig exists_and).

(*
exists_or:
  or 命令。
*)
Lemma exists_or :
  { instand : inst |
    forall (b1 b2 : bool) i1 i2 vs cs,
    instbool_spec b1 i1 -> instbool_spec b2 i2 ->
    exists i3 : inst, instbool_spec (orb b1 b2) i3 /\
    (i2 :: i1 :: vs, instand :: cs) |=>* (i3 :: vs, cs) }.
Proof.
  eexists => b1 b2 i1 i2 vs cs H H0.
  evalpartial' evalswap.
  do 2 evalpartial' evalpush.
  evalpartial (evalexecif b1).
  case b1 => /=.
  - evalpartial' evalpop.
    evalpartial evalpush.
    by evalauto.
  - evalpartial evalnop.
    by evalauto.
Defined.

Notation instor := (proj1_sig exists_or).
Notation evalor := (proj2_sig exists_or).


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal78.

Set Printing Depth 1000.
Definition lfind_eval  y:=
append y Nil.

Compute lfind_eval  (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons Zero Nil)))).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons Zero Nil))))).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)))))).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Nil).