Require Import Coq.Lists.List Coq.Sorting.Permutation.

From Coq Require Import ZArith.
From ITree Require Export ITree.
From Paco Require Import paco.
Require Import Lia.
Require Export Refinement Combinators.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.

(** * Basic Refinement Lemmas *)

Lemma padded_refines_ret E1 E2 R1 R2 RPre RPost RR r1 r2 :
  (RR r1 r2 : Prop) ->
  @padded_refines E1 E2 R1 R2 RPre RPost RR (Ret r1) (Ret r2).
Proof.
  apply padded_refines_ret.
Qed.

Lemma padded_refines_vis E1 E2 R1 R2 A B
        RPre RPost RR (e1 : E1 A) (e2 : E2 B)
        (k1 : A -> itree_spec E1 R1) (k2 : B -> itree_spec E2 R2) :
  (RPre A B e1 e2 : Prop) ->
  (forall a b, (RPost A B e1 e2 a b : Prop) -> padded_refines RPre RPost RR (k1 a) (k2 b)) ->
  padded_refines RPre RPost RR (Vis (Spec_vis e1) k1) (Vis (Spec_vis e2) k2).
Proof.
  unfold padded_refines. setoid_rewrite pad_vis. intros.
  pstep. constructor; auto. intros. left. pstep. constructor.
  left. eapply H0; auto.
Qed.

Lemma padded_refines_exists_r E1 E2 R1 R2 A
      RPre RPost RR (phi : itree_spec E1 R1) (kphi : A -> itree_spec E2 R2) a :
  padded_refines RPre RPost RR phi (kphi a) ->
  padded_refines RPre RPost RR phi (Vis Spec_exists kphi).
Proof.
  setoid_rewrite <- bind_trigger.
  apply padded_exists_spec_elim.
Qed.
Lemma padded_refines_exists_l E1 E2 R1 R2 A
      RPre RPost RR (phi : itree_spec E2 R2) (kphi : A -> itree_spec E1 R1) :
  (forall a, padded_refines RPre RPost RR (kphi a) phi) ->
  padded_refines RPre RPost RR (Vis Spec_exists kphi) phi.
Proof.
  setoid_rewrite <- bind_trigger.
  apply padded_exists_spec_eliml.
Qed.

Lemma padded_refines_forall_r E1 E2 R1 R2 A
      RPre RPost RR (phi : itree_spec E1 R1) (kphi : A -> itree_spec E2 R2) :
  (forall a, padded_refines RPre RPost RR phi (kphi a)) ->
  padded_refines RPre RPost RR phi (Vis Spec_forall kphi).
Proof.
  setoid_rewrite <- bind_trigger.
  apply padded_forall_spec_elim.
Qed.
Lemma padded_refines_forall_l E1 E2 R1 R2 A
      RPre RPost RR (phi : itree_spec E2 R2) (kphi : A -> itree_spec E1 R1) a :
  padded_refines RPre RPost RR (kphi a) phi ->
  padded_refines RPre RPost RR (Vis Spec_forall kphi) phi.
Proof.
  setoid_rewrite <- bind_trigger.
  apply padded_forall_spec_eliml.
Qed.

Lemma padded_refines_if_r E1 E2 RPre RPost R1 R2 RR (t1 : itree_spec E1 R1) (t2 t3: itree_spec E2 R2) b :
  (b = true  -> padded_refines RPre RPost RR t1 t2) ->
  (b = false -> padded_refines RPre RPost RR t1 t3) ->
  padded_refines RPre RPost RR t1 (if b then t2 else t3).
Proof.
  intros. destruct b; eauto.
Qed.
Lemma padded_refines_if_l E1 E2 RPre RPost R1 R2 RR (t1 t2 : itree_spec E1 R1) (t3 : itree_spec E2 R2) b :
  (b = true  -> padded_refines RPre RPost RR t1 t3) ->
  (b = false -> padded_refines RPre RPost RR t2 t3) ->
  padded_refines RPre RPost RR (if b then t1 else t2) t3.
Proof.
  intros. destruct b; eauto.
Qed.

Lemma padded_refines_if_bind_r A E1 E2 RPre RPost R1 R2 RR
      (t1 : itree_spec E1 R1) (t2 t3 : itree_spec E2 A)
      (t4 : A -> itree_spec E2 R2) (b : bool) :
  padded_refines RPre RPost RR t1 (if b then t2 >>= t4 else t3 >>= t4) ->
  padded_refines RPre RPost RR t1 ((if b then t2 else t3) >>= t4).
Proof.
  intros. destruct b; eauto.
Qed.
Lemma padded_refines_if_bind_l A E1 E2 RPre RPost R1 R2 RR
      (t1 t2 : itree_spec E1 A) (t3 : A -> itree_spec E1 R1)
      (t4 : itree_spec E2 R2) (b : bool) :
  padded_refines RPre RPost RR (if b then t1 >>= t3 else t2 >>= t3) t4 ->
  padded_refines RPre RPost RR ((if b then t1 else t2) >>= t3) t4.
Proof.
  intros. destruct b; eauto.
Qed.

Lemma padded_refines_match_list_r E1 E2 RPre RPost R1 R2 RR A (t1 : itree_spec E1 R1)
      (t2 : A -> list A -> itree_spec E2 R2) (t3 : itree_spec E2 R2) xs :
  (forall x xs', xs = x :: xs' -> padded_refines RPre RPost RR t1 (t2 x xs')) ->
  (xs = nil -> padded_refines RPre RPost RR t1 t3) ->
  padded_refines RPre RPost RR t1 (match xs with | x :: xs' => t2 x xs' | nil => t3 end).
Proof.
  intros. destruct xs; eauto.
Qed.
Lemma padded_refines_match_list_l E1 E2 RPre RPost R1 R2 RR A (t3 : itree_spec E2 R2)
      (t1 : A -> list A -> itree_spec E1 R1) (t2 : itree_spec E1 R1) xs :
  (forall x xs', xs = x :: xs' -> padded_refines RPre RPost RR (t1 x xs') t3) ->
  (xs = nil -> padded_refines RPre RPost RR t2 t3) ->
  padded_refines RPre RPost RR (match xs with | x :: xs' => t1 x xs' | nil => t2 end) t3.
Proof.
  intros. destruct xs; eauto.
Qed.

Lemma padded_refines_match_list_bind_r B E1 E2 RPre RPost R1 R2 RR A (t1 : itree_spec E1 R1)
      (t2 : A -> list A -> itree_spec E2 B) (t3 : itree_spec E2 B)
      (t4 : B -> itree_spec E2 R2) xs :
  padded_refines RPre RPost RR t1 (match xs with | x :: xs' => t2 x xs' >>= t4 | nil => t3 >>= t4 end) ->
  padded_refines RPre RPost RR t1 ((match xs with | x :: xs' => t2 x xs' | nil => t3 end) >>= t4).
Proof.
  intros. destruct xs; eauto.
Qed.
Lemma padded_refines_match_list_bind_l B E1 E2 RPre RPost R1 R2 RR A (t3 : itree_spec E2 R2)
      (t1 : A -> list A -> itree_spec E1 B) (t2 : itree_spec E1 B)
      (t4 : B -> itree_spec E1 R1) xs :
  padded_refines RPre RPost RR (match xs with | x :: xs' => t1 x xs' >>= t4 | nil => t2 >>= t4 end) t3 ->
  padded_refines RPre RPost RR ((match xs with | x :: xs' => t1 x xs' | nil => t2 end) >>= t4) t3.
Proof.
  intros. destruct xs; eauto.
Qed.

Lemma padded_refines_match_pair_r E1 E2 RPre RPost R1 R2 RR A B
      (t1 : itree_spec E1 R1) (t2 : A -> B -> itree_spec E2 R2) pr :
  (forall x y, pr = (x, y) -> padded_refines RPre RPost RR t1 (t2 x y)) ->
  padded_refines RPre RPost RR t1 (match pr with | (x,y) => t2 x y end).
Proof.
  intros. destruct pr; eauto.
Qed.
Lemma padded_refines_match_pair_l E1 E2 RPre RPost R1 R2 RR A B
      (t1 : A -> B -> itree_spec E1 R1) (t2 : itree_spec E2 R2) pr :
  (forall x y, pr = (x, y) -> padded_refines RPre RPost RR (t1 x y) t2) ->
  padded_refines RPre RPost RR (match pr with | (x,y) => t1 x y end) t2.
Proof.
  intros. destruct pr; eauto.
Qed.

Lemma padded_refines_match_pair_bind_r C E1 E2 RPre RPost R1 R2 RR A B
      (t1 : itree_spec E1 R1) (t2 : A -> B -> itree_spec E2 C)
      (t3 : C -> itree_spec E2 R2) pr :
  padded_refines RPre RPost RR t1 (match pr with | (x,y) => t2 x y >>= t3 end) ->
  padded_refines RPre RPost RR t1 ((match pr with | (x,y) => t2 x y end) >>= t3).
Proof.
  intros. destruct pr; eauto.
Qed.
Lemma padded_refines_match_pair_bind_l C E1 E2 RPre RPost R1 R2 RR A B
      (t1 : A -> B -> itree_spec E1 C) (t2 : itree_spec E2 R2)
      (t3 : C -> itree_spec E1 R1) pr :
  padded_refines RPre RPost RR (match pr with | (x,y) => t1 x y >>= t3 end) t2 ->
  padded_refines RPre RPost RR ((match pr with | (x,y) => t1 x y end) >>= t3) t2.
Proof.
  intros. destruct pr; eauto.
Qed.

Lemma padded_refines_ret_bind_r E1 E2 R1 R2 A
      RPre RPost RR (phi : itree_spec E1 R1) r (kphi : A -> itree_spec E2 R2) :
  padded_refines RPre RPost RR phi (kphi r) ->
  padded_refines RPre RPost RR phi (Ret r >>= kphi).
Proof.
  setoid_rewrite bind_ret_l; eauto.
Qed.
Lemma padded_refines_ret_bind_l E1 E2 R1 R2 A
      RPre RPost RR (phi : itree_spec E2 R2) r (kphi : A -> itree_spec E1 R1) :
  padded_refines RPre RPost RR (kphi r) phi ->
  padded_refines RPre RPost RR (Ret r >>= kphi) phi.
Proof.
  setoid_rewrite bind_ret_l; eauto.
Qed.

Lemma padded_refines_trigger_bind_r E1 E2 R1 R2 A
      RPre RPost RR (phi : itree_spec E1 R1) e (kphi : A -> itree_spec E2 R2) :
  padded_refines RPre RPost RR phi (Vis e kphi) ->
  padded_refines RPre RPost RR phi (ITree.trigger e >>= kphi).
Proof.
  setoid_rewrite bind_trigger; eauto.
Qed.
Lemma padded_refines_trigger_bind_l E1 E2 R1 R2 A
      RPre RPost RR (phi : itree_spec E2 R2) e (kphi : A -> itree_spec E1 R1) :
  padded_refines RPre RPost RR (Vis e kphi) phi ->
  padded_refines RPre RPost RR (ITree.trigger e >>= kphi) phi.
Proof.
  setoid_rewrite bind_trigger; eauto.
Qed.

Lemma padded_refines_vis_bind_r E1 E2 R1 R2 A1 A2
      RPre RPost RR (phi : itree_spec E1 R1) e
      (kphi1 : A1 -> itree_spec E2 A2) (kphi2 : A2 -> itree_spec E2 R2) :
  padded_refines RPre RPost RR phi (Vis e (fun a => kphi1 a >>= kphi2)) ->
  padded_refines RPre RPost RR phi (Vis e kphi1 >>= kphi2).
Proof.
  setoid_rewrite bind_vis; eauto.
Qed.
Lemma padded_refines_vis_bind_l E1 E2 R1 R2 A1 A2
      RPre RPost RR (phi : itree_spec E2 R2) e
      (kphi1 : A1 -> itree_spec E1 A2) (kphi2 : A2 -> itree_spec E1 R1) :
  padded_refines RPre RPost RR (Vis e (fun a => kphi1 a >>= kphi2)) phi ->
  padded_refines RPre RPost RR (Vis e kphi1 >>= kphi2) phi.
Proof.
  setoid_rewrite bind_vis; eauto.
Qed.

Lemma padded_refines_bind_bind_r E1 E2 R1 R2 A1 A2
      RPre RPost RR (phi1 : itree_spec E1 R1) (phi2 : itree_spec E2 A1)
      (kphi1 : A1 -> itree_spec E2 A2) (kphi2 : A2 -> itree_spec E2 R2) :
  padded_refines RPre RPost RR phi1 (phi2 >>= (fun a => kphi1 a >>= kphi2)) ->
  padded_refines RPre RPost RR phi1 ((phi2 >>= kphi1) >>= kphi2).
Proof.
  setoid_rewrite bind_bind; eauto.
Qed.
Lemma padded_refines_bind_bind_l E1 E2 R1 R2 A1 A2
      RPre RPost RR (phi1 : itree_spec E2 A1) (phi2 : itree_spec E1 R1)
      (kphi1 : A1 -> itree_spec E2 A2) (kphi2 : A2 -> itree_spec E2 R2) :
  padded_refines RPre RPost RR (phi1 >>= (fun a => kphi1 a >>= kphi2)) phi2 ->
  padded_refines RPre RPost RR ((phi1 >>= kphi1) >>= kphi2) phi2.
Proof.
  setoid_rewrite bind_bind; eauto.
Qed.

(** * Refinement Lemmas About Recursion *)

Section Rec.

Context (E1 E2 : Type -> Type) (A1 A2 R1 R2 : Type).
Context (RPre : PreRel E1 E2) (RPost : PostRel E1 E2) (RR : R1 -> R2 -> Prop).

Context (precond : A1 -> A2 -> Prop)
        (postcond : forall a1 a2, precond a1 a2 -> forall r1 r2, RR r1 r2 -> Prop).

Variant OnCallPreRel : PreRel (callE A1 R1) (callE A2 R2) :=
  | OnCallPreRel_i a1 a2 : precond a1 a2 ->
    OnCallPreRel R1 R2 (Call a1) (Call a2).

Variant OnCallPostRel : PostRel (callE A1 R1) (callE A2 R2) :=
  | OnCallPostRel_i a1 a2 r1 r2 p : depProdRel RR (postcond a1 a2 p) r1 r2 ->
    OnCallPostRel R1 R2 (Call a1) (Call a2) r1 r2.

Context (body1 : A1 -> itree_spec (callE A1 R1 +' E1) R1).

Section RecRec.
Context (body2 : A2 -> itree_spec (callE A2 R2 +' E2) R2).

Lemma padded_refines_rec (a1 : A1) (a2 : A2) :
  precond a1 a2 ->
  (forall a1 a2 (p : precond a1 a2),
     padded_refines (sumPreRel OnCallPreRel RPre)
                    (sumPostRel OnCallPostRel RPost)
                    (depProdRel RR (postcond a1 a2 p))
                    (body1 a1) (body2 a2)) ->
  padded_refines RPre RPost RR (mrec_spec (calling' body1) (Call a1))
                             (mrec_spec (calling' body2) (Call a2)).
Proof.
  intros.
  eapply padded_refines_monot with
    (RR1 := OnCallPostRel R1 R2 (Call a1) (Call a2)); eauto.
  { intros. inv PR. destruct H7. inj_existT. subst. auto. }
  eapply padded_refines_mrec with (RPreInv := OnCallPreRel)
                                  (RPostInv := OnCallPostRel).
  - intros A B [] [] []. unfold calling'.
    eapply padded_refines_monot with (RR1 := depProdRel RR (postcond a3 a4 H1)); eauto.
    intros. econstructor; eauto.
  - constructor; eauto.
Qed.

End RecRec.

Context (Pre : A2 -> Prop) (Post : A2 -> R2 -> Prop).
Context (rdec : A2 -> A2 -> Prop).

Definition total_spec_fix_body (a : A2) : itree_spec (callE A2 R2 +' E2) R2 :=
  assume_spec (Pre a);;
  (
    n <- exists_spec nat;;
    trepeat n (a' <- exists_spec A2;; assert_spec (Pre a' /\ rdec a' a);; call_spec a')
  );;
  b <- exists_spec R2;;
  assert_spec (Post a b);;
  Ret b.

From Coq Require Export Morphisms RelationClasses Setoid Program.Equality.
From Coq Require Export Eqdep EqdepFacts Logic.Classical.

Lemma padded_refines_total_spec (a1 : A1) (a2 : A2) :
  well_founded rdec ->
  precond a1 a2 ->
  (forall a1 a2 (p : precond a1 a2),
     padded_refines (sumPreRel OnCallPreRel RPre)
                    (sumPostRel OnCallPostRel RPost)
                    (depProdRel RR (postcond a1 a2 p))
                    (body1 a1) (total_spec_fix_body a2)) ->
  padded_refines RPre RPost RR (mrec_spec (calling' body1) (Call a1))
                             (total_spec Pre Post a2).
Proof.
  intro; rewrite <- total_spec_fix_total; eauto.
  apply padded_refines_rec.
Qed.

End Rec.

Lemma padded_refines_trepeat_zero_r E1 E2 R1 R2 RPre RPost RR
      (t1 : itree_spec E1 R1) (t2 : itree_spec E2 R2) :
  padded_refines RPre RPost RR t1 (Ret tt) ->
  padded_refines RPre RPost RR t1 (trepeat 0 t2).
Proof. eauto. Qed.

Lemma padded_refines_trepeat_suc_r E1 E2 R1 R2 RPre RPost RR
      (t1 : itree_spec E1 R1) n (t2 : itree_spec E2 R2) :
  padded_refines RPre RPost RR t1 (t2 ;; trepeat n t2) ->
  padded_refines RPre RPost RR t1 (trepeat (S n) t2).
Proof. eauto. Qed.

Lemma padded_refines_trepeat_bind_zero_r E1 E2 R1 R2 R3 RPre RPost RR
      (t1 : itree_spec E1 R1) (t2 : itree_spec E2 R2) (t3 : unit -> itree_spec E2 R3) :
  padded_refines RPre RPost RR t1 (t3 tt) ->
  padded_refines RPre RPost RR t1 (trepeat 0 t2 >>= t3).
Proof. eauto. Qed.

Lemma padded_refines_trepeat_bind_suc_r E1 E2 R1 R2 R3 RPre RPost RR
      (t1 : itree_spec E1 R1) n (t2 : itree_spec E2 R2) (t3 : unit -> itree_spec E2 R3) :
  padded_refines RPre RPost RR t1 (t2 ;; (trepeat n t2 >>= t3)) ->
  padded_refines RPre RPost RR t1 (trepeat (S n) t2 >>= t3).
Proof. simpl; rewrite bind_bind; eauto. Qed.

(** * Hint Database Definitions *)

Create HintDb refines.
Create HintDb prepostcond.

Hint Extern 999 (padded_refines _ _ _ _ _) => shelve : refines.

Definition RelGoal (goal : Prop) := goal.

Hint Opaque RelGoal : refines.

Hint Extern 999 (RelGoal _) =>
  unfold RelGoal; (reflexivity || shelve) : refines.

Lemma padded_refines_eq_unfold E R1 R2 RR (t1 : itree_spec E R1) (t2 : itree_spec E R2) :
  padded_refines eqPreRel eqPostRel RR t1 t2 ->
  padded_refines_eq RR t1 t2.
Proof. eauto. Qed.

Hint Extern 100 (padded_refines_eq _ _ _) =>
  simple apply padded_refines_eq_unfold : refines.

(** * IntroArg Definition and Hints *)

Inductive ArgName := Any | RetAny | Hyp | Exists | Forall | If | Match.
Ltac argName n :=
  match n with
  | Any      => fresh "a"
  | RetAny   => fresh "r"
  | Hyp      => fresh "H"
  | Exists   => fresh "e_exists"
  | Forall   => fresh "e_forall"
  | If       => fresh "e_if"
  | Match    => fresh "e_match"
  end.

Polymorphic Definition IntroArg (n : ArgName) A (goal : A -> Type) := forall a, goal a.

Hint Opaque IntroArg : refines prepostcond.

Polymorphic Lemma IntroArg_fold n A goal : forall a, IntroArg n A goal -> goal a.
Proof. intros a H; exact (H a). Qed.

(* Polymorphic Lemma IntroArg_unfold n A (goal : A -> Prop) : (forall a, goal a) -> IntroArg n A goal. *)
(* Proof. unfold IntroArg; intro H; exact H. Qed. *)

Ltac IntroArg_intro e := intro e.

Ltac IntroArg_forget := let e := fresh in intro e; clear e.

Polymorphic Lemma IntroArg_eta n A (f : A -> Type) x goal :
  IntroArg n (f x) goal ->
  IntroArg n ((fun x' => f x') x) goal.
Proof. eauto. Qed.

Polymorphic Lemma IntroArg_and n P Q (goal : P /\ Q -> Prop)
  : IntroArg n P (fun p => IntroArg n Q (fun q => goal (conj p q))) -> IntroArg n _ goal.
Proof. intros H [ p q ]; apply H. Qed.

Polymorphic Lemma IntroArg_sumPreRel_inl n E1 E2 F1 F2
                  (RPreE : PreRel E1 E2) (RPreF : PreRel F1 F2)
                  A B e1 e2 (goal : _ -> Prop) :
  IntroArg n (RPreE A B e1 e2) (fun p => goal (sumPreRel_inl _ _ _ _ _ _ p)) ->
  IntroArg n (@sumPreRel E1 E2 F1 F2 RPreE RPreF A B (inl1 e1) (inl1 e2)) goal.
Proof. intros ?H ?H; dependent destruction H0; apply H. Qed.
Polymorphic Lemma IntroArg_sumPreRel_inr n E1 E2 F1 F2
                  (RPreE : PreRel E1 E2) (RPreF : PreRel F1 F2)
                  A B f1 f2 (goal : _ -> Prop) :
  IntroArg n (RPreF A B f1 f2) (fun p => goal (sumPreRel_inr _ _ _ _ _ _ p)) ->
  IntroArg n (@sumPreRel E1 E2 F1 F2 RPreE RPreF A B (inr1 f1) (inr1 f2)) goal.
Proof. intros ?H ?H; dependent destruction H0; apply H. Qed.

Polymorphic Lemma IntroArg_sumPostRel_inl n E1 E2 F1 F2
                  (RPreE : PostRel E1 E2) (RPreF : PostRel F1 F2)
                  A B e1 e2 a b (goal : _ -> Prop) :
  IntroArg n (RPreE A B e1 e2 a b) (fun p => goal (sumPostRel_inl _ _ _ _ _ _ _ _ p)) ->
  IntroArg n (@sumPostRel E1 E2 F1 F2 RPreE RPreF A B (inl1 e1) (inl1 e2) a b) goal.
Proof. intros ?H ?H; dependent destruction H0; apply H. Qed.
Polymorphic Lemma IntroArg_sumPostRel_inr n E1 E2 F1 F2
                  (RPreE : PostRel E1 E2) (RPreF : PostRel F1 F2)
                  A B f1 f2 a b (goal : _ -> Prop) :
  IntroArg n (RPreF A B f1 f2 a b) (fun p => goal (sumPostRel_inr _ _ _ _ _ _ _ _ p)) ->
  IntroArg n (@sumPostRel E1 E2 F1 F2 RPreE RPreF A B (inr1 f1) (inr1 f2) a b) goal.
Proof. intros ?H ?H; dependent destruction H0; apply H. Qed.

Polymorphic Lemma IntroArg_eqPostRel n E A e a1 a2 (goal : _ -> Prop) :
  IntroArg n (a1 = a2) (fun p => goal (eq_rect _ _ (eqPostRel_refl A e a1) _ p)) ->
  IntroArg n (@eqPostRel E A A e e a1 a2) goal.
Proof.
  intros ?H ?H; dependent destruction H0.
  apply (fun H => H eq_refl) in H.
  erewrite eq_rect_eq; eauto.
Qed.

Polymorphic Lemma IntroArg_OnCallPreRel_i n A1 A2 R1 R2
                  (precond : A1 -> A2 -> Prop) a1 a2 (goal : _ -> Prop) :
  IntroArg n (precond a1 a2) (fun p => goal (OnCallPreRel_i _ _ _ _ _ _ _ p)) ->
  IntroArg n (OnCallPreRel A1 A2 R1 R2 precond R1 R2 (Call a1) (Call a2)) goal.
Proof. intros ?H ?H; dependent destruction H0; apply H. Qed.

Polymorphic Lemma IntroArg_OnCallPostRel_i n A1 A2 R1 R2
                  (RR : R1 -> R2 -> Prop) (precond : A1 -> A2 -> Prop)
                  (postcond : forall a1 a2, precond a1 a2 -> forall (r1 : R1) (r2 : R2), RR r1 r2 -> Prop)
                  a1 a2 r1 r2 (goal : _ -> Prop) :
  IntroArg n (precond a1 a2) (fun p0 => IntroArg n (RR r1 r2) (fun p1 =>
  IntroArg n (postcond a1 a2 p0 r1 r2 p1) (fun p2 =>
    goal (OnCallPostRel_i _ _ _ _ _ _ _ _ _ _ _ p0 (exist _ p1 p2))))) ->
  IntroArg n (OnCallPostRel A1 A2 R1 R2 RR precond postcond R1 R2 (Call a1) (Call a2) r1 r2) goal.
Proof. intros ?H ?H; dependent destruction H0; dependent destruction d; apply H. Qed.

Ltac IntroArg_intro_dependent_destruction n :=
  let e := argName n in
    IntroArg_intro e; dependent destruction e.

Ltac IntroArg_base_tac n A g :=
  lazymatch A with
  | (fun _ => _) _ => simple apply IntroArg_eta
  | _ /\ _ => simple apply IntroArg_and
  | sumPreRel _ _ _ _ (inl1 _) (inl1 _) => simple apply IntroArg_sumPreRel_inl
  | sumPreRel _ _ _ _ (inl1 _) (ReSum_inl _ _ _ _ _ _ _) => apply IntroArg_sumPreRel_inl
  | sumPreRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (inl1 _) => apply IntroArg_sumPreRel_inl
  | sumPreRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (ReSum_inl _ _ _ _ _ _ _) => apply IntroArg_sumPreRel_inl
  | sumPreRel _ _ _ _ (inr1 _) (inr1 _) => simple apply IntroArg_sumPreRel_inr
  | sumPreRel _ _ _ _ (inr1 _) (ReSum_inr _ _ _ _ _ _ _) => apply IntroArg_sumPreRel_inr
  | sumPreRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (inr1 _) => apply IntroArg_sumPreRel_inr
  | sumPreRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (ReSum_inr _ _ _ _ _ _ _) => apply IntroArg_sumPreRel_inr
  | sumPreRel _ _ _ _ (inl1 _) (inr1 _) => IntroArg_intro_dependent_destruction n
  | sumPreRel _ _ _ _ (inl1 _) (ReSum_inr _ _ _ _ _ _ _) => IntroArg_intro_dependent_destruction n
  | sumPreRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (inr1 _) => IntroArg_intro_dependent_destruction n
  | sumPreRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (ReSum_inr _ _ _ _ _ _ _) => IntroArg_intro_dependent_destruction n
  | sumPreRel _ _ _ _ (inr1 _) (inl1 _) => IntroArg_intro_dependent_destruction n
  | sumPreRel _ _ _ _ (inr1 _) (ReSum_inl _ _ _ _ _ _ _) => IntroArg_intro_dependent_destruction n
  | sumPreRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (inl1 _) => IntroArg_intro_dependent_destruction n
  | sumPreRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (ReSum_inl _ _ _ _ _ _ _) => IntroArg_intro_dependent_destruction n
  | sumPostRel _ _ _ _ (inl1 _) (inl1 _) _ _ => simple apply IntroArg_sumPostRel_inl
  | sumPostRel _ _ _ _ (inl1 _) (ReSum_inl _ _ _ _ _ _ _) _ _ => apply IntroArg_sumPostRel_inl
  | sumPostRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (inl1 _) _ _ => apply IntroArg_sumPostRel_inl
  | sumPostRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (ReSum_inl _ _ _ _ _ _ _) _ _ => apply IntroArg_sumPostRel_inl
  | sumPostRel _ _ _ _ (inr1 _) (inr1 _) _ _ => simple apply IntroArg_sumPostRel_inr
  | sumPostRel _ _ _ _ (inr1 _) (ReSum_inr _ _ _ _ _ _ _) _ _ => apply IntroArg_sumPostRel_inr
  | sumPostRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (inr1 _) _ _ => apply IntroArg_sumPostRel_inr
  | sumPostRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (ReSum_inr _ _ _ _ _ _ _) _ _ => apply IntroArg_sumPostRel_inr
  | sumPostRel _ _ _ _ (inl1 _) (inr1 _) _ _ => IntroArg_intro_dependent_destruction n
  | sumPostRel _ _ _ _ (inl1 _) (ReSum_inr _ _ _ _ _ _ _) _ _ => IntroArg_intro_dependent_destruction n
  | sumPostRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (inr1 _) _ _ => IntroArg_intro_dependent_destruction n
  | sumPostRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (ReSum_inr _ _ _ _ _ _ _) _ _ => IntroArg_intro_dependent_destruction n
  | sumPostRel _ _ _ _ (inr1 _) (inl1 _) _ _ => IntroArg_intro_dependent_destruction n
  | sumPostRel _ _ _ _ (inr1 _) (ReSum_inl _ _ _ _ _ _ _) _ _ => IntroArg_intro_dependent_destruction n
  | sumPostRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (inl1 _) _ _ => IntroArg_intro_dependent_destruction n
  | sumPostRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (ReSum_inl _ _ _ _ _ _ _) _ _ => IntroArg_intro_dependent_destruction n
  | eqPostRel _ _ _ _ _ _ => apply IntroArg_eqPostRel
  | OnCallPreRel _ _ _ _ _ _ _ (Call _) (Call _) => simple apply IntroArg_OnCallPreRel_i
  | OnCallPostRel _ _ _ _ _ _ _ _ _ (Call _) (Call _) _ _ => simple apply IntroArg_OnCallPostRel_i
  | true  = true  => IntroArg_intro_dependent_destruction n
  | false = false => IntroArg_intro_dependent_destruction n
  | true  = false => IntroArg_intro_dependent_destruction n
  | false = true  => IntroArg_intro_dependent_destruction n
  end.

Hint Extern 101 (IntroArg ?n ?A ?g) => IntroArg_base_tac n A g : refines prepostcond.

Hint Extern 102 (IntroArg ?n (@eq bool _ _) _) =>
  let e := argName n in IntroArg_intro e; rewrite e in * : refines prepostcond.

Hint Extern 199 (IntroArg ?n (?x = ?y) _) =>
  let e := argName n in IntroArg_intro e;
    try first [ is_var x; subst x | is_var y; subst y ] : refines.

Hint Extern 999 (IntroArg ?n _ _) =>
  let e := argName n in IntroArg_intro e : refines prepostcond.

(** * Hints for Relation Goals *)

Lemma RelGoal_eta A (f : A -> Prop) x :
  RelGoal (f x) -> RelGoal ((fun x' => f x') x).
Proof. eauto. Qed.

Hint Extern 101 (RelGoal ((fun _ => _) _)) =>
  simple apply RelGoal_eta.

Lemma RelGoal_sumPreRel_inl E1 E2 F1 F2 (RPreE : PreRel E1 E2) (RPreF : PreRel F1 F2)
                           A B e1 e2 :
  RelGoal (RPreE A B e1 e2) ->
  RelGoal (@sumPreRel E1 E2 F1 F2 RPreE RPreF A B (inl1 e1) (inl1 e2)).
Proof. constructor; eauto. Qed.
Lemma RelGoal_sumPreRel_inr E1 E2 F1 F2 (RPreE : PreRel E1 E2) (RPreF : PreRel F1 F2)
                           A B f1 f2 :
  RelGoal (RPreF A B f1 f2) ->
  RelGoal (@sumPreRel E1 E2 F1 F2 RPreE RPreF A B (inr1 f1) (inr1 f2)).
Proof. constructor; eauto. Qed.

Hint Extern 101 (RelGoal (sumPreRel _ _ _ _ (inl1 _) (inl1 _))) =>
  simple apply RelGoal_sumPreRel_inl : refines.
Hint Extern 101 (RelGoal (sumPreRel _ _ _ _ (inl1 _) (ReSum_inl _ _ _ _ _ _ _))) =>
  apply RelGoal_sumPreRel_inl : refines.
Hint Extern 101 (RelGoal (sumPreRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (inl1 _))) =>
  apply RelGoal_sumPreRel_inl : refines.
Hint Extern 101 (RelGoal (sumPreRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (ReSum_inl _ _ _ _ _ _ _))) =>
  apply RelGoal_sumPreRel_inl : refines.
Hint Extern 101 (RelGoal (sumPreRel _ _ _ _ (inr1 _) (inr1 _))) =>
  simple apply RelGoal_sumPreRel_inr : refines.
Hint Extern 101 (RelGoal (sumPreRel _ _ _ _ (inr1 _) (ReSum_inr _ _ _ _ _ _ _))) =>
  apply RelGoal_sumPreRel_inr : refines.
Hint Extern 101 (RelGoal (sumPreRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (inr1 _))) =>
  apply RelGoal_sumPreRel_inr : refines.
Hint Extern 101 (RelGoal (sumPreRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (ReSum_inr _ _ _ _ _ _ _))) =>
  apply RelGoal_sumPreRel_inr : refines.

Lemma RelGoal_sumPostRel_inl E1 E2 F1 F2 (RPreE : PostRel E1 E2) (RPreF : PostRel F1 F2)
                              A B e1 e2 a b :
  RelGoal (RPreE A B e1 e2 a b) ->
  RelGoal (@sumPostRel E1 E2 F1 F2 RPreE RPreF A B (inl1 e1) (inl1 e2) a b).
Proof. constructor; eauto. Qed.
Lemma RelGoal_sumPostRel_inr E1 E2 F1 F2 (RPreE : PostRel E1 E2) (RPreF : PostRel F1 F2)
                              A B f1 f2 a b :
  RelGoal (RPreF A B f1 f2 a b) ->
  RelGoal (@sumPostRel E1 E2 F1 F2 RPreE RPreF A B (inr1 f1) (inr1 f2) a b).
Proof. constructor; eauto. Qed.

Hint Extern 101 (RelGoal (sumPostRel _ _ _ _ (inl1 _) (inl1 _) _ _)) =>
  simple apply RelGoal_sumPostRel_inl : refines.
Hint Extern 101 (RelGoal (sumPostRel _ _ _ _ (inl1 _) (ReSum_inl _ _ _ _ _ _ _) _ _)) =>
  apply RelGoal_sumPostRel_inl : refines.
Hint Extern 101 (RelGoal (sumPostRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (inl1 _) _ _)) =>
  apply RelGoal_sumPostRel_inl : refines.
Hint Extern 101 (RelGoal (sumPostRel _ _ _ _ (ReSum_inl _ _ _ _ _ _ _) (ReSum_inl _ _ _ _ _ _ _) _ _)) =>
  apply RelGoal_sumPostRel_inl : refines.
Hint Extern 101 (RelGoal (sumPostRel _ _ _ _ (inr1 _) (inr1 _) _ _)) =>
  simple apply RelGoal_sumPostRel_inr : refines.
Hint Extern 101 (RelGoal (sumPostRel _ _ _ _ (inr1 _) (ReSum_inr _ _ _ _ _ _ _) _ _)) =>
  apply RelGoal_sumPostRel_inr : refines.
Hint Extern 101 (RelGoal (sumPostRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (inr1 _) _ _)) =>
  apply RelGoal_sumPostRel_inr : refines.
Hint Extern 101 (RelGoal (sumPostRel _ _ _ _ (ReSum_inr _ _ _ _ _ _ _) (ReSum_inr _ _ _ _ _ _ _) _ _)) =>
  apply RelGoal_sumPostRel_inr : refines.

Lemma RelGoal_OnCallPreRel_i A1 A2 R1 R2
      (precond : A1 -> A2 -> Prop)  a1 a2 :
  RelGoal (precond a1 a2) ->
  RelGoal (OnCallPreRel A1 A2 R1 R2 precond R1 R2 (Call a1) (Call a2)).
Proof. constructor; eauto. Qed.

Hint Extern 101 (RelGoal (OnCallPreRel _ _ _ _ _ _ _ (Call _) (Call _))) =>
  simple apply RelGoal_OnCallPreRel_i : refines.

Lemma RelGoal_OnCallPostRel_i A1 A2 R1 R2
      (RR : R1 -> R2 -> Prop) (precond : A1 -> A2 -> Prop)
      (postcond : forall a1 a2, precond a1 a2 -> forall (r1 : R1) (r2 : R2), RR r1 r2 -> Prop)
      a1 a2 r1 r2 :
  forall (p0 : RelGoal (precond a1 a2)) (p1 : RelGoal (RR r1 r2)),
  RelGoal (postcond a1 a2 p0 r1 r2 p1) ->
  RelGoal (OnCallPostRel A1 A2 R1 R2 RR precond postcond R1 R2 (Call a1) (Call a2) r1 r2).
Proof. econstructor; econstructor; eauto. Qed.

Hint Extern 101 (RelGoal (OnCallPostRel _ _ _ _ _ _ _ _ _ (Call _) (Call _) _ _)) =>
  simple apply RelGoal_OnCallPostRel_i : refines.

Lemma RelGoal_depProdRel {R1 R2} (RR1 : R1 -> R2 -> Prop) (RR2 : forall r1 r2, RR1 r1 r2 -> Prop) r1 r2 :
  forall (p1 : RelGoal (RR1 r1 r2)), RelGoal (RR2 r1 r2 p1) ->
  RelGoal (@depProdRel R1 R2 RR1 RR2 r1 r2).
Proof. econstructor; eauto. Qed.

Hint Extern 101 (RelGoal (depProdRel _ _ _ _)) =>
  simple apply RelGoal_depProdRel : refines.

Lemma RelGoal_eqPreRel_refl {E A e} :
  RelGoal (@eqPreRel E A A e e).
Proof. constructor. Qed.

Hint Extern 101 (RelGoal (eqPreRel _ _ _ _)) =>
  apply RelGoal_eqPreRel_refl : refines.

(** * Basic Refinement Hints *)

Definition padded_refines_ret_IntroArg E1 E2 R1 R2 RPre RPost RR r1 r2 :
  (RelGoal (RR r1 r2 : Prop)) ->
  @padded_refines E1 E2 R1 R2 RPre RPost RR (Ret r1) (Ret r2) :=
  padded_refines_ret E1 E2 R1 R2 RPre RPost RR r1 r2.

Hint Extern 102 (padded_refines _ _ _ (Ret _) (Ret _)) =>
  apply padded_refines_ret_IntroArg : refines.

Definition padded_refines_vis_IntroArg E1 E2 R1 R2 A B
        RPre RPost RR (e1 : E1 A) (e2 : E2 B)
        (k1 : A -> itree_spec E1 R1) (k2 : B -> itree_spec E2 R2) :
  (RelGoal (RPre A B e1 e2 : Prop)) ->
  (IntroArg Any A (fun a => IntroArg Any B (fun b =>
     IntroArg Hyp (RPost A B e1 e2 a b : Prop) (fun _ =>
       padded_refines RPre RPost RR (k1 a) (k2 b))))) ->
  padded_refines RPre RPost RR (Vis (Spec_vis e1) k1) (Vis (Spec_vis e2) k2) :=
  padded_refines_vis E1 E2 R1 R2 A B RPre RPost RR e1 e2 k1 k2.

Hint Extern 102 (padded_refines _ _ _ (Vis (Spec_vis _) _) (Vis (Spec_vis _) _)) =>
  apply padded_refines_vis_IntroArg : refines.
Hint Extern 102 (padded_refines _ _ _ (vis (Spec_vis _) _) (Vis (Spec_vis _) _)) =>
  apply padded_refines_vis_IntroArg : refines.
Hint Extern 102 (padded_refines _ _ _ (Vis (Spec_vis _) _) (vis (Spec_vis _) _)) =>
  apply padded_refines_vis_IntroArg : refines.
Hint Extern 102 (padded_refines _ _ _ (vis (Spec_vis _) _) (vis (Spec_vis _) _)) =>
  apply padded_refines_vis_IntroArg : refines.
Hint Extern 103 (padded_refines _ _ _ (vis _ _) (vis _ _)) =>
  apply padded_refines_vis_IntroArg : refines.

Definition padded_refines_exists_l_IntroArg E1 E2 R1 R2 A
      RPre RPost RR (phi : itree_spec E2 R2) (kphi : A -> itree_spec E1 R1) :
  (IntroArg Exists A (fun a => padded_refines RPre RPost RR (kphi a) phi)) ->
  padded_refines RPre RPost RR (Vis Spec_exists kphi) phi :=
  padded_refines_exists_l E1 E2 R1 R2 A RPre RPost RR phi kphi.
Definition padded_refines_forall_r_IntroArg E1 E2 R1 R2 A
      RPre RPost RR (phi : itree_spec E1 R1) (kphi : A -> itree_spec E2 R2) :
  (IntroArg Forall A (fun a => padded_refines RPre RPost RR phi (kphi a))) ->
  padded_refines RPre RPost RR phi (Vis Spec_forall kphi) :=
  padded_refines_forall_r E1 E2 R1 R2 A RPre RPost RR phi kphi.

Hint Extern 101 (padded_refines _ _ _ _ (Vis Spec_forall _)) =>
  simple apply padded_refines_forall_r_IntroArg : refines.
Hint Extern 101 (padded_refines _ _ _ _ (vis Spec_forall _)) =>
  apply padded_refines_forall_r_IntroArg : refines.
Hint Extern 101 (padded_refines _ _ _ (Vis Spec_exists _) _) =>
  simple apply padded_refines_exists_l_IntroArg : refines.
Hint Extern 101 (padded_refines _ _ _ (vis Spec_exists _) _) =>
  apply padded_refines_exists_l_IntroArg : refines.

Hint Extern 102 (padded_refines _ _ _ _ (Vis Spec_exists _)) =>
  unshelve (simple eapply padded_refines_exists_r); [shelve|] : refines.
Hint Extern 102 (padded_refines _ _ _ _ (vis Spec_exists _)) =>
  unshelve (eapply padded_refines_exists_r); [shelve|] : refines.
Hint Extern 102 (padded_refines _ _ _ (Vis Spec_forall _) _) =>
  unshelve (simple eapply padded_refines_forall_l); [shelve|] : refines.
Hint Extern 102 (padded_refines _ _ _ (vis Spec_forall _) _) =>
  unshelve (eapply padded_refines_forall_l); [shelve|] : refines.

Definition padded_refines_if_r_IntroArg E1 E2 RPre RPost R1 R2 RR t1 t2 t3 b :
  (IntroArg If (b = true) (fun _ => padded_refines RPre RPost RR t1 t2)) ->
  (IntroArg If (b = false) (fun _ => padded_refines RPre RPost RR t1 t3)) ->
  padded_refines RPre RPost RR t1 (if b then t2 else t3) :=
  padded_refines_if_r E1 E2 RPre RPost R1 R2 RR t1 t2 t3 b.
Definition padded_refines_if_l_IntroArg E1 E2 RPre RPost R1 R2 RR t1 t2 t3 b :
  (IntroArg If (b = true) (fun _ => padded_refines RPre RPost RR t1 t3)) ->
  (IntroArg If (b = false) (fun _ => padded_refines RPre RPost RR t2 t3)) ->
  padded_refines RPre RPost RR (if b then t1 else t2) t3 :=
  padded_refines_if_l E1 E2 RPre RPost R1 R2 RR t1 t2 t3 b.

Hint Extern 101 (padded_refines _ _ _ _ (if _ then _ else _)) =>
  apply padded_refines_if_r_IntroArg : refines.
Hint Extern 101 (padded_refines _ _ _ (if _ then _ else _) _) =>
  apply padded_refines_if_l_IntroArg : refines.

Hint Extern 101 (padded_refines _ _ _ _ ((if _ then _ else _) >>= _)) =>
  apply padded_refines_if_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ ((if _ then _ else _) >>= _) _) =>
  apply padded_refines_if_bind_l : refines.

Definition padded_refines_match_list_r_IntroArg E1 E2 RPre RPost R1 R2 RR A (t1 : itree_spec E1 R1)
      (t2 : A -> list A -> itree_spec E2 R2) (t3 : itree_spec E2 R2) xs :
  (IntroArg Any A (fun x => IntroArg Any (list A) (fun xs' =>
   IntroArg Match (xs = x :: xs') (fun _ => padded_refines RPre RPost RR t1 (t2 x xs'))))) ->
  (IntroArg Match (xs = nil) (fun _ => padded_refines RPre RPost RR t1 t3)) ->
  padded_refines RPre RPost RR t1 (match xs with | x :: xs' => t2 x xs' | nil => t3 end) :=
  padded_refines_match_list_r E1 E2 RPre RPost R1 R2 RR A t1 t2 t3 xs.
Definition padded_refines_match_list_l_IntroArg E1 E2 RPre RPost R1 R2 RR A (t3 : itree_spec E2 R2)
      (t1 : A -> list A -> itree_spec E1 R1) (t2 : itree_spec E1 R1) xs :
  (IntroArg Any A (fun x => IntroArg Any (list A) (fun xs' =>
   IntroArg Match (xs = x :: xs') (fun _ => padded_refines RPre RPost RR (t1 x xs') t3)))) ->
  (IntroArg Match (xs = nil) (fun _ => padded_refines RPre RPost RR t2 t3)) ->
  padded_refines RPre RPost RR (match xs with | x :: xs' => t1 x xs' | nil => t2 end) t3 :=
  padded_refines_match_list_l E1 E2 RPre RPost R1 R2 RR A t3 t1 t2 xs.

Hint Extern 101 (padded_refines _ _ _ _ (match _ with | _ :: _ => _ | nil => _ end)) =>
  apply padded_refines_match_list_r_IntroArg : refines.
Hint Extern 101 (padded_refines _ _ _ (match _ with | _ :: _ => _ | nil => _ end) _) =>
  apply padded_refines_match_list_l_IntroArg : refines.

Hint Extern 101 (padded_refines _ _ _ _ ((match _ with | _ :: _ => _ | nil => _ end) >>= _)) =>
  apply padded_refines_match_list_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ ((match _ with | _ :: _ => _ | nil => _ end) >>= _) _) =>
  apply padded_refines_match_list_bind_l : refines.

Definition padded_refines_match_pair_r_IntroArg E1 E2 RPre RPost R1 R2 RR A B
      (t1 : itree_spec E1 R1) (t2 : A -> B -> itree_spec E2 R2) pr :
  (IntroArg Any A (fun x => IntroArg Any B (fun y =>
   IntroArg Match (pr = (x, y)) (fun _ => padded_refines RPre RPost RR t1 (t2 x y))))) ->
  padded_refines RPre RPost RR t1 (match pr with | (x,y) => t2 x y end) :=
  padded_refines_match_pair_r E1 E2 RPre RPost R1 R2 RR A B t1 t2 pr.
Definition padded_refines_match_pair_l_IntroArg E1 E2 RPre RPost R1 R2 RR A B
      (t1 : A -> B -> itree_spec E1 R1) (t2 : itree_spec E2 R2) pr :
  (IntroArg Any A (fun x => IntroArg Any B (fun y =>
   IntroArg Match (pr = (x, y)) (fun _ => padded_refines RPre RPost RR (t1 x y) t2)))) ->
  padded_refines RPre RPost RR (match pr with | (x,y) => t1 x y end) t2 :=
  padded_refines_match_pair_l E1 E2 RPre RPost R1 R2 RR A B t1 t2 pr.

Hint Extern 101 (padded_refines _ _ _ _ (match _ with | (_,_) => _ end)) =>
  apply padded_refines_match_pair_r_IntroArg : refines.
Hint Extern 101 (padded_refines _ _ _ (match _ with | (_,_) => _ end) _) =>
  apply padded_refines_match_pair_l_IntroArg : refines.

Hint Extern 101 (padded_refines _ _ _ _ ((match _ with | (_,_) => _ end) >>= _)) =>
  apply padded_refines_match_pair_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ ((match _ with | (_,_) => _ end) >>= _) _) =>
  apply padded_refines_match_pair_bind_l : refines.

Hint Extern 101 (padded_refines _ _ _ _ (Ret _ >>= _)) =>
  simple apply padded_refines_ret_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ (Ret _ >>= _) _) =>
  simple apply padded_refines_ret_bind_l : refines.

Hint Extern 101 (padded_refines _ _ _ _ (ITree.trigger _ >>= _)) =>
  simple apply padded_refines_trigger_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ (ITree.trigger _ >>= _) _) =>
  simple apply padded_refines_trigger_bind_l : refines.

Hint Extern 101 (padded_refines _ _ _ _ (Vis _ _ >>= _)) =>
  simple apply padded_refines_vis_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ _ (vis _ _ >>= _)) =>
  apply padded_refines_vis_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ (Vis _ _ >>= _) _) =>
  simple apply padded_refines_vis_bind_l : refines.
Hint Extern 101 (padded_refines _ _ _ (vis _ _ >>= _) _) =>
  apply padded_refines_vis_bind_l : refines.

Hint Extern 101 (padded_refines _ _ _ _ ((_ >>= _) >>= _)) =>
  simple apply padded_refines_bind_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ ((_ >>= _) >>= _) _) =>
  simple apply padded_refines_bind_bind_l : refines.

Definition padded_refines_trigger_r E1 E2 R1 R2 RPre RPost RR phi e :
  padded_refines RPre RPost RR phi (Vis e (fun x => Ret x)) ->
  @padded_refines E1 E2 R1 R2 RPre RPost RR phi (ITree.trigger e) :=
  fun r => r.
Definition padded_refines_trigger_l E1 E2 R1 R2 RPre RPost RR phi e :
  padded_refines RPre RPost RR (Vis e (fun x => Ret x)) phi ->
  @padded_refines E1 E2 R1 R2 RPre RPost RR (ITree.trigger e) phi :=
  fun r => r.

Hint Extern 101 (padded_refines _ _ _ _ (ITree.trigger _)) =>
  simple apply padded_refines_trigger_r : refines.
Hint Extern 101 (padded_refines _ _ _ (ITree.trigger _) _) =>
  simple apply padded_refines_trigger_l : refines.

(* assert_spec _ := trigger _ ;; _ *)
Hint Extern 101 (padded_refines _ _ _ _ (assert_spec _)) =>
  apply padded_refines_trigger_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ (assert_spec _) _) =>
  apply padded_refines_trigger_bind_l : refines.
Hint Extern 101 (padded_refines _ _ _ _ (assert_spec _ >>= _)) =>
  apply padded_refines_bind_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ (assert_spec _ >>= _) _) =>
  apply padded_refines_bind_bind_l : refines.

(* assume_spec _ := trigger _ ;; _ *)
Hint Extern 101 (padded_refines _ _ _ _ (assume_spec _)) =>
  apply padded_refines_trigger_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ (assume_spec _) _) =>
  apply padded_refines_trigger_bind_l : refines.
Hint Extern 101 (padded_refines _ _ _ _ (assume_spec _ >>= _)) =>
  apply padded_refines_bind_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ (assume_spec _ >>= _) _) =>
  apply padded_refines_bind_bind_l : refines.

(* exists_spec _ := trigger _ *)
Hint Extern 101 (padded_refines _ _ _ _ (exists_spec _)) =>
  apply padded_refines_trigger_r : refines.
Hint Extern 101 (padded_refines _ _ _ (exists_spec _) _) =>
  apply padded_refines_trigger_l : refines.
Hint Extern 101 (padded_refines _ _ _ _ (exists_spec _ >>= _)) =>
  apply padded_refines_trigger_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ (exists_spec _ >>= _) _) =>
  apply padded_refines_trigger_bind_l : refines.

(* forall_spec _ := trigger _ *)
Hint Extern 101 (padded_refines _ _ _ _ (forall_spec _)) =>
  apply padded_refines_trigger_r : refines.
Hint Extern 101 (padded_refines _ _ _ (forall_spec _) _) =>
  apply padded_refines_trigger_l : refines.
Hint Extern 101 (padded_refines _ _ _ _ (forall_spec _ >>= _)) =>
  apply padded_refines_trigger_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ (forall_spec _ >>= _) _) =>
  apply padded_refines_trigger_bind_l : refines.

(** * Refinement Hints About Recursion *)

Definition WellFounded {A1} (a a2 : A1) := Prop.
Definition Precondition {A1 A2} (a1 : A1) (a2 : A2) := Prop.
Definition Postcondition {A1 A2 R1 R2 precond RR} (a1 : A1) (a2 : A2) (H : precond a1 a2)
                         (r1 : R1) (r2 : R2) (H0 : (RR r1 r2 : Prop)) := Prop.
Definition Continue (precond : Prop) (goal : Type) := (precond * goal)%type.

Hint Opaque WellFounded : refines prepostcond.
Hint Opaque Precondition : refines prepostcond.
Hint Opaque Postcondition : refines prepostcond.
Hint Opaque well_founded : refines prepostcond.
Hint Opaque Continue : refines prepostcond.

Lemma Continue_unfold precond goal :
  RelGoal precond -> goal -> Continue precond goal.
Proof. split; eauto. Qed.

Hint Extern 999 (WellFounded _ _) => shelve : prepostcond.
Hint Extern 999 (Precondition _ _) => shelve : prepostcond.
Hint Extern 999 (Postcondition _ _ _ _ _ _) => shelve : prepostcond.
Hint Extern 999 (well_founded _) => shelve : refines.
Hint Extern 999 (Continue _ _) => shelve : refines.

Definition padded_refines_rec_IntroArg
           E1 E2 A1 A2 R1 R2 RPre RPost (RR : R1 -> R2 -> Prop) body1 body2 a1 a2
           (precond : IntroArg Any A1 (fun a1 => IntroArg Any A2 (fun a2 => Precondition a1 a2)))
           (postcond : IntroArg Any A1 (fun a1 => IntroArg Any A2 (fun a2 =>
                       IntroArg Hyp (precond a1 a2) (fun H =>
                       IntroArg RetAny R1 (fun r1 => IntroArg RetAny R2 (fun r2 =>
                       IntroArg Hyp (RR r1 r2) (fun H0 => Postcondition a1 a2 H r1 r2 H0))))))) :
  Continue (precond a1 a2)
           (IntroArg Any A1 (fun a1 => IntroArg Any A2 (fun a2 =>
            IntroArg Hyp (precond a1 a2) (fun p =>
            padded_refines (sumPreRel _ RPre)
                           (sumPostRel _ RPost)
                           (depProdRel RR (postcond a1 a2 p))
                           (body1 a1) (body2 a2))))) ->
  padded_refines RPre RPost RR (mrec_spec (calling' body1) (Call a1))
                             (mrec_spec (calling' body2) (Call a2)) := fun pr =>
  match pr with
  | (p, q) => padded_refines_rec E1 E2 A1 A2 R1 R2 RPre RPost RR precond postcond body1 body2 a1 a2 p q
  end.

Ltac padded_refines_rec := eapply padded_refines_rec_IntroArg.

Hint Extern 101 (padded_refines _ _ _ (mrec_spec (calling' _) (Call _))
                                      (mrec_spec (calling' _) (Call _))) =>
  padded_refines_rec : refines.
Hint Extern 101 (padded_refines _ _ _ (rec_spec _ _) (rec_spec _ _)) =>
  padded_refines_rec : refines.
Hint Extern 101 (padded_refines _ _ _ (rec_fix_spec _ _) (rec_fix_spec _ _)) =>
  padded_refines_rec : refines.

Definition padded_refines_total_spec_IntroArg
           E1 E2 A1 A2 R1 R2 RPre RPost (RR : R1 -> R2 -> Prop) body1 a1 a2 Pre Post
           (precond : IntroArg Any A1 (fun a1 => IntroArg Any A2 (fun a2 => Precondition a1 a2)))
           (postcond : IntroArg Any A1 (fun a1 => IntroArg Any A2 (fun a2 =>
                       IntroArg Hyp (precond a1 a2) (fun H =>
                       IntroArg RetAny R1 (fun r1 => IntroArg RetAny R2 (fun r2 =>
                       IntroArg Hyp (RR r1 r2) (fun H0 => Postcondition a1 a2 H r1 r2 H0)))))))
           (rdec : IntroArg Any A2 (fun a1 => IntroArg Any A2 (fun a2 => WellFounded a1 a2))) :
  well_founded rdec ->
  Continue (precond a1 a2)
           (IntroArg Any A1 (fun a1 => IntroArg Any A2 (fun a2 =>
            IntroArg Hyp (precond a1 a2) (fun p =>
            padded_refines (sumPreRel _ RPre)
                           (sumPostRel _ RPost)
                           (depProdRel RR (postcond a1 a2 p))
                           (body1 a1) (total_spec_fix_body _ _ _ Pre Post rdec a2))))) ->
  padded_refines RPre RPost RR (mrec_spec (calling' body1) (Call a1))
                             (total_spec Pre Post a2) := fun pf pr =>
  match pr with
  | (p, q) => padded_refines_total_spec E1 E2 A1 A2 R1 R2 RPre RPost RR precond postcond body1 Pre Post rdec a1 a2 pf p q
  end.

Ltac padded_refines_total_spec :=
  eapply padded_refines_total_spec_IntroArg;
  unfold total_spec_fix_body.

Hint Extern 101 (padded_refines _ _ _ (mrec_spec (calling' _) (Call _)) (total_spec _ _ _)) =>
  padded_refines_total_spec : refines.
Hint Extern 101 (padded_refines _ _ _ (rec_spec _ _) (total_spec _ _ _)) =>
  padded_refines_total_spec : refines.
Hint Extern 101 (padded_refines _ _ _ (rec_fix_spec _ _) (total_spec _ _ _)) =>
  padded_refines_total_spec : refines.

Hint Extern 101 (padded_refines _ _ _ (call_spec _) (call_spec _)) =>
  apply padded_refines_trigger_l, padded_refines_trigger_r : refines.
Hint Extern 101 (padded_refines _ _ _ _ (call_spec _ >>= _)) =>
  apply padded_refines_trigger_bind_r : refines.
Hint Extern 101 (padded_refines _ _ _ (call_spec _ >>= _) _) =>
  apply padded_refines_trigger_bind_l : refines.

Hint Extern 991 (padded_refines _ _ _ (Vis (Spec_vis (inl1 (Call _))) _) (trepeat _ _)) =>
  simple apply padded_refines_trepeat_suc_r : refines.
Hint Extern 991 (padded_refines _ _ _ (vis (Spec_vis (inl1 (Call _))) _) (trepeat _ _)) =>
  simple apply padded_refines_trepeat_suc_r : refines.
Hint Extern 991 (padded_refines _ _ _ (Vis (Spec_vis (inl1 (Call _))) _) (trepeat _ _ >>= _)) =>
  simple apply padded_refines_trepeat_bind_suc_r : refines.
Hint Extern 991 (padded_refines _ _ _ (vis (Spec_vis (inl1 (Call _))) _) (trepeat _ _ >>= _)) =>
  simple apply padded_refines_trepeat_bind_suc_r : refines.

Hint Extern 992 (padded_refines _ _ _ _ (trepeat _ _)) =>
  simple apply padded_refines_trepeat_zero_r : refines.
Hint Extern 992 (padded_refines _ _ _ _ (trepeat _ _ >>= _)) =>
  simple apply padded_refines_trepeat_bind_zero_r : refines.

Hint Extern 101 (padded_refines _ _ _ (total_spec _ _ _) _) =>
  unfold total_spec at 1 : refines.
Hint Extern 101 (padded_refines _ _ _ (total_spec _ _ _ >>= _) _) =>
  unfold total_spec at 1 : refines.

(** * Tactics *)

Ltac prove_refinement_eauto :=
  unshelve (typeclasses eauto with refines).

Ltac prove_refinement_prepostcond :=
  try (unshelve (typeclasses eauto with prepostcond)).

Ltac prove_refinement :=
  prove_refinement_eauto; prove_refinement_prepostcond.

Ltac prove_refinement_continue :=
  apply Continue_unfold; prove_refinement.

(** * Examples *)

Open Scope Z_scope.

Lemma test_ifs E x :
  @padded_refines E E _ _ eqPreRel eqPostRel eq
                  (if x >=? 0 then if x <? 256 then Ret 1 else Ret 0 else Ret 0)
                  (if x <? 256 then if x >=? 0 then Ret 1 else Ret 0 else Ret 0).
Proof.
  prove_refinement.
Qed.

Lemma test_spins E (x : Z) :
  @padded_refines E E Z Z eqPreRel eqPostRel eq
                  (rec_fix_spec (fun rec a => rec a) x)
                  (rec_fix_spec (fun rec a => rec a) x).
Proof.
  prove_refinement.
  - exact True.
  - exact True.
  - prove_refinement_continue.
Qed.

Lemma test_exists E (x : Z) :
  @padded_refines E E Z Z eqPreRel eqPostRel eq
                  (if x >=? 0 then Ret x else Ret (-1 * x))
                  (r <- exists_spec Z ;; Ret r).
Proof.
  prove_refinement.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Relations.Relation_Operators.
Require Import Shallow.Imp Shallow.ImpExt Shallow.lib.RTClosure.

Inductive com : Type :=
  | CSkip
  | CAss (X: var) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CFor (c1 (* body *) c2 (* incr *) : com)
  | CBreak
  | CCont
  | CFor1 (c0 (* head *) c1 c2 : com)
  | CFor2 (c0 (* head *) c1 c2 : com)
.

Inductive exit_kind: Type :=
  | EK_Normal
  | EK_Break
  | EK_Cont.

Definition skip_sem: state -> exit_kind -> state -> Prop :=
  fun st1 ek st2 =>
    st1 = st2 /\ ek = EK_Normal.

Definition asgn_sem (X: var) (E: aexp): state -> exit_kind -> state -> Prop :=
  fun st1 ek st2 =>
    st2 X = aeval E st1 /\
    (forall Y, X <> Y -> st1 Y = st2 Y) /\
    ek = EK_Normal.

Definition break_sem: state -> exit_kind -> state -> Prop :=
  fun st1 ek st2 =>
    st1 = st2 /\ ek = EK_Break.

Definition cont_sem: state -> exit_kind -> state -> Prop :=
  fun st1 ek st2 =>
    st1 = st2 /\ ek = EK_Cont.

Definition seq_sem (d1 d2: state -> exit_kind -> state -> Prop):
  state -> exit_kind -> state -> Prop:=
  fun st1 ek st3 =>
    (exists st2, d1 st1 EK_Normal st2 /\ d2 st2 ek st3) \/
    (d1 st1 ek st3 /\ ek <> EK_Normal).

Definition test_sem (X: state -> Prop): state -> exit_kind -> state -> Prop :=
  fun st1 ek st2 =>
    st1 = st2 /\ X st1 /\ ek = EK_Normal.

Definition union_sem (d d': state -> exit_kind -> state -> Prop) :
  state -> exit_kind -> state -> Prop :=
  fun st1 ek st2 =>
    d st1 ek st2 \/ d' st1 ek st2.

Definition if_sem (b: bexp) (d1 d2: state -> exit_kind -> state -> Prop):
  state -> exit_kind -> state -> Prop :=
  union_sem
    (seq_sem (test_sem (beval b)) d1)
    (seq_sem (test_sem (beval (! b))) d2).

Inductive iter_loop_body:
  (state -> exit_kind -> state -> Prop) ->
  (state -> exit_kind -> state -> Prop) ->
  nat -> state -> state -> Prop :=
  | ILB_0: forall d1 d2 st1 st2,
      (d1 st1 EK_Break st2) \/
      (exists st3, d1 st1 EK_Normal st3 /\ d2 st3 EK_Break st2) ->
      iter_loop_body d1 d2 0 st1 st2
  | ILB_n: forall d1 d2 n st1 st2 st3 n',
      n = S n' ->
      ((seq_sem d1 d2 st1 EK_Normal st3) \/
      (seq_sem d1 d2 st1 EK_Cont st3)) ->
      iter_loop_body d1 d2 n' st3 st2 ->
      iter_loop_body d1 d2 n st1 st2.

Definition for_sem (d1 d2: state -> exit_kind -> state -> Prop):
  state -> exit_kind -> state -> Prop :=
  fun st1 ek st2 =>
    ek = EK_Normal /\
    exists n, iter_loop_body d1 d2 n st1 st2.

Fixpoint ceval (c: com): state -> exit_kind -> state -> Prop :=
  match c with
  | CSkip => skip_sem
  | CAss X E => asgn_sem X E
  | CSeq c1 c2 => seq_sem (ceval c1) (ceval c2)
  | CIf b c1 c2 => if_sem b (ceval c1) (ceval c2)
  | CFor c1 c2 => for_sem (ceval c1) (ceval c2)
  | CBreak => break_sem
  | CCont => cont_sem
  | _ => fun _ _ _ => False
  end.

Inductive KElements: Type :=
  | KSeq (c : com)
  | KLoop1 (c1 : com) (c2 : com)
  | KLoop2 (c1 : com) (c2 : com).

Definition continuation: Type := list KElements.

Lemma nil_app_neq {A : Type} : forall (a : A) l1 l2,
  nil = l1 ++ a :: l2 -> False.
Proof.
  intros.
  pose proof eq_refl (List.length (@nil A)).
  rewrite H in H0 at 1.
  rewrite List.app_length in H0.
  simpl in H0. lia.
Qed.

(* Inductive continuation': Type :=
  | Empty_Continuation
  | KSeq' (c : com) (k0 : continuation')
  | KLoop1' (c1 : com) (c2 : com) (k0 : continuation')
  | KLoop2' (c1 : com) (c2 : com) (k0 : continuation')
. *)

(* Inductive start_with_break: com -> Prop :=
  | SWB_Break: start_with_break CBreak
  | SWB_Seq: forall c1 c2,
      start_with_break c1 ->
      start_with_break (CSeq c1 c2).

Inductive start_with_cont: com -> Prop :=
  | SWC_Cont: start_with_cont CCont
  | SWC_Seq: forall c1 c2,
      start_with_cont c1 ->
      start_with_cont (CSeq c1 c2).

Inductive start_with_loop: com -> Prop :=
  | SWL_For : forall c1 c2, start_with_loop (CFor c1 c2)
  | SWL_Seq : forall c1 c2,
      start_with_loop c1 ->
      start_with_loop (CSeq c1 c2). *)

Inductive cstep: (com * continuation * state) -> (com * continuation * state) -> Prop :=
  | CS_AssStep : forall st X a a' k,
      astep st a a' ->
      cstep (CAss X a, k, st) (CAss X a', k, st)
  | CS_Ass : forall st1 st2 X n k,
      st2 X = n ->
      (forall Y, Y <> X -> st1 Y = st2 Y) ->
      cstep (CAss X (ANum n), k, st1) (CSkip, k, st2)

  | CS_Seq : forall st c1 c2 k,
      cstep (CSeq c1 c2, k, st) (c1, KSeq c2 :: k, st)
  | CS_SeqSkip : forall c k st,
      cstep (CSkip, (KSeq c) :: k, st) (c, k, st)
  | CS_SeqCont : forall c k st,
      cstep (CCont, (KSeq c) :: k, st) (CCont, k, st)
  | CS_SeqBreak : forall c k st,
      cstep (CBreak, (KSeq c) :: k, st) (CBreak, k, st)

  | CS_IfStep: forall st b b' c1 c2 k,
      bstep st b b' ->
      cstep (CIf b c1 c2, k, st) (CIf b' c1 c2, k, st)
  | CS_IfTrue: forall c1 c2 k st,
      cstep (CIf BTrue c1 c2, k, st) (c1, k, st)
  | CS_IfFalse: forall c1 c2 k st,
      cstep (CIf BFalse c1 c2, k, st) (c2, k, st)

  | CS_For: forall c1 c2 k st,
      cstep (CFor c1 c2, k, st)
            (CSeq c1 CCont, (KLoop1 c1 c2) :: k, st)
  | CS_ForSkip : forall c1 c2 k st,
      cstep (CSkip, (KLoop2 c1 c2) :: k, st)
            (CSeq c1 CCont, (KLoop1 c1 c2) :: k, st)
  | CS_ForCont : forall c1 c2 k st,
      cstep (CCont, (KLoop1 c1 c2) :: k, st)
            (c2, (KLoop2 c1 c2) :: k, st)
  | CS_ForBreak1 : forall c1 c2 k st,
      cstep (CBreak, (KLoop1 c1 c2) :: k, st)
            (CSkip, k, st)
  | CS_ForBreak2 : forall c1 c2 k st,
      cstep (CBreak, (KLoop2 c1 c2) :: k, st)
            (CSkip, k, st)

  | CS_For1 : forall c0 c1 c2 k st,
      cstep (CFor1 c0 c1 c2, k, st)
            (c0, KLoop1 c1 c2 :: k, st)
  | CS_For2 : forall c0 c1 c2 k st,
      cstep (CFor2 c0 c1 c2, k, st)
            (c0, KLoop2 c1 c2 :: k, st)
.

Lemma cstep_ctx_step: forall c k st c' k' st' k'',
  cstep (c, k, st) (c', k', st') ->
  cstep (c, k ++ k'', st) (c', k' ++ k'', st').
Proof.
  inversion 1; subst; constructor; auto.
Qed.

Inductive irreducible : com -> continuation -> state -> Prop :=
| IR_ForSkip : forall c1 c2 k st,
    irreducible CSkip (KLoop1 c1 c2 :: k) st
| IR_ForCont : forall c1 c2 k st,
    irreducible CCont (KLoop2 c1 c2 :: k) st
.

Definition NHalt c k : Prop := c = CSkip /\ k = @nil KElements.

Definition BHalt c k : Prop := c = CBreak /\ k = @nil KElements.

Definition CHalt c k : Prop := c = CCont /\ k = @nil KElements.

Definition Halt c k : Prop := NHalt c k \/ BHalt c k \/ CHalt c k.

Ltac auto_halt :=
  match goal with | |- Halt ?c _ =>
    unfold Halt; unfold NHalt; unfold BHalt; unfold CHalt;
    match c with
    | CSkip => left; auto
    | CBreak => right; left; auto
    | CCont => right; right; auto
    | _ => idtac
    end
  end
.

Lemma fill_cstep_inv: forall c c' k k0 k'' st st',
  ~ Halt c k -> cstep (c, k ++ k0, st) (c', k'', st') ->
  exists k', k'' = k' ++ k0 /\ cstep (c, k, st) (c', k', st').
Proof.
  intros.
  revert k'' H0.
  induction k; intros; simpl in *.
  - inversion H0; subst;
    match goal with
    | H: ~ Halt ?c _ |- _ =>
      match c with
      | CSkip => exfalso; apply H; auto_halt
      | CBreak => exfalso; apply H; auto_halt
      | CCont => exfalso; apply H; auto_halt
      | _ => idtac
      end
    | _ => idtac
    end.
    + exists nil; split; auto; constructor; auto.
    + exists nil; split; auto; constructor; auto.
    + exists (KSeq c2 :: nil); split; auto; constructor; auto.
    + exists nil; split; auto; constructor; auto.
    + exists nil; split; auto; constructor; auto.
    + exists nil; split; auto; constructor; auto.
    + exists (KLoop1 c1 c2 :: nil); split; auto; constructor; auto.
    + exists (KLoop1 c1 c2 :: nil); split; auto; constructor; auto.
    + exists (KLoop2 c1 c2 :: nil); split; auto; constructor; auto.
  - inversion H0; subst;
    match goal with
    | H0: cstep (_, ?a :: ?k ++ _, _) (_, ?a :: ?k ++ _, _) |- _ =>
        exists (a :: k); split; auto; constructor; auto
    | _ => idtac
    end.
    + exists (KSeq c2 :: a :: k); split; auto; constructor.
    + exists k; split; auto; constructor.
    + exists k; split; auto; constructor.
    + exists k; split; auto; constructor.
    + exists (KLoop1 c1 c2 :: a :: k); split; auto; constructor.
    + exists (KLoop1 c1 c2 :: k); split; auto; constructor.
    + exists (KLoop2 c1 c' :: k); split; auto; constructor.
    + exists k; split; auto; constructor.
    + exists k; split; auto; constructor.
    + exists (KLoop1 c1 c2 :: a :: k); split; auto; constructor.
    + exists (KLoop2 c1 c2 :: a :: k); split; auto; constructor.
Qed.

Definition reducible c k st : Prop := (exists c' k' st', cstep (c, k, st) (c', k', st')).

Lemma reducible_ctx_step : forall c k k' st,
  reducible c k st -> reducible c (k ++ k') st.
Proof.
  intros.
  destruct H as (c1 & k1 & st1 & ?).
  exists c1, (k1 ++ k'), st1.
  apply cstep_ctx_step; auto.
Qed.

(* Definition Error c k st : Prop := ~ Halt c k /\ irreducible c k st. *)

Definition mstep : (com * continuation * state) -> (com * continuation * state) -> Prop := clos_refl_trans cstep.

Import Assertion_D.

Lemma halt_choice : forall c k st,
  Halt c k \/ reducible c k st \/ irreducible c k st.
Proof.
  intros.
  destruct c.
  - destruct k as [| c' k]; [left; auto_halt |].
    right; destruct c'.
    + left. exists c, k, st. constructor.
    + right. constructor.
    + left. exists (CSeq c1 CCont), ((KLoop1 c1 c2) :: k), st. constructor.
  - right. left.
    pose proof aexp_halt_choice a st.
    destruct H.
    + inversion H; subst.
      exists CSkip, k, (state_update st X n).
      pose proof state_update_spec st X n as [? ?].
      constructor; auto.
    + destruct H. exists (CAss X x), k, st. constructor; auto.
  - right; left.
    exists c1, (KSeq c2 :: k), st.
    constructor.
  - right; left.
    pose proof bexp_halt_choice b st.
    destruct H.
    + inversion H; subst;
      [
        exists c1, k, st |
        exists c2, k, st
      ]; constructor.
    + destruct H. exists (CIf x c1 c2), k, st; constructor; auto.
  - right; left.
    exists (CSeq c1 CCont), ((KLoop1 c1 c2) :: k), st.
    constructor.
  - destruct k as [| c' k]; [left; auto_halt |].
    right; destruct c'.
    + left. exists CBreak, k, st. constructor.
    + left. exists CSkip, k, st. constructor.
    + left. exists CSkip, k, st. constructor.
  - destruct k as [| c' k]; [left; auto_halt |].
    right; destruct c'.
    + left. exists CCont, k, st. constructor.
    + left. exists c2, ((KLoop2 c1 c2) :: k), st. constructor.
    + right; constructor.
  - right; left.
    exists c1, (KLoop1 c2 c3 :: k), st; constructor.
  - right; left.
    exists c1, (KLoop2 c2 c3 :: k), st; constructor.
Qed.

Lemma halt_reducible_ex : forall c k st,
  Halt c k -> reducible c k st -> False.
Proof.
  intros.
  destruct H as [? | [? | ?]]; inversion H; subst;
  destruct H0 as (? & ? & ? & ?); inversion H0.
Qed.

Lemma halt_irreducible_ex : forall c k st,
  Halt c k -> irreducible c k st -> False.
Proof.
  intros.
  destruct H as [? | [? | ?]]; inversion H; subst;
  inversion H0.
Qed.

Lemma reducible_irreducible_ex : forall c k st,
  reducible c k st -> irreducible c k st -> False.
Proof.
  intros.
  destruct H0;
  destruct H as (? & ? & ? & ?); inversion H.
Qed.

Ltac solve_wp_0 :=
  match goal with
  | |- ~ Halt ?c ?k => unfold not; intros;
    match goal with
    | _: reducible c k ?st |- _ =>
      apply (halt_reducible_ex c k st); auto
    | _: irreducible c k ?st |- _ =>
      apply (halt_irreducible_ex c k st); auto
    end
  end.

Lemma halt_em: forall c k (st : state),
  Halt c k \/ ~ Halt c k.
Proof.
  intros.
  pose proof halt_choice c k st as [? | [? | ?]].
  - left; auto.
  - right; solve_wp_0.
  - right; solve_wp_0.
Qed.

Lemma determinism : forall c st1 st2 st3 ek1 ek2,
  ceval c st1 ek1 st2 ->
  ceval c st1 ek2 st3 ->
  (ek1 = ek2 /\ st2 = st3).
Abort.

(* Ltac induction_cstep H :=
  match type of H with
  | ?cstep ?a ?b =>
    revert_dependent_component a H;
    revert_dependent_component b H;
    let a0 := fresh "cst" in
    let b0 := fresh "cst" in
    let EQa := fresh "EQ" in
    let EQb := fresh "EQ" in
    remember a as a0 eqn:EQa in H;
    remember b as b0 eqn:EQb in H;
    revert EQa EQb;
    revert_component a;
    revert_component b;
    match goal with
    | |- ?Q =>
      let Pab := eval pattern a0, b0 in Q in
      match Pab with
      | ?P a0 b0 =>
        change (P a0 b0); induction H
      end
    end;
    intros ? ? ? ?;
    match goal with
    | IH: forall _ _ _ _, _ = _ -> _ = _ -> _ |- _ =>
      specialize_until_EQ IH;
      specialize (IH eq_refl)
    | _ => idtac
    end;
    intros_until_EQ EQa; intros EQb;
        match goal with
          | |- ?Base =>
            let Base0 := fresh in
            remember Base as Base0 in |- *;
            first [ injection EQa; clear EQa; intros_and_subst Base0
                  | revert EQa; intros_and_subst Base0
                  | idtac ];
            subst Base0
          end;
          match goal with
          | |- ?Base =>
            let Base0 := fresh in
            remember Base as Base0 in |- *;
            first [ injection EQb; clear EQb; intros_and_subst Base0
                  | revert EQb; intros_and_subst Base0
                  | idtac ];
            subst Base0
          end
  end. *)

(* 2021-05-08 18:58 *)


Set Implicit Arguments.
Require Import List Arith Lia Morphisms FinFun.
Import ListNotations.
From Undecidability.HOU Require Import std.std.
From Undecidability.HOU.calculus Require Import
  prelim terms syntax semantics equivalence typing order confluence.

Set Default Proof Using "Type".

(* * Terms Extension *)

Notation "sigma •₊ A" := (map (subst_exp sigma) A) (at level 69).
Notation renL delta A := (map (ren delta) A).
Notation Vars := (flat_map vars).

Lemma tab_subst {X} sigma (f: nat -> exp X) n:
  sigma •₊ tab f n = tab (f >> subst_exp sigma) n.
Proof.
  induction n; cbn; simplify; cbn; rewrite ?IHn; reflexivity.
Qed.

Section TermsExtension.

  Context {X: Const}.
  Implicit Types (s t: exp X) (n m: nat) (Gamma Delta: ctx) (A B: type)
           (sigma tau: fin -> exp X) (delta xi: fin -> fin)
           (S T: list (exp X)) (L: list type).

  (* ** Typing *)
  Reserved Notation "Gamma ⊢₊ A : L" (at level 80, A at level 99).

  Inductive listtyping Gamma : list (exp X) -> list type -> Prop :=
  | listtyping_nil: Gamma ⊢₊ nil : nil
  | listtyping_cons s S A L:
      Gamma ⊢ s : A -> Gamma ⊢₊ S : L -> Gamma ⊢₊ s :: S : A :: L
  where "Gamma ⊢₊ A : L" := (listtyping Gamma A L).

  Hint Constructors listtyping : core.

  Reserved Notation "Gamma ⊢₊( n ) A : L" (at level 80, A at level 99).

  Inductive orderlisttyping n Gamma: list (exp X) -> list type -> Prop :=
  | orderlisttyping_nil: Gamma ⊢₊(n) nil : nil
  | orderlisttyping_cons s S A L:
      Gamma ⊢(n) s : A -> Gamma ⊢₊(n) S : L -> Gamma ⊢₊(n) s :: S : A :: L
  where "Gamma ⊢₊( n ) A : L" := (orderlisttyping n Gamma A L).

  Hint Constructors orderlisttyping : core.

  Section ListTypingProperties.
    Lemma listtyping_app Gamma S1 S2 L1 L2:
      Gamma ⊢₊ S1 : L1 -> Gamma ⊢₊ S2 : L2 -> Gamma ⊢₊ S1 ++ S2 : L1 ++ L2.
    Proof.
      induction 1; cbn; (eauto 3).
    Qed.

    Lemma orderlisttyping_app n Gamma S1 S2 L1 L2:
      Gamma ⊢₊(n) S1 : L1 -> Gamma ⊢₊(n) S2 : L2 -> Gamma ⊢₊(n) S1 ++ S2 : L1 ++ L2.
    Proof.
      induction 1; cbn; (eauto 3).
    Qed.

    Lemma Vars_listtyping x Gamma S L:
      Gamma ⊢₊ S : L -> x ∈ Vars S -> x ∈ dom Gamma.
    Proof.
      induction 1; cbn; simplify; intuition eauto using typing_variables.
    Qed.

    Lemma Vars_listordertyping x n Gamma S L:
      Gamma ⊢₊(n) S : L -> x ∈ Vars S -> exists A, nth Gamma x = Some A /\ ord A <= n.
    Proof.
      induction 1; cbn; simplify; intuition eauto using vars_ordertyping.
    Qed.

    Lemma repeated_typing Gamma S A:
      (forall s, s ∈ S -> Gamma ⊢ s : A) ->
      forall n, n = length S -> Gamma ⊢₊ S : repeat A n.
    Proof.
      induction S; cbn; intros; subst; cbn;eauto.
      intuition.
    Qed.

    Lemma repeated_ordertyping n Gamma S A:
      (forall s, s ∈ S -> Gamma ⊢(n) s : A) ->
      forall m, m = length S -> Gamma ⊢₊(n) S : repeat A m.
    Proof.
      induction S; cbn; intros; subst; cbn; (eauto 2).
      intuition.
    Qed.

    Lemma map_var_typing n Gamma N L:
      N ⊆ dom Gamma -> select N Gamma = L ->
      ord' L <= n -> Gamma ⊢₊(n) map var N : L.
    Proof.
      induction N in L |-*; cbn; intuition.
      - destruct L; try discriminate; intuition.
      - specialize (H a) as H'; mp H'; intuition; domin H'.
        rewrite H' in H0. subst. econstructor.
        all: cbn in H1; simplify in H1; intuition.
        eapply IHN; (eauto 1); lauto.
    Qed.

    Lemma var_typing n Gamma:
      ord' Gamma <= n -> Gamma ⊩(n) @var X : Gamma.
    Proof.
      intros ????; econstructor; (eauto 1);
        eapply ord'_elements; eauto using nth_error_In.
    Qed.

    Lemma const_ordertyping_list Gamma n Cs:
      ord' (map (ctype X) Cs) <= S n ->
      Gamma ⊢₊(n) map const Cs : map (ctype X) Cs.
    Proof.
      induction Cs; cbn; (eauto 2).
      intros H; simplify in H; intuition; econstructor; (eauto 2).
    Qed.

    Lemma listtyping_preservation_under_renaming delta Gamma Delta S L:
      Gamma ⊢₊ S : L -> Delta ⊫ delta : Gamma -> Delta ⊢₊ renL delta S : L.
    Proof.
      intros H1 H2; induction H1; cbn; (eauto 3).
    Qed.

    Lemma orderlisttyping_preservation_under_renaming n delta Gamma Delta S L:
      Gamma ⊢₊(n) S : L -> Delta ⊫ delta : Gamma -> Delta ⊢₊(n) renL delta S : L.
    Proof.
      intros H1 H2; induction H1; cbn; (eauto 3).
    Qed.

    Lemma orderlisttyping_preservation_under_substitution Gamma n S L Delta sigma:
      Gamma ⊢₊(n) S : L -> Delta ⊩(n) sigma : Gamma -> Delta ⊢₊(n) sigma •₊ S : L.
    Proof.
      induction 1; cbn; (eauto 4).
    Qed.

    Lemma orderlisttyping_element Gamma n S L:
      Gamma ⊢₊(n) S : L -> forall s, s ∈ S -> exists A, Gamma ⊢(n) s : A /\ A ∈ L.
    Proof.
      induction 1; cbn; intros; intuition; subst.
      eexists; intuition; (eauto 2).
      edestruct IHorderlisttyping; (eauto 1); intuition;
        eexists; split; (eauto 2).
    Qed.

  End ListTypingProperties.

  (* ** Semantics *)
  Notation "S >₊ T" := (lstep step S T) (at level 60).
  Notation "S >₊* T" := (star (lstep step) S T) (at level 60).
  Notation "S ≡₊ T" := (equiv (lstep step) S T) (at level 60).

  Section ListSemanticProperties.
    Lemma list_equiv_ren delta S T:
      S ≡₊ T -> renL delta S ≡₊ renL delta T.
    Proof.
      intros; pattern S, T; eapply list_equiv_ind; (eauto 2).
      intros s t S' T' H1 H2 IH; cbn; now rewrite H1, IH.
    Qed.

    Lemma list_equiv_subst sigma S T:
      S ≡₊ T -> (sigma •₊ S) ≡₊ (sigma •₊ T).
    Proof.
      intros; pattern S, T; eapply list_equiv_ind; (eauto 2).
      intros s t S' T' H1 H2 IH; cbn; now rewrite H1, IH.
    Qed.

    Lemma list_equiv_anti_ren delta (S T: list (exp X)):
      Injective delta -> renL delta S ≡₊ renL delta T -> S ≡₊ T.
    Proof.
      intros In. remember (renL delta S) as S'. remember (renL delta T) as T'.
      intros H; revert S T HeqS' HeqT'; pattern S', T'.
      eapply list_equiv_ind; (eauto 2).
      all: intros.
      - destruct S, T; try discriminate. reflexivity.
      - destruct S0, T0; try discriminate.
        injection HeqS' as ??; injection HeqT' as ??; subst.
        eapply equiv_lstep_cons_proper; (eauto 2).
        eapply equiv_anti_ren; (eauto 2).
    Qed.

    Global Instance list_ren_proper delta:
      Proper (equiv (lstep step) ++> equiv (lstep (@step X))) (map (ren delta)).
    Proof.
      intros ??; now eapply list_equiv_ren.
    Qed.

    Global Instance list_subst_proper sigma:
      Proper (equiv (lstep step) ++> equiv (lstep (@step X))) (map (subst_exp sigma)).
    Proof.
      intros ??; now eapply list_equiv_subst.
    Qed.

  End ListSemanticProperties.

  (* ** Big Arrow *)
  Section ArrowProperties.

    Fixpoint Arr (B: list type) (A: type) :=
      match B with
      | nil => A
      | A' :: B => A' → (Arr B A)
      end.

    Lemma Arr_app L1 L2 A:
      Arr (L1 ++ L2) A = Arr L1 (Arr L2 A).
    Proof.
      induction L1; cbn; congruence.
    Qed.

    Lemma arity_Arr L A: arity (Arr L A) = length L + arity A.
    Proof. induction L; cbn; congruence. Qed.

    Lemma Arr_inversion L1 L2 A1 A2:
      length L1 <= length L2 ->
      Arr L1 A1 = Arr L2 A2 -> exists L, L2 = L1 ++ L  /\ A1 = Arr L A2.
    Proof.
      induction L1 in L2, A1, A2 |-*; cbn.
      - intros _. exists L2. intuition.
      - destruct L2. inversion 1.
        intros H H1. cbn in H. eapply le_S_n in H.
        injection H1 as ??. subst. edestruct IHL1; (eauto 2).
        intuition. exists x; intuition. f_equal; (eauto 2).
    Qed.

    Lemma type_decompose:
      forall A, exists L beta, A = Arr L (typevar beta).
    Proof.
      induction A; cbn.
      - exists nil; exists n. reflexivity.
      - destruct IHA2 as (L & beta & H). subst.
        exists (A1 :: L); exists beta. reflexivity.
    Qed.

    Lemma target_ord A: ord (target A) = 1.
    Proof.
      induction A; cbn; congruence.
    Qed.

    Lemma arity_decomposed L beta:
      arity (Arr L (typevar beta)) = length L.
    Proof.
      induction L; cbn; congruence.
    Qed.

    Lemma Arr_left_injective L1 L2 A:
      Arr L1 A = Arr L2 A -> L1 = L2.
    Proof.
      destruct (le_ge_dec (length L1) (length L2)); intros H; [|symmetry in H].
      all: eapply Arr_inversion in H as [L3]; (eauto 1); intuition.
      all: destruct L3; simplify in *; (eauto 2).
      all: eapply (f_equal arity) in H1; cbn in H1; rewrite arity_Arr in H1.
      all: lia.
    Qed.

    Lemma ord_Arr L A: ord (Arr L A) = max (1 + ord' L) (ord A).
    Proof.
      induction L; cbn -[max].
      symmetry; eapply Nat.max_r. eapply ord_1.
      rewrite IHL, Nat.max_assoc.
      cbn [plus]. reflexivity.
    Qed.

    Lemma target_Arr L A: target (Arr L A) = target A.
    Proof.
      induction L; cbn; congruence.
    Qed.

    Lemma ord_repeated n A: ord' (repeat A n) <= ord A.
    Proof.
      induction n; cbn; (eauto 2).
      lia.
    Qed.

  End ArrowProperties.

  Hint Rewrite ord'_app ord_Arr ord_repeated : simplify.

  Hint Rewrite ord_Arr target_Arr target_ord : simplify.

  (* ** List Abstraction and Application *)

  Fixpoint Lambda (n: nat) (s: exp X) :=
    match n with
    | 0 => s
    | S n => lambda (Lambda n s)
    end.

  Fixpoint AppR (e: exp X) (A: list (exp X))  :=
    match A with
    | nil => e
    | e' :: A => AppR e A e'
    end.

  Fixpoint AppL (A: list (exp X)) (e: exp X) :=
    match A with
    | nil => e
    | e' :: A => e' (AppL A e)
    end.

  Lemma Lambda_plus (n m: nat) s:
    Lambda n (Lambda m s) = Lambda (n + m) s.
  Proof.
    induction n; cbn; congruence.
  Qed.

  Lemma Lambda_injective n (s t: exp X):
    Lambda n s = Lambda n t -> s = t.
  Proof.
    induction n; cbn; intuition; eapply IHn; congruence.
  Qed.

  Lemma AppL_app S1 S2 t:
    AppL (S1 ++ S2) t = AppL S1 (AppL S2 t).
  Proof.
    revert S2 t; induction S1; cbn; congruence.
  Qed.

  Lemma AppR_app T1 T2 s:
    AppR s (T1 ++ T2) = AppR (AppR s T2) T1.
  Proof.
    revert T2 s; induction T1; cbn; congruence.
  Qed.

  Lemma AppR_vars s T:
    vars (AppR s T) === vars s ++ Vars T.
  Proof.
    induction T; cbn; simplify; lauto.
    rewrite IHT, <-app_assoc; eapply proper_app_seteq; lauto.
    eauto using app_comm.
  Qed.

  Lemma AppR_head s T: head (AppR s T) = head s.
  Proof.
    induction T in s |-*; cbn ; (eauto 1); now rewrite IHA.
  Qed.

  Hint Rewrite AppR_head : simplify.

  (* ** Substitutions and Renaming *)
  Section ListOperatorsSubstitutionRenaming.

    Lemma Lambda_ren delta n s:
      ren delta (Lambda n s) = Lambda n (ren (it n up_ren delta) s).
    Proof.
      induction n in delta |-*; cbn; (eauto 2).
      rewrite IHn. do 3 f_equal.
      symmetry. eapply it_commute.
    Qed.

    Lemma Lambda_subst sigma n s:
      sigma • (Lambda n s) = Lambda n (it n up sigma • s).
    Proof.
      induction n in sigma |-*; cbn; (eauto 2).
      rewrite IHn; do 3 f_equal.
      symmetry. eapply it_commute.
    Qed.

    Lemma AppL_ren delta S t:
      ren delta (AppL S t) = AppL (renL delta S) (ren delta t).
    Proof.
      induction S; cbn; congruence.
    Qed.

    Lemma AppL_subst sigma S t:
      sigma • AppL S t = AppL (sigma •₊ S) (sigma • t).
    Proof.
      induction S; cbn; congruence.
    Qed.

    Lemma AppR_ren delta s T:
      ren delta (AppR s T) = AppR (ren delta s) (renL delta T) .
    Proof.
      induction T; cbn; congruence.
    Qed.

    Lemma AppR_subst sigma s T:
      sigma • AppR s T = AppR (sigma • s) (sigma •₊ T).
    Proof.
      induction T; cbn; congruence.
    Qed.

  End ListOperatorsSubstitutionRenaming.

  (* ** Compatibility Properties *)
  Section ListOperatorsCompatibilityProperties.

    Global Instance Lambda_step_proper k:
      Proper (step ++> step) (Lambda k).
    Proof.
      induction k; cbn; intros ??; (eauto 3).
    Qed.

    Global Instance AppR_step_proper:
      Proper (step ++> eq ++> step) AppR.
    Proof.
      intros s t ? ? A ->.
      induction A in s, t, H |-*; cbn; (eauto 3).
    Qed.

    Global Instance AppR_lstep_proper:
      Proper (eq ++> lstep step ++> step) AppR.
    Proof.
      intros ? ? -> ? ? H.
      induction H in y |-*; cbn; (eauto 2).
    Qed.

    Global Instance AppL_step_proper:
      Proper (eq ++> step ++> step) AppL.
    Proof.
      intros ? A -> s t H.
      induction A in s, t, H |-*; cbn; (eauto 3).
    Qed.

    Global Instance AppL_lstep_proper:
      Proper (lstep step ++> eq ++> step) AppL.
    Proof.
      intros ? ? H ? t ->.
      induction H in t |-*; cbn; (eauto 2).
    Qed.

    Global Instance Lambda_steps_proper k:
      Proper (star step ++> star step) (Lambda k).
    Proof.
      induction 1; (eauto 1); now rewrite H.
    Qed.

    Global Instance AppL_proper:
      Proper (star (lstep step) ++> star step ++> star step) AppL.
    Proof.
      intros ? ?. induction 1.
      - intros ? ? ?. induction H; cbn; (eauto 2).
        rewrite <-IHstar.
        econstructor 2; (eauto 1); eapply AppL_step_proper; (eauto 2).
      - intros ? ? ?. rewrite H. specialize (IHstar _ _ H1).
        now rewrite IHstar.
    Qed.

    Global Instance AppR_proper:
      Proper (star step ++> star (lstep step) ++> star step) AppR.
    Proof.
      intros ? ?. induction 1.
      - intros ? ? ?. induction H; cbn; (eauto 2).
        rewrite <-IHstar.
        econstructor 2; (eauto 1); eapply AppR_lstep_proper; (eauto 2).
      - intros ? ? ?. rewrite H. specialize (IHstar _ _ H1).
        now rewrite IHstar.
    Qed.

    Global Instance Lambda_equiv_proper n:
      Proper (equiv step ++> equiv step) (Lambda n).
    Proof.
      intros ? ? ?; induction n; cbn; (eauto 2).
      now rewrite IHn.
    Qed.

    Global Instance equiv_AppL_proper:
      Proper (equiv (lstep step) ++> equiv step ++> equiv step) AppL.
    Proof.
      intros ? ? (? & H1 & H2) % church_rosser ? ? (? & H3 & H4) % church_rosser;
        eauto.
      now rewrite H1, H2, H3, H4.
    Qed.

    Global Instance equiv_AppR_proper:
      Proper (equiv step ++> equiv (lstep step) ++> equiv step) AppR.
    Proof.
      intros ? ? (? & H1 & H2) % church_rosser ? ? (? & H3 & H4) % church_rosser; (eauto 2).
      now rewrite H1, H2, H3, H4.
    Qed.

  End ListOperatorsCompatibilityProperties.

  Lemma AppR_Lambda T s n sigma:
    AppR (sigma • Lambda (length T + n) s) T >* T .+ sigma • Lambda n s.
  Proof.
    revert s n sigma; induction T; intros; cbn [AppR length]; (eauto 2).
    replace (S (length T) + n) with (length T + S n) by lia.
    rewrite IHT; cbn; econstructor 2; (eauto 2); now asimpl.
  Qed.

  Lemma AppR_Lambda' T s m:
    m = length T -> AppR (Lambda m s) T >* T .+ var • s.
  Proof.
    intros ?; replace (Lambda m s) with (var • Lambda m s) by now asimpl.
    replace m with (length T + 0) by lia.
    eapply AppR_Lambda with (n := 0).
  Qed.

  (* ** Equivalence Inversions *)
  Section EquivalenceInversions.

    Lemma equiv_Lambda_elim k s t:
      Lambda k s ≡ Lambda k t -> s ≡ t.
    Proof.
      induction k; cbn; eauto using equiv_lam_elim.
    Qed.

    Lemma equiv_AppR_elim s1 s2 T1 T2:
      AppR s1 T1 ≡ AppR s2 T2 ->
      isAtom s1 ->
      isAtom s2 ->
      T1 ≡₊ T2 /\ s1 = s2.
    Proof.
      intros; assert (isAtom (head (AppR s1 T1))); simplify; (eauto 2).
      intros; assert (isAtom (head (AppR s2 T2))); simplify; (eauto 2).

      revert T2 H H2 H3; induction T1 as [|a A IH]; intros [| b B]; cbn; intros.
      + intuition.
        destruct s1, s2; cbn in *; intuition; try Discriminate.
        all: Injection H; now subst.
      + destruct s1; cbn in *; try now intuition; Discriminate.
      + destruct s2; cbn in *; try now intuition; Discriminate.
      + Injection H. intuition; edestruct IH; (eauto 2).
        now rewrite H5, H.
    Qed.

    Lemma equiv_AppL_elim S1 S2 t1 t2:
      AppL S1 t1 ≡ AppL S2 t2 ->
      (forall s, s ∈ S1 -> isAtom (head s)) ->
      (forall s, s ∈ S2 -> isAtom (head s)) ->
      length S1 = length S2 ->
      S1 ≡₊ S2 /\ t1 ≡ t2.
    Proof.
      revert S2; induction S1 as [|s1 S1 IH]; intros [| s2 S2];
        cbn; intros;
        try discriminate.
      + intuition.
      + apply equiv_app_elim in H as ?; rewrite ?AppR_head; (eauto 3).
        intuition; edestruct IH; (eauto 3).
        now rewrite H3, H4.
    Qed.

  End EquivalenceInversions.

  (* ** Normality *)
  Section Normality.

    Lemma normal_Lambda k s:
      normal (Lambda k s) -> normal s.
    Proof.
      induction k; cbn; eauto using normal_lam_elim.
    Qed.

    Lemma normal_AppL_left S t:
      normal (AppL S t) -> Normal (lstep step) S.
    Proof.
      induction S; cbn; intros H ? H1; inv H1.
      - eapply H; (eauto 2).
      - eapply IHS; eauto using normal_app_r.
    Qed.

    Lemma normal_AppL_right S t:
      normal (AppL S t) -> normal t.
    Proof.
      induction S in t |-*; cbn; eauto using normal_app_r.
    Qed.

    Lemma normal_AppR_right s T:
      normal (AppR s T) -> Normal (lstep step) T.
    Proof.
      induction T; cbn; intros H ? H1; inv H1.
      - eapply H. eauto.
      - eapply IHT; eauto using normal_app_l.
    Qed.

    Lemma normal_AppR_left s T:
      normal (AppR s T) -> normal s.
    Proof.
      induction T in s |-*; cbn; eauto using normal_app_l.
    Qed.

  End Normality.

  Hint Resolve
       normal_Lambda normal_AppR_left normal_AppR_right : core.

  (* ** List Operators Typing *)
  Section ListOperatorsTyping.

    Lemma Lambda_typing Gamma L B k s:
      length L = k ->
      rev L ++ Gamma ⊢ s : B ->
                      Gamma ⊢ (Lambda k s) : Arr L B.
    Proof.
      induction k in L, Gamma, s |-*.
      - destruct L; try discriminate.
        intros _; cbn; (eauto 2).
      - destruct L; try discriminate.
        intros H; injection H as H.
        cbn; intros; econstructor.
        eapply IHk; (eauto 2).
        now rewrite <-app_assoc in H0.
    Qed.

    Lemma Lambda_ordertyping n Gamma L B k s:
      length L = k ->
      rev L ++ Gamma ⊢(n) s : B ->
                        Gamma ⊢(n) (Lambda k s) : Arr L B.
    Proof.
      induction k in L, Gamma, s |-*.
      - destruct L; try discriminate.
        intros _; cbn; (eauto 2).
      - destruct L; try discriminate.
        intros H; injection H as H.
        cbn; intros; econstructor.
        eapply IHk; (eauto 2).
        now rewrite <-app_assoc in H0.
    Qed.

    Lemma AppL_typing_repeated Gamma s T n A:
      Gamma ⊢₊ T: repeat (A → A) n -> Gamma ⊢ s : A -> Gamma ⊢ AppL T s : A.
    Proof.
      induction T in n |-*; (eauto 1); cbn.
      intros; inv H; intuition.
      destruct n; try discriminate.
      cbn in H3; injection H3 as ??; subst.
      econstructor; (eauto 2).
    Qed.

    Lemma AppL_ordertyping_repeated k Gamma s T n A:
      Gamma ⊢₊(n) T: repeat (A → A) k -> Gamma ⊢(n) s : A -> Gamma ⊢(n) AppL T s : A.
    Proof.
      induction T in k |-*; (eauto 1); cbn.
      intros; inv H; intuition.
      destruct k; try discriminate.
      cbn in H3; injection H3 as ??; subst.
      econstructor; (eauto 2).
    Qed.

    Lemma AppR_typing Gamma L s T B:
      Gamma ⊢₊ T : L -> Gamma ⊢ s : Arr (rev L) B -> Gamma ⊢ AppR s T : B.
    Proof.
      induction 1 in s, B |-*; cbn; (eauto 1); rewrite Arr_app; cbn; (eauto 3).
    Qed.

    Lemma AppR_ordertyping n Gamma T s L B:
      Gamma ⊢₊(n) T : L -> Gamma ⊢(n) s : Arr (rev L) B -> Gamma ⊢(n) AppR s T : B.
    Proof.
      induction 1 in s, B |-*; cbn; (eauto 1); rewrite Arr_app; cbn; (eauto 3).
    Qed.

    Lemma Lambda_typing_inv Gamma s k B:
      Gamma ⊢ Lambda k s : B ->
          exists L A, rev L ++ Gamma ⊢ s : A /\
          B = Arr L A /\ length L = k.
    Proof.
      induction k in Gamma, B |-*; cbn.
      - exists nil. exists B. intuition.
      - intros H; inv H.
        edestruct IHk as (? & ? & ?); (eauto 2).
        intuition. exists (A :: x). exists x0.
        intuition; cbn; try congruence.
        now rewrite <-app_assoc.
    Qed.

    Lemma Lambda_ordertyping_inv n Gamma s k B:
      Gamma ⊢(n) Lambda k s : B ->
      exists L A, rev L ++ Gamma ⊢(n) s : A /\
        B = Arr L A /\ length L = k.
    Proof.
      induction k in Gamma, B |-*; cbn.
      - exists nil. exists B. cbn in *; intuition.
      - intros H; inv H.
        edestruct IHk as (? & ? & ?); (eauto 2).
        intuition. exists (A :: x). exists x0.
        intuition; cbn; try congruence.
        now rewrite <-app_assoc.
    Qed.

    Lemma AppL_typing_inv Gamma T B t:
      Gamma ⊢ AppL T t : B -> exists L A, Gamma ⊢₊ T : L /\ Gamma ⊢ t : A.
    Proof.
      induction T in B |-*; cbn.
      - exists nil. exists B. intuition.
      - intros H; inv H.
        edestruct IHT as (? & ? & ?); (eauto 2).
        do 2 eexists; intuition; (eauto 2).
    Qed.

    Lemma AppL_ordertyping_inv n Gamma T B t:
      Gamma ⊢(n) AppL T t : B -> exists L A, Gamma ⊢₊(n) T : L /\ Gamma ⊢(n) t : A.
    Proof.
      induction T in B |-*; cbn.
      - exists nil. exists B. intuition.
      - intros H; inv H.
        edestruct IHT as (? & ? & ?); (eauto 2).
        do 2 eexists; intuition; (eauto 2).
    Qed.

    Lemma AppR_typing_inv Gamma T B t:
      Gamma ⊢ AppR t T : B -> exists L, Gamma ⊢₊ T : L /\ Gamma ⊢ t : Arr (rev L) B.
    Proof.
      induction T in Gamma, B, t |-*; cbn; intros.
      - exists nil; intuition.
      - inv H. destruct (IHT _ _ _ H2) as [L]; intuition.
        exists (A :: L). intuition; cbn; rewrite Arr_app; (eauto 2).
    Qed.

    Lemma AppR_ordertyping_inv n Gamma T B t:
      Gamma ⊢(n) AppR t T : B -> exists L, Gamma ⊢₊(n) T : L /\ Gamma ⊢(n) t : Arr (rev L) B.
    Proof.
      induction T in Gamma, B, t |-*; cbn; intros.
      - exists nil; intuition.
      - inv H. destruct (IHT _ _ _ H2) as [L]; intuition.
        exists (A :: L). intuition; cbn; rewrite Arr_app; (eauto 2).
    Qed.

  End ListOperatorsTyping.

  (* ** Utilities *)
  Section Utilities.

    Inductive nf: exp X -> Type :=
      nfc k s t T:
      (forall t, t ∈ T -> nf t) ->
      isAtom s ->
      t = Lambda k (AppR s T) ->
      nf t.

    Lemma normal_nf s:
      normal s -> nf s.
    Proof.
      induction s.
      + intros. exists 0 (var f) nil; cbn; intuition.
      + intros. exists 0 (const c) nil; cbn; intuition.
      + intros H; mp IHs; eauto using normal_lam_elim;
          destruct IHs as [k s' t' T H1].
        exists (S k) s' T; (eauto 1); cbn; congruence.
      + intros H; eapply normal_app_r in H as Ns1;
        eapply normal_app_l in H as Ns2.
        mp IHs1; (eauto 1); mp IHs2; (eauto 2).
        destruct IHs1. subst t.
        destruct k; [|exfalso; eapply H; cbn; eauto].
        exists 0 s (s2 :: T); (eauto 1); cbn; simplify.
        intros t. destruct (s2 == t); subst; intuition.
        destruct (t el T); intuition.
        exfalso; intuition.
    Qed.

    Lemma AppL_largest (P: exp X -> Prop) (s: exp X):
      Dec1 P ->
      { S & { t | (forall s, s ∈ S -> P s) /\
                  s = AppL S t /\
                  forall (u v: exp X), t = u v -> ~ P u}}.
    Proof.
      intros D. induction s.
      - exists nil. exists (var f). cbn; intuition; discriminate.
      - exists nil. exists (const c). cbn; intuition; discriminate.
      - exists nil. exists (lambda s). cbn; intuition; discriminate.
      - destruct IHs2 as (S & t & ? & -> & ?).
        destruct (D s1).
        + exists (s1 :: S). exists t; cbn; intuition; subst; (eauto 2).
        + exists nil. exists (s1 (AppL S t)). cbn; intuition.
          injection H1 as ??;subst; intuition.
    Qed.

    Lemma head_decompose s: exists T, s = AppR (head s) T.
    Proof.
      induction s; try solve [exists nil; eauto].
      destruct IHs1 as [T]; cbn.
      exists (s2 :: T); cbn. congruence.
    Qed.

  End Utilities.

End TermsExtension.

#[export] Hint Constructors listtyping : core.
#[export] Hint Constructors orderlisttyping : core.
Global Hint Rewrite ord'_app ord_Arr ord_repeated : simplify.
Global Hint Rewrite ord_Arr : simplify.
#[export] Hint Resolve
     normal_Lambda normal_AppR_left normal_AppR_right : core.
Global Hint Rewrite @Lambda_ren @Lambda_subst @AppL_ren @AppL_subst @AppR_ren @AppR_subst : asimpl.

Global Hint Rewrite @AppR_head : simplify.

Global Hint Rewrite target_Arr target_ord: simplify.
Global Hint Rewrite arity_Arr : simplify.

Notation "S >₊ T" := (lstep step S T) (at level 60).
Notation "S >₊* T" := (star (lstep step) S T) (at level 60).
Notation "S ≡₊ T" := (equiv (lstep step) S T) (at level 60).
Notation "Gamma ⊢₊ A : L" := (listtyping Gamma A L) (at level 80, A at level 99).
Notation "Gamma ⊢₊( n ) A : L" := (orderlisttyping n Gamma A L) (at level 80, A at level 99).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


From CoindSemWhile Require Import Trace.
From Coq Require Export Arith.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Definition expr := state -> val.
Parameter is_true: val -> bool.

Inductive stmt : Set :=
| Sskip
| Sassign (_ :id) (_: expr)
| Sseq (_: stmt) (_ :stmt)
| Sifthenelse (_: expr) (_: stmt) (_: stmt)
| Swhile (_: expr) (_ :stmt).

Definition update (x: id) (v: val) (st:state): state :=
  fun y => if x =? y then v else st y.

Notation "x <- e" := (Sassign x e) (at level 80).
Notation "s1 ';;' s2" :=
  (Sseq s1 s2) (at level 80, right associativity).


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Lia.
From Coq Require Import Strings.String.
From Coq Require Import Logic.Eqdep_dec.
From Coq Require Import Classes.RelationClasses.
From PFPL Require Import PartialMap_Set.
From PFPL Require Import Definitions.
From PFPL Require Import Lemmas_Vars.
From PFPL Require Import Lemmas_Rename.
From PFPL Require Import Lemmas_Same_Structure.
From PFPL Require Import Induction_Expr.
From PFPL Require Import Lemmas_AlphaEquiv.
From PFPL Require Import Lemmas_Rename_AlphaEquiv.

Lemma alpha_equiv_trans : forall e e' e'',
  alpha_equiv_rel e e' -> alpha_equiv_rel e' e'' ->
  alpha_equiv_rel e e''.
Proof.
  induction e using expr_ind; intros.
  - inversion H. subst.
    inversion H0. subst.
    apply alpha_equiv_rel_id.
  - inversion H1. subst.
    inversion H2. subst.
    apply alpha_equiv_rel_let.
    apply (H e1 (same_structure_refl e1) e1').
    assumption. assumption.
    intros.
    remember (
      max (get_fresh_var e2) (max (get_fresh_var e2') (get_fresh_var e2'0))
    ) as newX.
    assert (H11 : all_vars e2 newX = false).
    apply fresh_var_not_in_all_vars. lia.
    assert (H12 : all_vars e2' newX = false).
    apply fresh_var_not_in_all_vars. lia.
    assert (H13 : all_vars e2'0 newX = false).
    apply fresh_var_not_in_all_vars. lia.
    assert (H14 := H0
      (rename e2 x newX)
      (rename_keeps_structure e2 x newX)
      (rename e2' x' newX)
      (rename e2'0 x'0 newX)
    ).
    assert (H15 := alpha_equiv_renamed e2 e2'0 x x'0 newX z H11 H13 H3 H4).
    apply H15.
    apply H14.
    apply H8. assumption. assumption.
    apply H10. assumption. assumption.
  - inversion H. subst. inversion H0. subst.
    assumption.
  - inversion H. subst. inversion H0.
    apply eqb_eq in H2. subst.
    apply eqb_eq in H3. subst.
    assumption.
  - inversion H1. subst.
    inversion H2. subst.
    apply alpha_equiv_rel_plus.
    apply (H e1 (same_structure_refl e1) e1' e1'0).
    assumption. assumption.
    apply (H0 e2 (same_structure_refl e2) e2' e2'0).
    assumption. assumption.
  - inversion H1. subst.
    inversion H2. subst.
    apply alpha_equiv_rel_times.
    apply (H e1 (same_structure_refl e1) e1' e1'0).
    assumption. assumption.
    apply (H0 e2 (same_structure_refl e2) e2' e2'0).
    assumption. assumption.
  - inversion H1. subst.
    inversion H2. subst.
    apply alpha_equiv_rel_cat.
    apply (H e1 (same_structure_refl e1) e1' e1'0).
    assumption. assumption.
    apply (H0 e2 (same_structure_refl e2) e2' e2'0).
    assumption. assumption.
  - inversion H0. subst.
    inversion H1. subst.
    apply alpha_equiv_rel_len.
    apply (H e (same_structure_refl e) e1' e1'0).
    assumption. assumption.
Qed.


Require Import VerdiRaft.Raft.

Require Import VerdiRaft.CommonDefinitions.

Section TermsAndIndicesFromOneLogInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition terms_and_indices_from_one_log (net : network) : Prop :=
    forall h,
      terms_and_indices_from_one (log (nwState net h)).

  Definition terms_and_indices_from_one_log_nw (net : network) : Prop :=
    forall p t leaderId prevLogIndex prevLogTerm entries leaderCommit,
      In p (nwPackets net) ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm entries leaderCommit ->
      terms_and_indices_from_one entries.

  Class terms_and_indices_from_one_log_interface : Prop := {
    terms_and_indices_from_one_log_invariant : forall net,
      raft_intermediate_reachable net ->
      terms_and_indices_from_one_log net;
    terms_and_indices_from_one_log_nw_invariant : forall net,
      raft_intermediate_reachable net ->
      terms_and_indices_from_one_log_nw net
  }.
End TermsAndIndicesFromOneLogInterface.


From logrel_heaplang_sessions Require Export lty ltyping any arr prod.
From iris.heap_lang Require Export lifting metatheory.
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import notation proofmode.

Section types.
  Context `{heapG Σ}.

  Definition lty_ref (A : lty Σ) : lty Σ := Lty (λ w,
    ∃ (l : loc) (v : val), ⌜w = #l⌝ ∗ l ↦ v ∗ ▷ A v)%I.
End types.

Notation "'ref' A" := (lty_ref A) : lty_scope.

Section properties.
  Context `{heapG Σ}.

  Global Instance lty_ref_contractive : Contractive (@lty_ref Σ _).
  Proof. solve_contractive. Qed.

  Global Instance lty_ref_ne : NonExpansive2 (@lty_ref Σ _).
  Proof. solve_proper. Qed.

  Global Instance lty_ref_unboxed A : LTyUnboxed (ref A).
  Proof. iIntros (v). by iDestruct 1 as (i w ->) "?". Qed.

  Definition refalloc : val := λ: "init", ref "init".
  Lemma ltyped_alloc A :
    ∅ ⊨ refalloc : A → ref A.
  Proof.
    iIntros (vs) "HΓ /=".
    wp_apply wp_value.
    iModIntro. iIntros (v) "Hv".
    rewrite /refalloc. wp_pures.
    wp_alloc l as "Hl".
    iExists l, v. iSplit=> //.
    iFrame "Hv Hl".
  Qed.

  (* The intuition for the any is that the value is still there, but
  it no longer holds any Iris resources. Just as in Rust, where a move
  might turn into a memcpy, which leaves the original memory
  unmodified, but moves the resources, in the sense that you can no
  longer use the memory at the old location. *)
  Definition refload : val := λ: "r", (!"r", "r").
  Lemma ltyped_load A :
    ∅ ⊨ refload : (ref A → A * ref any)%lty.
  Proof.
    iIntros (vs) "HΓ /=".
    wp_apply wp_value.
    iModIntro. iIntros (v) "Hv".
    rewrite /refload. wp_pures.
    iDestruct "Hv" as (l w ->) "[Hl Hw]".
    wp_load.
    wp_pures.
    iExists w, #l. iSplit=> //.
    iFrame "Hw".
    iExists l, w. iSplit=> //.
    iFrame "Hl".
    by iModIntro.
  Qed.

  Definition refstore : val := λ: "r" "new", "r" <- "new";; "r".
  Lemma ltyped_store A B:
    ∅ ⊨ refstore : (ref A → B ⊸ ref B)%lty.
  Proof.
    iIntros (vs) "HΓ /=".
    wp_apply wp_value.
    iModIntro. iIntros (v) "Hv".
    rewrite /refstore. wp_pures.
    iDestruct "Hv" as (l old ->) "[Hl Hold]".
    iIntros (new) "Hnew". wp_pures.
    wp_store.
    iExists l, new. iSplit=> //.
    iFrame "Hl Hnew".
  Qed.

End properties.


(******************************)
(******************************)
(****                      ****)
(****   Girard's paradox   ****)
(****                      ****)
(******************************)
(******************************)

(*
  Girard's paradox shows that any type is inhabited if `Type : Type`. The
  presentation of the paradox was adapted from this paper:

    Antonius J. C. Hurkens. 1995. A Simplification of Girard's Paradox. In
    Proceedings of the Second International Conference on Typed Lambda Calculi
    and Applications (TLCA '95). Springer-Verlag, Berlin, Heidelberg, 266-278.

  To demonstrate the paradox, we first need to disable universe checking.
*)

#[local] Unset Universe Checking.

Definition exfalso := forall (p : Type), p.
Definition negate := fun (phi : Type) => phi -> exfalso.
Definition power := fun (S : Type) => S -> Type.
Definition universe :=
  forall (X : Type),
    ((power (power X) -> X) -> power (power X)).
Definition tau :=
  fun (t : power (power universe)) =>
    fun (X : Type) =>
      fun (f : power (power X) -> X) =>
        fun (p : power X) =>
          t (fun (x : universe) => p (f (x X f))).
Definition sigma :=
  fun (s : universe) =>
    s universe (fun (t : power (power universe)) => tau t).
Definition delta :=
  fun (y : universe) =>
    negate (forall (p : power universe), sigma y p -> p (tau (sigma y))).
Definition omega :=
  tau (fun (p : power universe) => forall (x : universe), sigma x p -> p x).

Definition bad := (
  fun (
    zero :
      forall (p : power universe),
        (forall (x : universe), sigma x p -> p x) -> p omega
  ) => (
    zero delta (
      fun (x : universe) =>
        fun (two : sigma x delta) =>
          fun (
            three :
              forall (p : power universe), sigma x p -> p (tau (sigma x))
          ) => three delta two (
            fun (p : power universe) =>
              three (fun (y : universe) => p (tau (sigma y)))
          )
    )
  ) (
    fun (p : power universe) => zero (fun (y : universe) => p (tau (sigma y)))
  )
) (
  fun (p : power universe) =>
    fun (one : forall (x : universe), sigma x p -> p x) =>
      one omega (fun (x : universe) => one (tau (sigma x)))
).

Check bad. (* `exfalso` *)
Check bad False. (* `False` *)

(*
  ```
  Compute bad.
  Compute bad False.
  ```
*)


Require Export CalculusSM_derived4.
Require Export MinBFTprops2.
Require Export MinBFTtacts2.
Require Export MinBFTinv.
Require Export MinBFTsame.

Section MinBFTass_diss.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Hint Rewrite ui_in_log_log_new_prepare : minbft.
  Hint Rewrite ui_in_log_log_new_commit : minbft.

  Lemma commit2sender_j_mk_auth_commit:
    forall v r ui1 ui2,
      commit2sender_j (mk_auth_commit v r ui1 ui2) = ui2rep ui2.
  Proof.
    tcsp.
  Qed.
  Hint Rewrite commit2sender_j_mk_auth_commit : minbft.

  Lemma commit2sender_j_mk_my_commit :
    forall c ui,
      commit2sender_j (mk_my_commit c ui) = ui2rep ui.
  Proof.
    tcsp.
  Qed.
  Hint Rewrite commit2sender_j_mk_my_commit : minbft.

  Lemma log_state_entry2rep_add_commit2entry :
    forall ui e,
      log_state_entry2rep (add_commit2entry ui e)
      = log_state_entry2rep e.
  Proof.
    introv; unfold log_state_entry2rep; autorewrite with minbft; auto.
  Qed.
  Hint Rewrite log_state_entry2rep_add_commit2entry : minbft.

  Lemma log_entry_commits_add_commit2entry :
    forall ui e,
      log_entry_commits (add_commit2entry ui e)
      = if rep_deq (ui2rep ui) (log_state_entry2rep e)
        then log_entry_commits e
        else add_commit2commits ui (log_entry_commits e).
  Proof.
    introv; destruct e; unfold log_state_entry2rep; simpl; smash_minbft2.
  Qed.
  Hint Rewrite log_entry_commits_add_commit2entry : minbft.

  Lemma find_entry_some_implies_eq_log_state_entry2rep :
    forall rd s e,
      find_entry rd s = Some e
      -> log_state_entry2rep e = request_data2rep rd.
  Proof.
    induction s; introv h; simpl in *; tcsp; smash_minbft2.
  Qed.

  Lemma find_entry_implies_prepare_already_in_log :
    forall c s e,
      find_entry (commit2request_data_i c) s = Some e
      -> prepare_already_in_log (commit2prepare c) s = true.
  Proof.
    induction s; introv h; simpl in *; ginv; smash_minbft2.
  Qed.

  Lemma ASSUMPTION_diss_correct_implies_knows_true :
    forall (eo : EventOrdering), assume_eo eo ASSUMPTION_diss_correct_implies_knows.
  Proof.
    Opaque KE_CORRECT_TRACE_BEFORE.
    introv diss cor; simpl in *; exrepnd.
    unfold disseminate_data in *; simpl in *; exrepnd.
    unfold M_byz_output_sys_on_event in *.
    revert dependent o.
    rewrite diss1 in *; simpl in *; introv run out.
    apply interp_KE_CORRECT_TRACE_BEFORE in cor.

    eapply correct_byz_output_implies in cor; eauto; exrepnd; subst; simpl in *.
    eapply data_is_in_out_and_dmsgs_are_out_implies in cor2; eauto.
    clear dependent o.
    apply in_flat_map in cor2; exrepnd; simpl in *.

    unfold M_output_ls_on_event in *.
    apply in_olist2list in cor2; exrepnd; simpl in *.
    apply option_map_Some in cor2; exrepnd; subst; simpl in *.
    applydup M_run_ls_before_event_ls_is_minbft in cor2; exrepnd; subst; simpl in *.

    unfold knows_after,  state_after; simpl.
    unfold M_state_sys_on_event; simpl.
    allrw; simpl.
    unfold M_state_ls_on_event; simpl.
    rewrite M_run_ls_on_event_unroll2.
    allrw; simpl.

    applydup usig_same_id in cor2 as eqid; subst; simpl in *.
    hide_hyp cor2.

    unfold M_output_ls_on_this_one_event, trigger_op in *; simpl in *.
    unfold M_run_ls_on_this_one_event, trigger_op; simpl.
    rewrite cor0 in *; simpl in *.
    unfold M_run_ls_on_input_out, M_run_ls_on_input_ls in *; simpl in *.

    remember (M_run_ls_on_input (MinBFTlocalSys_new (usig_id s1) s s1 s2) (msg_comp_name 0) i) as run.
    symmetry in Heqrun; repnd; simpl in *.
    apply in_olist2list in cor3; exrepnd; subst; simpl in *.
    applydup (M_run_ls_on_input_ls_is_minbft_new (msg_comp_name 0)) in Heqrun.
    exrepnd; subst; simpl in *.
    unfold state_of_component; simpl.
    exists l'.

    unfold M_run_ls_on_input in *; simpl in *.
    autorewrite with minbft in *; simpl in *.

    Time minbft_dest_msg Case;
      repeat (autorewrite with minbft comp in *; simpl in *; smash_minbft2);
      repeat (repndors; subst; simpl in *; tcsp);
      unfold state_of_component in *; simpl in *;
      dands; try (complete (eexists;dands;try reflexivity));
      unfold MinBFT_data_knows; simpl; repeat smash_minbft2;
      unfold lower_out_break in *; simpl in *; minbft_simp;
      repeat (repndors; subst; simpl in *; tcsp);
      repeat smash_minbft2;
      try (complete (rename_hyp_with invalid_prepare invp;
                     applydup invalid_prepare_false_implies_eq_prepare2view in invp as eqv; rewrite <- eqv in *;
                     applydup invalid_prepare_false_implies_eq_prepare2sender in invp as eqs;
                     applydup invalid_prepare_false_implies_diff_prepare2sender in invp as dp;
                     autorewrite with minbft in *;
                     unfold commit_ui_j_rep_not_in_log in *; simpl in *; smash_minbft2;
                     rename_hyp_with find_entry fe;
                     rewrite prepare_not_already_in_log_implies_find_entry in fe; ginv; simpl in *; repndors; tcsp;
                     unfold log_state_entry2rep in *; simpl in *; autorewrite with minbft in *; try congruence));
      try (complete (rename_hyp_with invalid_commit invc;
                     applydup invalid_commit_false_implies_eq_commit2view in invc as eqv; rewrite <- eqv in *;
                     applydup invalid_commit_false_implies_eq_commit2sender_i in invc as eqs;
                     autorewrite with minbft in *;
                     unfold commit_ui_j_rep_not_in_log in *; simpl in *; smash_minbft2;
                     rename_hyp_with find_entry fe;
                     rewrite find_entry_log_new_commit in fe; simpl in *; smash_minbft2;
                     rename_hyp_with find_entry fe;
                     apply find_entry_implies_prepare_already_in_log in fe; tcsp)).
  Qed.

End MinBFTass_diss.

Hint Resolve ASSUMPTION_diss_correct_implies_knows_true : minbft.