Require Import Utf8 List Basics Reals.
Import ListNotations.

Require Export Utf8 List Basics Reals.
Export ListNotations.
Require Export CpdtTactics.

Open Scope program_scope.

Set Implicit Arguments.
Implicit Types V : Set.

(** * Syntax *)

(**
If [V] is the type of the representation of a variable, then [inc V]
is the type of the representation of the same variable after the free
variable environment is extended by one.
*)
Inductive inc (V : Set) : Set :=
| VZ : inc V
| VS : V → inc V
.

Arguments VZ {V}.
Arguments VS {V}.

Notation "∅" := Empty_set.

Definition empty_fun {T} : ∅ → T :=
  λ y, match y with end.

Notation "∅→" := empty_fun.

(** Extend a variable mapping. *)
Definition env_ext (V : Set) (T : Type) (env : V → T) (t : T) :
    inc V → T :=
  λ y, match y with
  | VZ => t
  | VS x => env x
  end.

(** types *)
Inductive ty : Set :=
| ty_unit : ty
| ty_bool : ty
| ty_real : ty
| ty_fun  : ty → ty → ty
| ty_pair : ty → ty → ty
| ty_dist : ty → ty
.
Notation "𝟙" := ty_unit.
Notation "𝟚" := ty_bool.
Notation ℝ := ty_real.
Notation 𝕋 := ty.

Inductive binop : Set :=
(** binary operations *)
| binop_plus
| binop_mult
| binop_lt
| binop_le
| binop_eq_real
.

Inductive val V : Set :=
(** values *)
| val_var   : V → val V
| val_unit  : val V
| val_bool  : bool → val V
| val_real  : R → val V
| val_fun   : exp (inc V) → val V
| val_fix   : exp (inc V) → val V
| val_pair  : val V → val V → val V
| val_unif  : val V
| val_query : exp V → val V

with exp V : Set :=
(** terms *)
| exp_val     : val V → exp V
| exp_app     : exp V → exp V → exp V
| exp_let     : exp V → exp (inc V) → exp V
| exp_binop   : binop → exp V → exp V → exp V
| exp_proj    : exp V → bool → exp V
| exp_if      : exp V → exp V → exp V → exp V
| exp_sample  : exp V → exp V
| exp_score   : exp V → exp V
| exp_exn     : exp V
.

Arguments val_unit {V}.
Arguments val_bool {V}.
Arguments val_real {V}.
Arguments val_unif {V}.
Arguments exp_exn {V}.

Notation val0 := (val ∅).
Notation exp0 := (exp ∅).

Coercion exp_val : val >-> exp.

Inductive ktx : Set :=
(** evaluation contexts *)
| ktx_hole   : ktx
| ktx_app1   : ktx → exp0 → ktx
| ktx_app2   : val0 → ktx → ktx
| ktx_let    : ktx → exp (inc ∅) → ktx
| ktx_binop1 : binop → ktx → exp0 → ktx
| ktx_binop2 : binop → val0 → ktx → ktx
| ktx_proj   : ktx → bool → ktx
| ktx_if     : ktx → exp0 → exp0 → ktx
| ktx_sample : ktx → ktx
| ktx_score  : ktx → ktx
.

(** Well-founded measure on the syntax *)
Fixpoint size_val
V (v : val V) : nat :=
match v with
| val_var _ => 0
| val_unit => 0
| val_bool _ => 0
| val_real _ => 0
| val_fun e => 1 + size_exp e
| val_fix e => 1 + size_exp e
| val_pair v1 v2 => 1 + size_val v1 + size_val v2
| val_unif => 0
| val_query e => 1 + size_exp e
end
with size_exp
V (e : exp V) : nat :=
match e with
| exp_val v => 1 + size_val v
| exp_app e1 e2 => 1 + size_exp e1 + size_exp e2
| exp_let e1 e2 => 1 + size_exp e1 + size_exp e2
| exp_binop _ e1 e2 => 1 + size_exp e1 + size_exp e2
| exp_proj e1 _ => 1 + size_exp e1
| exp_if e1 e2 e3 => 1 + size_exp e1 + size_exp e2 + size_exp e3
| exp_sample e => 1 + size_exp e
| exp_score e => 1 + size_exp e
| exp_exn => 0
end.

Reserved Notation "K '[/' e ']'" (at level 60, e at level 55).
Fixpoint ktx_plug (K : ktx) (e : exp0) {struct K} :=
match K with
| ktx_hole => e
| ktx_app1 K f => exp_app (K[/e]) f
| ktx_app2 f K => exp_app f (K[/e])
| ktx_let K f  => exp_let (K[/e]) f
| ktx_binop1 op K f => exp_binop op (K[/e]) f
| ktx_binop2 op f K => exp_binop op f (K[/e])
| ktx_proj K b => exp_proj (K[/e]) b
| ktx_if K e1 e2 => exp_if (K[/e]) e1 e2
| ktx_sample K => exp_sample (K[/e])
| ktx_score K => exp_score (K[/e])
end
where "K '[/' e ']' " := (ktx_plug K e)
.

Fixpoint ktx_comp (K J : ktx) {struct K} :=
match K with
| ktx_hole => J
| ktx_app1 K f => ktx_app1 (ktx_comp K J) f
| ktx_app2 f K => ktx_app2 f (ktx_comp K J)
| ktx_let K f  => ktx_let (ktx_comp K J) f
| ktx_binop1 op K f => ktx_binop1 op (ktx_comp K J) f
| ktx_binop2 op f K => ktx_binop2 op f (ktx_comp K J)
| ktx_proj K b => ktx_proj (ktx_comp K J) b
| ktx_if K e1 e2 => ktx_if (ktx_comp K J) e1 e2
| ktx_sample K => ktx_sample (ktx_comp K J)
| ktx_score K => ktx_score (ktx_comp K J)
end.

Lemma ktx_plug_comp
(K J : ktx) e :
K[/(J[/e])] = (ktx_comp K J)[/e].
Proof.
induction K ; simpl ; crush.
Qed.

Lemma ktx_plug_injection K e e':
  K[/e] = K[/e'] → e = e'.
Proof.
  induction K in e, e' |-*; cbn;
  intros Heq;
  inversion Heq;
  auto.
Qed.

Lemma plug_exn_is_not_val K (v : val0):
  K[/exp_exn] ≠ v.
Proof.
  destruct K; destruct v; intros [=].
Qed.

Lemma ktx_plug_is_exp_exn_inv K e :
  K[/e] = exp_exn →
  K = ktx_hole ∧ e = exp_exn.
Proof.
  destruct K; cbn; intros [=].
  auto.
Qed.

Lemma ktx_plug_is_val_inv K : ∀ e v,
K[/e] = exp_val v →
K = ktx_hole ∧ e = v.
Proof.
induction K ; crush.
Qed.

Ltac ktx_plug_is_val_absurd :=
repeat match goal with
| [ H : ktx_plug ?K ?e = exp_val ?v |- _ ] =>
  exfalso ; apply ktx_plug_is_val_inv in H ;
  destruct H as [? ?]
| [ H : exp_val ?v = ktx_plug ?K ?e |- _ ] =>
  apply eq_sym in H
| [ H : exp_app _ _ = exp_val _ |- _ ] =>
  discriminate H
| [ H : exp_let _ _ = exp_val _ |- _ ] =>
  discriminate H
| [ H : exp_binop _ _ _ = exp_val _ |- _ ] =>
  discriminate H
| [ H : exp_proj _ _ = exp_val _ |- _ ] =>
  discriminate H
| [ H : exp_if _ _ _ = exp_val _ |- _ ] =>
  discriminate H
| [ H : exp_sample _ = exp_val _ |- _ ] =>
  discriminate H
| [ H : exp_score _ = exp_val _ |- _ ] =>
  discriminate H
| [ H : exp_exn = exp_val _ |- _ ] =>
  discriminate H
end.

Lemma exp_val_dec V (e : exp V) :
{ v & e = exp_val v } + { ∀ v, e = exp_val v → False }.
Proof.
destruct e ; (
  (left ; eexists ; reflexivity) ||
  (right ; intros v H ; inversion H)
).
Defined.

Ltac bind_ktx_app1 := repeat match goal with
| [ |- context[exp_app ?e1 ?e2] ] =>
  replace (exp_app e1 e2) with (ktx_plug (ktx_app1 ktx_hole e2) e1)
  by trivial
end.
Ltac bind_ktx_app2 := repeat match goal with
| [ |- context[exp_app (exp_val ?v) ?e] ] =>
  replace (exp_app (exp_val v) e) with (ktx_plug (ktx_app2 v ktx_hole) e)
  by trivial
end.
Ltac bind_ktx_let := repeat match goal with
| [ |- context[exp_let ?e1 ?e2] ] =>
  replace (exp_let e1 e2) with (ktx_plug (ktx_let ktx_hole e2) e1)
  by trivial
end.
Ltac bind_ktx_binop1 := repeat match goal with
| [ |- context[exp_binop ?op ?e1 ?e2] ] =>
  replace (exp_binop op e1 e2) with (ktx_plug (ktx_binop1 op ktx_hole e2) e1)
  by trivial
end.
Ltac bind_ktx_binop2 := repeat match goal with
| [ |- context[exp_binop ?op (exp_val ?v) ?e] ] =>
  replace (exp_binop op (exp_val v) e) with (ktx_plug (ktx_binop2 op v ktx_hole) e)
  by trivial
end.
Ltac bind_ktx_proj := repeat match goal with
| [ |- context[exp_proj ?e ?b] ] =>
  replace (exp_proj e b) with (ktx_plug (ktx_proj ktx_hole b) e)
  by trivial
end.
Ltac bind_ktx_if := repeat match goal with
| [ |- context[exp_if ?e1 ?e2 ?e3] ] =>
  replace (exp_if e1 e2 e3) with (ktx_plug (ktx_if ktx_hole e2 e3) e1)
  by trivial
end.
Ltac bind_ktx_sample := repeat match goal with
| [ |- context[exp_sample ?e] ] =>
  replace (exp_sample e) with (ktx_plug (ktx_sample ktx_hole) e)
  by trivial
end.
Ltac bind_ktx_score := repeat match goal with
| [ |- context[exp_score ?e] ] =>
  replace (exp_score e) with (ktx_plug (ktx_score ktx_hole) e)
  by trivial
end.

Fact exp_ktx_exn_dec_aux1 e1 e2 K
(H : exp_app e1 e2 =  K[/exp_exn])
(Notval_e1 : ∀ v, e1 = exp_val v → False) :
∃ K', e1 = K'[/exp_exn] ∧ K = ktx_app1 K' e2.
Proof.
destruct K; simpl in H.
+ inversion H.
+ inversion H; subst; clear H. eauto.
+ inversion H; subst; clear H. exfalso. eapply Notval_e1. reflexivity.
+ inversion H.
+ inversion H.
+ inversion H.
+ inversion H.
+ inversion H.
+ inversion H.
+ inversion H.
Qed.

Fact exp_ktx_exn_dec_aux2 (v : val0) e K
(H : exp_app v e = K[/exp_exn]) :
∃ K', e = K'[/exp_exn] ∧ K = ktx_app2 v K'.
Proof.
destruct K; simpl in H.
+ inversion H.
+ inversion H; subst; clear H. ktx_plug_is_val_absurd.
+ inversion H; subst; clear H. eexists; eauto.
+ inversion H.
+ inversion H.
+ inversion H.
+ inversion H.
+ inversion H.
+ inversion H.
+ inversion H.
Qed.

Fixpoint exp_ktx_exn_dec (e : exp0) {struct e}:
{ K & e = K[/exp_exn] } + { ∀ K, e = K[/exp_exn] → False }.
Proof.
destruct e.
+ right. intros. ktx_plug_is_val_absurd.
+ destruct (exp_ktx_exn_dec e1) as [ [K ?] | ]; subst.
  - left. eexists (ktx_app1 K _). reflexivity.
  - destruct (exp_val_dec e1) as [ [v ?] | ]; subst.
    2:{
      right. intros K H.
      destruct K; simpl in H; inversion H; subst; clear H; eauto.
    }
    destruct (exp_ktx_exn_dec e2) as [ [K ?] | ]; subst.
    * left. eexists (ktx_app2 _ K). reflexivity.
    * right. intros K H.
      destruct K; simpl in H; inversion H; subst; clear H; eauto.
+ destruct (exp_ktx_exn_dec e1) as [ [K ?] | ]; subst.
  - left. eexists (ktx_let K _). reflexivity.
  - right. intros K H.
    destruct K; simpl in H; inversion H; subst; clear H; eauto.
+ destruct (exp_ktx_exn_dec e1) as [ [K ?] | ]; subst.
  - left. eexists (ktx_binop1 _ K _). reflexivity.
  - destruct (exp_val_dec e1) as [ [v ?] | ]; subst.
    2:{
      right. intros K H.
      destruct K; simpl in H; inversion H; subst ; clear H; eauto.
    }
    destruct (exp_ktx_exn_dec e2) as [ [K ?] | ]; subst.
    * left. eexists (ktx_binop2 _ _ K). reflexivity.
    * right. intros K H.
      destruct K; simpl in H; inversion H; subst ; clear H; eauto.
+ destruct (exp_ktx_exn_dec e) as [ [K ?] | ]; subst.
  - left. eexists (ktx_proj K _). reflexivity.
  - right. intros K H.
    destruct K; simpl in H; inversion H; subst; clear H; eauto.
+ destruct (exp_ktx_exn_dec e1) as [ [K ?] | ]; subst.
  - left. eexists (ktx_if K _ _). reflexivity.
  - right. intros K H.
    destruct K; simpl in H; inversion H; subst; clear H; eauto.
+ destruct (exp_ktx_exn_dec e) as [ [K ?] | ]; subst.
  - left. eexists (ktx_sample K). reflexivity.
  - right. intros K H.
    destruct K; simpl in H; inversion H; subst; clear H; eauto.
+ destruct (exp_ktx_exn_dec e) as [ [K ?] | ]; subst.
  - left. eexists (ktx_score K). reflexivity.
  - right. intros K H.
    destruct K; simpl in H; inversion H; subst; clear H; eauto.
+ left. exists ktx_hole. reflexivity.
Defined.


(* ============================================================================================= *)
(* * Equivalence of category between Kleisli monads and multiplicative monads.                   *)
(*                                                                                *)
(* Contents:                                                                                *)
(*   - kleislification (functor from multiplicative monads to Kleisli monads).                   *)
(*   - unkleislification (functor from Kleisli monads to multiplicative monads).                 *)
(*   - kleislification/unkleislification is an equivalence of categories.                        *)
(*                                                                                *)
(* Written by: Marco Maggesi, Cosimo Perini (2017)                                               *)
(* ============================================================================================= *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.KTriples.
Require Import UniMath.CategoryTheory.catiso.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.

Local Open Scope cat.

Lemma Monad_Mor_eq {C : category} (T T' : Monad_data C) (α β : Monad_Mor T T')
      (e : ∏ a : C, α a = β a) :
  α = β.
Proof.
  use subtypePath.
  - intro. apply isaprop_Monad_Mor_laws; apply homset_property.
  - now apply (nat_trans_eq_alt).
Defined.

(* ----- Monad associated to a Kleisli monad ----- *)

Definition unkleislify_data {C : category} (T : KleisliMonad C) : Monad_data C :=
  (kleisli_functor T,, nat_trans_μ T) ,, nat_trans_η T.

Lemma unkleislify_laws {C : category} (T : KleisliMonad C) :
  Monad_laws (unkleislify_data T).
Proof.
  split; simpl; intros; unfold μ.
  + split; intros.
    * apply (bind_η T).
    * rewrite (bind_map T). rewrite id_right. apply (η_bind T).
  + rewrite (bind_map T). rewrite id_right.
    rewrite (bind_bind T). now rewrite id_left.
Defined.

Definition unkleislify {C : category} (T : KleisliMonad C) : Monad C :=
  unkleislify_data T ,, unkleislify_laws T.

(* ----- Monad morphism associated to a Kleisli monad morphism ----- *)

Lemma unkleislify_mor_laws {C : category} {T T' : KleisliMonad C} (α : Kleisli_Mor T T') :
  Monad_Mor_laws (T  := unkleislify T)
                 (T' := unkleislify T')
                 (nat_trans_kleisli_mor α).
Proof.
  split; simpl; intros; unfold μ.
  + rewrite <- assoc. rewrite (bind_map T'). rewrite id_right.
    rewrite <- (Kleisli_Mor_bind α). now rewrite id_left.
  + apply Kleisli_Mor_η.
Defined.

Definition unkleislify_mor {C : category} {T T' : KleisliMonad C}
           (α : Kleisli_Mor T T') :
  Monad_Mor (unkleislify T) (unkleislify T') :=
  nat_trans_kleisli_mor α ,, unkleislify_mor_laws α.

(* ----- Functor from KleisliMonad to Monads. ----- *)

Definition functor_data_unkleislify (C : category) :
  functor_data (category_Kleisli C) (category_Monad C).
Proof.
  use make_functor_data.
  - exact (λ T : KleisliMonad C, unkleislify T).
  - intros. apply (unkleislify_mor X).
Defined.

Lemma is_functor_unkleislify {C : category} :
  is_functor (functor_data_unkleislify C).
Proof.
  split; red; simpl; intros.
  - unfold unkleislify_mor.
    apply subtypePath; simpl.
    + intro. apply isaprop_Monad_Mor_laws; apply homset_property.
    + apply subtypePath; simpl.
      * intro. apply isaprop_is_nat_trans; apply homset_property.
      * now apply funextsec.
  - apply subtypePath; simpl.
    + intro. apply isaprop_Monad_Mor_laws; apply homset_property.
    + apply subtypePath; simpl.
      * intro. apply isaprop_is_nat_trans; apply homset_property.
      * now apply funextsec.
Defined.

Definition functor_unkleislify {C : category} :
  functor (category_Kleisli C) (category_Monad C) :=
  (functor_data_unkleislify C) ,, is_functor_unkleislify.

(* ----- Support Lemmas. ----- *)

Lemma Monad_law4 {C : precategory_data} {T : Monad_data C} {a b : C} (f : a --> b) :
  Monads.η T a · # T f = f · Monads.η T b.
Proof.
  apply pathsinv0. apply (nat_trans_ax (Monads.η T) _ _ f).
Defined.

Lemma Monad_law5 {C : precategory_data} {T : Monad_data C} {a b: C} (f: a --> b) :
  # T (# T f) · (Monads.μ T b) = (Monads.μ T a) · (# T f).
Proof.
  apply (nat_trans_ax (Monads.μ T) _ _ f).
Defined.

(* ----- Kleisli monad associated to a Monad. ----- *)

Definition Monad_Kleisli_data {C : category} (T : Monad_data C) : Kleisli_Data C := (pr1(pr1(pr1 (pr1 T))),,
  (Monads.η T: nat_trans_data _ _),, (@Monads.bind C T)).

Lemma Monad_Kleisli_laws {C : category} (T : Monad C) :
  Kleisli_Laws (Monad_Kleisli_data T).
Proof.
  split.
  - exact Monad_law2.
  - split.
    + exact (@Monads.η_bind C T).
    + exact (@Monads.bind_bind C T).
Defined.

(* ----- Kleisli monad morphism associated to a Monad morphism. ----- *)

Definition kleislify {C : category} (M : Monad C) : KleisliMonad C :=
  Monad_Kleisli_data M ,, Monad_Kleisli_laws M.

Lemma kleislify_mor_law {C : category} {M M' : Monad C} (α : Monad_Mor M M') :
  Kleisli_Mor_laws (kleislify M) (kleislify M') (λ x : C, α x).
Proof.
  split; simpl; intros.
  - apply Monad_Mor_η.
  - unfold bind. unfold Monad_Kleisli_data. simpl. unfold Monads.bind.
    rewrite functor_comp. do 2 rewrite assoc.
    set (H := nat_trans_ax α). simpl in H. rewrite <- H. rewrite assoc4.
    rewrite <-H. rewrite <- assoc4. set (H2 :=  Monad_Mor_μ α b).
    simpl in H2. do 3 rewrite <- assoc.
    unfold Monads.μ in H2. simpl in H2.
    unfold Monads.μ. simpl.
    do 3 rewrite assoc. rewrite assoc4.
    repeat rewrite <- assoc.
    apply cancel_precomposition.
    rewrite assoc.
    rewrite H.
    apply pathsinv0.
    apply H2.
Defined.

Definition kleislify_mor {C : category} {M M' : Monad C}
           (α : Monad_Mor M M') :
  Kleisli_Mor (kleislify M) (kleislify M') :=
  (λ x:C, α x) ,, kleislify_mor_law α.

Definition functor_data_kleislify (C : category) :
  functor_data (category_Monad C) (category_Kleisli C).
Proof.
  use make_functor_data.
  - exact (λ T : Monad C, kleislify T).
  - intros. apply (kleislify_mor X).
Defined.

(* ----- Functoriality of [kleislify]. ----- *)

Lemma is_functor_kleislify {C : category} :
  is_functor (functor_data_kleislify C).
Proof.
  split; red; simpl; intros.
  - unfold kleislify_mor.
    apply subtypePath; simpl.
    + intro. apply isaprop_Kleisli_Mor_laws; apply homset_property.
    + reflexivity.
  - apply subtypePath; simpl.
    + intro. apply isaprop_Kleisli_Mor_laws; apply homset_property.
    + reflexivity.
Defined.

Definition functor_kleislify {C : category} :
  functor (category_Monad C) (category_Kleisli C) :=
  (functor_data_kleislify C) ,, is_functor_kleislify.

(* ----- Proof of the isomorphism. ----- *)

Section Adjunction.

  Context {C : category}.

  (* this result could not be preserved with the parameter [F] as field of [Kleisli_Data]:
  Lemma Kleisli_data_eq {F : C → C} (K K' : Kleisli_Data F)
        (η_eq : ∏ a : C, η K a = η K' a)
        (bind_eq : ∏ (a b : C) (f : a --> F b), bind K f = bind K' f) :
    K = K'.
  Proof.
    intros. apply dirprod_paths.
    - change (η K = η K'). apply funextsec. intro a. apply η_eq.
    - apply funextsec. intro a. apply funextsec. intro b. apply funextfun.
      intro f. apply bind_eq.
  Defined.
*)

  Lemma unkleislify_data_eq  (T : KleisliMonad C) : Monad_Kleisli_data (unkleislify_data T) = T.
  Proof.
    (* UniMath.MoreFoundations.Tactics.show_id_type. *)
    apply (maponpaths (λ p, tpair _ _ p )).
    apply pair_path_in2.
    simpl. apply funextsec. intro a. apply funextsec. intro b.
    apply funextfun. intro f.
    unfold Monads.bind.
    abstract (simpl; unfold μ; rewrite (bind_map T); rewrite id_right; apply idpath).
  Defined.

  Lemma kleislify_unkleislify (T : KleisliMonad C) :
    kleislify (unkleislify T) = T.
  Proof.
    unfold unkleislify, kleislify. simpl.
    destruct T as (D, L). simpl.
    use total2_paths_f; simpl.
    apply unkleislify_data_eq.
    (* UniMath.MoreFoundations.Tactics.show_id_type. *)
    apply (isaprop_Kleisli_Laws D).
  Defined.

  Lemma unkleislify_kleislify (M : Monad C) :
    unkleislify (kleislify M) = M.
  Proof.
    apply Monad_eq_raw_data.
    unfold Monad_to_raw_data. simpl.
    apply (pair_path_in2). apply total2_paths2.
    2: apply idpath.
    apply total2_paths2.
    - apply funextsec. intro a.
      apply funextsec; intro b.
      apply funextfun; intro f.
      simpl. unfold map. unfold bind. unfold η. simpl.
      unfold Monads.bind, Monads.η.
      rewrite functor_comp. rewrite <- assoc.
      set (H:= Monad_law2 (T:=M) b). simpl in H.
      unfold Monads.η, Monads.μ in H. simpl in H.
      unfold Monads.μ.
      etrans.
      { apply cancel_precomposition. apply H. }
      apply id_right.
    - apply funextsec; intro x.
      set (H:= functor_id (C:=C) (C':=C) M (M x)). simpl in H.
      unfold μ. simpl.
      unfold bind, Monads.μ. simpl. unfold Monads.bind, Monads.μ.
      etrans.
      { apply cancel_postcomposition. apply H. }
      apply id_left.
  Defined.

  Definition eps (T : KleisliMonad C) (a : C) : C ⟦ T a, T a ⟧ :=
    identity (pr1 T a).

  Lemma eps_morph_law (T : KleisliMonad C) :
    Kleisli_Mor_laws T (kleislify (unkleislify T)) (eps T).
  Proof.
    split; simpl; intros.
    - apply id_right.
    - rewrite id_left, id_right. rewrite id_right.
      unfold μ. unfold bind. simpl. unfold Monads.bind. unfold Monads.μ. simpl.
      unfold μ. rewrite (bind_map T). now rewrite id_right.
  Defined.

  Definition eps_morph (T : KleisliMonad C) :
    Kleisli_Mor T (kleislify (unkleislify T)) :=
    eps T ,, eps_morph_law T.

  Lemma epsinv_morph_law (T : KleisliMonad C) :
    Kleisli_Mor_laws (kleislify (unkleislify T)) T (eps T).
  Proof.
    split; simpl; intros.
    - apply id_right.
    - rewrite id_left, id_right. rewrite id_right.
      unfold μ. unfold bind. simpl. unfold Monads.bind. unfold Monads.μ. simpl.
      unfold μ. rewrite (bind_map T). now rewrite id_right.
  Defined.

  Definition epsinv_morph (T : KleisliMonad C) :
    Kleisli_Mor (kleislify (unkleislify T)) T :=
    eps T ,, epsinv_morph_law T.

  Lemma is_inverse_epsinv (T : KleisliMonad C) :
    is_inverse_in_precat
      (eps_morph T : category_Kleisli C ⟦T, kleislify (unkleislify T)⟧)
      (epsinv_morph T).
  Proof.
    split.
    - apply Kleisli_Mor_eq.
      apply funextsec. intro a. simpl.
      unfold eps. apply id_left.
    - apply Kleisli_Mor_eq.
      apply funextsec. intro a. simpl.
      unfold eps. apply id_left.
  Defined.

  Definition is_z_iso_eps_morph (T : KleisliMonad C) :
    is_z_isomorphism (eps_morph T :
              category_Kleisli C ⟦ T,(kleislify (unkleislify T))⟧) :=
      epsinv_morph T,, is_inverse_epsinv T.

  Lemma is_natural_eps :
    is_nat_trans (functor_identity (category_Kleisli C))
                 (functor_unkleislify ∙ functor_kleislify)
                 eps_morph.
  Proof.
    red. simpl. intros T T' α.
    (* UniMath.MoreFoundations.Tactics.show_id_type. *)
    apply (Kleisli_Mor_eq(T := T)(T' := kleislify(unkleislify T'))). simpl.
    apply funextsec. intro a.
    unfold nat_trans_from_kleisli_mor, eps.
    rewrite id_left. apply id_right.
  Defined.

  Definition eps_natural :
    functor_identity (category_Kleisli C)
    ⟹ functor_unkleislify ∙ functor_kleislify :=
    eps_morph ,, is_natural_eps.

  Definition eta_arrow (T : Monad C) (a : C) : C ⟦ T a, T a ⟧ := identity (T a).

  Lemma eta_arrow_natural (T : Monad C) :
    is_nat_trans (kleisli_functor_data (kleislify T)) T (eta_arrow T).
  Proof.
    intros a b f. simpl.
    unfold eta_arrow.
    rewrite id_left, id_right.
    unfold map, bind, η. simpl. unfold Monads.bind, Monads.η, Monads.μ.
    rewrite functor_comp.
    rewrite <- assoc.
    set (H := Monad_law2 (T := T) b). progress simpl in H.
    unfold Monads.η, Monads.μ in H.
    etrans.
    { apply cancel_precomposition. apply H. }
    now rewrite id_right.
  Defined.

  Definition eta_data (T : Monad C) : kleisli_functor_data (kleislify T) ⟹ T :=
    eta_arrow T ,, eta_arrow_natural T.

  Lemma is_nat_trans_etainv (T : Monad C) :
    is_nat_trans T (kleisli_functor_data (kleislify T)) (eta_arrow T).
  Proof.
    intros a b f.
    simpl.
    unfold eta_arrow.
    rewrite id_right.
    rewrite id_left.
    unfold map, bind, η. simpl. unfold Monads.bind, Monads.η, Monads.μ.
    rewrite functor_comp.
    rewrite <- assoc.
    set (H := Monad_law2 (T := T) b). progress simpl in H.
    unfold Monads.η, Monads.μ in H.
    etrans.
    2: { apply cancel_precomposition. apply pathsinv0. apply H. }
    now rewrite id_right.
  Defined.

  Definition etainv_data (T : Monad C) : T ⟹ kleisli_functor_data (kleislify T) :=
    eta_arrow T ,, is_nat_trans_etainv T.

  Lemma etainv_data_laws (T : Monad C) :
    @Monad_Mor_laws C
                    (Monad_data_from_Monad C T)
                    (@unkleislify_data C (@kleislify C T)) (etainv_data T).
  Proof.
    split; simpl; intros.
    - unfold eta_arrow.
      rewrite id_right.
      unfold map, μ, Monads.μ, bind. simpl. unfold Monads.bind, η, Monads.μ. simpl.
      unfold Monads.η.
      do 2 rewrite id_left.
      rewrite functor_id, id_left.
      rewrite <- assoc.
      set (H := Monad_law3 (T := T) a). progress simpl in H.
      unfold Monads.μ in H.
      etrans.
      2: { apply cancel_precomposition. apply H. }
      rewrite assoc.
      rewrite <- functor_comp.
      set (H1 := Monad_law1 (T := T) a). progress simpl in H1.
      unfold Monads.η, Monads.μ in H1.
      etrans.
      2: { apply cancel_postcomposition. apply maponpaths. apply pathsinv0.
           (* UniMath.MoreFoundations.Tactics.show_id_type. *) eapply H1. }
      now rewrite functor_id, id_left.
    - apply id_right.
  Defined.

  Definition etainv_morph (T : Monad C) :
    Monad_Mor T (unkleislify (kleislify T)) :=
    etainv_data T ,, etainv_data_laws T.

  Lemma etainv_morph_law (T : Monad C) :
    Monad_Mor_laws (T := T) (T' := (unkleislify (kleislify T))) (etainv_data T).
  Proof.
    split; simpl; intro a.
    - unfold eta_arrow.
      rewrite id_right.
      rewrite id_left.
      unfold Monads.μ, bind, μ, map, μ, bind, map, μ. simpl. unfold Monads.bind; simpl.
      unfold Monads.μ, η.
      rewrite functor_comp. do 2 rewrite functor_id.
      do 2 rewrite id_left.
      set (H1 := Monad_law2 (T := T) (T a)).
      unfold Monads.μ, Monads.η in H1.
      progress simpl in H1.
      simpl. unfold Monads.η.
      etrans.
      2: { apply cancel_postcomposition. apply pathsinv0. apply H1. }
      now rewrite id_left.
    - apply id_right.
  Defined.

  Lemma eta_data_laws (T : Monad C) :
    @Monad_Mor_laws C
                    (@unkleislify_data C (@kleislify C T))
                    (Monad_data_from_Monad C T) (eta_data T).
  Proof.
    split; simpl; intros.
    - unfold eta_arrow.
      rewrite id_right.
      rewrite id_left.
      unfold Monads.μ, μ, bind, μ. simpl. unfold Monads.bind, Monads.μ.
      do 2 rewrite functor_id. do 2 rewrite id_left. apply idpath.
    - apply id_right.
  Defined.

  Definition eta_morph (T : Monad C) :
    Monad_Mor (unkleislify (kleislify T)) T :=
    eta_data T ,, eta_data_laws T.

  Lemma is_inverse_etainv (T : Monad C) :
    is_inverse_in_precat
      (eta_morph T : category_Monad C ⟦unkleislify (kleislify T), T⟧)
      (etainv_morph T : category_Monad C ⟦T, unkleislify (kleislify T)⟧).
  Proof.
    split.
    - apply Monad_Mor_eq.
      intros. simpl.
      unfold eta_arrow. apply id_left.
    - apply Monad_Mor_eq.
      intros. simpl.
      unfold eta_arrow. apply id_left.
  Defined.

  Definition is_z_iso_eta_morph (T : Monad C) :
    is_z_isomorphism (eta_morph T :
              category_Monad C ⟦unkleislify (kleislify T), T⟧)
   := etainv_morph T,, is_inverse_etainv T.

  Lemma is_natural_eta :
    is_nat_trans
      (functor_composite_data (functor_data_kleislify C)
                              (functor_data_unkleislify C))
      (functor_identity_data (precategory_Monad_data C)) eta_morph.
  Proof.
    red; simpl. intros T T' α.
    apply (Monad_Mor_eq (unkleislify (kleislify T))).
    intros. simpl.
    unfold eta_arrow.
    now rewrite id_left, id_right.
  Defined.

  Definition eta_natural :
    functor_kleislify ∙ functor_unkleislify
                               ⟹ functor_identity (category_Monad C) :=
    eta_morph ,, is_natural_eta.

  Lemma form_adjunction_eps_eta :
    form_adjunction functor_unkleislify
                    functor_kleislify
                    eps_natural eta_natural.
  Proof.
    split; red; simpl.
    - intro T.
      apply (Monad_Mor_eq (unkleislify T) (unkleislify T)).
      intros. simpl.
      unfold eps.
      now rewrite id_left.
    - intro T. (* UniMath.MoreFoundations.Tactics.show_id_type. *)
      apply (Kleisli_Mor_eq (T:=kleislify T) (T':=kleislify T)).
      intros. simpl.
      apply funextsec.
      intro a.
      unfold eps.
      now rewrite id_left.
  Defined.

  Definition are_adjoint_monad_form_kleislify :
    are_adjoints functor_unkleislify functor_kleislify :=
    (eps_natural ,, eta_natural) ,, form_adjunction_eps_eta.

  Definition is_left_adjoint_functor_unkleislify :
    is_left_adjoint functor_unkleislify :=
    functor_kleislify ,, are_adjoint_monad_form_kleislify.

  Lemma form_equivalence_unkleislify :
    forms_equivalence is_left_adjoint_functor_unkleislify.
  Proof.
    split; simpl.
    - intros T. apply is_z_iso_eps_morph.
    - intros T. apply is_z_iso_eta_morph.
  Defined.

  Lemma is_catiso : is_catiso (functor_unkleislify(C:=C)).
  Proof.
    split.
    - apply fully_faithful_from_equivalence.
      use (is_left_adjoint_functor_unkleislify,, form_equivalence_unkleislify).
    - apply (isweq_iso _ (λ T : Monad C, kleislify T)).
      + intro T. simpl. apply kleislify_unkleislify.
      + simpl. apply unkleislify_kleislify.
  Defined.

  Corollary weq_Kleisli_Monad_categories:
    (category_Monad C) ≃ (category_Kleisli C).
  Proof.
    set (aux := pr2 is_catiso).
    exact (invweq (make_weq _ aux)).
  Defined.
(** This is the main result of [UniMath.CategoryTheory.Monads.Kleisli]. *)

End Adjunction.


Require Export unscoped header_extensible.

Require Export atomicsyntax implicativesyntax.
Require Import classical_deduction.

Reserved Notation "A ⊢ p" (at level 70).
Reserved Notation "A ⊢A p" (at level 70).

Section atomic.
  Context {Sigma : Signature}.

  Variable form : Type.

  Variable retract : retract (form_atomic) form.
  Variable retract_implicative : included form_implicative form.

  Variable translate : form -> form.
  Definition translate_atomic (p : form_atomic) : form := ¬¬(inj p).
  Notation "« p »" := (translate p).
  Notation "«/ A »" := (map translate A).

  Variable translation_inj : forall p, «inj p» = translate_atomic  p.
  Variable subst_form : (fin -> term) -> form -> form.
  Variable subst_form_inj : forall sigma p, subst_form sigma (inj p) = subst_form_atomic _ _ sigma p.
  Variable subst_dn : forall sigma p, subst_form sigma (¬¬p) = ¬¬(subst_form sigma p).
  Variable translation_subst : forall sigma q, «subst_form sigma q» = subst_form sigma «q».
  Lemma translation_subst_atm sigma p : « subst_form_atomic _ _ sigma p » = subst_form sigma (translate_atomic p).
  Proof. destruct p. cbn. unfold Pred_. rewrite translation_inj. unfold translate_atomic. rewrite subst_dn.
    rewrite subst_form_inj. reflexivity.
  Defined.

  Variable nd : list form -> form -> Prop.
  Notation "A ⊢ p" := (nd A p) (at level 70).
  Variable cnd_retract : forall A p, nd_classic _ _ nd A p -> A ⊢ p.
  Variable translation_bwd : forall A p,  A ⊢ «p» -> A ⊢ p.
  Lemma translation_bwd_atm A p: A ⊢ translate_atomic p -> A ⊢ inj p.
  Proof. destruct p; cbn. intro. apply translation_bwd. now rewrite translation_inj.
  Defined.

  Variable cut : forall A p q,  A ⊢ p -> (p :: A) ⊢ q -> A ⊢ q.
  Variable agree_imp : forall A p, nd_imp _ _ nd A p -> A ⊢ p.
  Variable translation_helper : forall A p, A ⊢ (¬¬«p») -> A ⊢ «p».
  Lemma translation_helper_atm A p : A ⊢ (¬¬(translate_atomic p)) -> A ⊢ translate_atomic p.
  Proof. unfold translate_atomic. intro. apply (cut _ _ _ H).
    apply agree_imp,ndII,agree_imp,(ndIE _ _ _ _ (¬¬¬(inj p))).
    apply agree_imp,ndHyp. right. now left.
    apply agree_imp,ndII,agree_imp,(ndIE _ _ _ _ (¬(inj p))). apply agree_imp,ndHyp. now left.
    apply agree_imp,ndHyp. right. now left.
  Defined.

End atomic.


(** * performance of rewrite/rewrite_strat under binders *)
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := let y := x in f y.
Strategy 100 [Let_In].
Global Hint Opaque Let_In : rewrite.
Reserved Notation "'dlet_nd' x .. y := v 'in' f"
         (at level 200, x binder, y binder, f at level 200, format "'dlet_nd'  x .. y  :=  v  'in' '//' f").
Reserved Notation "'dlet' x .. y := v 'in' f"
         (at level 200, x binder, y binder, f at level 200, format "'dlet'  x .. y  :=  v  'in' '//' f").
Notation "'dlet_nd' x .. y := v 'in' f" := (Let_In (P:=fun _ => _) v (fun x => .. (fun y => f) .. )) (only parsing).
Notation "'dlet' x .. y := v 'in' f" := (Let_In v (fun x => .. (fun y => f) .. )).
Global Instance Let_In_nd_Proper {A P}
  : Proper (eq ==> pointwise_relation _ eq ==> eq) (@Let_In A (fun _ => P)).
Proof. cbv; intros; subst; auto. Qed.
Global Hint Extern 0 (Proper _ (@Let_In _ _)) => simple apply @Let_In_nd_Proper : typeclass_instances.
Global Instance eq_eq_eq {A}
  : Proper (eq ==> eq ==> eq) (@eq A).
Proof. repeat intro; subst; reflexivity. Qed.
Global Instance all_Proper {A} (* Why do we need this??? *)
  : Proper (pointwise_relation _ eq ==> Basics.flip Basics.impl) (@all A).
Proof. intros f g H Hg x; specialize (H x); specialize (Hg x); congruence. Qed.

Fixpoint make_lets_def (n : nat) (v : nat) (acc : nat) {struct n} :=
  match n with
  | 0 => acc + acc + v
  | S n => dlet acc := acc + acc + v in make_lets_def n v acc
  end.

Notation goal n := (forall acc, make_lets_def n 0 acc = acc) (only parsing).

Goal goal 50. cbv [make_lets_def]. Time repeat setoid_rewrite <- plus_n_O. Abort.
(* Finished transaction in 0.249 secs (0.249u,0.s) (successful) *)
Goal goal 100. cbv [make_lets_def]. Time repeat setoid_rewrite <- plus_n_O. Abort.
(* Finished transaction in 1.455 secs (1.455u,0.s) (successful) *)
Goal goal 200. cbv [make_lets_def]. Time repeat setoid_rewrite <- plus_n_O. Abort.
(* Finished transaction in 9.922 secs (9.922u,0.s) (successful) *)

Goal goal 10. cbv [make_lets_def]. Time repeat rewrite_strat topdown <- plus_n_O. Abort.
(* Finished transaction in 0.083 secs (0.083u,0.s) (successful) *)
Goal goal 20. cbv [make_lets_def]. Time repeat rewrite_strat topdown <- plus_n_O. Abort.
(* Finished transaction in 0.392 secs (0.392u,0.s) (successful) *)
Goal goal 40. cbv [make_lets_def]. Time repeat rewrite_strat topdown <- plus_n_O. Abort.
(* Finished transaction in 3.241 secs (3.241u,0.s) (successful) *)

Goal goal 10. cbv [make_lets_def]. Time repeat rewrite_strat bottomup <- plus_n_O. Abort.
(* Finished transaction in 0.085 secs (0.082u,0.002s) (successful) *)
Goal goal 20. cbv [make_lets_def]. Time repeat rewrite_strat bottomup <- plus_n_O. Abort.
(* Finished transaction in 0.395 secs (0.391u,0.003s) (successful) *)
Goal goal 40. cbv [make_lets_def]. Time repeat rewrite_strat bottomup <- plus_n_O. Abort.
(* Finished transaction in 3.261 secs (3.261u,0.s) (successful) *)


From Coq Require Import Classes.RelationClasses.
From Nominal Require Import Alpha Instances.Name Instances.Prod.

#[universes(template=no)]
Record NameAbstraction `{Nominal X} := mkAbstraction { abs :> (Name * X) }.
Arguments NameAbstraction _ {_ _ _ _}.
Arguments mkAbstraction {_ _ _ _ _} _.
Notation " '[𝔸]' X " := (NameAbstraction X) (at level 1, no associativity, format "[𝔸] X").
Notation " [ a ] x " := ({| abs := (a,x) |}) (at level 1, no associativity, format "[ a ] x").

(* Given X nominal, the pair (name * X) is a nominal type module (≈α) *)
#[export] Instance name_abstraction_equiv `{Nominal X}: Equiv [𝔸]X := (≈α).
#[export] Instance name_abstraction_equivalence `{Nominal X}: Equivalence (name_abstraction_equiv (X := X)).
Proof.
    split; unfold name_abstraction_equiv; repeat intro.
    - destruct x as [[a x]]; simpl; new b fresh a x; exists b; split; intuition.
    - destruct x as [[a x]]; destruct y as [[b y]]; simpl in *; destruct H1 as [c []];
        exists c; split; intuition.
    - destruct x as [[a x]]; destruct y as [[b y]]; destruct z as [[c z]]; apply alpha_some_any in H1,H2;
        simpl in *; new f fresh a b c x y z; exists f; split; [intuition | etransitivity];
        [eapply H1 | eapply H2]; intuition.
Qed.

#[export] Instance name_abstraction_action `{Nominal X}: PermAction [𝔸]X :=
    λ p a, mkAbstraction (p • (fst a), p • (snd a)).

(* FIXME: Por aonde? *)
#[export] Instance perm_support: Support Perm := λ p, perm_dom p.

#[export] Instance name_abstraction_perm `{Nominal X}: PermT [𝔸]X.
Proof.
    Opaque alpha_equiv_e.
    split.
    - exact name_abstraction_equivalence.
    - intros p q Heq1 [[a x]] [[b y]] Heq2.
        unfold action, name_abstraction_action, equiv, name_abstraction_equiv.
        unfold equiv, name_abstraction_equiv in Heq2; simpl in *.
        new w fresh p q a b x y (p • x) (q • y); exists w; apply alpha_some_any in Heq2; split.
        + split_and!; try apply name_fresh_action; auto.
        + cut ((p • w ≡ w) ∧ (q • w ≡ w)); [intros [W1 W2] | split; apply perm_notin_domain_id; auto].
            (* slow *)rewrite <-W1 at 1; (* slow *)rewrite <-W2 at 2.
            rewrite 2!gact_compat, <-2!perm_comm_distr, <-2!gact_compat, Heq1.
            apply perm_inj. unfold alpha_equiv_a in *; apply Heq2; intuition.
    - intros [[a x]]; unfold action, name_abstraction_action, prod_action, equiv, name_abstraction_equiv; simpl.
        apply alpha_some_any; intros w ?; rewrite 2!gact_id; reflexivity.
    - intros ? ? [[a x]]; unfold action, name_abstraction_action, prod_action, equiv, name_abstraction_equiv;
        apply alpha_some_any; intros w ?; simpl in *; rewrite <-2!gact_compat; reflexivity.
Qed.

#[export] Instance name_abstraction_support `{Nominal X}: Support [𝔸]X :=
    λ a, support (abs a).

#[export] Instance name_abstraction_nominal `{Nominal X}: Nominal [𝔸]X.
Proof. split.
    - exact name_abstraction_perm.
    - intros [[a x]] b c ? ?; destruct (decide (b = c)), (decide (b = a)), (decide (c = a));
          try (subst; congruence || subst; apply perm_action_equal); unfold support, name_abstraction_support in *; simpl in *.
        + apply support_fresh,fresh_prod_iff in H1 as [?%name_neq_fresh_iff ?]; congruence.
        + apply support_fresh,fresh_prod_iff in H2 as [?%name_neq_fresh_iff ?]; congruence.
        + new z fresh (⟨b,c⟩ • a) a (⟨b,c⟩ • x) x; exists z; simpl; split; simpl; [intuition |].
          rewrite perm_swap_neither, (fresh_fixpoint b c x); auto; apply fresh_prod_iff in H1,H2; intuition.
Qed.

(* Basic properties *)
Lemma name_abstraction_rename `{Nominal X} (a b: Name) (x: X):
    b#x → [a]x ≡ [b](⟨a,b⟩ • x).
Proof. apply alpha_rename. Qed.

Lemma nabs_action `{Nominal X} p a (x: X): p • [a]x = [p • a](p • x).
Proof. auto. Qed.

Lemma nabs_support `{Nominal X} a (x: X): support [a]x = support a ∪ support x.
Proof. auto. Qed.

Lemma nabs_inv `{Nominal X} a (x x': X): [a]x ≡ [a]x' ↔ x ≡ x'.
Proof. split; intros HH.
    - unfold equiv, name_abstraction_equiv in HH; apply alpha_inv_name_equiv_iff in HH; auto.
    - apply (alpha_inv_name_equiv_iff a) in HH; assumption.
Qed.

Lemma fresh_same_alpha_class `{Nominal X} a (x: X): a # [a]x.
Proof.
    destruct (exist_fresh (support a ∪ support x)) as [w ?]; exists w.
    split; [auto |].
    unfold equiv, name_abstraction_equiv; simpl.
    rewrite perm_swap_left; apply alpha_inv_iff; right; split.
    - apply fresh_prod_iff; split; apply support_fresh; set_solver.
    - rewrite swap_perm; reflexivity.
Qed.

Lemma alpha_class_inv1 `{Nominal X} (a a': Name) (x: X): a = a' ∨ a' # x → a' # [a]x.
Proof.
    intros [EqA | F]; [rewrite EqA | destruct (decide (a = a')); subst]; try apply fresh_same_alpha_class.
    destruct (exist_fresh (support a ∪ support a' ∪ support x)) as [w ?]; exists w.
    split; [set_solver |].
    unfold equiv, name_abstraction_equiv; simpl.
    rewrite perm_swap_neither; try set_solver.
    apply alpha_inv_name_equiv_iff, fresh_fixpoint; [assumption | apply support_fresh]; set_solver.
Qed.

Lemma alpha_class_inv2 `{Nominal X} (a a': Name) (x: X): a' # [a]x → a = a' ∨ a' # x.
Proof.
    intros F; destruct (decide (a = a')); subst; [intuition |].
    right. (* a ≠ a' *)
    destruct (exist_fresh (support a ∪ support a' ∪ support x ∪ support [a]x)) as [w ?]; exists w.
    split; [set_solver |]; apply some_any_iff in F; cut (w ∉ support [a]x); [intros Hw | set_solver].
    specialize (F w Hw); unfold equiv, name_abstraction_equiv in F.
    simpl in F. assert (L: ⟨a',w⟩ • a = a). { apply perm_swap_neither; set_solver. }
    rewrite L in F; apply alpha_inv_name_equiv_iff in F; assumption.
Qed.

Lemma alpha_class_inv `{Nominal X} (a a': Name) (x: X): a = a' ∨ a' # x ↔ a' # [a]x.
Proof. split; [apply alpha_class_inv1 | apply alpha_class_inv2]. Qed.


Require Import Undecidability.SystemF.SysF Undecidability.SystemF.Autosubst.syntax Undecidability.SystemF.Autosubst.unscoped.
Import UnscopedNotations.
From Undecidability.SystemF.Util Require Import typing_facts term_facts step.
Require Import Setoid Morphisms.
Require List.

Set Default Proof Using "Type".

Definition pw_iff {X} p q := (forall x : X, p x <-> q x).
Notation "p == q" := (pw_iff p q) (at level 70).

#[local] Instance Equiv_pw_iff {X} : Equivalence (@pw_iff X).
Proof.
  firstorder.
Qed.

Lemma pw {X : Type} P Q :
  (forall x : X, P x <-> Q x) ->
  (forall x, P x) <-> (forall x, Q x).
Proof.
  firstorder.
Qed.
Ltac pw := repeat (apply pw; intros).

(* * Strong Normalisation  *)

(* ** Logical Relation  *)

Definition active P :=
  match P with
  | abs _ _ | ty_abs _ => true
  | _ => false
  end.

Definition tpred := term -> Prop.

Definition M (p : tpred) : tpred :=
  fun P => forall ξ1 ξ2, p (ren_term ξ1 ξ2 P).

Inductive R (p : tpred) P : Prop :=
| RI : (active P = true -> M p P) ->
       (forall Q, step P Q -> R p Q) ->
       R p P.

#[local] Instance R_ext :
  Proper (pw_iff ==> eq ==> iff) R.
Proof.
  intros p1 p2 Heq P ? ->. split; induction 1 as [P H H1 H2].
  - econstructor. intros H3 ξ1 ξ2. eapply Heq. now eapply H. eauto.
  - econstructor. intros H3 ξ1 ξ2. eapply Heq. now eapply H. eauto.
Qed.

Record model := mk_model
  {
    Var : tpred -> tpred ;
    Arr : tpred -> tpred -> tpred ;
    All : (tpred -> tpred) -> tpred ;
    Var_ext : Proper (pw_iff ==> pw_iff) Var ;
    Arr_ext : Proper (pw_iff ==> pw_iff ==> pw_iff) Arr ;
    All_ext : Proper (pointwise_relation _ pw_iff ==> pw_iff) All
  }.
#[local] Existing Instances Var_ext Arr_ext All_ext.

Section Evaluation.
  Variable (M : model).

  Fixpoint eval (ρ : nat -> tpred) (s : poly_type) : tpred :=
    match s with
    | poly_var n => Var M (ρ n)
    | poly_arr s t => Arr M (eval ρ s) (eval ρ t)
    | poly_abs s => All M (fun d => eval (d .: ρ) s)
    end.

  #[local] Instance eval_ext :
    Proper (pointwise_relation _ pw_iff ==> eq ==> pw_iff) eval.
  Proof.
    intros ρ1 ρ2 Heq s ? <-. induction s in ρ1, ρ2, Heq |- *; cbn.
    - now rewrite (Heq n).
    - now rewrite IHs1, IHs2.
    - eapply All_ext. intros d. eapply IHs. intros []; cbn; intuition.
  Qed.

  Lemma eval_ren ξ s ρ :
    eval ρ (ren_poly_type ξ s) == eval (ξ >> ρ) s.
  Proof.
    induction s in ξ, ρ |- *; cbn.
    - reflexivity.
    - now rewrite IHs1, IHs2.
    - eapply All_ext. intros d. rewrite IHs.
      eapply eval_ext. now intros []. reflexivity.
  Qed.

  Lemma eval_weaken s ρ d :
    eval (d .: ρ) (ren_poly_type shift s) == eval ρ s.
  Proof. now rewrite eval_ren. Qed.

  Definition lift : model.
  Proof using M.
    refine (mk_model id (Arr M) (fun F => All M (Var M >> F)) _ _ _).
    abstract firstorder.
    abstract (intros p1 p2 H; eapply All_ext; intros P; eapply H).
  Defined.

End Evaluation.

Lemma eval_subst (M : model) σ s ρ :
  eval M ρ (subst_poly_type σ s) == eval (lift M) (σ >> eval M ρ) s.
Proof.
  induction s in σ, ρ |- *; cbn.
  - reflexivity.
  - now rewrite IHs1, IHs2.
  - eapply All_ext. intros d. rewrite IHs. asimpl.
    eapply eval_ext; try reflexivity. intros []. reflexivity. eapply eval_weaken.
Qed.

Lemma eval_beta (M : model) s t ρ :
  eval M ρ (subst_poly_type (t .: poly_var) s) == eval (lift M) (eval M ρ t .: ρ >> Var M) s.
Proof.
  rewrite eval_subst.
  eapply eval_ext. now intros []. reflexivity.
Qed.

Definition D : model.
Proof.
  refine {| Var :=  id ;
            Arr := fun p q P => match P with abs s P => forall Q, R p Q -> R q (subst_term poly_var (Q .: var) P) | _ => False end ;
            All := fun F P => match P with ty_abs P => forall p s, R (F p) (subst_term (s .: poly_var) var P) | _ => False end |}.
  - abstract firstorder.
  - abstract (intros p1 p2 Heq1 p1' p2' Heq2 []; cbn; try tauto; pw; now rewrite Heq1, Heq2).
  - abstract (intros F1 F2 Heq []; cbn; try tauto; pw; now rewrite (Heq x)).
Defined.

(* Instance equiv_D : equiv D. *)

Notation V s ρ := (eval D ρ s).
Notation K s ρ := (M (V s ρ)).
Notation E s ρ := (R (V s ρ)).

(* ** Reducibility Candidates  *)

Lemma R_sn p P :
  R p P -> sn P.
Proof.
  induction 1. eauto using sn.
Qed.

Lemma R_step p P Q :
  step P Q -> R p P -> R p Q.
Proof.
  intros ? []. eauto.
Qed.

Lemma R_var p n :
  R p (var n).
Proof.
  econstructor. intros [=].
  intros Q H. inversion H.
Qed.

Lemma R_ren ξ1 ξ2 p P :
  R p P -> R p (ren_term ξ1 ξ2 P).
Proof.
  induction 1 as [P H H0 H1]. econstructor.
  - intros HnP ξ'1 ξ'2. asimpl. eapply H. now destruct P.
  - intros Q.  erewrite rinst_inst_term; try reflexivity.
    intros (P' & H2 & <-) % step_subst_inv.
    erewrite <- rinst_inst_term; try reflexivity. eauto.
Qed.

(* ** Logical Relation  *)

Lemma K_var n ρ P :
  K (poly_var n) ρ P = forall ξ1 ξ2, ρ n (ren_term ξ1 ξ2 P).
Proof.
  reflexivity.
Qed.

Lemma K_arr s t ρ u P :
  K (poly_arr s t) ρ (abs u P) <->
  forall ξ1 ξ2 Q, E s ρ Q -> E t ρ (subst_term (ξ1 >> poly_var) (Q .: ξ2 >> var) P).
Proof.
  unfold M. cbn. pw. asimpl. eapply R_ext. reflexivity.
  now_asimpl.
Qed.

Lemma K_all s ρ P :
  K (poly_abs s) ρ (ty_abs P) <->
  forall ξ p t, E s (p .: ρ) (subst_term (t .: ξ >> poly_var) var P).
Proof.
  unfold M. split.
  - intros H ξ p t. specialize (H ξ id p t). fold ren_term in H.
    eapply R_ext. 3:eapply H. reflexivity. now_asimpl.
  - intros H ξ1 ξ2 p t. specialize (H ξ1 p t).
    pose proof (Hren := R_ren id ξ2 _ _ H). asimpl in Hren.
    eapply R_ext. 3:eapply Hren. reflexivity. now_asimpl.
Qed.

Lemma V_weaken s ρ p :
  V (ren_poly_type shift s) (p .: ρ) == V s ρ.
Proof.
  now rewrite eval_weaken.
Qed.

Lemma K_weaken s ρ p :
  K (ren_poly_type shift s) (p .: ρ) == K s ρ.
Proof.
  intros P. pw. eapply V_weaken.
Qed.

Lemma E_weaken s ρ p :
  E (ren_poly_type shift s) (p .: ρ) == E s ρ.
Proof.
  intros P. eapply R_ext. eapply V_weaken. reflexivity.
Qed.

Lemma V_beta s t ρ :
  V (subst_poly_type (t .: poly_var) s) ρ == V s (V t ρ .: ρ).
Proof.
  now rewrite eval_beta.
Qed.

Lemma E_beta  s t ρ :
  E (subst_poly_type (t .: poly_var) s) ρ == E s (V t ρ .: ρ).
Proof.
  intros P. now rewrite eval_beta.
Qed.

(* ** Logical relation on contexts  *)

Definition C (Γ : nat -> poly_type) (ρ : nat -> tpred) : (nat -> term) -> Prop :=
  fun σ => forall n, E (Γ n) ρ (σ n).

Lemma C_ext :
  Proper (pointwise_relation _ eq ==> eq ==> eq ==> iff) C.
Proof.
  split; repeat intros ?; subst. now rewrite <- H. now rewrite H.
Qed.

Lemma C_scons s Γ ρ σ P :
  E s ρ P -> C Γ ρ σ -> C (s .: Γ) ρ (P .: σ).
Proof.
  intros HE HC. hnf. intros []. eassumption. eapply HC.
Qed.

Lemma C_rename Γ ρ σ ξ1 ξ2 :
  C Γ ρ σ -> C Γ ρ (σ >> ren_term ξ1 ξ2).
Proof.
  intros H ?. eapply R_ren, H.
Qed.

Lemma C_up s Γ ρ σ :
  C Γ ρ σ -> C (s .: Γ) ρ (up_term_term σ).
Proof.
  intros H. eapply C_scons. eapply R_var. now eapply C_rename.
Qed.

(* ** Fundamental theorem & Strong Normalisation  *)
Lemma E2_ind s t ρ1 ρ2 p :
  (forall P Q, E s ρ1 P -> E t ρ2 Q -> (forall P', step P P' -> p P' Q) -> (forall Q', step Q Q' -> p P Q') -> p P Q) ->
  forall P Q, E s ρ1 P -> E t ρ2 Q -> p P Q.
Proof.
  intros H P Q.
  induction 1 in Q |- *. induction 1.
  eapply H; eauto using R.
Qed.

Lemma E_app s t P Q ρ :
  E (poly_arr s t) ρ P -> E s ρ Q -> E t ρ (app P Q).
Proof.
  revert P Q. eapply E2_ind.
  intros P Q nP nQ IHP IHQ. econstructor.
  inversion 1. intros R Hst. inv Hst; eauto.
  destruct nP. rewrite K_arr in H; eauto.
Qed.

Lemma E_lam s t s' ρ P :
  sn P ->
  (forall ξ1 ξ2 Q, E s ρ Q -> E t ρ (subst_term (ξ1 >> poly_var) (Q .: ξ2 >> var) P)) ->
  E (poly_arr s t) ρ (abs s' P).
Proof.
    induction 1 as [P _ IH]. intros H.
    econstructor.
    - intros _. rewrite K_arr. eauto.
    - intros Q Hst. inv Hst. eapply IH; eauto.
      intros. eapply R_step; eauto using step_subst.
Qed.

Lemma E_tapp s t ρ P r :
  E (poly_abs s) ρ P -> E (subst_poly_type (t .: poly_var) s) ρ (ty_app P r).
Proof.
  induction 1 as [P H IH H2]. eapply E_beta.
  econstructor. inversion 1. intros Q Hst. inv Hst.
  - specialize (H eq_refl). rewrite K_all in H. eauto.
  - eapply H2 in H4. now eapply E_beta in H4.
Qed.

Lemma E_tlam s ρ P :
  sn P ->
  (forall ξ p t, E s (p .: ρ) (subst_term (t .: ξ >> poly_var) var P)) ->
  E (poly_abs s) ρ (ty_abs P).
Proof.
  induction 1 as [P _ IH]. intros H. econstructor.
  - rewrite K_all. intros _. eapply H.
  - intros Q Hst. inv Hst. eapply IH. eauto.
    intros ξ p t.
    eapply R_step; eauto using step_subst.
Qed.

Lemma fundamental {Γ s P} :
  typing Γ P s ->
  forall σ τ ρ,
  C (fun n => match List.nth_error Γ n with Some x => x | _ => poly_abs (poly_var 0) end) ρ τ ->
  E s ρ (subst_term σ τ P).
Proof.
  induction 1 as [Γ n s H | | Γ | | ]; intros σ τ ρ HC.
  - specialize (HC n). cbn in HC. rewrite H in HC. eapply HC.
  - cbn. eapply E_app; eauto.
  -  eapply E_lam; fold subst_term.
     + eapply R_sn. eapply IHtyping.
       eapply C_ext. 4:{ eapply C_up, HC. }
       all: try reflexivity.
       now intros [].
     + intros ξ1 ξ2 Q HQ.
       match goal with [ |- E _ _ ?R] =>
                       replace R with (subst_term (σ >> ren_poly_type ξ1) (Q .: τ >> ren_term ξ1 ξ2) P)
       end.
       * eapply IHtyping. eapply C_ext.
         4:{ eapply C_scons. eauto. eapply C_rename, HC. }
         all: try reflexivity.
         intros []; cbn; try reflexivity.
       * asimpl. eapply ext_term. intros. asimpl.
         -- erewrite rinst_inst_poly_type; reflexivity.
         -- intros []. reflexivity. asimpl.
            erewrite rinst_inst_term; try reflexivity. now asimpl.
  - cbn. eapply E_tapp; eauto.
  - cbn. eapply E_tlam.
    + specialize (IHtyping (up_poly_type_poly_type σ) (τ >> ren_term shift id) ((fun _ => False) .: ρ)).
      eapply R_sn. refine (IHtyping _).
      intros n.
      rewrite List.nth_error_map.
      destruct List.nth_error eqn:Eq.
      * cbn. asimpl. eapply E_weaken.
        specialize (HC n). cbn in HC. rewrite Eq in HC.
        eapply R_ren, HC.
      * unfold ssrfun.Option.map, ssrfun.Option.bind, ssrfun.Option.apply.
        eapply R_ren. specialize (HC n). cbn in HC.
        rewrite Eq in HC. eapply HC.
    + intros ξ p t. asimpl. eapply IHtyping.
      intros n. asimpl. eapply R_ext. 2:reflexivity.
      2:{ eapply E_weaken.
          erewrite <- rinst_inst_term; try reflexivity.
          eapply R_ren. eapply HC. }
      * f_equal. rewrite List.nth_error_map.
        now destruct List.nth_error eqn:Eq.
Qed.

Lemma SN {Gamma P t} : typing Gamma P t -> sn P.
Proof.
  intros Htp. pose proof (fundamental Htp poly_var var (fun _ _ => False)).
  asimpl in H.
  eapply R_sn, H.
  intros n. eapply R_var.
Qed.

Lemma typing_normal_form {Gamma P t} : typing Gamma P t -> exists Q, normal_form Q /\ typing Gamma Q t.
Proof.
  intros H.
  destruct (sn_normal _ _ _ H (SN H)) as (Q & H1 & H2).
  exists Q. split. eassumption. eapply preservation_star; eauto.
Qed.


Require Export Basics.

Require Export EnvListAux7.
Require Export EnvListAuxT1.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import Coq.Logic.ProofIrrelevance.

Require Import TPipStaticM2.
Require Import TPipDynamicM2.
Require Import TRInductM2.
Require Import WeakM2.
Require Import TSoundnessM2.
Require Import IdModType.
Require Import IdMod2.

Module HDV3 (*IdT: IdModType*) <: IdModType.

Module TSoundness2 := TSoundness IdModM2.
Export TSoundness2.

Definition Id := TSoundness2.Id.
Definition IdEqDec := TSoundness2.IdEqDec.
Definition IdEq := TSoundness2.IdEq.
Definition W := TSoundness2.W.
Definition Loc_PI := TSoundness2.Loc_PI.
Definition BInit := TSoundness2.BInit.
Definition WP := TSoundness2.WP.

(**************************************************)

Definition hoareTriple_ExtendedStep
           (P : W -> Prop) (Q : Exp -> W -> Prop)
           (ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t) : Prop :=
  forall (s s': W) (e': Exp),
    EClosure fenv env (Conf Exp s e) (Conf Exp s' e') ->
    P s -> Q e' s'.

Notation "{{ P }} << fenv , ftenv , wfenv >> << env , tenv , wenv >>  << e , t , we >> {{ Q }}" :=
(hoareTriple_ExtendedStep P Q ftenv tenv fenv env wfenv wenv e t we) (at level 90) : state_scope.

Open Scope state_scope.

Lemma conjProp (P R : W -> Prop) (Q : Exp -> W -> Prop)
   (ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t) :
{{ P }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>>  <<e,t,we>>  {{ Q }}
-> {{ R }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{fun _ => R}}
-> {{fun s => P s/\ R s}} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{fun a s => Q a s/\ R s}}.
Proof.
intros H1 H2.
intros s s' e'.
intros H3 H4.
destruct H4 as [H4 H5].
split.
-unfold hoareTriple_ExtendedStep in H1.
 apply H1 in H3.
 assumption. assumption.
-unfold hoareTriple_ExtendedStep in H2.
 apply H2 in H3.
 assumption. assumption.
Qed.

Definition wp (P : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
  W -> Prop := fun s => forall (e':Exp) (s': W),
       EClosure fenv env (Conf Exp s e) (Conf Exp s' e') -> P e' s'.

Lemma wpIsPrecondition (P : Exp -> W -> Prop)
(ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t) :
  {{ wp P fenv env e }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ P }}.
Proof.
unfold hoareTriple_ExtendedStep.
intros s s' e' H1 H2.
unfold wp in H2.
auto.
Qed.

Lemma wpIsWeakestPrecondition(P : Exp -> W -> Prop) (Q : W -> Prop) (ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t) :
  {{ Q }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ P }} -> forall s, Q s -> (wp P fenv env e) s.
Proof.
intros H1 s H2.
unfold wp.
intros e' s' H3.
apply H1 in H3.
auto.
Qed.

Lemma postAnd :
forall (P : W -> Prop) (Q R : Exp -> W -> Prop) (ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t),
  {{ P }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ Q }}
-> {{ P }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ R }}
-> {{ P }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ fun a s => Q a s /\ R a s }}.
Proof.
intros P Q R ftenv tenv fenv env wfenv wenv e t we H1 H2.
intros a s.
intros e' H3 H4.
split.
-unfold hoareTriple_ExtendedStep in H1.
 apply H1 in H3.
 assumption. assumption.
-apply H2 in H3.
 auto.
Qed.

Lemma preOr :
  forall (P Q : W -> Prop) (R : Exp -> W -> Prop)
(ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t),
  {{ P }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ R }}
-> {{ Q }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ R }}
-> {{ fun s => P s \/ Q s }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ R }}.
Proof.
intros P Q R ftenv tenv fenv env wfenv wenv e t we H1 H2 s.
intros s' e' H3 H4.
destruct H4.
-apply H1 in H3 .
 auto.
-apply H2 in H3.
 auto.
Qed.

Lemma preAndPost :
forall (P1 Q1 : W -> Prop) (P2  : Exp -> W -> Prop)
(ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t),
{{P1}} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{P2}} ->
{{fun s => P1 s /\ Q1 s}} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{fun a => Q1 }} ->
{{fun s => P1 s /\ Q1 s}} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{fun a s => P2 a s /\ Q1 s}}.
Proof.
intros P1 Q1 P2 ftenv tenv fenv env wfenv wenv e t we H1 H2 s s'.
intros e' H3 [H4 H5].
split.
-apply H1 in H3.
 auto.
-apply H2 in H3.
 apply H3.
 auto.
Qed.

Lemma andAssocHT  :
forall (P1 P2 P3 : W -> Prop) (R  : Exp -> W -> Prop)
(ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t),
{{ fun s => (P1 s /\ P2 s) /\ P3 s }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ R }}
<-> {{ fun s => P1 s /\ P2 s /\ P3 s }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ R }}.
Proof.
intros P1 P2 P3 R ftenv tenv fenv env wfenv wenv e t we.
split.
-intro H.
 unfold hoareTriple_ExtendedStep.
 intros s s' e' H1 [H2 [H3 H4]].
 apply H in H1.
 apply H1.
 auto.
-intro s.
 unfold hoareTriple_ExtendedStep.
 intros s0 s' e' H1 [[H2 H3] H4].
 apply s in H1.
 auto.
Qed.

Lemma permutHT :
forall (P1 P2 P3 : W -> Prop) (R  : Exp -> W -> Prop)
(ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t),
{{ fun s => P1 s /\ P2 s /\ P3 s }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ R }}
<-> {{ fun s => P1 s /\ P3 s /\ P2 s }} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{ R }}.
Proof.
intros P1 P2 P3 R ftenv tenv fenv env wfenv wenv e t we.
split.
-intro s.
 unfold hoareTriple_ExtendedStep.
 intros s0 s' e' H1 [H2 [H3 H4]].
 apply s in H1.
 auto.
-intro s.
 unfold hoareTriple_ExtendedStep.
 intros s0 s' e' H1 [H2 [H3 H4]].
 apply s in H1.
 auto.
Qed.
(*
split;
intro s;
unfold hoareTriple_ExtendedStep;
intros s0 s' e' H1 [H2 [H3 H4]];
apply s in H1;
auto.*)

Lemma preAnd:
 forall (P1 Q : W -> Prop) (P2  : Exp -> W -> Prop)
(ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t),
{{P1}} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{P2}}
-> {{fun s => P1 s /\ Q s}} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{P2}}.
Proof.
intros P1 Q P2 ftenv tenv fenv env wfenv wenv e t we H s.
intros s' e' H1 [H2 H3].
apply H in H1.
apply H1.
auto.
Qed.

Lemma conjPrePost :
forall (P1 Q1 : W -> Prop) (P2 Q2 : Exp -> W -> Prop)
(ftenv: funTC) (tenv: valTC) (fenv: funEnv) (env: valEnv)
           (wfenv: FEnvTyping fenv ftenv)
           (wenv: EnvTyping env tenv)
           (e: Exp) (t: VTyp)
           (we: ExpTyping ftenv tenv fenv e t),
{{P1}} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{P2}} ->
{{Q1}} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>> {{Q2}} ->
{{fun s => P1 s /\ Q1 s}} <<fenv,ftenv,wfenv>> <<env,tenv,wenv>> <<e,t,we>>  {{fun a s => P2 a s /\ Q2 a s}}.
Proof.
intros P1 Q1 P2 Q2 ftenv tenv fenv env wfenv wenv e t we H1 H2 s.
intros s' e' H3 [H4 H5].
split.
-apply H1 in H3.
 auto.
-apply H2 in H3.
 auto.
Qed.

End HDV3.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import coqutil.Tactics.Tactics.
Import ListNotations.

Require Import Cava.Core.Core.
Require Import Cava.Semantics.Combinational.
Require Import Cava.Util.Nat.
Require Import Cava.Util.List.
Require Import Cava.Util.Tactics.
Require Import Cava.Util.Identity.

Existing Instance CombinationalSemantics.

(* Run a circuit for many timesteps, starting at the reset value *)
Definition simulate {i o} (c : Circuit i o) (input : list i) : list o :=
  fold_left_accumulate (step c) input (reset_state c).

Local Ltac simsimpl :=
  repeat first [ progress cbv [simulate]
               | progress cbn [reset_state circuit_state step fst snd]
               | destruct_pair_let
               | progress simpl_ident ].

Lemma simulate_compose {A B C} (c1 : Circuit A B) (c2 : Circuit B C) (input : list A) :
  simulate (Compose c1 c2) input = simulate c2 (simulate c1 input).
Proof.
  simsimpl.
  rewrite fold_left_accumulate_fold_left_accumulate.
  apply fold_left_accumulate_ext; intros.
  simsimpl. reflexivity.
Qed.
Hint Rewrite @simulate_compose using solve [eauto] : push_simulate.

Lemma simulate_comb {A B} (c : A -> ident B) (input : list A) :
  simulate (Comb c) input = map c input.
Proof. apply fold_left_accumulate_to_map. Qed.
Hint Rewrite @simulate_comb using solve [eauto] : push_simulate.

Lemma simulate_first {A B C} (f : Circuit A C) (input : list (A * B)) :
  simulate (First f) input = combine (simulate f (map fst input))
                                      (map snd input).
Proof.
  simsimpl. rewrite !fold_left_accumulate_map.
  destruct input as [|i0 ?]; [ reflexivity | ].
  rewrite !fold_left_accumulate_to_seq with (default:=i0).
  factor_out_loops.
  eapply fold_left_accumulate_double_invariant_seq
    with (I:= fun i st1 st2 acc1 acc2 =>
                st1 = st2 /\
                length acc2 = i /\
                length acc1 = i /\
                acc2 = combine acc1 (map snd (firstn i (i0 :: input)))).
  { ssplit; reflexivity. }
  { intros *; push_length; natsimpl.
    intros; logical_simplify; subst acc2; subst.
    repeat destruct_pair_let; cbn [fst snd].
    ssplit; try reflexivity; try lia; [ ].
    rewrite firstn_succ_snoc with (d:=i0) by length_hammer.
    pull_snoc. rewrite combine_append by length_hammer.
    reflexivity. }
  { intros; logical_simplify; subst. push_firstn; natsimpl.
    reflexivity. }
Qed.
Hint Rewrite @simulate_first using solve [eauto] : push_simulate.

Lemma simulate_second {A B C} (f : Circuit B C) (input : list (A * B)) :
  simulate (Second f) input = combine (map fst input)
                                       (simulate f (map snd input)).
Proof.
  simsimpl. rewrite !fold_left_accumulate_map.
  destruct input as [|i0 ?]; [ reflexivity | ].
  rewrite !fold_left_accumulate_to_seq with (default:=i0).
  factor_out_loops.
  eapply fold_left_accumulate_double_invariant_seq
    with (I:= fun i st1 st2 acc1 acc2 =>
                st1 = st2 /\
                length acc2 = i /\
                length acc1 = i /\
                acc2 = combine (map fst (firstn i (i0 :: input))) acc1).
  { ssplit; reflexivity. }
  { intros *. push_length; natsimpl.
    intros; logical_simplify. subst acc2; subst.
    repeat destruct_pair_let; cbn [fst snd].
    ssplit; try reflexivity; try lia; [ ].
    rewrite firstn_succ_snoc with (d:=i0) by length_hammer.
    pull_snoc. rewrite combine_append by length_hammer.
    reflexivity. }
  { intros; logical_simplify; subst. push_firstn; natsimpl.
    reflexivity. }
Qed.
Hint Rewrite @simulate_second using solve [eauto] : push_simulate.

Lemma simulate_DelayInitCE {t} (init : combType t) input :
  simulate (DelayInitCE init) input
  = firstn (length input)
           (init :: (fold_left_accumulate
                      (fun st i_en =>
                         if (snd i_en : bool)
                         then (fst i_en, fst i_en)
                         else (st, st))
                      input init)).
Proof.
  simsimpl. generalize init.
  induction input; intros; [ reflexivity | ].
  repeat (push_length || push_firstn || push_fold_acc).
  destruct_products; cbn [fst snd]. erewrite IHinput.
  destruct_one_match;  reflexivity.
Qed.
Hint Rewrite @simulate_DelayInitCE using solve [eauto] : push_simulate.

Lemma simulate_DelayCE {t} (input : list (combType t * bool)) :
  simulate DelayCE input = firstn (length input)
                                  (defaultSignal
                                     :: (fold_left_accumulate
                                          (fun st i_en =>
                                             if (snd i_en : bool)
                                             then (fst i_en, fst i_en)
                                             else (st, st))
                                          input defaultSignal)).
Proof. apply simulate_DelayInitCE. Qed.
Hint Rewrite @simulate_DelayCE using solve [eauto] : push_simulate.

Lemma simulate_DelayInit {t} init (input : list (combType t)) :
  simulate (DelayInit init) input = firstn (length input) (init :: input).
Proof.
  cbv [DelayInit]. simpl_ident. autorewrite with push_simulate push_length.
  erewrite fold_left_accumulate_to_seq with (default:=(defaultSignal,false)).
  eapply fold_left_accumulate_invariant_seq
    with (I:=fun i (st : combType t) acc =>
               acc = firstn i input
               /\ st = nth i (init :: input) defaultSignal).
  {  ssplit; reflexivity. }
  { cbv zeta; intro i; intros. subst.
    destruct_products; cbn [fst snd] in *.
    logical_simplify; subst. cbn [fst snd].
    autorewrite with push_length in *.
    repeat (push_firstn || push_nth || pull_snoc || natsimpl).
    rewrite !map_nth_inbounds with (d2:=defaultSignal) by length_hammer.
    erewrite firstn_succ_snoc by lia. cbn [fst snd].
    ssplit; reflexivity. }
  { intros. logical_simplify; subst. cbn [fst snd].
    push_length; push_firstn.
    reflexivity. }
Qed.
Hint Rewrite @simulate_DelayInit using solve [eauto] : push_simulate.

Lemma simulate_Delay {t} (input : list (combType t)) :
  simulate Delay input = firstn (length input) (defaultSignal :: input).
Proof. apply simulate_DelayInit. Qed.
Hint Rewrite @simulate_Delay using solve [eauto] : push_simulate.

Lemma simulate_length {i o} (c : Circuit i o) input :
  length (simulate c input) = length input.
Proof.
  simsimpl. generalize (reset_state c).
  induction input; intros; [ reflexivity | ].
  simsimpl. push_length. reflexivity.
Qed.
Hint Rewrite @simulate_length using solve [eauto] : push_length.

Lemma simulate_LoopInitCE
      {i s o} resetval (body : Circuit (i * combType s) (o * combType s))
      (input : list (i * bool)) :
  simulate (LoopInitCE resetval body) input =
  fold_left_accumulate
    (fun '(cs, st) '(i, en) =>
       let '(cs', (o, st')) := step body cs (i, st) in
       let new_state := if (en : bool) then st' else st in
       (cs', new_state, o))
    input (reset_state body, resetval).
Proof. reflexivity. Qed.
Hint Rewrite @simulate_LoopInitCE using solve [eauto] : push_simulate.

Lemma simulate_LoopCE
      {i s o} (body : Circuit (i * combType s) (o * combType s))
      (input : list (i * bool)) :
  simulate (LoopCE body) input =
  fold_left_accumulate
    (fun '(cs, st) '(i, en) =>
       let '(cs', (o, st')) := step body cs (i, st) in
       let new_state := if (en : bool) then st' else st in
       (cs', new_state, o))
    input (reset_state body, defaultCombValue s).
Proof. apply simulate_LoopInitCE. Qed.
Hint Rewrite @simulate_LoopCE using solve [eauto] : push_simulate.

Lemma simulate_LoopInit
      {i s o} resetval (body : Circuit (i * combType s) (o * combType s))
      (input : list i) :
  simulate (LoopInit resetval body) input =
  fold_left_accumulate
    (fun '(cs, st) i =>
       let '(cs', (o, st')) := step body cs (i, st) in
       (cs', st', o))
    input (reset_state body, resetval).
Proof.
  cbv [LoopInit]. simpl_ident. autorewrite with push_simulate.
  rewrite fold_left_accumulate_map.
  apply fold_left_accumulate_ext; intros.
  repeat destruct_pair_let. reflexivity.
Qed.
Hint Rewrite @simulate_LoopInit using solve [eauto] : push_simulate.

Lemma simulate_Loop
      {i s o} (body : Circuit (i * combType s) (o * combType s))
      (input : list i) :
  simulate (Loop body) input =
  fold_left_accumulate
    (fun '(cs, st) i =>
       let '(cs', (o, st')) := step body cs (i, st) in
       (cs', st', o))
    input (reset_state body, defaultCombValue s).
Proof. apply simulate_LoopInit. Qed.
Hint Rewrite @simulate_Loop using solve [eauto] : push_simulate.