From SSL_Iris Require Import core.
From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Export tactics coq_tactics ltac_tactics reduction.
From iris.heap_lang Require Import lang notation proofmode.
Require Import common.
From iris_string_ident Require Import ltac2_string_ident.
From Hammer Require Import Hammer.
Context `{!heapG Σ}.
Set Default Proof Using "Type".

Definition sll_dupleton : val :=
rec: "sll_dupleton" "x" "y" "r" :=
let: "a2" := ! ("r") in
#();;
let: "z2" := AllocN (#2) (#()) in
#();;
let: "nxtz2" := AllocN (#2) (#()) in
#();;
("r") <- ("z2");;
("z2" +ₗ #1) <- ("nxtz2");;
("nxtz2" +ₗ #1) <- (#null_loc);;
("z2") <- ("x");;
("nxtz2") <- ("y");;
#().

Lemma sll_dupleton_spec :
∀ (r : loc) (a : loc) (x : Z) (y : Z),
{{{ r ↦ #a }}}
  sll_dupleton #x #y #r
{{{ RET #(); ∃ (elems : (list Z)) (z : loc) (_alpha_523 : sll_card), ⌜(elems = [x; y])⌝ ∗ r ↦ #z ∗ (sll z elems _alpha_523) }}}.
Proof.
iIntros (r a x y ϕ) "iH1 Post".
iRewriteHyp.
iLöb as "sll_dupleton" forall (r a x y ϕ).
ssl_begin.
try rename a into a2.
ssl_load.
wp_alloc z2 as "?"; try by safeDispatchPure.
wp_pures.
do 2 try rewrite array_cons. iSplitAllHyps. try rewrite array_nil.
try rewrite !loc_add_assoc !Z.add_1_r.

movePure.
wp_alloc nxtz2 as "?"; try by safeDispatchPure.
wp_pures.
do 2 try rewrite array_cons. iSplitAllHyps. try rewrite array_nil.
try rewrite !loc_add_assoc !Z.add_1_r.

movePure.
ssl_store.
ssl_store.
ssl_store.
ssl_store.
ssl_store.
try wp_pures.
iFindApply.
iExists [x; y].
iExists z2.
iExists (sll_card_1 (sll_card_1 (sll_card_0  : sll_card) : sll_card) : sll_card).
ssl_finish.
ssl_rewrite_first_heap sll_card_1_open.
pull_out_exist.
iExists x.
pull_out_exist.
iExists ([y] ++ []).
pull_out_exist.
iExists nxtz2.
ssl_finish.
ssl_rewrite_first_heap sll_card_1_open.
pull_out_exist.
iExists y.
pull_out_exist.
iExists [].
pull_out_exist.
iExists null_loc.
ssl_finish.
ssl_rewrite_first_heap sll_card_0_open.
ssl_finish.
Qed.


Require Import Coq.omega.Omega.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Export DeclarationEvaluation.
Require Export DeclarationTyping.

(******************************************************************************)
(* Weakening lemmas                                                           *)
(******************************************************************************)

Lemma shift_etvar_sub {Γ1 U V} (sub: Sub Γ1 U V) :
  ∀ {c Γ2}, shift_etvar c Γ1 Γ2 → Sub Γ2 (tshiftTy c U) (tshiftTy c V).
Proof.
  induction sub; simpl; econstructor; eauto with shift.
Qed.
Hint Resolve shift_etvar_sub : infra shift.

Lemma shift_evar_sub {Γ1 U V} (sub: Sub Γ1 U V) :
  ∀ {c Γ2}, shift_evar c Γ1 Γ2 → Sub Γ2 U V.
Proof.
  induction sub; simpl; econstructor; eauto with shift.
Qed.
Hint Resolve shift_evar_sub : infra shift.

Lemma weaken_sub {Γ U V} (sub: Sub Γ U V) :
  ∀ Δ, Sub (appendEnv Γ Δ)
         (weakenTy U (domainEnv Δ)) (weakenTy V (domainEnv Δ)).
Proof.
  induction Δ; simpl; eauto with shift.
Qed.

Lemma shift_etvar_typing {Γ1 t T} (wt: Typing Γ1 t T) :
  ∀ {c Γ2}, shift_etvar c Γ1 Γ2 → Typing Γ2 (tshiftTm c t) (tshiftTy c T).
Proof.
  induction wt; isimpl; econstructor; eauto with shift.
Qed.

Lemma shift_evar_typing {Γ1 t T} (wt: Typing Γ1 t T) :
  ∀ {c Γ2}, shift_evar c Γ1 Γ2 → Typing Γ2 (shiftTm c t) T.
Proof.
  induction wt; simpl; econstructor; eauto with shift.
Qed.

(******************************************************************************)
(* Well-formedness                                                            *)
(******************************************************************************)

Lemma sub_wf {Γ U V} (sub: Sub Γ U V) :
  wfTy (domainEnv Γ) U ∧ wfTy (domainEnv Γ) V.
Proof.
  induction sub; destruct_conjs; eauto with wf.
Qed.

Hint Extern 8 (wfTy _ _) =>
  match goal with
    | H: Sub _ _ _ |- _ => destruct (sub_wf H); clear H
  end : infra shift wf.

Lemma typing_wf {Γ t T} (wt: Typing Γ t T) : wfTy (domainEnv Γ) T.
Proof.
  induction wt; simpl; eauto with wf.
Qed.

(******************************************************************************)
(* Reflexivity, transitivity and narrowing                                    *)
(******************************************************************************)

Lemma sub_refl {Γ T} (wfT: wfTy (domainEnv Γ) T) : Sub Γ T T.
Proof.
  depind wfT; simpl; econstructor; eauto with wf.
Qed.

Lemma narrow_lookup_etvar_ne {Γ T1 T2 Δ} :
  ∀ {X U}, X ≠ (weakenIndexty I0 (domainEnv Δ)) →
    lookup_etvar (appendEnv (etvar Γ T1) Δ) X U →
    lookup_etvar (appendEnv (etvar Γ T2) Δ) X U.
Proof.
  induction Δ; inversion 2; isimpl; try constructor; isimpl; intuition.
  - apply IHΔ; congruence.
Qed.

Definition Trans Q :=
  ∀ Γ S T, Sub Γ S Q → Sub Γ Q T → Sub Γ S T.

Definition Narrow Q :=
  ∀ Γ Δ S T, Sub (appendEnv (etvar Γ Q) Δ) S T →
    ∀ R, Sub Γ R Q → Sub (appendEnv (etvar Γ R) Δ) S T.

Lemma trans_case Q
  (hypT : ∀ R, size_Ty R < size_Ty Q → Trans R)
  (hypN : ∀ R, size_Ty R < size_Ty Q → Narrow R) :
  Trans Q.
Proof with simpl; eauto with infra; try omega.
  intros Γ S T subSQ subQT; revert T subQT.
  induction subSQ; intros; auto.
  - dependent destruction subQT; constructor; auto.
  - eapply SA_Trans_TVar; eauto.
  - dependent destruction subQT; simpl; constructor...
    + apply (hypT T1)...
    + apply (hypT T2)...
  - dependent destruction subQT; constructor...
    + apply (hypT T1)...
    + apply (hypT T2)...
      refine (hypN T1 _ Γ empty _ _ subSQ2 _ subQT1)...
Qed.

Lemma narrow_case Q (hyp : ∀ (R : Ty), size_Ty R = size_Ty Q → Trans R) :
  Narrow Q.
Proof.
  intros Γ Δ U T subUT; depind subUT; intros R subQ.
  - apply SA_Top; isimpl; auto.
  - apply SA_Refl_TVar; isimpl; auto.
  - destruct (sub_wf subQ) as [wfR wfQ].
    case (eq_index_dec X (weakenIndexty I0 (domainEnv Δ))); intros; subst.
    + pose proof (lookup_etvar_functional H (weaken_lookup_etvar_here Δ wfQ)).
      (* The lookup position X is the one that is being narrowed, so U is in
         fact Q weakened and hence we can use transitivity for U.  U. We can
         derive the goal like this:

                               Γ ⊢ R<:Q
                             ------------- shift_etvar_sub
                             Γ,x<:R ⊢ R<:Q
                            --------------- weaken_sub
         (x<:R) ∈ Γ,x<:R,Δ  Γ,x<:R,Δ ⊢ R<:Q
         ---------------------------------- SA_Trans  -------------- IH
                   Γ,x<:R,Δ ⊢ x<:U                    Γ,x:R,Δ ⊢ U<:T
         ----------------------------------------------------------- hyp U
                                 Γ,x<:R,Δ ⊢ x<:T
      *)
      apply (hyp U); subst; isimpl; auto.
      eapply SA_Trans_TVar; eauto using weaken_sub with infra.
    (* Just push the narrowing into the subtyping part. *)
    + eapply SA_Trans_TVar; eauto using narrow_lookup_etvar_ne.
  - constructor; auto.
  - constructor; auto; apply (IHsubUT2 (etvar Δ T1) _ Q); auto.
Qed.

Lemma sub_trans_and_narrow Q : Trans Q ∧ Narrow Q.
Proof.
  induction Q using (sizeind size_Ty); intros; split.
  - apply trans_case; apply H; auto.
  - apply narrow_case; intros R eq.
    apply trans_case; rewrite eq; apply H.
Qed.

Lemma sub_trans {Q Γ S T} : Sub Γ S Q → Sub Γ Q T → Sub Γ S T.
Proof.
  intros; eapply sub_trans_and_narrow; eauto.
Qed.

Lemma sub_narrow {Γ Δ Q R S T} (subQ: Sub Γ R Q) :
  Sub (appendEnv (etvar Γ Q) Δ) S T → Sub (appendEnv (etvar Γ R) Δ) S T.
Proof.
  intros; eapply sub_trans_and_narrow; eauto.
Qed.

Lemma lookup_evar_narrow {Γ Δ Q R} :
  ∀ {x T}, lookup_evar (appendEnv (etvar Γ Q) Δ) x T →
           lookup_evar (appendEnv (etvar Γ R) Δ) x T.
Proof.
  induction Δ; inversion 1; isimpl; constructor; isimpl; eauto with wf.
Qed.

Lemma typing_narrow {Γ} Δ {Q R t T} (subQ: Sub Γ R Q) :
  Typing (appendEnv (etvar Γ Q) Δ) t T → Typing (appendEnv (etvar Γ R) Δ) t T.
Proof.
  intro wt; depind wt; eauto using Typing, lookup_evar_narrow, sub_narrow.
  - eapply T_Abs; isimpl; eauto.
    refine (IHwt Γ (evar Δ T1) _ _ eq_refl); auto.
  - eapply T_Tabs; isimpl; eauto.
    refine (IHwt Γ (etvar _ _) _ _ eq_refl); auto.
Qed.

Lemma typing_narrow0 {Γ Q R t T} (subQ: Sub Γ R Q) :
  Typing (etvar Γ Q) t T → Typing (etvar Γ R) t T.
Proof.
  apply (typing_narrow empty subQ).
Qed.

(******************************************************************************)
(* Substitution lemmas                                                        *)
(******************************************************************************)

Lemma subst_etvar_lookup_etvar {Γ B S X Γ1 Γ2} (wS : wfTy (domainEnv Γ) S)
  (subS: Sub Γ S B) (esub: subst_etvar Γ B S X Γ1 Γ2) :
  ∀ Y U, lookup_etvar Γ1 Y U → Sub Γ2 (tsubstIndex X S Y) (tsubstTy X S U).
Proof.
  induction esub; inversion 1; isimpl;
    try refine (SA_Trans_TVar _ _ (sub_refl _)); eauto with infra.
Qed.

Lemma subst_etvar_sub {Γ B Γ1 S U V} (wS : wfTy (domainEnv Γ) S)
  (subS: Sub Γ S B) (sub: Sub Γ1 U V) :
  ∀ Γ2 X, subst_etvar Γ B S X Γ1 Γ2 → Sub Γ2 (tsubstTy X S U) (tsubstTy X S V).
Proof.
  induction sub; isimpl; try econstructor; eauto using sub_refl with infra;
    eauto using subst_etvar_lookup_etvar, sub_trans with infra.
Qed.

Lemma subst_etvar_typing {Γ B S Γ1 t T} (wS: wfTy (domainEnv Γ) S)
  (subS: Sub Γ S B) (wt: Typing Γ1 t T) :
  ∀ {X Γ2}, subst_etvar Γ B S X Γ1 Γ2 →
     Typing Γ2 (tsubstTm X S t) (tsubstTy X S T).
Proof.
  induction wt; simpl; intros;
    try (isimpl; econstructor; eauto using subst_etvar_sub with infra; fail).
  - eapply T_Abs; eauto with infra.
    (* Urgs, ugly. *)
    replace (tsubstTy X S T2) with (tsubstTy (XS tm X) S T2)
      by apply tsubstTy_tm; eauto with infra.
Qed.

Lemma subst_evar_sub {Γ D t Γ1 T1 T2} (st: Sub Γ1 T1 T2) :
  ∀ {Y Γ2}, subst_evar Γ D t Y Γ1 Γ2 → Sub Γ2 T1 T2.
Proof.
  induction st; isimpl; econstructor; eauto with subst.
Qed.

Lemma subst_evar_lookup_evar {Γ s S x Γ1 Γ2} (ws: Typing Γ s S)
  (esub: subst_evar Γ S s x Γ1 Γ2) :
  ∀ {y T}, lookup_evar Γ1 y T → Typing Γ2 (substIndex x s y) T.
Proof.
  induction esub; inversion 1; subst; simpl;
    eauto using T_Var, shift_evar_typing, shift_etvar_typing with subst.
Qed.

Lemma subst_evar_typing {Γ s S Γ1 t T} (ws: Typing Γ s S) (wt: Typing Γ1 t T) :
  ∀ {x Γ2}, subst_evar Γ S s x Γ1 Γ2 → Typing Γ2 (substTm x s t) T.
Proof.
  induction wt; simpl; eauto using subst_evar_lookup_evar;
    econstructor; eauto using subst_evar_sub with subst.
Qed.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tarr {t T1 T2} (v: Value t) (wt: Typing empty t (tarr T1 T2)) :
  ∃ T1' t2, t = abs T1' t2.
Proof.
  depind wt; try contradiction.
  - exists T1, t; reflexivity.
  - inversion H; eauto; inversion H0.
Qed.

Lemma can_form_tall {t T1 T2} (v: Value t) (wt: Typing empty t (tall T1 T2)) :
  ∃ T1' t2, t = tabs T1' t2.
Proof.
  depind wt; try contradiction.
  - exists T1, t; reflexivity.
  - inversion H; eauto; inversion H0.
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with destruct_conjs; subst; eauto using red.
  depind wt; simpl; auto.
  - inversion H.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [vt|[t1' r1]]...
    destruct (can_form_tall vt wt)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma t_abs_inversion {Γ t T0 T1} (wt: Typing Γ (abs T1 t) T0) :
  ∀ {T2 T3}, Sub Γ T0 (tarr T2 T3) → Sub Γ T2 T1 ∧ Typing (evar Γ T1) t T3.
Proof.
  depind wt.
  - inversion 1; eauto using T_Sub, shift_evar_sub with shift.
  - eauto using sub_trans.
Qed.

Lemma t_tabs_inversion {Γ t T0 T1} (wt: Typing Γ (tabs T1 t) T0) :
  ∀ {T2 T3}, Sub Γ T0 (tall T2 T3) → Sub Γ T2 T1 ∧ Typing (etvar Γ T2) t T3.
Proof.
  depind wt.
  - inversion 1; subst; split; eauto using T_Sub, typing_narrow0.
  - eauto using sub_trans.
Qed.

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - destruct (t_abs_inversion wt1 (sub_refl (typing_wf wt1))).
    eauto using subst_evar_typing, T_Sub with subst.
  - destruct (t_tabs_inversion wt (sub_refl (typing_wf wt))).
    eauto using subst_etvar_typing, T_Sub with infra.
Qed.


Load Preamble.

Definition FE := forall X Y (g f : X -> Y), (forall x, f x = g x) -> f = g.

Lemma Stab_func_eq X B :
  FE -> (forall a b : B, stable (a = b)) -> forall f g : X -> B, stable (f = g).
Proof.
  intros fe H f g nnH.
  apply fe. intros x.
  apply H. apply (DN.remove nnH).
  now intros ->.
Qed.

Section type.
  Variable F : Type.
  Definition LEM_T := forall (A : Type), sum A (A -> F).
  Definition PL_T := forall (A B : Type), ((A -> B) -> A) -> A.

  Goal PL_T -> LEM_T.
  Proof.
    intros H A.
    refine (H _ F _). intros h.
    right. intros a. apply h. now left.
  Qed.
End type.

Definition PL := forall B A, ((A -> B) -> A) -> A.
Definition sDN := forall B A, ((A -> B) -> B) -> A.

Lemma much_PL :
  forall A B C D E F, (E -> B) -> (E -> F) -> (A -> D) -> (C -> D) ->
  ((((A -> B) -> C) -> D) -> E) -> F.
Proof.
  intros A B C D E F H0 H1 H2 H3 H4. apply H1, H4.
  intros H5. apply H3, H5.
  intros a. apply H0, H4.
  intros _. apply H2, a.
Qed.

Goal sDN -> PL.
Proof.
  intros dn F A. apply (dn F). tauto.
Qed.

Goal forall F, (forall A, ((A -> F) -> F) -> A) -> PL.
Proof.
  intros F H A B. apply H.
  refine (fun f => f (fun g => g (fun a => _))).
  apply H; tauto.
Qed.

Lemma PL_equiv :
 PL <=> (forall A B C D, (A -> D) -> (C -> D) -> ((A -> B) -> C) -> D).
Proof.
  split; intros pl.
  - intros A B C D ???.
    apply (pl B). tauto.
  - intros B A. now apply pl.
Qed.

Goal PL <=> (forall F A, (F -> A) -> ((A -> F) -> F) -> A).
Proof.
  split; intros pl.
  - intros F A. now apply PL_equiv.
  - intros F A. apply (pl F); tauto.
Qed.

Goal PL <=> (forall A, (False -> A) -> ((A -> False) -> False) -> A).
Proof.
  split; intros pl.
  - intros A. now apply PL_equiv.
  - intros B A. apply pl; tauto.
Qed.

Section FixF.

  Variable F : Type.

  (* If the F-negation of A implies A, then we have A *)
  Definition wPL := forall A, ((A -> F) -> A) -> A.
  Definition Expl := forall A, F -> A.
  Definition DN := forall A, ((A -> F) -> F) -> A.

  Goal DN -> Expl * PL.
  Proof.
    intros dn; split.
    - intros ??. apply dn. tauto.
    - intros A B. apply dn.
      refine (fun f => f (fun g => g (fun a => _))).
      apply dn; tauto.
  Qed.

  Goal  Expl * PL -> DN.
  Proof.
    intros [expl pl].
    intros A ?.
    apply (pl F). intros ?.
    apply (pl A), expl. tauto.
  Qed.

  Goal DN -> Expl * wPL.
  Proof.
    intros dn. split.
    - intros A ?. apply (dn A). tauto.
    - intros A. apply dn. tauto.
  Qed.

  Goal Expl * wPL -> DN.
  Proof.
    intros [expl pl] A ?.
    apply (pl A). intros ?.
    apply expl. tauto.
  Qed.

End FixF.

Section FixF.

  Variable F : Type.
  Notation "¬ A" := (A -> F) (at level 10).

  Definition Expl' := forall A, ¬ ¬ (F -> A).
  Definition DN' := forall A, ¬ ¬ (((A -> F) -> F) -> A).

  Goal DN' -> Expl'.
  Proof.
    intros dn.
    intros A ?. apply (dn A). tauto.
  Qed.

  Goal Expl' -> DN'.
  Proof.
    intros expl A H.
    enough (pl : forall A, ¬ ¬ (((A -> F) -> A) -> A )).
    - eapply pl. intros pl'.
      eapply expl. intros expl'.
      apply H. intros ?.
      apply (pl'). intros ?.
      apply expl'. tauto.
    - intros. tauto.
  Qed.

  Inductive Three := one | two | three.
  Definition P A := (A -> F) -> A.
  Definition E A := (F -> A) -> F.
  Definition Id (A : Type) := A.

  Definition Tr n :=
    match n with
    | one => P
    | two => E
    | three => Id
    end.

  (* The below shows that having E everywhere is the only candidate that make Peirce work *)
  Goal forall A B a b, (((Tr a A) -> (Tr b B)) -> (Tr b A)) -> Tr b A.
  Proof.
    intros A B [][]; unfold Tr.
    5: unfold E; tauto.
    all: unfold P, E, Id.
    all: try tauto.
  Admitted.

  Goal forall A B, (((E A) -> (E B)) -> (E A)) -> E A.
  Proof.
    intros A B; unfold Tr, P, E, Id. try tauto.
  Qed.

  Goal forall A B, E (A -> B) -> (E A) -> (E B).
  Proof.
    intros A B. unfold E; try tauto.
  Qed.

  Goal forall A B, E (A + B) -> ((E A) + (E B)).
  Proof.
    intros A B. unfold E; try tauto.
  Qed.

  Goal forall A B, (E A) * (E B) -> E (A * B).
  Proof.
    intros A B. unfold E; try tauto.
  Qed.

  Goal forall A, E (E A) -> E A.
  Proof.
    intros A. unfold E; try tauto.
  Qed.

  Goal forall X (p : X -> Type) (a : X),
    (forall x, E (p x)) -> E (forall x, p x).
  Proof.
    intros X p a H exp. firstorder.
  Qed.

  Goal forall X (p : X -> Type) (a : X),
    E (Sigma x, p x) -> (Sigma x, E (p x)).
  Proof.
    unfold E. intros X p a H. exists a. intros h.
    apply H. intros f%h. now exists a.
  Qed.

  Goal forall A, ((E A -> F) -> F) -> E A.
  Proof.
    intros A; unfold E; try tauto.
  Qed.

End FixF.


(** * Partial: Triples for Partial Correctness *)

Set Implicit Arguments.
From SLF Require Export Nondet.
Close Scope val_scope.
Close Scope trm_scope.

Implicit Types f : var.
Implicit Types b : bool.
Implicit Types s : state.
Implicit Types t : trm.
Implicit Types v : val.
Implicit Types n : int.
Implicit Types p : loc.
Implicit Types h : heap.
Implicit Types P : Prop.
Implicit Types H : hprop.
Implicit Types Q : val->hprop.

(* ################################################################# *)
(** * First Pass *)

(** In this chapter, we investigate definitions of Hoare triples and Separation
    Logic triples with respect to partial correctness, that is, without imposing
    termination.

    Partial correctness is a weaker property than total correctness. However,
    it may be suited for reasoning about programs that are not meant to
    terminate, and may be interesting to consider as an intermediate target
    when reasoning about programs for which termination is much harder to
    establish than correctness.

    This chapter is organized as follows:

    - Partial correctness with respect to big-step semantics.
    - Bonus contents: partial correctness with respect to small-step semantics.

    This chapter, like the previous chapter [Nondet], omits sequences and
    non-recursive functions, as these features can be encoded. *)

(* ================================================================= *)
(** ** Big-Step Characterization of Partial Correctness *)

(** For total correctness, the judgment [evals s t Q] asserts that any
    execution of the program [(s,t)] terminates on an output satisfying [Q].
    In contrast, the partial correctness judgment [evalnp s t Q] asserts that
    any execution of the program [(s,t)] either terminates on an output
    satisfying [Q], or diverges (that is, executes forever).

    The definition of the predicate [evalnp] is obtained by taking the
    constructors from the inductive definition of [evaln], and considering
    the coinductive interpretation of these constructors. The coinductive
    interpretation allows for infinite derivation. It thereby introduces the
    possibility of diverging executions. Importantly, the predicate [evalnp]
    still disallows executions that get stuck. *)

CoInductive evalnp : state -> trm -> (val->state->Prop) -> Prop :=
  | evalnp_val : forall s v Q,
      Q v s ->
      evalnp s (trm_val v) Q
  | evalnp_fix : forall s f x t1 Q,
      Q (val_fix f x t1) s ->
      evalnp s (trm_fix f x t1) Q
  | evalnp_app_fix : forall s1 v1 v2 f x t1 Q,
      v1 = val_fix f x t1 ->
      evalnp s1 (subst x v2 (subst f v1 t1)) Q ->
      evalnp s1 (trm_app v1 v2) Q
  | evalnp_let : forall Q1 s1 x t1 t2 Q,
      evalnp s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalnp s2 (subst x v1 t2) Q) ->
      evalnp s1 (trm_let x t1 t2) Q
  | evalnp_if : forall s1 b t1 t2 Q,
      evalnp s1 (if b then t1 else t2) Q ->
      evalnp s1 (trm_if (val_bool b) t1 t2) Q
  | evalnp_add : forall s n1 n2 Q,
      Q (val_int (n1 + n2)) s ->
      evalnp s (val_add (val_int n1) (val_int n2)) Q
  | evalnp_rand : forall s n Q,
      n > 0 ->
      (forall n1, 0 <= n1 < n -> Q n1 s) ->
      evalnp s (val_rand (val_int n)) Q
  | evalnp_ref : forall s v Q,
      (forall p, ~ Fmap.indom s p ->
         Q (val_loc p) (Fmap.update s p v)) ->
      evalnp s (val_ref v) Q
  | evalnp_get : forall s p Q,
      Fmap.indom s p ->
      Q (Fmap.read s p) s ->
      evalnp s (val_get (val_loc p)) Q
  | evalnp_set : forall s p v Q,
      Fmap.indom s p ->
      Q val_unit (Fmap.update s p v) ->
      evalnp s (val_set (val_loc p) v) Q
  | evalnp_free : forall s p Q,
      Fmap.indom s p ->
      Q val_unit (Fmap.remove s p) ->
      evalnp s (val_free (val_loc p)) Q.

(** The judgment [hoarenp t H Q] captures partial correctness, in terms of
    [evalnp]. It is defined through the usual pattern for Hoare triples. *)

Definition hoarenp (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
  forall s, H s -> evalnp s t Q.

(** One key property is the covariance of [evalnp], which induces the rule
    of consequence for [hoarenp]. An interesting about the proof of covariance
    is that it is not carried out by induction, like [evaln_conseq], but by
    coinduction. Observe carefully the details of that proof. *)

Lemma evalnp_conseq : forall s t Q1 Q2,
  evalnp s t Q1 ->
  Q1 ===> Q2 ->
  evalnp s t Q2.
Proof using.
  introv M W. unfolds qimpl, himpl.
  gen s t Q1 Q2. cofix IH. intros. inverts M; try solve [ constructors* ].
Qed.

(** **** Exercise: 3 stars, standard, optional (evalnp_inv_eval)

    Assume [evalnp s t Q] to hold. Prove that the postcondition [Q] holds of
    any output that [(s,t)] may evaluate to according to the judgment [eval]. *)

Lemma evalnp_inv_eval : forall s t v s' Q,
  evalnp s t Q ->
  eval s t s' v ->
  Q v s'.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** From Total to Partial Correctness *)

(** Total correctness is a stronger property than partial correctness:
    [hoaren t H Q] entails [hoarenp t H Q]. To formalize this result, we first
    establish that [evaln s t Q], which is defined inductively, entails
    [evalnp s t Q], which is defined coinductively.

    The proof is a straightforward induction, reflecting on the fact that a
    coinductive interpretation of a set of rules is always derivable from an
    inductive interpretation of a same set of derivation rules. *)

Lemma evalnp_of_evaln : forall s t Q,
  evaln s t Q ->
  evalnp s t Q.
Proof using. introv M. induction M; try solve [ constructors* ]. Qed.

Lemma hoaren_of_cohoare : forall t H Q,
  hoaren t H Q ->
  hoarenp t H Q.
Proof using.
  introv M. intros s K. specializes M K. applys evalnp_of_evaln M.
Qed.

(* ================================================================= *)
(** ** Characterization of Divergence *)

(** The judgment partial correctness judgment [evalnp s t Q] asserts that
    any execution of the program [(s,t)] either terminates on an output
    satisfying [Q], or diverge. By instantiating [Q] as the predicate that is
    always false, we are thus able to assert that "every possible execution of
    the program [(s,t)] diverges".

    Let us name [Empty] this "empty" postcondition, which characterizes an
    empty set of output configurations. *)

Definition Empty : val->state->Prop :=
  fun v s => False.

(** The judgment [divn s t], defined as [evalnp s t Empty], asserts that every
    possible execution of the program [(s,t)] diverges. *)

Definition divn (s:state) (t:trm) : Prop :=
  evalnp s t Empty.

(* ================================================================= *)
(** ** Big-Step-Based Reasoning Rules *)

(** For the partial correctness triple ([hoarenp]), we can derive all the usual
    reasoning rules. The proofs are the same as for the reasoning rules for
    deriving total correctness triples ([hoaren]). *)

(** Structural rules *)

Lemma hoarenp_conseq : forall t H' Q' H Q,
  hoarenp t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  hoarenp t H Q.
Proof using.
  unfolds hoarenp. introv M MH MQ HF. applys* evalnp_conseq.
Qed.

Lemma hoarenp_hexists : forall t (A:Type) (J:A->hprop) Q,
  (forall x, hoarenp t (J x) Q) ->
  hoarenp t (hexists J) Q.
Proof using. introv M. intros h (x&Hh). applys M Hh. Qed.

Lemma hoarenp_hpure : forall t (P:Prop) H Q,
  (P -> hoarenp t H Q) ->
  hoarenp t (\[P] \* H) Q.
Proof using.
  introv M. intros h (h1&h2&M1&M2&D&U). destruct M1 as (M1&HP).
  lets E: hempty_inv HP. subst. rewrite Fmap.union_empty_l. applys~ M.
Qed.

(** Rules for term constructs *)

Lemma hoarenp_val : forall v H Q,
  H ==> Q v ->
  hoarenp (trm_val v) H Q.
Proof using. introv M. intros h K. applys* evalnp_val. Qed.

Lemma hoarenp_fix : forall f x t1 H Q,
  H ==> Q (val_fix f x t1) ->
  hoarenp (trm_fix f x t1) H Q.
Proof using. introv M. intros h K. applys* evalnp_fix. Qed.

Lemma hoarenp_app_fix : forall v1 v2 f x t1 H Q,
  v1 = val_fix f x t1 ->
  hoarenp (subst x v2 (subst f v1 t1)) H Q ->
  hoarenp (trm_app v1 v2) H Q.
Proof using. introv E M. intros h K. applys* evalnp_app_fix. Qed.

Lemma hoarenp_let : forall x t1 t2 H Q Q1,
  hoarenp t1 H Q1 ->
  (forall v1, hoarenp (subst x v1 t2) (Q1 v1) Q) ->
  hoarenp (trm_let x t1 t2) H Q.
Proof using. introv M1 M2. intros h K. applys* evalnp_let. Qed.

Lemma hoarenp_if : forall (b:bool) t1 t2 H Q,
  hoarenp (if b then t1 else t2) H Q ->
  hoarenp (trm_if b t1 t2) H Q.
Proof using. introv M. intros h K. applys* evalnp_if. Qed.

(** Rules for primitive operations *)

Lemma hoarenp_add : forall H n1 n2,
  hoarenp (val_add n1 n2)
    H
    (fun r => \[r = val_int (n1 + n2)] \* H).
Proof using.
  intros. intros h K. applys* evalnp_add. rewrite* hstar_hpure_l.
Qed.

Lemma hoarenp_rand : forall n,
  n > 0 ->
  hoarenp (val_rand n)
    \[]
    (fun r => \exists n1, \[0 <= n1 < n] \* \[r = val_int n1]).
Proof using.
  introv N. intros h K. applys* evalnp_rand.
  lets ->: hempty_inv K.
  intros n1 H1. applys* hexists_intro n1. rewrite* hstar_hpure_l.
  split*. applys* hpure_intro.
Qed.

Lemma hoarenp_ref : forall H v,
  hoarenp (val_ref v)
    H
    (fun r => (\exists p, \[r = val_loc p] \* p ~~> v) \* H).
Proof using.
  intros. intros s1 K. applys evalnp_ref. intros p D.
  unfolds update. applys hstar_intro K.
  { applys hexists_intro p. rewrite hstar_hpure_l.
    split*. applys hsingle_intro. }
  { applys* disjoint_single_of_not_indom. }
Qed.

Lemma hoarenp_get : forall H v p,
  hoarenp (val_get p)
    ((p ~~> v) \* H)
    (fun r => \[r = v] \* (p ~~> v) \* H).
Proof using.
  intros. intros s K.
  lets (h1&h2&P1&P2&D&->): hstar_inv (rm K).
  lets E1: hsingle_inv P1. lets I1: indom_single p v.
  applys evalnp_get.
  { applys* Fmap.indom_union_l. subst. applys indom_single. }
  { rewrite hstar_hpure_l. split.
    { subst h1. rewrite* Fmap.read_union_l. rewrite* Fmap.read_single. }
    { applys* hstar_intro. } }
Qed.

Lemma hoarenp_set : forall H w p v,
  hoarenp (val_set (val_loc p) v)
    ((p ~~> w) \* H)
    (fun r => \[r = val_unit] \* (p ~~> v) \* H).
Proof using.
  intros. intros s1 K.
  lets (h1&h2&P1&P2&D&->): hstar_inv (rm K).
  lets E1: hsingle_inv P1. lets I1: indom_single p v.
  applys evalnp_set.
  { applys* Fmap.indom_union_l. subst. applys indom_single. }
  { rewrite hstar_hpure_l. split*.
    { subst h1. rewrite Fmap.update_union_l.
      2:{ applys indom_single. }
      rewrite update_single. applys hstar_intro.
      { applys hsingle_intro. }
      { applys P2. }
      { applys Fmap.disjoint_single_set D. } } }
Qed.

Lemma hoarenp_free : forall H p v,
  hoarenp (val_free (val_loc p))
    ((p ~~> v) \* H)
    (fun r => \[r = val_unit] \* H).
Proof using.
  intros. intros s1 K.
  lets (h1&h2&P1&P2&D&->): hstar_inv (rm K).
  lets E1: hsingle_inv P1. lets I1: indom_single p v.
  applys evalnp_free.
  { applys* Fmap.indom_union_l. subst. applys indom_single. }
  { rewrite hstar_hpure_l. split*.
    { subst h1. rewrite* Fmap.remove_union_single_l.
      { intros Dl. applys* Fmap.disjoint_inv_not_indom_both D Dl. } } }
Qed.

(* ================================================================= *)
(** ** Big-Step-Based Reasoning Rules for Divergence *)

(** In a partial correctness setting, it is also interesting to derive
    reasoning rules for establishing that a program diverges. These rules
    are stated and proved next. *)

Lemma divn_app_fix : forall s1 v1 v2 f x t1,
  v1 = val_fix f x t1 ->
  divn s1 (subst x v2 (subst f v1 t1)) ->
  divn s1 (trm_app v1 v2).
Proof using. introv E M. unfolds divn. applys* evalnp_app_fix. Qed.

(** **** Exercise: 2 stars, standard, especially useful (divn_let_ctx)

    Prove the divergence rule for a let-binding covering the case where the
    first subterm diverges. *)

Lemma divn_let_ctx : forall s1 x t1 t2,
  divn s1 t1 ->
  divn s1 (trm_let x t1 t2).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

Lemma divn_let : forall s1 x t1 t2 Q1,
  evalnp s1 t1 Q1 ->
  (forall s2 v1, divn s2 (subst x v1 t2)) ->
  divn s1 (trm_let x t1 t2).
Proof using. introv M1 M2. unfolds divn. applys* evalnp_let M1. Qed.

Lemma divn_if : forall s1 b t1 t2,
  divn s1 (if b then t1 else t2) ->
  divn s1 (trm_if (val_bool b) t1 t2).
Proof using. introv M. unfolds divn. applys* evalnp_if. Qed.

(* ################################################################# *)
(** * Optional Material *)

(* ================================================================= *)
(** ** Interpretation of [evalnp] w.r.t. [eval] and [safe] *)

(** The predicate [safe s t] asserts that an execution of the configuration
    [t/s] can never get stuck. Its definition is a simplified version of
    [evalnp] where all occurences of [Q] are removed. In the rule for let-
    bindings, namely [safe_let], the quantification over the configuration
    [v1/s2] is done by refering to the big-step judgment [eval]. *)

CoInductive safe : state -> trm -> Prop :=
  | safe_val : forall s v,
      safe s (trm_val v)
  | safe_fix : forall s f x t1,
      safe s (trm_fix f x t1)
  | safe_app_fix : forall s v1 v2 f x t1,
      v1 = val_fix f x t1 ->
      safe s (subst x v2 (subst f v1 t1)) ->
      safe s (trm_app v1 v2)
  | safe_let : forall s x t1 t2,
      safe s t1 ->
      (forall v1 s2, eval s t1 s2 v1 -> safe s2 (subst x v1 t2)) ->
      safe s (trm_let x t1 t2)
  | safe_if : forall s b t1 t2,
      safe s (if b then t1 else t2) ->
      safe s (trm_if (val_bool b) t1 t2)
  | safe_add : forall s n1 n2,
      safe s (val_add (val_int n1) (val_int n2))
  | safe_rand : forall s n,
      n > 0 ->
      safe s (val_rand (val_int n))
  | safe_ref : forall s v,
      safe s (val_ref v)
  | safe_get : forall s p,
      Fmap.indom s p ->
      safe s (val_get (val_loc p))
  | safe_set : forall s p v,
      Fmap.indom s p ->
      safe s (val_set (val_loc p) v)
  | safe_free : forall s p,
      Fmap.indom s p ->
      safe s (val_free (val_loc p)).

Section EvalnpSafe.
Hint Constructors eval evalnp.

(** **** Exercise: 5 stars, standard, especially useful (evalnp_iff_safe_and_post)

    Prove that [evalnp s t Q] is equivalent to the conjunction of [safe s t]
    and to a partial correctness result asserting that if an evaluation of
    [t/s] terminates on a particular result, then this result satisfies [Q].
    Hint: make sure to split the equivalence and the conjunction before
    entering the coinductive proofs. *)

Lemma evalnp_iff_safe_and_post : forall s t Q,
  evalnp s t Q <-> (safe s t /\ (forall v s', eval s t s' v -> Q v s')).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** Let [Any] denotes the postcondition that accepts any result. *)

Definition Any : val->state->Prop :=
  fun v s => True.

Hint Unfold Any.

(** **** Exercise: 2 stars, standard, especially useful (safe_iff_evalnp_any)

    Prove that [safe s t] is equivalent to [evalnp s t Any].
    Hint: a direct proof fails---why?
    The solution is to exploit [evalnp_iff_safe_and_post]. *)

Lemma safe_iff_evalnp_any : forall s t,
  safe s t <-> evalnp s t Any.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

End EvalnpSafe.

(* ================================================================= *)
(** ** Small-Step Characterization of Partial Correctness *)

(** So far, this chapter has focused on handling partial correctness using
    a big-step semantics. In this bonus section, we investigate the treatment
    of partial correctness using a small-step semantics. *)

(** Before we get started, let us state and prove a basic lemma asserting
    that values cannot take a step. It will useful throughout the section. *)

Lemma exists_step_val_inv : forall s v,
  (exists s' t', step s v s' t') ->
  False.
Proof using. introv (s'&t'&S). inverts S. Qed.

(** In the chapter [Nondet], we presented a definition named
    [evals_attempt_3] that defined a small-step characterization of partial
    correctness. Let us rename this definition to [evalnps].

    The judgment [evalnps s t Q] asserts that, for any configuration
    [(s',t')] that can be reached from [(s',t')], either [t'] is a value that,
    together with [s'], satisfy the postcondition [Q]; or the configuration
    [(s',t')] can take a step, that is, it is not a stuck configuration. *)

Definition evalnps (s:state) (t:trm) (Q:val->state->Prop) : Prop :=
  forall s' t', evals s t s' t' ->
       (exists v, t' = trm_val v /\ Q v s')
    \/ (exists s'' t'', step s' t' s'' t'').

(** On top of [evalnps], we define a partial correctness Hoare triple
    judgment [hoarenps] in the usual way. *)

Definition hoarenps (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
  forall s, H s -> evalnps s t Q.

(** The property [evalnps s t Q] may be viewed as a form of typing:
    the configuration [(s,t)] admits the "type" [Q].

    - Base case: if [t] is a value, we assert that a configuration [(s,v)] has
      type [Q] iff [Q v s] holds.

    - Preservation property: if the configuration [(s,t)] has type [Q] and
      reduces to [(s',t')], then the configuration [(s',t')] also admits the
      same type [Q].

    - Progress property: if the configuration [(s,t)] has type [Q], then
      either [t] is of the form [trm_val v] and [(s,v)] admits type [Q],
      or the configuration [(s,t)] can take a reduction step to some
      configuration [(s',t')].

    The progress property is, in essence, a partial correctness
    property. Indeed, it ensures that programs never get stuck, yet without
    imposing termination.

    In what follows, we formally state and prove the three properties
    associated with the judgment [evalnps s t Q]: the characterization of the
    base case, the preservation property, and the progress property. *)

(** First, let's prove an introduction lemma and an inversion lemma for the
    base case, that is, the characteriation of values. *)

Lemma evalnps_val : forall s v Q,
  Q v s ->
  evalnps s v Q.
Proof using.
  introv M R. inverts R as.
  { left*. }
  { intros s1 t1 R1 R2. false. inverts R1. }
Qed.

Lemma evalnps_val_inv : forall s v Q,
  evalnps s v Q ->
  Q v s.
Proof using.
  introv M. forwards N: M s v. { applys evals_refl. }
  destruct N as [(v1&E1&P1)|(s2&t2&R)].
  { inverts* E1. }
  { inverts R. }
Qed.

(** Second, let's prove the preservation property. *)

(** **** Exercise: 3 stars, standard, especially useful (evalnps_inv_step)

    Prove that the property [evalnps] for a given postcondition [Q] is
    preserved when a program takes a reduction step. *)

Lemma evalnps_inv_step : forall s1 t1 s2 t2 Q,
  evalnps s1 t1 Q ->
  step s1 t1 s2 t2 ->
  evalnps s2 t2 Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** Third, let's prove the progress property. *)

(** **** Exercise: 4 stars, standard, especially useful (evalnps_not_val_inv)

    Prove that if the property [evalnps] holds for a given postcondition [Q],
    and for a configuration that has not already reached a value, then this
    configuration can take a step. Moreover, the configuration reached also
    satisfies the property [evalnps] for that same [Q]. *)

Lemma evalnps_not_val_inv : forall s1 t1 Q,
  evalnps s1 t1 Q ->
  (forall v, t1 <> trm_val v) ->
  exists s2 t2, step s1 t1 s2 t2 /\ evalnps s2 t2 Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Reasoning Rules w.r.t. Small-Step Characterization *)

(** We present two proofs of reasoning rules established with respect to the
    judgment [hoarenps]. The first proof targets the rule of consequence. This
    result leverages the covariance property for [evalnps]. *)

Lemma evalnps_conseq : forall s t Q Q',
  evalnps s t Q' ->
  Q' ===> Q ->
  evalnps s t Q.
Proof using.
  introv M WQ. introv R. lets [(v&E&P)|N]: M R.
  { left. exists v. split~. applys* WQ. }
  { right*. }
Qed.

Lemma hoarenps_conseq : forall t H' Q' H Q,
  hoarenps t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  hoarenps t H Q.
Proof using.
  introv M WH WQ. intros h K. applys evalnps_conseq WQ.
  applys M. applys WH K.
Qed.

(** The second proof targets the reasoning rule for let-bindings, stated
    for the judgment [hoarenps]. This result leverages as key intermediate
    lemma an introduction rule for let-bindings with respect to [evalnps]. *)

(** **** Exercise: 5 stars, standard, especially useful (evalnps_let)

    Prove the reasoning rule for let-bindings for [evalnps].
    Hint: in the proof, you can use [tests C: (exists v1, t1 = trm_val v1)]
    to make a case analysis on whether [t1] is a value or not. *)

Lemma evalnps_let : forall s x t1 t2 Q1 Q,
  evalnps s t1 Q1 ->
  (forall s1 v1, Q1 v1 s1 -> evalnps s1 (subst x v1 t2) Q) ->
  evalnps s (trm_let x t1 t2) Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

Lemma hoarenps_let : forall x t1 t2 H Q Q1,
  hoarenps t1 H Q1 ->
  (forall v1, hoarenps (subst x v1 t2) (Q1 v1) Q) ->
  hoarenps (trm_let x t1 t2) H Q.
Proof using.
  introv M1 M2. intros h K. applys* evalnps_let.
  { introv K'. applys* M2. }
Qed.

(* ================================================================= *)
(** ** Small-Step Characterization of Divergence *)

(** Recall the definition of [evalnps].

    Definition evalnps (s:state) (t:trm) (Q:val->state->Prop) : Prop :=
      forall s' t', evals s t s' t' ->
           (exists v, t' = trm_val v /\ Q v s')
        \/ (exists s'' t'', step s' t' s'' t'').

    The judgment [evalnps s t Q] can be specialized with the empty post-
    condition [Q := Empty] to express divergence, just like we did earlier on
    for setting up the definition of [divn].

    Recall that [Empty v s] is equivalent to [False]. Thus, let's take the
    definition of [evalnps s t Q] and replace [Q v s'] with [False]. The
    first clause of the disjunction, [exists v, t' = trm_val v /\ Q v s']
    is never satisfiable and thus may be removed. What remains is a simpler,
    direct characterization of the property that "all executions diverge".

    The corresponding predicate, named [divns s t] below, asserts that any
    execution prefix can be extended by at least one step. *)

Definition divns (s:state) (t:trm) : Prop :=
  forall s' t', evals s t s' t' ->
  exists s'' t'', step s' t' s'' t''.

(** **** Exercise: 3 stars, standard, optional (divns_iff_evalnps_Empty)

    Prove the equivalence between [divns] and the specialization
    of [evalnps] to [Empty]. *)

Lemma divns_iff_evalnps_Empty : forall s t,
  divns s t <-> evalnps s t Empty.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** The three exercises that follow can be proved trivially by exploiting
    the equivalence [divns_iff_evalnps_Empty] then exploiting the already
    established properties of [evalnps]. However, it is interesting to
    know how to carry out proofs directly with respect to the definition
    [divns]. *)

(** **** Exercise: 2 stars, standard, optional (divns_inv_step)

    Prove that if a diverging configuration takes a step, then it reaches a
    configuration that also diverges. *)

Lemma divns_inv_step : forall s1 t1 s2 t2,
  divns s1 t1 ->
  step s1 t1 s2 t2 ->
  divns s2 t2.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 2 stars, standard, optional (divns_val_inv)

    Prove that the execution of a value does not diverge. *)

Lemma divns_val_inv : forall s v,
  ~ divns s v.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 5 stars, standard, optional (divns_let_ctx)

    Prove the divergence rule for a let-binding covering the case where the
    first subterm diverges, with respect to the definition [divns]. *)

Lemma divns_let_ctx : forall s1 x t1 t2,
  divns s1 t1 ->
  divns s1 (trm_let x t1 t2).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Coinductive, Small-Step Characterization of Partial Correctness *)

(** In the previous section, we characterized partial correctness using the
    judgment [evalnps], which is defined in terms of the transitive closure
    of the small-step relation [evals]. In this section, we present an
    alternative definition, based on a coinductive definition.

    Concretely, we start from the inductively defined judgment [evalns],
    which characterizes total correctness, and we consider the coinductive
    intrepretation of the same rules. The resulting judgment is written
    [evalnpz s t Q]. This coinductive definition, because it allows for
    infinite derivations, covers the case of diverging computations that
    take involve infinitely many reduction steps. *)

CoInductive evalnpz : state->trm->(val->hprop)->Prop :=
  | evalnpz_val : forall s v Q,
      Q v s ->
      evalnpz s v Q
  | evalnpz_step : forall s t Q,
      (exists s' t', step s t s' t') ->
      (forall s' t', step s t s' t' -> evalnpz s' t' Q) ->
      evalnpz s t Q.

(** We name [hoarenpz] the associated Hoare triple definition. *)

Definition hoarenpz (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
  forall s, H s -> evalnpz s t Q.

(** Here again, we focus on the proofs of two particular reasoning rules,
    established with respect to [evalnpz]. *)

(** Firstly, let's prove the rule of consequence. The key intermediate result is
    to establish the covariance of [evalnpz]. Observe that this proof is to
    be conducted by coinduction. *)

Lemma evalnpz_conseq : forall s t Q Q',
  evalnpz s t Q' ->
  Q' ===> Q ->
  evalnpz s t Q.
Proof using.
  introv M WQ. gen s t Q'. cofix IH; intros. destruct M.
  { applys evalnpz_val. applys* WQ. }
  { applys evalnpz_step.
    { eauto. }
    { introv R'. lets M': H0 R'. applys IH M' WQ. } }
Qed.

Lemma hoarenpz_conseq : forall t H' Q' H Q,
  hoarenpz t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  hoarenpz t H Q.
Proof using.
  introv M WH WQ. intros h K. applys evalnpz_conseq WQ.
  applys M. applys WH K.
Qed.

(** Secondly, we let's prove the reasoning rule for let-bindings. Here again,
    the key intermediate result is to establish a rule for [evalnpz]. *)

(** **** Exercise: 5 stars, standard, especially useful (hoarenpz_let)

    Prove the reasoning rule for let-bindings stated for [evalnpz].
    Hint: to set up the coinductive proof, follow the template that appears
    at the beginning of the proof of [evalnpz_conseq]. *)

Lemma evalnpz_let : forall s x t1 t2 Q1 Q,
  evalnpz s t1 Q1 ->
  (forall s1 v1, Q1 v1 s1 -> evalnpz s1 (subst x v1 t2) Q) ->
  evalnpz s (trm_let x t1 t2) Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

Lemma hoarenpz_let : forall x t1 t2 H Q Q1,
  hoarenpz t1 H Q1 ->
  (forall v1, hoarenpz (subst x v1 t2) (Q1 v1) Q) ->
  hoarenpz (trm_let x t1 t2) H Q.
Proof using.
  introv M1 M2. intros h K. applys* evalnpz_let.
  { introv K'. applys* M2. }
Qed.

(** To express diverge, the judgment [evalnp s t Q] may be specialized with
    the postcondition [Q := Empty]. Starting from the definition of
    [evalnpz], replacing [Q v s] with [False] is equivalent to removing
    the constructor [evalnpz_val] altogether. Thus, divergence of a
    configuration [(s,t)] may be characterized directly by the coinductive
    judgment [divnz s t] defined below, featuring a single constructor. *)

CoInductive divnz : state -> trm -> Prop :=
  | divnz_step : forall s1 t1,
      (exists s2 t2, step s1 t1 s2 t2) ->
      (forall s2 t2, step s1 t1 s2 t2 -> divnz s2 t2) ->
      divnz s1 t1.

(** **** Exercise: 4 stars, standard, optional (divnz_iff_evalnpz_Empty)

    Prove the equivalence between [divnz] and the specialization of the
    judgment [evalnp] to [Empty]. *)

Lemma divnz_iff_evalnpz_Empty : forall s t,
  divnz s t <-> evalnpz s t Empty.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Equivalence Between the Two Small-Step Charact. of Partial Correctness *)

(** This section establishes that [hoarenpz] is equivalent to [hoarenps].
    The key result is to prove [evalnpz] equivalent to [evalnps]. *)

Lemma evalnpz_eq_evalnps :
  evalnpz = evalnps.
Proof using.
  extens. intros s t Q. iff M.
  { introv R. gen M. induction R; intros.
    { inverts M as M1 M2.
      { left*. }
      { right. applys M1. } }
    { rename H into R1, R into R2. inverts M as M1 M2.
      { false. inverts R1. }
      { applys IHR. applys M2 R1. } } }
  { gen s t Q. cofix IH. intros.
    tests C: (exists v, t = trm_val v).
    { destruct C as (v&->). applys evalnpz_val. applys evalnps_val_inv M. }
    { lets (s2&t2&R2&RS): evalnps_not_val_inv M C. applys evalnpz_step.
      { exists* s2 t2. }
      { intros s' t' R'. applys IH. applys evalnps_inv_step M R'. } } }
Qed.

Lemma hoarenpz_eq_hoarenps :
  hoarenpz = hoarenps.
Proof using. unfold hoarenps, hoarenpz. rewrite* evalnpz_eq_evalnps. Qed.

(** As a corollary, we can establish the equivalence between the two small-step
    characterization of divergence. Indeed, both characterizations are obtained
    by specializing the postcondition of their underlying evaluation jugment to
    the empty postcondition, namely [Empty]. *)

Lemma divnz_eq_divns :
  divnz = divns.
Proof using.
  extens. intros s t.
  rewrite divns_iff_evalnps_Empty.
  rewrite divnz_iff_evalnpz_Empty.
  rewrite* evalnpz_eq_evalnps.
Qed.

(* ================================================================= *)
(** ** Equivalence Between Small-Step and Big-Step Partial Correctness Semantics *)

(** We end this chapter with the proof of equivalence between [hoarenps] and
    [hoarenp], establishing a formal relationship between partial correctness
    triples defined with respect to a small-step semantics and those defined
    with respect to a big-step semantics.

    The first step of the proof is to formally relate [evalnpz] and [evalnp],
    which are both defined coinductively. Then, we can derive the equality
    between [hoarenpz] and [hoarenp], and conclude using the equality
    [hoarenpz_eq_hoarenps], which was established earlier on. *)

(** The first direction is from [evalnpz] to [evalnp]. To establish it, we
    need 3 inversion lemmas for let-bindings. *)

Lemma evalnpz_let_inv_ctx : forall x s1 t1 t2 Q Q1,
  evalnpz s1 (trm_let x t1 t2) Q ->
  (fun v s => evals s1 t1 s v) ===> Q1 ->
  evalnpz s1 t1 Q1.
Proof using.
  cofix IH. introv M WQ. inverts M as M0 M'.
  tests C: (exists v1, t1 = trm_val v1).
  { destruct C as (v1&->). applys evalnpz_val.
    applys WQ. applys evals_refl. }
  { applys evalnpz_step.
    { destruct M0 as (s'&t'&S). inverts S as. 2:{ false* C. }
      intros S. exists. applys S. }
    { intros s2 t1' S. applys IH.
      { applys M'. applys step_let_ctx S. }
      { intros v s R. applys WQ. applys evals_step S R. } } }
Qed.

Lemma evalnpz_let_inv_cont : forall s1 s2 v1 x t1 t2 Q,
  evalnpz s1 (trm_let x t1 t2) Q ->
  evals s1 t1 s2 v1 ->
  evalnpz s2 (subst x v1 t2) Q.
Proof using.
  introv M R. gen_eq t1': (trm_val v1). induction R; intros; subst.
  { inverts M as _ M'. applys M'. applys step_let. }
  { rename H into S, R into R', t0 into t1'.
    inverts M as _ M'. applys* IHR. applys M'.
    applys step_let_ctx S. }
Qed.

Lemma evalnpz_let_inv : forall s1 x t1 t2 Q,
  evalnpz s1 (trm_let x t1 t2) Q ->
  exists Q1, evalnpz s1 t1 Q1
          /\ (forall v1 s2, Q1 v1 s2 -> evalnpz s2 (subst x v1 t2) Q).
Proof using.
  introv M. exists (fun v s => evals s1 t1 s (trm_val v)). split.
  { applys* evalnpz_let_inv_ctx M. }
  { introv K. applys* evalnpz_let_inv_cont M K. }
Qed.

(** Using these inversion lemmas, we can prove by induction the first
    direction, from [evalnpz] to [evalnp]. *)

Lemma evalnp_of_evalnpz : forall s t Q,
  evalnpz s t Q ->
  evalnp s t Q.
Proof using.
  cofix IH. introv M. destruct t; try solve [ inverts M; false_invert ].
  { inverts M as.
    { intros R. applys evalnp_val R. }
    { intros (s'&t'&S) _. inverts S. } }
  { inverts M as.
    { intros (s'&t'&S) _. inverts S. } }
  { inverts M as (s'&t'&S) M'. inverts S. } (* not included in semantics *)
  { rename v into f, v0 into x, t into t1.
    inverts M as (s'&t'&S) M1. inverts S.
    applys evalnp_fix.
    forwards M1': M1. { applys step_fix. }
    inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
  { inverts M as (s'&t'&S) M1. inverts S as.
    { applys evalnp_app_fix. { reflexivity. } applys IH.
      applys M1. applys* step_app_fix. }
    { applys evalnp_add.
      forwards M1': M1. { applys step_add. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv N. applys* evalnp_rand. { math. }
      intros n1' N1.
      forwards M1': M1. { applys* step_rand n1'. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_ref. intros p' D'.
      forwards M1': M1. { applys* step_ref p'. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_get.
      forwards M1': M1. { applys* step_get. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_set.
      forwards M1': M1. { applys* step_set. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_free.
      forwards M1': M1. { applys* step_free. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } } }
  { inverts M as (s'&t'&S) M'. inverts S. } (* not included in semantics *)
  { lets (Q1&M1&M2): evalnpz_let_inv M. applys evalnp_let.
    { applys IH. applys M1. }
    { introv R. applys IH. applys M2 R. } }
  { inverts M as (s'&t'&S) M1. inverts S. applys evalnp_if.
    applys IH. applys M1. applys step_if. }
Qed.

(** For the reciprocal direction, we also need one key inversion lemma. It
    is stated below. Its hypothesis is [evalnp s t Q], and its conclusion
    corresponds to the disjunction of the constructors of the inductive
    definition of [evalnpz s t Q]. *)

Lemma evalnp_inv_step : forall s t Q,
  evalnp s t Q ->
     (exists v, t = trm_val v /\ Q v s)
  \/ ((exists s' t', step s t s' t' /\ evalnp s' t' Q)
      /\ (forall s' t', step s t s' t' -> evalnp s' t' Q)).
Proof using.
  introv M. gen s Q. induction t; intros; inverts M as.
  { introv R. left. eauto. }
  { introv R. right. split.
    { exists. split. { applys step_fix. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S. applys* evalnp_val. } }
  { introv M1. right. split.
    { exists. split. { applys* step_app_fix. } { auto. } }
    { intros s' t' S. inverts S as E. inverts E. auto. } }
  { introv R. right. split.
    { exists. split. { applys step_add. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S. applys* evalnp_val. } }
  { introv N R. right. split.
    { exists. split. { applys* step_rand 0. math. }
       { applys* evalnp_val. applys R. math. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv R. right. split.
    { forwards~ (p&D&N): (exists_fresh null s).
      exists. split. { applys* step_ref. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv D R. right. split.
    { exists. split. { applys* step_get. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv D R. right. split.
    { exists. split. { applys* step_set. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv D R. right. split.
    { exists. split. { applys* step_free. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv M1 M2. rename v into x. right. split.
    { forwards [(v1&->&HQ1)|((s'&t'&S'&M')&_)]: IHt1 M1.
      { exists. split. { applys step_let. } { applys* M2. } }
      { exists. split.
        { applys step_let_ctx S'. }
        { applys evalnp_let M'. applys M2. } } }
    { intros s' t' S. inverts S as S.
      { forwards [(v1&->&HQ1)|(_&M3)]: IHt1 M1.
        { inverts S. }
        { specializes M3 S. applys evalnp_let M3 M2. } }
      { inverts M1 as R. applys* M2. } } }
  { introv M1. right. split.
    { exists. split. { applys step_if. } { auto. } }
    { intros s' t' S. inverts S. auto. } }
Qed.

(** Using this inversion lemma, it is straightforward to derive the
    implication from [evalnp] to [evalnpz]. *)

Lemma evalnpz_of_coeval : forall s t Q,
  evalnp s t Q ->
  evalnpz s t Q.
Proof.
  cofix IH. introv M. lets C: evalnp_inv_step M.
  destruct C as [(v&->&HQ)|((s'&t'&S&M1)&M2)].
  { applys evalnpz_val HQ. }
  { applys evalnpz_step.
    { exists. applys S. }
    { intros s1 t1 S'. applys IH. applys M2 S'. } }
Qed.

(** Combining the two directions yields the equality between [evalnpz] and
    [evalnp], and that between [evalnps] and [evalnp]. *)

Lemma evalnpz_eq_evalnp :
   evalnpz = evalnp.
Proof using.
  extens. intros s t Q. iff M.
  { applys* evalnp_of_evalnpz. }
  { applys* evalnpz_of_coeval. }
Qed.

Lemma hoarenpcso_eq_hoarenp :
  hoarenpz = hoarenp.
Proof using. unfold hoarenp, hoarenpz. rewrite* evalnpz_eq_evalnp. Qed.

Lemma hoarenps_eq_hoarenp :
   hoarenps = hoarenp.
Proof using.
  rewrite <- hoarenpz_eq_hoarenps. rewrite* hoarenpcso_eq_hoarenp.
Qed.

(** As another corollary, we can establish the equivalence between the big-step
    and the small-step characterization of divergence. Indeed, both are
    obtained by specializing the postcondition to [Empty]. *)

Lemma divns_eq_divn :
  divns = divn.
Proof using.
  extens. intros s t. unfold divn.
  rewrite divns_iff_evalnps_Empty.
  rewrite <- evalnpz_eq_evalnp.
  rewrite* evalnpz_eq_evalnps.
Qed.

(* ================================================================= *)
(** ** Historical Notes *)

(** Many program verification tools target partial correctness only, or provide
    separate tooling for justifying termination.

    The soundness of program logics delivering partial correctness is nearly
    always justified with respect to a small-step semantics of the programming
    language. Partial correctness is generally chosen because it appears better
    suited for reasoning about programs that involve some amount of
    concurrency, and for programs that are not meant to terminate (e.g., system
    kernels).

    Capturing partial correctness using a coinductive big-step judgment, as done
    in this chapter with the predicate [evalnp], appears to be novel as of Jan.
    2021. *)

(* 2022-08-08 17:28 *)


Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.AsciiOpt.
Require Import
        Bedrock.Word
        Coq.Strings.Ascii
        Coq.Strings.String.

Section String.
  (* this has an exact idential structure to _FixList_ *)
  Context {A : Type}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Fixpoint format_string (xs : string) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    match xs with
    | EmptyString => ret (mempty, ce)
    | String x xs' => `(b1, env1) <- format_ascii x ce;
                      `(b2, env2) <- format_string xs' env1;
                      ret (mappend b1 b2, env2)
    end%comp.

    Fixpoint encode_string (xs : string) (ce : CacheFormat) : B * CacheFormat :=
    match xs with
    | EmptyString => (mempty, ce)
    | String x xs' => let (b1, env1) := encode_ascii x ce in
                      let (b2, env2) := encode_string xs' env1 in
                          (mappend b1 b2, env2)
    end.

  Fixpoint decode_string (s : nat) (b : B) (cd : CacheDecode) : option (string * B * CacheDecode) :=
    match s with
    | O => Some (EmptyString, b, cd)
    | S s' => `(x, b1, e1) <- decode_ascii b cd;
              `(xs, b2, e2) <- decode_string s' b1 e1;
              Some (String x xs, b2, e2)
    end.

  Local Opaque format_ascii.
  Local Opaque encode_ascii.

  Theorem String_decode_correct
          {P : CacheDecode -> Prop}
    : forall sz
             (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b))),
      CorrectDecoder
        monoid
        (fun ls => length ls = sz)
        (fun _ _ => True)
        format_string (decode_string sz) P.
  Proof.
    split.
    { intros env env' xenv l l' ext ? Eeq Ppred Ppred_rest Penc.
      subst.
      generalize dependent env.
      revert env' xenv l' env_OK.
      induction l.
      { intros.
        inversion Penc; subst; clear Penc.
        rewrite mempty_left; eexists; intuition eauto.  }
      { intros.
        simpl in *.
        unfold Bind2 in *; computes_to_inv; subst.
        injection Penc''; intros; subst.
        destruct v; destruct v0.
        destruct (proj1 (Ascii_decode_correct P_OK) _ _ _ _ _ (mappend b0 ext) env_OK Eeq I I Penc) as [? [? [? xenv_OK] ] ].
      simpl. rewrite <- mappend_assoc, H; simpl.
      destruct (IHl _ _ _ xenv_OK _ H0 Penc') as [? [? ?] ].
      rewrite H1; simpl; eexists; eauto.
      }
    }
    { induction sz; simpl; intros.
      { injections; repeat eexists; eauto using mempty_left. }
      { destruct (decode_ascii bin env') as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate.
        destruct (decode_string sz b c) as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate; injections.
        eapply (proj2 (Ascii_decode_correct P_OK)) in Heqo; eauto;
          destruct Heqo as [? [? ?] ]; destruct_ex; intuition; subst;
            eapply IHsz in Heqo0; eauto; destruct Heqo0 as [? [? ?] ];
              destruct_ex; intuition; subst.
        simpl.
        eexists; eexists; intuition eauto.
        computes_to_econstructor; eauto.
        computes_to_econstructor; eauto.
        rewrite mappend_assoc; reflexivity.
      }
    }
  Qed.

  Definition decode_string_with_term_char
           (term_char : Ascii.ascii)
           (b : B) (cd : CacheDecode)
    : option (string * B * CacheDecode).
    refine (Fix well_founded_lt_b
           (fun _ => CacheDecode -> option (string * B * CacheDecode))
      (fun b rec cd =>
         (`(a, b1, e1) <- Decode_w_Measure_lt decode_ascii b cd _;
      If ascii_dec a term_char Then
        Some (EmptyString, proj1_sig b1, e1)
      Else
      (`(xs, b2, e2) <- rec _ (proj2_sig b1) e1;
      Some (String a xs, b2, e2)))) b cd).
    exact ascii_decode_lt.
  Defined.

  Definition format_string_with_term_char
             (term_char : Ascii.ascii)
             (xs : string) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    format_string (xs ++ (String term_char EmptyString)) ce.

  Theorem String_decode_with_term_char_correct
          {P : CacheDecode -> Prop}
    : forall term_char (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b))),
      CorrectDecoder
        monoid
        (fun s => forall s1 s2, s <> s1 ++ String term_char s2)%string
        (fun _ _ => True)
        (format_string_with_term_char term_char)
        (decode_string_with_term_char term_char) P.
  Proof.
    split.
    { intros env env' xenv s s' ext ? Eeq Ppred Ppred_rest Penc.
      subst.
      generalize dependent env.
      revert env' xenv s' env_OK.
      induction s.
      { intros.
        unfold format_string_with_term_char in Penc.
        unfold decode_string_with_term_char.
        simpl in Penc; unfold Bind2 in *; computes_to_inv; subst; simpl in *.
        rewrite mempty_right in Penc''; inversion Penc''; subst.
        destruct v; simpl in *.
        eapply Ascii_decode_correct in Penc; eauto.
        destruct Penc; intuition.
        eexists; rewrite Init.Wf.Fix_eq.
        eapply Decode_w_Measure_lt_eq in H0; destruct_ex.
        rewrite H0; simpl.
        destruct (ascii_dec term_char term_char); simpl; try congruence.
        eauto.
        intros.
        repeat (apply functional_extensionality; intros; f_equal).
        rewrite H1; reflexivity.
      }
      { intros.
        unfold format_string_with_term_char in Penc;
          unfold decode_string_with_term_char.
        simpl in *.
        unfold Bind2 in *; computes_to_inv; subst.
        injection Penc''; intros; subst.
        destruct v; destruct v0.
        destruct (proj1 (Ascii_decode_correct P_OK) _ _ _ _ _ (mappend b0 ext) env_OK Eeq I I Penc) as [? [? [? xenv_OK] ] ].
      simpl.
      unfold format_string_with_term_char in IHs.
      simpl in Penc'; eapply IHs in Penc'.
      destruct Penc'; intuition.
      eexists; rewrite Init.Wf.Fix_eq.
      eapply Decode_w_Measure_lt_eq in H; destruct_ex.
      rewrite <- mappend_assoc, H; simpl.
      destruct (ascii_dec a term_char); simpl.
      - elimtype False.
        subst; eapply (Ppred "")%string; simpl; reflexivity.
      - intuition.
        unfold decode_string_with_term_char in H2.
        rewrite H2; simpl; eauto.
        eauto.
        eauto.
      - intros; repeat (apply functional_extensionality; intros; f_equal).
        rewrite H3; reflexivity.
      - unfold not; intros; eapply (Ppred (String a s1) s2); simpl; congruence.
      - eauto.
      - eauto.
      }
    }
    { unfold decode_string_with_term_char, format_string_with_term_char;
        intros env env' xenv' data bin;
        revert env env' xenv' data.
      eapply (@well_founded_induction _ _ well_founded_lt_b) with
      (a := bin); intros.
      rewrite Coq.Init.Wf.Fix_eq in H2; auto; simpl.
      apply DecodeBindOpt2_inv in H2;
        destruct H2 as [? [? [? [? ?] ] ] ]; injections; subst.
      destruct (decode_ascii x env') as [ [ [? ?] ?] | ] eqn: ? .
      - destruct (Decode_w_Measure_lt_eq _ _ _ ascii_decode_lt Heqo).
        rewrite H4 in H2; injections.
        destruct (ascii_dec x0 term_char) eqn: ?; simpl in H3.
        + injections.
          eapply (proj2 (Ascii_decode_correct P_OK)) in Heqo; eauto;
            destruct Heqo as [? [? ?] ]; destruct_ex; intuition; subst.
          simpl.
          eexists _, _; intuition.
          computes_to_econstructor; eauto.
          computes_to_econstructor; eauto.
          simpl; rewrite mempty_right; eauto.
          destruct s1; simpl in *; discriminate.
          eauto.
        + eapply (proj2 (Ascii_decode_correct P_OK)) in Heqo; eauto;
            destruct Heqo as [? [? ?] ]; destruct_ex.
          symmetry in H3; apply DecodeBindOpt2_inv in H3;
            destruct H3 as [? [? [? [? ?] ] ] ]; injections; subst.
          eapply H in H3; intuition.
          destruct_ex; intuition; subst; eauto.
          eexists _, _; intuition.
          simpl.
          computes_to_econstructor; eauto.
          computes_to_econstructor; eauto.
          simpl; rewrite mappend_assoc; eauto.
          destruct s1; simpl in *; injections; intros; congruence.
          simpl; eauto.
          simpl; eauto.
      - eapply Decode_w_Measure_lt_eq' in Heqo; rewrite Heqo in H2;
          discriminate.
      - intros; repeat (apply functional_extensionality; intros; f_equal).
        rewrite H3; reflexivity.
    }
  Qed.

End String.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj10synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (plus lv1 lv2)) (plus (plus lv1 lv0) lv2)).
Admitted.
QuickChick conj10synthconj5.


(** studies coproducts in the categories on which is being acted in actegories

author: Ralph Matthes, 2023
 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.
Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.
Require Import UniMath.CategoryTheory.Actegories.ProductActegory.
Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories.
(* Require Import UniMath.CategoryTheory.coslicecat. *)
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.ProductCategory.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
(* Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. *)

Local Open Scope cat.

Import BifunctorNotations.
Import MonoidalNotations.
Import ActegoryNotations.

Section FixAMonoidalCategory.

  Context {V : category} (Mon_V : monoidal V). (** given the monoidal category that acts upon categories *)

Section BinaryCoproduct.

  Context {C : category} (BCP : BinCoproducts C) (Act : actegory Mon_V C).

  Definition actegory_bincoprod_antidistributor : ∏ (a : V) (c c' : C),
      BCP (leftwhiskering_functor Act a c) (leftwhiskering_functor Act a c') --> leftwhiskering_functor Act a (BCP c c')
    := bifunctor_bincoprod_antidistributor BCP BCP Act.

  Lemma actegory_bincoprod_antidistributor_nat_left (v : V) (cd1 cd2 : category_binproduct C C) (g : cd1 --> cd2) :
    actegory_bincoprod_antidistributor v (pr1 cd1) (pr2 cd1) · v ⊗^{Act}_{l} #(bincoproduct_functor BCP) g =
    #(bincoproduct_functor BCP) (v ⊗^{actegory_binprod Mon_V Act Act}_{l} g) · actegory_bincoprod_antidistributor v (pr1 cd2) (pr2 cd2).
  Proof.
    apply bincoprod_antidistributor_nat_left.
  Qed.

  Lemma actegory_bincoprod_antidistributor_nat_right (v1 v2 : V) (cd : category_binproduct C C) (f : v1 --> v2) :
    actegory_bincoprod_antidistributor v1 (pr1 cd) (pr2 cd) · f ⊗^{ Act}_{r} bincoproduct_functor BCP cd  =
    #(bincoproduct_functor BCP) (f ⊗^{ actegory_binprod Mon_V Act Act}_{r} cd) · actegory_bincoprod_antidistributor v2 (pr1 cd) (pr2 cd).
  Proof.
    apply bincoprod_antidistributor_nat_right.
  Qed.

  Lemma bincoprod_antidistributor_pentagon_identity (v w : V) (cd : category_binproduct C C) :
    # (bincoproduct_functor BCP) aα^{actegory_binprod Mon_V Act Act}_{v, w, cd} ·
                                      actegory_bincoprod_antidistributor v (w ⊗_{Act} pr1 cd) (w ⊗_{ Act} pr2 cd) ·
                                      v ⊗^{Act}_{l} actegory_bincoprod_antidistributor w (pr1 cd) (pr2 cd) =
      actegory_bincoprod_antidistributor (v ⊗_{Mon_V} w) (pr1 cd) (pr2 cd)
        · aα^{Act}_{v, w, bincoproduct_functor BCP cd}.
  Proof.
    etrans.
    { rewrite assoc'.
      apply postcompWithBinCoproductArrow. }
    etrans.
    2: { apply pathsinv0, postcompWithBinCoproductArrow. }
    apply maponpaths_12.
    - etrans.
      { repeat rewrite assoc.
        apply cancel_postcomposition.
        rewrite assoc'.
        apply maponpaths.
        apply BinCoproductIn1Commutes. }
      etrans.
      2: { apply actegory_actornatleft. }
      rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply pathsinv0, (functor_comp (leftwhiskering_functor Act v)). }
      apply maponpaths.
      apply BinCoproductIn1Commutes.
    - etrans.
      { repeat rewrite assoc.
        apply cancel_postcomposition.
        rewrite assoc'.
        apply maponpaths.
        apply BinCoproductIn2Commutes. }
      etrans.
      2: { apply actegory_actornatleft. }
      rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply pathsinv0, (functor_comp (leftwhiskering_functor Act v)). }
      apply maponpaths.
      apply BinCoproductIn2Commutes.
  Qed.

  Lemma bincoprod_antidistributor_triangle_identity (cd : category_binproduct C C) :
    #(bincoproduct_functor BCP) au^{actegory_binprod Mon_V Act Act}_{cd} =
      actegory_bincoprod_antidistributor I_{Mon_V} (pr1 cd) (pr2 cd) · au^{Act}_{bincoproduct_functor BCP cd}.
  Proof.
    etrans.
    2: { apply pathsinv0, postcompWithBinCoproductArrow. }
    cbn. unfold BinCoproductOfArrows.
    apply maponpaths_12; apply pathsinv0, actegory_unitornat.
  Qed.

  Lemma actegory_bincoprod_antidistributor_commutes_with_associativity_of_coproduct (v : V) (c d e : C) :
    #(bincoproduct_functor BCP) (catbinprodmor (actegory_bincoprod_antidistributor v c d) (identity (v ⊗_{Act} e))) ·
      actegory_bincoprod_antidistributor v (BCP c d) e ·
      v ⊗^{Act}_{l} bincoprod_associator_data BCP c d e =
    bincoprod_associator_data BCP (v ⊗_{Act} c) (v ⊗_{Act} d) (v ⊗_{Act} e) ·
      #(bincoproduct_functor BCP) (catbinprodmor (identity (v ⊗_{Act} c)) (actegory_bincoprod_antidistributor v d e)) ·
      actegory_bincoprod_antidistributor v c (BCP d e).
  Proof.
    apply bincoprod_antidistributor_commutes_with_associativity_of_coproduct.
  Qed.

  Definition actegory_bincoprod_distributor_data : UU := bifunctor_bincoprod_distributor_data BCP BCP Act.
  Identity Coercion actegory_bincoprod_distributor_data_coercion: actegory_bincoprod_distributor_data >-> bifunctor_bincoprod_distributor_data.

  Definition actegory_bincoprod_distributor_iso_law (δ : actegory_bincoprod_distributor_data) : UU :=
    bifunctor_bincoprod_distributor_iso_law BCP BCP Act δ.
  Definition actegory_bincoprod_distributor : UU := bifunctor_bincoprod_distributor BCP BCP Act.

  Definition actegory_bincoprod_distributor_to_data (δ : actegory_bincoprod_distributor) : actegory_bincoprod_distributor_data := pr1 δ.
  Coercion actegory_bincoprod_distributor_to_data : actegory_bincoprod_distributor >-> actegory_bincoprod_distributor_data.

  Definition bincoprod_functor_lineator_data (δ : actegory_bincoprod_distributor) :
    lineator_data Mon_V (actegory_binprod Mon_V Act Act) Act (bincoproduct_functor BCP).
  Proof.
    intros v cd.
    exact (δ v (pr1 cd) (pr2 cd)).
  Defined.

  Definition bincoprod_functor_lineator_strongly (δ : actegory_bincoprod_distributor) :
    lineator_strongly _ _ _ _ (bincoprod_functor_lineator_data δ).
  Proof.
    intros v cd.
    exists (actegory_bincoprod_antidistributor v (pr1 cd) (pr2 cd)).
    apply (pr2 δ v).
  Defined.

  Lemma bincoprod_functor_lineator_laxlaws (δ : actegory_bincoprod_distributor) :
    lineator_laxlaws _ _ _ _ (bincoprod_functor_lineator_data δ).
  Proof.
    red; repeat split.
    - red.
      intros v cd1 cd2 g.
      apply (z_iso_inv_to_right _ _ _ _ (_,,bincoprod_functor_lineator_strongly δ v _)).
      rewrite assoc'.
      apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly δ v _)).
      apply (bincoprod_antidistributor_nat_left _ _ Act).
    - red.
      intros v1 v2 cd f.
      apply (z_iso_inv_to_right _ _ _ _ (_,,bincoprod_functor_lineator_strongly δ _ _)).
      rewrite assoc'.
      apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly δ _ _)).
      apply (bincoprod_antidistributor_nat_right _ _ Act).
    - red.
      intros v w cd.
      apply pathsinv0, (z_iso_inv_to_right _ _ _ _ (_,,bincoprod_functor_lineator_strongly δ _ _)).
      rewrite assoc'.
      apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly δ _ _)).
      rewrite assoc.
      apply (z_iso_inv_to_right _ _ _ _ (functor_on_z_iso (leftwhiskering_functor Act v)
                                           (_,,bincoprod_functor_lineator_strongly δ _ _))).
      apply pathsinv0, bincoprod_antidistributor_pentagon_identity.
    - red.
      intro cd.
      apply pathsinv0, (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly δ _ _)).
      apply pathsinv0, bincoprod_antidistributor_triangle_identity.
  Qed.

  Definition bincoprod_functor_lineator (δ : actegory_bincoprod_distributor) :
    lineator Mon_V (actegory_binprod Mon_V Act Act) Act (bincoproduct_functor BCP).
  Proof.
    use tpair.
    - exists (bincoprod_functor_lineator_data δ).
      exact (bincoprod_functor_lineator_laxlaws δ).
    - apply bincoprod_functor_lineator_strongly.
  Defined.

  Lemma bincoprod_distributor_commutes_with_associativity_of_coproduct (δ : actegory_bincoprod_distributor) (v : V) (c d e : C) :
    v ⊗^{Act}_{l} bincoprod_associator_data BCP c d e ·
      δ v c (BCP d e) ·
      #(bincoproduct_functor BCP) (catbinprodmor (identity (v ⊗_{Act} c)) (δ v d e)) =
    δ v (BCP c d) e ·
      #(bincoproduct_functor BCP) (catbinprodmor (δ v c d) (identity (v ⊗_{Act} e))) ·
      bincoprod_associator_data BCP (v ⊗_{Act} c) (v ⊗_{Act} d) (v ⊗_{Act} e).
  Proof.
    repeat rewrite assoc'.
    apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly δ v (((BCP c d): C),, e))).
    repeat rewrite assoc.
    apply (z_iso_inv_to_right _ _ _ _ (functor_on_z_iso (functor_fix_fst_arg _ _ _
                                                           (bincoproduct_functor BCP) (v ⊗_{ Act} c))
                                         (_,,bincoprod_functor_lineator_strongly δ v (d,,e)))).
    apply (z_iso_inv_to_right _ _ _ _ (_,,bincoprod_functor_lineator_strongly δ v (c,,((BCP d e): C)))).
    repeat rewrite assoc'.
    apply (z_iso_inv_to_left _ _ _ (functor_on_z_iso (functor_fix_snd_arg _ _ _
                                                           (bincoproduct_functor BCP) (v ⊗_{ Act} e))
                                      (_,,bincoprod_functor_lineator_strongly δ v (c,,d)))).
    repeat rewrite assoc.
    apply actegory_bincoprod_antidistributor_commutes_with_associativity_of_coproduct.
  Qed.

End BinaryCoproduct.

Section Coproduct.

  Context {I : UU} {C : category} (CP : Coproducts I C) (Act : actegory Mon_V C).

  Definition actegory_coprod_antidistributor := bifunctor_coprod_antidistributor CP CP Act.

  Lemma actegory_coprod_antidistributor_nat_left (v : V)
    (cs1 cs2 : power_category I C) (g : cs1 --> cs2) :
    actegory_coprod_antidistributor v cs1 · v ⊗^{Act}_{l} #(coproduct_functor I CP) g =
      #(coproduct_functor I CP) (v ⊗^{actegory_power Mon_V I Act}_{l} g) ·
        actegory_coprod_antidistributor v cs2.
  Proof.
    apply coprod_antidistributor_nat_left.
  Qed.

  Lemma actegory_coprod_antidistributor_nat_right (v1 v2 : V)
    (cs : power_category I C) (f : v1 --> v2) :
    actegory_coprod_antidistributor v1 cs · f ⊗^{Act}_{r} coproduct_functor I CP cs  =
      #(coproduct_functor I CP) (f ⊗^{actegory_power Mon_V I Act}_{r} cs) ·
        actegory_coprod_antidistributor v2 cs.
  Proof.
    apply coprod_antidistributor_nat_right.
  Qed.

  Lemma coprod_antidistributor_pentagon_identity (v w : V) (cs : power_category I C) :
    # (coproduct_functor I CP) aα^{actegory_power Mon_V I Act}_{v, w, cs} ·
                                      actegory_coprod_antidistributor v (fun i => w ⊗_{Act} (cs i)) ·
                                      v ⊗^{Act}_{l} actegory_coprod_antidistributor w cs =
     actegory_coprod_antidistributor (v ⊗_{Mon_V} w) cs
        · aα^{Act}_{v, w, coproduct_functor I CP cs}.
  Proof.
    etrans.
    { rewrite assoc'.
      apply postcompWithCoproductArrow. }
    etrans.
    2: { apply pathsinv0, postcompWithCoproductArrow. }
    apply maponpaths; apply funextsec; intro i.
    etrans.
    { repeat rewrite assoc.
      apply cancel_postcomposition.
      rewrite assoc'.
      apply maponpaths.
      apply CoproductInCommutes. }
    etrans.
    2: { apply actegory_actornatleft. }
    rewrite assoc'.
    apply maponpaths.
    etrans.
    { apply pathsinv0, (functor_comp (leftwhiskering_functor Act v)). }
    apply maponpaths.
    apply CoproductInCommutes.
  Qed.

  Lemma coprod_antidistributor_triangle_identity (cs : power_category I C) :
    #(coproduct_functor I CP) au^{actegory_power Mon_V I Act}_{cs} =
      actegory_coprod_antidistributor I_{Mon_V} cs · au^{Act}_{coproduct_functor I CP cs}.
  Proof.
    etrans.
    2: { apply pathsinv0, postcompWithCoproductArrow. }
    cbn. unfold CoproductOfArrows.
    apply maponpaths, funextsec; intro i; apply pathsinv0, actegory_unitornat.
  Qed.

  Definition actegory_coprod_distributor_data : UU := bifunctor_coprod_distributor_data CP CP Act.
  Identity Coercion actegory_coprod_distributor_data_coercion:
    actegory_coprod_distributor_data >-> bifunctor_coprod_distributor_data.

  Definition actegory_coprod_distributor_iso_law (δ : actegory_coprod_distributor_data) : UU :=
    bifunctor_coprod_distributor_iso_law CP CP Act δ.
  Definition actegory_coprod_distributor : UU := bifunctor_coprod_distributor CP CP Act.

  Definition actegory_coprod_distributor_to_data (δ : actegory_coprod_distributor) :
    actegory_coprod_distributor_data := pr1 δ.
  Coercion actegory_coprod_distributor_to_data :
    actegory_coprod_distributor >-> actegory_coprod_distributor_data.

  Definition coprod_functor_lineator_data (δ : actegory_coprod_distributor_data) :
    lineator_data Mon_V (actegory_power Mon_V I Act) Act (coproduct_functor I CP).
  Proof.
    intros v cs.
    exact (δ v cs).
  Defined.

  Definition coprod_functor_lineator_strongly (δ : actegory_coprod_distributor) :
    lineator_strongly _ _ _ _ (coprod_functor_lineator_data δ).
  Proof.
    intros v cs.
    exists (actegory_coprod_antidistributor v cs).
    apply (pr2 δ).
  Defined.

  Lemma coprod_functor_lineator_laxlaws (δ : actegory_coprod_distributor) :
    lineator_laxlaws _ _ _ _ (coprod_functor_lineator_data δ).
  Proof.
    red; repeat split.
    - red.
      intros v cs1 cs2 g.
      apply (z_iso_inv_to_right _ _ _ _ (_,,coprod_functor_lineator_strongly δ v _)).
      rewrite assoc'.
      apply (z_iso_inv_to_left _ _ _ (_,,coprod_functor_lineator_strongly δ v _)).
      apply actegory_coprod_antidistributor_nat_left.
    - red.
      intros v1 v2 cs f.
      apply (z_iso_inv_to_right _ _ _ _ (_,,coprod_functor_lineator_strongly δ _ _)).
      rewrite assoc'.
      apply (z_iso_inv_to_left _ _ _ (_,,coprod_functor_lineator_strongly δ _ _)).
      apply actegory_coprod_antidistributor_nat_right.
    - red.
      intros v w cs.
      apply pathsinv0, (z_iso_inv_to_right _ _ _ _ (_,,coprod_functor_lineator_strongly δ _ _)).
      rewrite assoc'.
      apply (z_iso_inv_to_left _ _ _ (_,,coprod_functor_lineator_strongly δ _ _)).
      rewrite assoc.
      apply (z_iso_inv_to_right _ _ _ _ (functor_on_z_iso (leftwhiskering_functor Act v)
                                           (_,,coprod_functor_lineator_strongly δ _ _))).
      apply pathsinv0, coprod_antidistributor_pentagon_identity.
    - red.
      intro cs.
      apply pathsinv0, (z_iso_inv_to_left _ _ _ (_,,coprod_functor_lineator_strongly δ _ _)).
      apply pathsinv0, coprod_antidistributor_triangle_identity.
  Qed.

  Definition coprod_functor_lineator (δ : actegory_coprod_distributor) :
    lineator Mon_V (actegory_power Mon_V I Act) Act (coproduct_functor I CP).
  Proof.
    use tpair.
    - exists (coprod_functor_lineator_data δ).
      exact (coprod_functor_lineator_laxlaws δ).
    - apply coprod_functor_lineator_strongly.
  Defined.

End Coproduct.

End FixAMonoidalCategory.

Section TwoMonoidalCategories.

  Context {V : category} (Mon_V : monoidal V) {C : category} (Act : actegory Mon_V C)
    {W : category} (Mon_W : monoidal W)
    {F : W ⟶ V} (U : fmonoidal Mon_W Mon_V F).

  Let ActW : actegory Mon_W C := lifted_actegory Mon_V Act Mon_W U.

Section BinaryCase.

  Context (BCP : BinCoproducts C) (δ : actegory_bincoprod_distributor Mon_V BCP Act).

  Definition lifted_bincoprod_distributor_data : actegory_bincoprod_distributor_data Mon_W BCP ActW.
  Proof.
    intros w c c'.
    apply (δ (F w)).
  Defined.

  Lemma lifted_bincoprod_distributor_law :
    actegory_bincoprod_distributor_iso_law _ _ _ lifted_bincoprod_distributor_data.
  Proof.
    intros w c c'.
    split; unfold lifted_bincoprod_distributor_data; apply (pr2 δ (F w)).
  Qed.

  Definition lifted_bincoprod_distributor : actegory_bincoprod_distributor Mon_W BCP ActW :=
    _,,lifted_bincoprod_distributor_law.

End BinaryCase.

Section IndexedCase.

  Context {I : UU} (CP : Coproducts I C) (δ : actegory_coprod_distributor Mon_V CP Act).

  Definition lifted_coprod_distributor_data : actegory_coprod_distributor_data Mon_W CP ActW.
  Proof.
    intros w cs.
    apply (δ (F w)).
  Defined.

  Lemma lifted_coprod_distributor_law :
    actegory_coprod_distributor_iso_law _ _ _ lifted_coprod_distributor_data.
  Proof.
    intros w cs.
    split; unfold lifted_coprod_distributor_data; apply (pr2 δ).
  Qed.

  Definition lifted_coprod_distributor : actegory_coprod_distributor Mon_W CP ActW :=
    _,,lifted_coprod_distributor_law.

End IndexedCase.

End TwoMonoidalCategories.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


From mathcomp Require Import ssreflect ssrnat eqtype ssrbool ssrfun seq.
From mathcomp Require Import finmap choice finfun fintype.
From coqspec Require Import utilities substitution.
From deriving Require Import deriving.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Open Scope fmap_scope.
Open Scope fset_scope.

Inductive Cntr :=
  | CONStest of Arg
  | ATOMtest of Exp & Exp.
Notation "CONS?" := (CONStest) (only parsing).
Notation "'EQA?'"  := (ATOMtest) (only parsing).

Definition FVCntr (c : Cntr) : {fset Var} :=
  match c with
  | EQA? x y => FVExp x `|` FVExp y
  | CONS? x  => FVArg x
  end.

Inductive Tree :=
  | RET  of Exp
  | LET  of Var  & Exp  & Tree
  | COND of Cntr & Tree & Tree
  | HT   of Var & Var & Var & Tree
  | CALL of FName & seq Exp.
Coercion RET : Exp >-> Tree.

Fixpoint VTree (t : Tree) : {fset Var} :=
  match t with
  | RET e        => FVExp e
  | LET v x t    => v |` (FVExp x `|` VTree t)
  | COND c t1 t2 => FVCntr c `|` VTree t1 `|` VTree t2
  | HT v u x t   => [fset v; u; x] `|`  (VTree t)
  | CALL f xs    => [fset x | y in xs, x in FVExp y]
  end.

Fixpoint FVTree (t : Tree) : {fset Var} :=
  match t with
  | RET e        => FVExp e
  | LET v x t    => (FVExp x `|` FVTree t) `\ v
  | COND c t1 t2 => FVCntr c `|` FVTree t1 `|` FVTree t2
  | HT v u x t   => (FVExp x `|` FVTree t) `\ v `\ u
  | CALL f xs    => [fset x | y in xs, x in FVExp y]
  end.

Definition maxvar (t : Tree) : Var := max_set (VTree t).

Lemma subst_max (e1 e2 : Env) (e : Exp) :
  (forall x, x <= maxvar e -> e1 x = e2 x) ->
  e /s/ e1 = e /s/ e2.
Proof.
elim: e=> [[[]|?]|? IHe1 ? IHe2 I] //=; first apply.
- rewrite /maxvar /=; apply/max_setin; by rewrite ?inE.
  by rewrite IHe1 ?IHe2 //; move=> ? I'; apply/I; rewrite /maxvar /=;
rewrite max_setU leq_max I' ?orbT.
Qed.

Inductive Def := DEFINE of FName & seq Var & Tree.

Definition Prog := seq Def.

Inductive Branch :=
  | TRUE  of Env
  | FALSE of Env
  | ERR.

Definition cntr (c : Cntr) (e : Env) : Branch :=
  match c with
  | EQA? x y    =>
    match x /s/ e, y /s/ e with
    | Arg_Val 'a, Arg_Val 'b => if a == b then TRUE e else FALSE e
    | _, _ => ERR
    end
  | CONS? x =>
    if x /s/ e is CONS a _ then
      TRUE e
    else FALSE e
  end.

Fixpoint get_func (f : FName) (p : Prog) : (Tree * seq Var)%type :=
  match p with
  | [::]                  => (RET ERROR, [::])
  | (DEFINE g xs t) :: ps =>
    if f == g then (t, xs)
    else get_func f ps
  end.

Fixpoint int (n : nat) (t : Tree) (e : Env) (p : Prog) : Exp :=
  match t with
  | RET x         =>
    if n is n'.+1 then
      subst x e
    else ERROR
  | LET v x t     =>
    if n is n'.+1 then
      int n' t  [fsfun e with v |-> x /s/ e] p
    else ERROR
  | COND c t' t'' =>
    if n is n'.+1 then
      match cntr c e with
      | TRUE e'   => int n' t'  e'  p
      | FALSE e'' => int n' t'' e'' p
      | ERR       => ERROR
      end
    else ERROR
  | HT v u x t =>
    if n is n'.+1 then
      if x /s/ e is CONS a b then
        int n' t [fsfun e with v |-> a, u |-> b] p
      else ERROR
    else ERROR
  | CALL f args =>
    if n is n'.+1 then
      let: (t, xs) := (get_func f p) in
        int n' t (mkEnv xs (map (subst^~ e) args)) p
    else ERROR
  end.

Lemma aux_CONS e a:
  aux e (FVCntr (CONS? a)) = FVExp (a /s/ e).
Proof.
move=> /=; have->: FVArg a = FVExp a by case: a=> [[]|].
exact/aux_FVExp.
Qed.

Lemma aux_EQA e a1 a2:
  aux e (FVCntr (EQA? a1 a2)) = FVExp (a1 /s/ e) `|` FVExp (a2 /s/ e).
Proof. by move=> /=; rewrite auxU ?aux_FVExp. Qed.

Lemma auxE e c rs:
  aux e (FVCntr c) `<=` FVCntr c `|` whole (e, rs).
Proof.
apply/fsubsetP=> y /mem_aux[x I].
rewrite -[e x]/((Exp_Arg (Arg_Var x)) /s/ e)=> /(fsubsetP (whole_subst _ rs _)).
move=> /=; rewrite 2?inE => /orP[/eqP->|H]; first by rewrite inE I.
by rewrite inE H orbT.
Qed.

Lemma cntr_env_TRUE c env e:
  cntr c env = TRUE e ->
  (env = e).
Proof.
case: c=> /= [?|??]; case: (_ /s/ env)=> //.
- by move=> ?? [].
by case=> // [[]] ?; case: (_ /s/ _)=> // [[]] // [] ?; case: ifP=> // ? [].
Qed.

Lemma cntr_env_FALSE c env e:
  cntr c env = FALSE e -> e = env.
Proof.
case: c=> [/= >|/= ??]; case (_ /s/ _)=> //; first by move=> ?[->].
case=> //[][]. case: (_ /s/ _)=> //[][]//[] ??.
by case:ifP=> // ?[->].
Qed.

Section IntSpec.

Context {p : Prog}.

Fixpoint well_typed (t : Tree) : bool :=
  match t with
  | RET _ => true
  | LET v x t => well_typed t && (v \notin FVExp x)
  | COND c t1 t2 =>  well_typed t1 && well_typed t2
  | HT v u x t => [&& x != v, x != u, v != u & well_typed t]
  | CALL f xs => size xs == size (get_func f p).2
  end.

Lemma int_freevar (e1 e2 : Env) t n:
  well_typed t ->
  (forall x, x \in FVTree t -> e1 x = e2 x) ->
  int n t e1 p = int n t e2 p.
Proof.
elim: t e1 e2 n=> [??? n ? H *|??? IHt ?? n|c ? IHt1 ? IHt2 ++ n|?? v ? IHt e1 e2 n|++++ n].
all: case: n=> // n.
- apply/subst_fv=> *; exact/H.
- move=> /andP[? /negbTE NI I]; apply/IHt=> // ? F; rewrite ?fsfun_withE.
  case: ifP=> [/eqP E|N].
  - apply/subst_fv=> ? I'; apply/I; rewrite /= ?inE I' /= andbT.
    apply/negP=> /eqP E'; by rewrite E' NI in I'.
  by apply/I; rewrite ?inE F N orbT.
- case: c=> [[[a ?? /andP[??] I]|v e1 e2 /andP[??] I]|] /=.
  - apply/IHt2=> // ? I'; apply/I; by rewrite ?inE I' orbT.
  - have->: e1 v = e2 v by apply/I; rewrite ?inE eq_refl.
    case E: (e2 v); [apply/IHt2 | apply/IHt1] => // ? I'; apply/I;
    by rewrite ?inE I' orbT.
  - move=> e e' e1 e2 /andP[??] I.
    have->: (e /s/ e1 = e /s/ e2).
    - by apply/subst_fv=> ? I'; apply/I; rewrite ?inE I'.
    case: (e /s/ e2)=> // [[[]|]] //= ?.
    have->: (e' /s/ e1 = e' /s/ e2).
    - by apply/subst_fv=> ? I'; apply/I; rewrite ?inE I' orbT.
    case: (e' /s/ e2)=> // [[]] // [?]; case: ifP=> ?;
    [apply/IHt1 | apply/IHt2] => // ? I'; apply/I; by rewrite ?inE I' ?orbT.
- case/and4P=> N1 N2 ?? I /=.
  have->: e1 v = e2 v.
  - by apply/I=> /=; rewrite ?inE N1 N2 eq_refl /=.
  case: (e2 v)=> // ??; apply/IHt=> // ? I'; rewrite ?fsfun_withE.
  (do? case: ifP=> //)=> N1' N2'; apply/I; by rewrite ?inE N1' N2' I' orbT.
move=> f l e1 e2 ? IH /=.
case: (get_func f p)=> ? xs.
have-> //: (mkEnv xs [seq x /s/ e1 | x <- l]) =  (mkEnv xs [seq x /s/ e2 | x <- l]).
apply/congr1/eq_in_map=> x H. apply/subst_fv=> y ?.
apply/IH/imfset2P; exists x=> //; by exists y.
Qed.

Lemma int_maxvar (e1 e2 : Env) t n:
  well_typed t ->
  (forall x, x <= maxvar t -> e1 x = e2 x) ->
  int n t e1 p = int n t e2 p.
Proof.
move=> wf H; apply/int_freevar=> // ? I; rewrite H // /maxvar max_setin //.
elim: t I {wf H}=> //= [??? IH|?? IH1 ? IH2|???? IH]; rewrite ?inE.
- case/andP=> ? /orP[|/IH]->; by rewrite ?orbT.
- case/orP=> [/orP[|/IH1]|/IH2]->; by rewrite ?orbT.
case/and3P=> ?? /orP[|/IH]->; by rewrite ?orbT.
Qed.

Arguments int: simpl nomatch.

Lemma int_not0 n t e:
  int n t e p <> ERROR ->
  int n t e p = int n.+1 t e p.
Proof.
elim: n t e p=> [[]|] // n IH [] //=.
- move=> *; by rewrite IH.
- move=> c ?? e ?; case: c=> //= [[[]??|v]|] //=; rewrite 1?IH //;
  rewrite /int /= -/int.
  - case E: (e v)=> ?; by rewrite IH.
  move=> e1 e2 /=. case: (e1 /s/ e)=> //= [[]] // [] //.
  case (e2 /s/ e)=> [] // [] // [] ??; case: ifP=> ??; by rewrite IH.
- move=> ?? v ?; rewrite /int/= -/int=> e; case: (e v)=> // *.
  by rewrite IH.
move=> ????. rewrite {1 2 3}/int/=-/int. case: (get_func _ _)=> // ???.
by rewrite IH.
Qed.

End IntSpec.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.